when xmpp connection fails, show the host(s) it tried to connect to

Assistant/WebApp/Configurators/XMPP.hs

@@ -21,17 +21,15 @@ import Assistant.Types.Buddies
 import Assistant.NetMessager
 import Assistant.Alert
 import Assistant.DaemonStatus
-import Utility.SRV
 import Assistant.WebApp.RepoList
 import Assistant.WebApp.Configurators
 import Assistant.XMPP
 #endif
 
 #ifdef WITH_XMPP
-import Network
 import Network.Protocol.XMPP
+import Network
 import qualified Data.Text as T
-import Control.Exception (SomeException)
 #endif
 
 {- Displays an alert suggesting to configure XMPP. -}
@@ -118,7 +116,7 @@ xmppform next = xmppPage $ do
 			creds2Form <$> oldcreds
 	let showform problem = $(widgetFile "configurators/xmpp")
 	case result of
-		FormSuccess f -> either (showform . Just . show) (lift . storecreds)
+		FormSuccess f -> either (showform . Just) (lift . storecreds)
 			=<< liftIO (validateForm f)
 		_ -> showform Nothing
   where
@@ -184,7 +182,7 @@ jidField = checkBool (isJust . parseJID) bad textField
 	bad :: Text
 	bad = "This should look like an email address.."
 
-validateForm :: XMPPForm -> IO (Either SomeException XMPPCreds)
+validateForm :: XMPPForm -> IO (Either String XMPPCreds)
 validateForm f = do
 	let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
 	let username = fromMaybe "" (strNode <$> jidNode jid)
@@ -196,10 +194,26 @@ validateForm f = do
 		, xmppJID = formJID f
 		}
 
-testXMPP :: XMPPCreds -> IO (Either SomeException XMPPCreds)
-testXMPP creds = either Left (const $ Right creds)
-	<$> connectXMPP creds (const noop)
+testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
+testXMPP creds = do
+	(good, bad) <- partition (either (const False) (const True) . snd) 
+		<$> connectXMPP creds (const noop)
+	case good of
+		(((h, PortNumber p), _):_) -> return $ Right $ creds
+			{ xmppHostname = h
+			, xmppPort = fromIntegral p
+			}
+		(((h, _), _):_) -> return $ Right $ creds
+			{ xmppHostname = h
+			}
+		_ -> return $ Left $ intercalate "; " $ map formatlog bad
+  where
+  	formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
+  	formatlog _ = ""
 
+	showport (PortNumber n) = show n
+	showport (Service s) = s
+	showport (UnixSocket s) = s
 #endif
 
 xmppPage :: Widget -> Handler RepHtml

Assistant/XMPP/Client.hs

@@ -27,36 +27,43 @@ data XMPPCreds = XMPPCreds
 	}
 	deriving (Read, Show)
 
-connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
+connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
 connectXMPP c a = case parseJID (xmppJID c) of
 	Nothing -> error "bad JID"
 	Just jid -> connectXMPP' jid c a
 
 {- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
-connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
-connectXMPP' jid c a = go =<< lookupSRV srvrecord
+connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
+connectXMPP' jid c a = reverse <$> (go [] =<< lookupSRV srvrecord)
   where
 	srvrecord = mkSRVTcp "xmpp-client" $
 		T.unpack $ strDomain $ jidDomain jid
 	serverjid = JID Nothing (jidDomain jid) Nothing
 
-	go [] = run (xmppHostname c)
-			(PortNumber $ fromIntegral $ xmppPort c)
-			(a jid)
-	go ((h,p):rest) = do
+	go l [] = do
+		let h = xmppHostname c
+		let p = PortNumber $ fromIntegral $ xmppPort c
+		r <- run h p $ a jid
+		return (r : l)
+	go l ((h,p):rest) = do
 		{- Try each SRV record in turn, until one connects,
 		 - at which point the MVar will be full. -}
 		mv <- newEmptyMVar
 		r <- run h p $ do
 			liftIO $ putMVar mv ()
 			a jid
-		ifM (isEmptyMVar mv) (go rest, return r)
+		ifM (isEmptyMVar mv)
+			( go (r : l) rest
+			, return (r : l)
+			)
 
 	{- Async exceptions are let through so the XMPP thread can
 	 - be killed. -}
-	run h p a' = tryNonAsync $
-		runClientError (Server serverjid h p) jid
-			(xmppUsername c) (xmppPassword c) (void a')
+	run h p a' = do
+		r <- tryNonAsync $
+			runClientError (Server serverjid h p) jid
+				(xmppUsername c) (xmppPassword c) (void a')
+		return ((h, p), r)
 
 {- XMPP runClient, that throws errors rather than returning an Either -}
 runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a

Utility/SRV.hs

@@ -15,6 +15,7 @@ module Utility.SRV (
 	mkSRV,
 	lookupSRV,
 	lookupSRVHost,
+	HostPort,
 ) where
 
 import Utility.Process