mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Show error message to user when testing XMPP creds.

Browse source
This commit is contained in:
Joey Hess 2012-11-13 13:21:09 -04:00
parent 46b580a039
commit 75dbce69e6
3 changed files with 16 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
Assistant/WebApp/Configurators/XMPP.hs
View file

@ -33,6 +33,7 @@ import Network
import Network.Protocol.XMPP import Network.Protocol.XMPP
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception (SomeException)
#endif #endif
{- Displays an alert suggesting to configure XMPP, with a button. -} {- Displays an alert suggesting to configure XMPP, with a button. -}
@ -78,9 +79,9 @@ getXMPPR' redirto = xmppPage $ do
let authtoken = webAppFormAuthToken let authtoken = webAppFormAuthToken
$(widgetFile "configurators/xmpp") $(widgetFile "configurators/xmpp")
case result of case result of
FormSuccess f -> maybe (showform True) (lift . storecreds) FormSuccess f -> either (showform . Just . show) (lift . storecreds)
=<< liftIO (validateForm f) =<< liftIO (validateForm f)
_ -> showform False _ -> showform Nothing
where where
storecreds creds = do storecreds creds = do
void $ runAnnex undefined $ setXMPPCreds creds void $ runAnnex undefined $ setXMPPCreds creds
@ -133,7 +134,7 @@ jidField = checkBool (isJust . parseJID) bad textField
bad :: Text bad :: Text
bad = "This should look like an email address.." bad = "This should look like an email address.."
validateForm :: XMPPForm -> IO (Maybe XMPPCreds) validateForm :: XMPPForm -> IO (Either SomeException XMPPCreds)
validateForm f = do validateForm f = do
let jid = fromMaybe (error "bad JID") $ parseJID (formJID f) let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
let domain = T.unpack $ strDomain $ jidDomain jid let domain = T.unpack $ strDomain $ jidDomain jid
@ -155,10 +156,9 @@ validateForm f = do
, xmppJID = formJID f , xmppJID = formJID f
} }
testXMPP :: XMPPCreds -> IO (Maybe XMPPCreds) testXMPP :: XMPPCreds -> IO (Either SomeException XMPPCreds)
testXMPP creds = either (const $ return Nothing) testXMPP creds = either Left (const $ Right creds)
(const $ return $ Just creds) <$> connectXMPP creds (const noop)
=<< connectXMPP creds (const noop)
#endif #endif

6
debian/changelog vendored
View file

@ -1,3 +1,9 @@
git-annex (3.20121113) UNRELEASED; urgency=low
* Show error message to user when testing XMPP creds.
-- Joey Hess <joeyh@debian.org> Tue, 13 Nov 2012 13:17:07 -0400
git-annex (3.20121112) unstable; urgency=low git-annex (3.20121112) unstable; urgency=low
* assistant: Can use XMPP to notify other nodes about pushes made to other * assistant: Can use XMPP to notify other nodes about pushes made to other

6
templates/configurators/xmpp.hamlet
View file

@ -9,10 +9,10 @@
It's fine to reuse an existing jabber account; git-annex won't # It's fine to reuse an existing jabber account; git-annex won't #
post any messages to it. post any messages to it.
<p> <p>
$if problem $maybe msg <- problem
<i .icon-warning-sign></i> Unable to connect to the Jabber server. # <i .icon-warning-sign></i> Unable to connect to the Jabber server. #
Maybe you entered the wrong password? Maybe you entered the wrong password? (Error message: #{msg})
$else $nothing
<i .icon-user></I> If you have a Gmail account, you can use # <i .icon-user></I> If you have a Gmail account, you can use #
Google Talk. Just enter your full Gmail address # Google Talk. Just enter your full Gmail address #
<small>(<tt>you@gmail.com</tt>)</small> # <small>(<tt>you@gmail.com</tt>)</small> #