use getAddrInfo rather than A/AAAA lookups

We should use getAddrInfo rather than A/AAAA lookups so host-specific
settings (like /etc/hosts) can take effect.

source/Network/Xmpp/Stream.hs

@@ -37,6 +37,8 @@ import           Data.XML.Types
 import qualified GHC.IO.Exception as GIE
 import           Network
 import           Network.DNS hiding (encode, lookup)
+import qualified Network.Socket as S
+import           Network.Socket (AddrInfo)
 import           Network.Xmpp.Marshal
 import           Network.Xmpp.Types
 import           System.IO
@@ -563,7 +565,7 @@ connect realm config = do
     case connectionDetails config of
         UseHost host port -> lift $ do
             debugM "Pontarius.Xmpp" "Connecting to configured address."
-            h <- connectTcp $ [(host, port)]
+            h <- resolveAndConnectTcp host port
             case h of
                 Nothing -> return Nothing
                 Just h' -> do
@@ -596,20 +598,23 @@ connectSrv config host = do
                 Nothing -> do
                     lift $ debugM "Pontarius.Xmpp"
                         "No SRV records, using fallback process."
-                    lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host)
+                    lift $ resolveAndConnectTcp host 5222
-                                               5222
                 Just [(".", _)] -> do
                     liftIO $ infoM "Pontarius.Xmpp"
                                 "SRV lookup returned \".\"; service not available"
                     throwError TcpConnectionFailure
                 Just srvRecords' -> do
                     lift $ debugM "Pontarius.Xmpp"
-                        "SRV records found, performing A/AAAA lookups."
+                        "SRV records found, looking up host."
-                    lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords'
+                    lift $ resolvSrvsAndConnectTcp
+                           ( for srvRecords' $
+                              \(domain, port) -> ( BSC8.unpack domain
+                                                 , fromIntegral port))
         Nothing -> do
                 lift $ errorM "Pontarius.Xmpp"
                     "The hostname could not be validated."
                 throwError XmppIllegalTcpDetails
+  where for = flip fmap
 
 showPort :: PortID -> String
 #if MIN_VERSION_network(2, 4, 1)
@@ -622,22 +627,28 @@ showPort (UnixSocket x) = "UnixSocket " ++ show x
 #endif
 #endif
 
+connectHandle :: AddrInfo -> IO Handle
+connectHandle addrInfo = do
+    s <- S.socket (S.addrFamily addrInfo) S.Stream S.defaultProtocol
+    S.connect s (S.addrAddress addrInfo)
+    S.socketToHandle s ReadWriteMode
+
 -- Connects to a list of addresses and ports. Surpresses any exceptions from
 -- connectTcp.
-connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle)
+connectTcp :: [AddrInfo] -> IO (Maybe Handle)
 connectTcp [] = return Nothing
-connectTcp ((address, port):remainder) = do
+connectTcp (addrInfo:remainder) = do
+    let addr = (show $ S.addrAddress addrInfo)
     result <- Ex.try $ (do
-        debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++
+        debugM "Pontarius.Xmpp" $ "Connecting to " ++ addr
-            (showPort port) ++ "."
+        connectHandle addrInfo) :: IO (Either Ex.IOException Handle)
-        connectTo address port) :: IO (Either Ex.IOException Handle)
     case result of
         Right handle -> do
-            debugM "Pontarius.Xmpp" $ "Successfully connected to " ++ show address
+            debugM "Pontarius.Xmpp" $ "Successfully connected to " ++ addr
             return $ Just handle
         Left _ -> do
             debugM "Pontarius.Xmpp" $
-                "Connection to " ++ show address ++ " could not be established."
+                "Connection to " ++ addr ++ " could not be established."
             connectTcp remainder
 
 #if MIN_VERSION_dns(1, 0, 0)
@@ -651,44 +662,26 @@ fixDnsResult = id
 -- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If
 -- a handle can not be acquired this way, an analogous A query is performed.
 -- Surpresses all IO exceptions.
-resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle)
+resolveAndConnectTcp :: HostName -> PortNumber -> IO (Maybe Handle)
-resolvAndConnectTcp resolvSeed domain port = do
+resolveAndConnectTcp hostName port = do
-    aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $
+    ais <- S.getAddrInfo Nothing (Just hostName) Nothing
-                        \resolver -> fmap fixDnsResult $ lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6]))
+    connectTcp $ setPort <$> ais
-    handle <- case aaaaResults of
+  where
-        Right Nothing -> return Nothing
+    setPort ai = ai {S.addrAddress = setAddressPort port (S.addrAddress ai)}
-        Right (Just ipv6s) -> connectTcp $
+    setAddressPort port (S.SockAddrInet _ addr) = S.SockAddrInet port addr
-                                  map (\ip -> ( show ip
+    setAddressPort port (S.SockAddrInet6 _ flow addr scope) =
-                                                , PortNumber $ fromIntegral port))
+        S.SockAddrInet6 port flow addr scope
-                                      ipv6s
+    setAddressPort _ addr = addr
-        Left _e -> return Nothing
-    case handle of
-        Nothing -> do
-            aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $
-                             \resolver -> fmap fixDnsResult $ lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4]))
-            handle' <- case aResults of
-                Left  _       -> return Nothing
-                Right Nothing -> return Nothing
-
-                Right (Just ipv4s) -> connectTcp $
-                                          map (\ip -> (show ip
-                                                        , PortNumber
-                                                          $ fromIntegral port))
-                                              ipv4s
-            case handle' of
-                Nothing -> return Nothing
-                Just handle'' -> return $ Just handle''
-        Just handle' -> return $ Just handle'
 
 -- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is
 -- acquired.
-resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, Int)] -> IO (Maybe Handle)
+resolvSrvsAndConnectTcp :: [(HostName, PortNumber)] -> IO (Maybe Handle)
-resolvSrvsAndConnectTcp _ [] = return Nothing
+resolvSrvsAndConnectTcp [] = return Nothing
-resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do
+resolvSrvsAndConnectTcp ((domain, port):remaining) = do
-    result <- resolvAndConnectTcp resolvSeed domain port
+    result <- resolveAndConnectTcp domain port
     case result of
         Just handle -> return $ Just handle
-        Nothing -> resolvSrvsAndConnectTcp resolvSeed remaining
+        Nothing -> resolvSrvsAndConnectTcp remaining
 
 
 -- The DNS functions may make error calls. This function catches any such

source/Network/Xmpp/Types.hs

@@ -1192,7 +1192,7 @@ resourceprepProfile = SP.Profile { SP.maps = [SP.b1]
 data ConnectionDetails = UseRealm -- ^ Use realm to resolv host. This is the
                                   -- default.
                        | UseSrv HostName -- ^ Use this hostname for a SRV lookup
-                       | UseHost HostName PortID -- ^ Use specified host
+                       | UseHost HostName PortNumber -- ^ Use specified host
                        | UseConnection (ErrorT XmppFailure IO StreamHandle)
                          -- ^ Use a custom method to create a StreamHandle. This
                          -- will also be used by reconnect. For example, to