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

avoid duplicate srv lookup when testing xmpp

Browse source
This commit is contained in:
Joey Hess 2013-05-27 13:45:07 -04:00
parent eba9ee5bc6
commit 5a678244e2
1 changed files with 7 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -187,24 +187,14 @@ jidField = checkBool (isJust . parseJID) bad textField
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
hostports <- lookupSRV $ mkSRVTcp "xmpp-client" domain
let username = fromMaybe "" (strNode <$> jidNode jid)
case hostports of
((h, PortNumber p):_) -> testXMPP $ XMPPCreds
{ xmppUsername = username
, xmppPassword = formPassword f
, xmppHostname = h
, xmppPort = fromIntegral p
, xmppJID = formJID f
}
_ -> testXMPP $ XMPPCreds
{ xmppUsername = username
, xmppPassword = formPassword f
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
, xmppPort = 5222
, xmppJID = formJID f
}
testXMPP $ XMPPCreds
{ xmppUsername = username
, xmppPassword = formPassword f
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
, xmppPort = 5222
, xmppJID = formJID f
}
testXMPP :: XMPPCreds -> IO (Either SomeException XMPPCreds)
testXMPP creds = either Left (const $ Right creds)