diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,5 +1,5 @@ Name: pontarius-xmpp -Version: 0.4.2.2 +Version: 0.4.3 Cabal-Version: >= 1.9.2 Build-Type: Custom License: BSD3 @@ -11,14 +11,14 @@ Stability: alpha Homepage: https://github.com/pontarius/pontarius-xmpp/ Bug-Reports: https://github.com/pontarius/pontarius-xmpp/issues/ -Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.4.0.2.tar.gz +Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.4.3.tar.gz Synopsis: An XMPP client library Description: Pontarius XMPP is a work in progress implementation of RFC 6120 ("XMPP CORE"), RFC 6121 ("XMPP IM"), and RFC 6122 ("XMPP ADDR"). While in alpha, Pontarius XMPP works quite well and fulfills most requirements of the RFCs. Category: Network -Tested-With: GHC ==7.6.3 +Tested-With: GHC ==7.10.1 Extra-Source-Files: README.md , ChangeLog.md @@ -63,7 +63,7 @@ , stm >=2.4 , stringprep >=1.0.0 , text >=0.11.1.5 - , tls >=1.2 + , tls >=1.3 , transformers >=0.3 , unbounded-delays >=0.1 , void >=0.5.5 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -37,6 +37,8 @@ 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 @@ 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 @@ Nothing -> do lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process." - lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host) - 5222 + lift $ resolveAndConnectTcp host 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." - lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' + "SRV records found, looking up host." + 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 @@ #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 " ++ - (showPort port) ++ "." - connectTo address port) :: IO (Either Ex.IOException Handle) + debugM "Pontarius.Xmpp" $ "Connecting to " ++ addr + connectHandle addrInfo) :: 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 @@ -- 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) -resolvAndConnectTcp resolvSeed domain port = do - aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> fmap fixDnsResult $ lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6])) - handle <- case aaaaResults of - Right Nothing -> return Nothing - Right (Just ipv6s) -> connectTcp $ - map (\ip -> ( show ip - , PortNumber $ fromIntegral port)) - ipv6s - 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' +resolveAndConnectTcp :: HostName -> PortNumber -> IO (Maybe Handle) +resolveAndConnectTcp hostName port = do + ais <- S.getAddrInfo Nothing (Just hostName) Nothing + connectTcp $ setPort <$> ais + where + setPort ai = ai {S.addrAddress = setAddressPort port (S.addrAddress ai)} + setAddressPort port (S.SockAddrInet _ addr) = S.SockAddrInet port addr + setAddressPort port (S.SockAddrInet6 _ flow addr scope) = + S.SockAddrInet6 port flow addr scope + setAddressPort _ addr = addr -- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is -- acquired. -resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, Int)] -> IO (Maybe Handle) -resolvSrvsAndConnectTcp _ [] = return Nothing -resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do - result <- resolvAndConnectTcp resolvSeed domain port +resolvSrvsAndConnectTcp :: [(HostName, PortNumber)] -> IO (Maybe Handle) +resolvSrvsAndConnectTcp [] = return Nothing +resolvSrvsAndConnectTcp ((domain, port):remaining) = do + 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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1192,7 +1192,7 @@ 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