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