From 95dbb2c724baa19b76e6cb1052da99f2ba63e7f8 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 10 Mar 2013 20:47:44 +0100 Subject: [PATCH] Simplify `openStream' and `session'; allow for SockAddr; validate IP `openStream' and `session' now takes a `HostName'. If the hostname is an IP adress, we connect to it using the default XMPP port. If it's a hostname, we perform the SRV lookup (or fallback on A/AAAA lookups and the default XMPP port). This patch allows for the use of a socket and socket address pair in the settings, giving advanced users additionally flexibility. This field can also be used by users that want to use a non-standard port in combination with a) a misconfigured XMPP domain name (one without SRV records), or b) connection by IP. The "manual" A(AAA) lookups have been kept in order to allow the Pontarius XMPP client to attempt to connect to multiple IP addresses. --- examples/echoclient/EchoClient.hs | 5 +- examples/echoclient/echoclient.cabal | 2 +- source/Network/Xmpp.hs | 2 - source/Network/Xmpp/Concurrent.hs | 6 +- source/Network/Xmpp/Stream.hs | 133 +++++++++++++++------------ source/Network/Xmpp/Types.hs | 17 ++-- 6 files changed, 90 insertions(+), 75 deletions(-) diff --git a/examples/echoclient/EchoClient.hs b/examples/echoclient/EchoClient.hs index f28ba28..bbcc37a 100644 --- a/examples/echoclient/EchoClient.hs +++ b/examples/echoclient/EchoClient.hs @@ -37,9 +37,6 @@ username = "echo" password = "pwd" resource = Just "bot" -config = def{srvOverrideDetails = Just ( fromJust $ hostname "127.0.0.1" - , 5222) } - -- | Automatically accept all subscription requests from other entities autoAccept :: Session -> IO () autoAccept session = forever $ do @@ -60,7 +57,7 @@ main = do sess' <- session realm - config + def Nothing -- (Just exampleParams) (Just ([scramSha1 username Nothing password], resource)) sess <- case sess' of diff --git a/examples/echoclient/echoclient.cabal b/examples/echoclient/echoclient.cabal index bc5724b..c50f62d 100755 --- a/examples/echoclient/echoclient.cabal +++ b/examples/echoclient/echoclient.cabal @@ -8,5 +8,5 @@ Maintainer: info@jonkri.com Synopsis: Echo client test program for Pontarius XMPP Executable echoclient - Build-Depends: base, hslogger, mtl, pontarius-xmpp, text, tls + Build-Depends: base, data-default, hslogger, mtl, pontarius-xmpp, text, tls Main-Is: EchoClient.hs \ No newline at end of file diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index c71aca5..19b6c2a 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -155,8 +155,6 @@ module Network.Xmpp , AuthSaslFailure , AuthIllegalCredentials , AuthOtherFailure ) - , Hostname - , hostname ) where import Network diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 4fbd8dd..bb36ff5 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -132,7 +132,7 @@ writeWorker stCh writeR = forever $ do -- value, @session@ will attempt to secure the connection with TLS. If the fifth -- parameters is a 'Just' value, @session@ will attempt to authenticate and -- acquire an XMPP resource. -session :: Hostname -- ^ The hostname / realm +session :: HostName -- ^ The hostname / realm -> StreamConfiguration -- ^ configuration details -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the -- connection to the server is @@ -141,8 +141,8 @@ session :: Hostname -- ^ The hostname / realm -- JID resource (or Nothing to let -- the server decide) -> IO (Either XmppFailure (Session, Maybe AuthFailure)) -session host config mbTls mbSasl = runErrorT $ do - con <- ErrorT $ openStream (Right host) config +session realm config mbTls mbSasl = runErrorT $ do + con <- ErrorT $ openStream realm config case mbTls of Nothing -> return () Just tls -> ErrorT $ startTls tls con diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 791b3c7..4487316 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -53,6 +53,15 @@ import Data.List import Data.IP import System.Random +import qualified Network.Socket as NS + +-- "readMaybe" definition, as readMaybe is not introduced in the `base' package +-- until version 4.6. +readMaybe_ :: (Read a) => String -> Maybe a +readMaybe_ string = case reads string of + [(a, "")] -> Just a + _ -> Nothing + -- import Text.XML.Stream.Elements mbl :: Maybe [a] -> [a] @@ -259,9 +268,9 @@ streamS expectedTo = do -- | Connects to the XMPP server and opens the XMPP stream against the given -- realm. -openStream :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) -openStream destination config = runErrorT $ do - stream' <- createStream destination config +openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +openStream realm config = runErrorT $ do + stream' <- createStream realm config result <- liftIO $ withStream startStream stream' return stream' @@ -410,15 +419,11 @@ xmppNoStream = Stream { zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" -createStream :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) -createStream destination config = do - result <- connect destination config +createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +createStream realm config = do + result <- connect realm config case result of Just h -> ErrorT $ do - let address = case destination of - Left (Left ipv4, _) -> Text.pack $ show ipv4 - Left (Right ipv6, _) -> Text.pack $ show ipv6 - Right (Hostname hostname) -> hostname debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." hSetBuffering h NoBuffering @@ -435,7 +440,7 @@ createStream destination config = do , streamHandle = hand , streamEventSource = eSource , streamFeatures = StreamFeatures Nothing [] [] - , streamAddress = (Just address) + , streamAddress = Just $ Text.pack realm , streamFrom = Nothing , streamId = Nothing , streamLang = Nothing @@ -454,66 +459,78 @@ createStream destination config = do "." return d - - --- Connects to the provided hostname or IP address. If a hostname is provided, --- one or many DNS lookups are performed, starting with a SRV lookup (unless --- `srvOverrideDetails' has been specified, in which case those details are used --- instead). Will return the Handle acquired, if any. -connect :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) -connect (Left (ip, portNumber)) config = do - let ip' = case ip of - Left ipv4 -> Text.pack $ show ipv4 - Right ipv6 -> Text.pack $ show ipv6 - lift $ connectTcp' [(ip', portNumber)] -connect (Right (Hostname realm)) config = do - case srvOverrideDetails config of - Just (Hostname hostname, portNumber) -> lift $ do - debugM "Pontarius.Xmpp" "Connecting to hardcoded TCP host and port..." - connectTcp' [(hostname, portNumber)] +-- Connects to the provided hostname or IP address. If a hostname is provided, a +-- DNS-SRV lookup is performed (unless `sockAddr' has been specified, in which +-- case that address is used instead). If an A(AAA) record results are +-- encountered, all IP addresses will be tried until a successful connection +-- attempt has been made. Will return the Handle acquired, if any. +connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) +connect realm config = do + case socketDetails config of + -- Just (_, NS.SockAddrUnix _) -> do + -- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided." + -- throwError XmppIllegalTcpDetails + Just socketDetails' -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..." + connectTcp $ Left socketDetails' Nothing -> do - resolvSeed <- lift $ makeResolvSeed (resolvConf config) - lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." - srvRecords <- srvLookup realm resolvSeed - case srvRecords of - -- No SRV records. Try fallback lookup. - Nothing -> do - lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." - lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ Text.unpack realm) (fromIntegral 5222) - Just srvRecords' -> do - lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." - lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' + case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of + (Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] + (Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] + (Nothing, Nothing, Just (Hostname realm')) -> do + resolvSeed <- lift $ makeResolvSeed (resolvConf config) + lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvRecords <- srvLookup realm' resolvSeed + case srvRecords of + -- No SRV records. Try fallback lookup. + Nothing -> do + lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." + lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 + Just srvRecords' -> do + lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." + lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' + (Nothing, Nothing, Nothing) -> do + lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated." + throwError XmppIllegalTcpDetails -- Connects to a list of addresses and ports. Surpresses any exceptions from -- connectTcp. -connectTcp' :: [(Text, PortNumber)] -> IO (Maybe Handle) -connectTcp' [] = return Nothing -connectTcp' ((address, port):remainder) = do - result <- try $ connectTcp address port :: IO (Either IOException Handle) +connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) +connectTcp (Right []) = return Nothing +connectTcp (Right ((address, port):remainder)) = do + result <- try $ (do + debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ + (show port) ++ "." + connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) case result of Right handle -> do - debugM "Pontarius.Xmpp" "Successfully connected." + debugM "Pontarius.Xmpp" "Successfully connected to HostName." return $ Just handle Left _ -> do - debugM "Pontarius.Xmpp" "Connection could not be established." - connectTcp' remainder - -connectTcp :: Text -> PortNumber -> IO Handle -connectTcp address port = do - debugM "Pontarius.Xmpp" $ "Connecting to " ++ (Text.unpack address) ++ - " on port " ++ (show port) ++ "." - connectTo (Text.unpack address) (PortNumber port) + debugM "Pontarius.Xmpp" "Connection to HostName could not be established." + connectTcp $ Right remainder +connectTcp (Left (sock, sockAddr)) = do + result <- try $ (do + NS.connect sock sockAddr + NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle) + case result of + Right handle -> do + debugM "Pontarius.Xmpp" "Successfully connected to SockAddr." + return $ Just handle + Left _ -> do + debugM "Pontarius.Xmpp" "Connection to SockAddr could not be established." + return Nothing -- 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 -> PortNumber -> IO (Maybe Handle) +resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) resolvAndConnectTcp resolvSeed domain port = do aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) handle <- case aaaaResults of Right Nothing -> return Nothing - Right (Just ipv6s) -> connectTcp' $ Data.List.map (\ipv6 -> (Text.pack $ show ipv6, port)) ipv6s + Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s Left e -> return Nothing case handle of Nothing -> do @@ -521,7 +538,7 @@ resolvAndConnectTcp resolvSeed domain port = do \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) handle' <- case aResults of Right Nothing -> return Nothing - Right (Just ipv4s) -> connectTcp' $ Data.List.map (\ipv4 -> (Text.pack $ show ipv4, port)) ipv4s + Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s case handle' of Nothing -> return Nothing Just handle'' -> return $ Just handle'' @@ -529,7 +546,7 @@ resolvAndConnectTcp resolvSeed domain port = do -- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is -- acquired. -resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, PortNumber)] -> IO (Maybe Handle) +resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, Int)] -> IO (Maybe Handle) resolvSrvsAndConnectTcp _ [] = return Nothing resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do result <- resolvAndConnectTcp resolvSeed domain port @@ -550,7 +567,7 @@ rethrowErrorCall action = do -- Provides a list of A(AAA) names and port numbers upon a successful -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. -srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, PortNumber)]) +srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) srvLookup realm resolvSeed = ErrorT $ do result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." @@ -559,7 +576,7 @@ srvLookup realm resolvSeed = ErrorT $ do debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) -- Get [(Domain, PortNumber)] of SRV request, if any. srvResult' <- orderSrvResult srvResult - return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, fromIntegral port)) srvResult' + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult' -- The service is not available at this domain. -- Sorts the records based on the priority value. Just [(_, _, _, ".")] -> do diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index ccfefb9..88871c8 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -82,6 +82,7 @@ import qualified Text.StringPrep as SP import Network import Network.DNS +import Network.Socket import Data.Default import Data.IP @@ -662,8 +663,8 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream | TcpConnectionFailure -- ^ All attempts to TCP -- connect to the server -- failed. - | DnsLookupFailed -- ^ An IP address to connect to could not be - -- resolved. + | XmppIllegalTcpDetails -- ^ The TCP details provided did not + -- validate. | TlsError TLS.TLSError -- ^ An error occurred in the -- TLS layer | TlsNoServerSupport -- ^ The server does not support @@ -1027,10 +1028,12 @@ data StreamConfiguration = -- boolean is set to 'True', then the JID is also -- included when the 'ConnectionState' is 'Plain' , toJid :: !(Maybe (Jid, Bool)) - -- | By specifying these details, Pontarius XMPP will - -- connect to the provided address and port, and will - -- not perform a DNS look-up - , srvOverrideDetails :: Maybe (Hostname, PortNumber) + -- | By settings this field, clients can specify the + -- network interface to use, override the SRV lookup + -- of the realm, as well as specify the use of a + -- non-standard port when connecting by IP or + -- connecting to a domain without SRV records. + , socketDetails :: Maybe (Socket, SockAddr) -- | DNS resolver configuration , resolvConf :: ResolvConf } @@ -1039,7 +1042,7 @@ data StreamConfiguration = instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing - , srvOverrideDetails = Nothing + , socketDetails = Nothing , resolvConf = defaultResolvConf }