From 477dbc14c7da04c5aa5048c326ff0f4886fa8bab Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 20 Mar 2013 15:45:49 +0100 Subject: [PATCH] elaborate connectionDetails add ConnectionDetails type remove Hostname type rename hostname to checkHostname --- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/Stream.hs | 88 +++++++++++++++++------------------ source/Network/Xmpp/Types.hs | 32 +++++-------- 3 files changed, 56 insertions(+), 65 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 585039e..82e02ac 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -29,6 +29,7 @@ module Network.Xmpp , session , StreamConfiguration(..) , SessionConfiguration(..) + , ConnectionDetails(..) -- TODO: Close session, etc. -- ** Authentication handlers -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 86bc227..9077d5b 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -19,9 +19,10 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Trans.Class +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Base64 -import Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Char8 as BSC8 import Data.Conduit import Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as DCI @@ -483,60 +484,50 @@ createStream realm config = do -- 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 - 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." + case connectionDetails config of + UseHost host port -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to configured address." + connectTcp $ [(host, port)] + UseSrv host -> connectSrv host + UseRealm -> connectSrv realm + where + connectSrv realm = do + case checkHostName (Text.pack realm) of + Just realm' -> do + resolvSeed <- lift $ makeResolvSeed (resolvConf config) + lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvRecords <- srvLookup realm' resolvSeed + case srvRecords of + 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 -> 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 :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) -connectTcp (Right []) = return Nothing -connectTcp (Right ((address, port):remainder)) = do +connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle) +connectTcp [] = return Nothing +connectTcp ((address, port):remainder) = do result <- try $ (do - debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ + debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++ (show port) ++ "." - connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) + connectTo address port) :: IO (Either IOException Handle) case result of Right handle -> do debugM "Pontarius.Xmpp" "Successfully connected to HostName." return $ Just handle Left _ -> do 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 + connectTcp remainder -- 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. @@ -547,7 +538,10 @@ resolvAndConnectTcp resolvSeed domain port = do \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) handle <- case aaaaResults of Right Nothing -> return Nothing - Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s + Right (Just ipv6s) -> connectTcp $ + map (\ipv6 -> ( show ipv6 + , PortNumber $ fromIntegral port)) + ipv6s Left e -> return Nothing case handle of Nothing -> do @@ -555,7 +549,11 @@ 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 $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s + Right (Just ipv4s) -> connectTcp $ + map (\ipv4 -> (show ipv4 + , PortNumber + $ fromIntegral port)) + ipv4s case handle' of Nothing -> return Nothing Just handle'' -> return $ Just handle'' diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 5ad805d..bab4d33 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -37,6 +37,7 @@ module Network.Xmpp.Types , ConnectionState(..) , StreamErrorInfo(..) , StanzaHandler + , ConnectionDetails(..) , StreamConfiguration(..) , langTag , Jid(..) @@ -46,8 +47,7 @@ module Network.Xmpp.Types , jidFromTexts , StreamEnd(..) , InvalidXmppXml(..) - , Hostname(..) - , hostname + , checkHostName , SessionConfiguration(..) , TlsBehaviour(..) ) @@ -70,7 +70,6 @@ import Data.Typeable(Typeable) import Data.XML.Types import Network import Network.DNS -import Network.Socket import Network.TLS hiding (Version) import Network.TLS.Extra import qualified Text.NamePrep as SP @@ -1012,6 +1011,10 @@ data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) instance Exception InvalidXmppXml +data ConnectionDetails = UseRealm -- ^ Use realm to resolv host + | UseSrv HostName -- ^ Use this hostname for a SRC lookup + | UseHost HostName PortID -- ^ Use specified host + -- | Configuration settings related to the stream. data StreamConfiguration = StreamConfiguration { -- | Default language when no language tag is set @@ -1026,7 +1029,7 @@ data StreamConfiguration = -- 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) + , connectionDetails :: ConnectionDetails -- | DNS resolver configuration , resolvConf :: ResolvConf -- | Whether or not to perform the legacy @@ -1039,11 +1042,10 @@ data StreamConfiguration = , tlsParams :: TLSParams } - instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing - , socketDetails = Nothing + , connectionDetails = UseRealm , resolvConf = defaultResolvConf , establishSession = True , tlsBehaviour = PreferTls @@ -1053,22 +1055,12 @@ instance Default StreamConfiguration where } } -data Hostname = Hostname Text deriving (Eq, Show) - -instance Read Hostname where - readsPrec _ x = case hostname (Text.pack x) of - Nothing -> [] - Just h -> [(h,"")] - -instance IsString Hostname where - fromString = fromJust . hostname . Text.pack - -- | Validates the hostname string in accordance with RFC 1123. -hostname :: Text -> Maybe Hostname -hostname t = do - eitherToMaybeHostname $ AP.parseOnly hostnameP t +checkHostName :: Text -> Maybe Text +checkHostName t = do + eitherToMaybeHostName $ AP.parseOnly hostnameP t where - eitherToMaybeHostname = either (const Nothing) (Just . Hostname) + eitherToMaybeHostName = either (const Nothing) Just -- Validation of RFC 1123 hostnames. hostnameP :: AP.Parser Text