From 830a99764aa01fe499ca48c1b0b333a394eed03a Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 7 Mar 2013 04:17:33 +0100 Subject: [PATCH 1/5] Make "SRV" and "AAAA" lookups; wrap DNS `error' calls --- pontarius-xmpp.cabal | 1 + source/Network/Xmpp/Stream.hs | 226 +++++++++++++++++++++++----------- source/Network/Xmpp/Types.hs | 5 +- 3 files changed, 162 insertions(+), 70 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 79a2b11..9b049a9 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -38,6 +38,7 @@ Library , data-default >=0.2 , dns , hslogger >=1.1.0 + , iproute , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 , network >=2.3 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index f1b25e1..115abc9 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -46,6 +46,11 @@ import Network.Xmpp.Utilities import Network.DNS hiding (encode, lookup) +import Data.Ord +import Data.Maybe +import Data.List +import Data.IP + -- import Text.XML.Stream.Elements @@ -254,41 +259,10 @@ streamS expectedTo = do -- realm. openStream :: Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) openStream realm config = runErrorT $ do - (address, port) <- case hardcodedTcpDetails config of - Nothing -> dnsLookup realm (resolvConf config) - Just (address, port) -> return (address, port) - stream' <- connectTcp (Text.unpack address) port realm config + stream' <- createStream realm config result <- liftIO $ withStream startStream stream' return stream' -dnsLookup :: Text -> ResolvConf -> ErrorT XmppFailure IO (Text, PortID) -dnsLookup realm resolvConf = ErrorT $ do - resolvSeed <- makeResolvSeed resolvConf - withResolver resolvSeed $ \resolver -> do - debugM "Pontarius.Xmpp" "Performing SRV lookup..." - srvResult <- lookupSRV resolver (BSC8.pack $ Text.unpack realm) - debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) - - -- TODO: Use SRV result. Is list always empty? - - -- TODO: Attempt to connect over IPv6 if it is resolvable. - -- TODO: Setting field to disable IPv6 lookup. - - -- aaaaResult <- lookupAAAA resolver (BSC8.pack $ Text.unpack realm) - -- debugM "Pontarius.Xmpp" $ "AAAA result: " ++ (show aaaaResult) - -- if isJust aaaaResult && (Prelude.length $ fromJust aaaaResult) > 0 - -- then return $ Right (Text.pack $ show $ Prelude.head $ fromJust aaaaResult, (PortNumber 5222)) - -- else - - do - aResult <- lookupA resolver (BSC8.pack $ Text.unpack realm) - debugM "Pontarius.Xmpp" $ "A result: " ++ (show aResult) - case aResult of - Nothing -> return $ Left DnsLookupFailed - Just r | Prelude.length r == 0 -> return $ Left DnsLookupFailed - -- Is it safe to ignore tail of A records? - | otherwise -> return $ Right (Text.pack $ show $ Prelude.head r, (PortNumber 5222)) - -- | Send "" and wait for the server to finish processing and to -- close the connection. Any remaining elements from the server are returned. -- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. @@ -431,45 +405,48 @@ xmppNoStream = Stream { zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" -connectTcp :: HostName -> PortID -> Text -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) -connectTcp host port hostname config = ErrorT $ do - let PortNumber portNumber = port - debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ - (show portNumber) ++ " through the realm " ++ (Text.unpack hostname) ++ "." - h <- connectTo host port - debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." - hSetBuffering h NoBuffering - let eSource = DCI.ResumableSource +createStream :: Text -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +createStream realm config = do + result <- connect realm config + case result of + Just h -> ErrorT $ do + debugM "Pontarius.Xmpp" "Acquired handle." + debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." + hSetBuffering h NoBuffering + let eSource = DCI.ResumableSource ((sourceHandle h $= logConduit) $= XP.parseBytes def) (return ()) - let hand = StreamHandle { streamSend = \d -> do - debugM "Pontarius.Xmpp" $ - "Sending TCP data: " ++ (BSC8.unpack d) - ++ "." - catchPush $ BS.hPut h d - , streamReceive = \n -> do - d <- BS.hGetSome h n - debugM "Pontarius.Xmpp" $ - "Received TCP data: " ++ - (BSC8.unpack d) ++ "." - return d - , streamFlush = hFlush h - , streamClose = hClose h - } - let stream = Stream - { streamState = Plain - , streamHandle = hand - , streamEventSource = eSource - , streamFeatures = StreamFeatures Nothing [] [] - , streamHostname = (Just hostname) - , streamFrom = Nothing - , streamId = Nothing - , streamLang = Nothing - , streamJid = Nothing - , streamConfiguration = config - } - stream' <- mkStream stream - return $ Right stream' + let hand = StreamHandle { streamSend = \d -> do + debugM "Pontarius.Xmpp" $ + "Sending TCP data: " ++ (BSC8.unpack d) + ++ "." + catchPush $ BS.hPut h d + , streamReceive = \n -> do + d <- BS.hGetSome h n + debugM "Pontarius.Xmpp" $ + "Received TCP data: " ++ + (BSC8.unpack d) ++ "." + return d + , streamFlush = hFlush h + , streamClose = hClose h + } + let stream = Stream + { streamState = Plain + , streamHandle = hand + , streamEventSource = eSource + , streamFeatures = StreamFeatures Nothing [] [] + , streamHostname = (Just realm) + , streamFrom = Nothing + , streamId = Nothing + , streamLang = Nothing + , streamJid = Nothing + , streamConfiguration = config + } + stream' <- mkStream stream + return $ Right stream' + Nothing -> do + lift $ debugM "Pontarius.Xmpp" "Did not acquire handle." + throwError TcpConnectionFailure where logConduit :: Conduit ByteString IO ByteString logConduit = CL.mapM $ \d -> do @@ -478,6 +455,117 @@ connectTcp host port hostname config = ErrorT $ do "." return d +-- `connect' will perform one or many DNS lookups for the provided +-- realm host (unless `hardcodedTcpDetails' has been specified, in which case +-- those details are used instead). Will return the Handle acquired, if any. +connect :: Text -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) +connect realm config = do + case hardcodedTcpDetails config of + Just (address, port) -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to hardcoded TCP settings..." + connectTcp' [(address, port)] + 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' + +-- 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) + case result of + Right handle -> do + debugM "Pontarius.Xmpp" "Successfully connected." + 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) + +-- 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 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 + Left e -> return Nothing + case handle of + Nothing -> do + aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ + \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 + 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, PortNumber)] -> IO (Maybe Handle) +resolvSrvsAndConnectTcp _ [] = return Nothing +resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do + result <- resolvAndConnectTcp resolvSeed domain port + case result of + Just handle -> return $ Just handle + Nothing -> resolvSrvsAndConnectTcp resolvSeed remaining + + +-- The DNS functions may make error calls. This function catches any such +-- exceptions and rethrows them as IOExceptions. +rethrowErrorCall :: IO a -> IO a +rethrowErrorCall action = do + result <- try action + case result of + Right result' -> return result' + Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e + Left e -> throwIO e + +-- 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 realm resolvSeed = ErrorT $ do + result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do + srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." + case srvResult of + Just srvResult -> do + debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) + -- Get [(Domain, PortNumber)] of SRV request, if any. + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, fromIntegral port)) $ + sortBy (comparing $ \(prio, _weight, _, _) -> prio) srvResult + -- TODO: Perform the `Weight' probability calculations of + -- . + -- The service is not available at this domain. + -- Sorts the records based on the priority value. + Just [(_, _, _, ".")] -> do + debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." + return $ Just [] + Nothing -> do + debugM "Pontarius.Xmpp" "No SRV result returned." + return Nothing + case result of + Right result' -> return $ Right result' + Left e -> return $ Left $ XmppIOException e -- Closes the connection and updates the XmppConMonad Stream state. -- killStream :: TMVar Stream -> IO (Either ExL.SomeException ()) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 131c6b7..315db1d 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -656,6 +656,9 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream -- constructor wraps the -- elements collected so -- far. + | TcpConnectionFailure -- ^ All attempts to TCP + -- connect to the server + -- failed. | DnsLookupFailed -- ^ An IP address to connect to could not be -- resolved. | TlsError TLS.TLSError -- ^ An error occurred in the @@ -1024,7 +1027,7 @@ data StreamConfiguration = -- | By specifying these details, Pontarius XMPP will -- connect to the provided address and port, and will -- not perform a DNS look-up - , hardcodedTcpDetails :: Maybe (Text, PortID) + , hardcodedTcpDetails :: Maybe (Text, PortNumber) -- | DNS resolver configuration , resolvConf :: ResolvConf } From 2ff809d740be69b9d67768ea8d26a475ff4500b6 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 7 Mar 2013 09:02:39 +0100 Subject: [PATCH 2/5] Enable weight-respecting server selection mechanism for SRV records --- source/Network/Xmpp/Stream.hs | 46 +++++++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 5 deletions(-) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index d12dae4..0c7f908 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -50,7 +50,7 @@ import Data.Ord import Data.Maybe import Data.List import Data.IP - +import System.Random -- import Text.XML.Stream.Elements @@ -555,10 +555,8 @@ srvLookup realm resolvSeed = ErrorT $ do Just srvResult -> do debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) -- Get [(Domain, PortNumber)] of SRV request, if any. - return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, fromIntegral port)) $ - sortBy (comparing $ \(prio, _weight, _, _) -> prio) srvResult - -- TODO: Perform the `Weight' probability calculations of - -- . + srvResult' <- orderSrvResult srvResult + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, fromIntegral port)) srvResult' -- The service is not available at this domain. -- Sorts the records based on the priority value. Just [(_, _, _, ".")] -> do @@ -570,6 +568,44 @@ srvLookup realm resolvSeed = ErrorT $ do case result of Right result' -> return $ Right result' Left e -> return $ Left $ XmppIOException e + where + -- This function orders the SRV result in accordance with RFC + -- 2782. It sorts the SRV results in order of priority, and then + -- uses a random process to order the records with the same + -- priority based on their weight. + orderSrvResult :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSrvResult srvResult = do + -- Order the result set by priority. + let srvResult' = sortBy (comparing (\(priority, _, _, _) -> priority)) srvResult + -- Group elements in sublists based on their priority. The + -- type is `[[(Int, Int, Int, Domain)]]'. + let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Int, Int, Int, Domain)]] + -- For each sublist, put records with a weight of zero first. + let srvResult''' = Data.List.map (\sublist -> let (a, b) = partition (\(_, weight, _, _) -> weight == 0) sublist in Data.List.concat [a, b]) srvResult'' + -- Order each sublist. + srvResult'''' <- mapM orderSublist srvResult''' + -- Concatinated the results. + return $ Data.List.concat srvResult'''' + where + orderSublist :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSublist [] = return [] + orderSublist sublist = do + -- Compute the running sum, as well as the total sum of + -- the sublist. Add the running sum to the SRV tuples. + let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist + -- Choose a random number between 0 and the total sum + -- (inclusive). + randomNumber <- randomRIO (0, total) + -- Select the first record with its running sum greater + -- than or equal to the random number. + let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' + -- Remove the running total number from the remaining + -- elements. + let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end]) + -- Repeat the ordering procedure on the remaining + -- elements. + tail <- orderSublist sublist'' + return $ ((priority, weight, port, domain):tail) -- Closes the connection and updates the XmppConMonad Stream state. -- killStream :: TMVar Stream -> IO (Either ExL.SomeException ()) From 3f56ef5ff10c3cd06e92649639323c4744e1d859 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 7 Mar 2013 13:04:48 +0100 Subject: [PATCH 3/5] Add Hostname type, `hostname' creator, and Attoparsec hostname validation --- examples/echoclient/EchoClient.hs | 2 +- source/Network/Xmpp.hs | 3 +- source/Network/Xmpp/Concurrent.hs | 2 +- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 4 +- source/Network/Xmpp/Stream.hs | 12 +++--- source/Network/Xmpp/Types.hs | 40 ++++++++++++++++++- 6 files changed, 51 insertions(+), 12 deletions(-) diff --git a/examples/echoclient/EchoClient.hs b/examples/echoclient/EchoClient.hs index 6b44404..e69be62 100644 --- a/examples/echoclient/EchoClient.hs +++ b/examples/echoclient/EchoClient.hs @@ -31,7 +31,7 @@ import System.Log.Handler.Simple import System.Log.Logger -- Server and authentication details. -realm = "species64739.dyndns.org" +realm = fromJust $ hostname "species64739.dyndns.org" username = "echo" password = "pwd" resource = Just "bot" diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index e384f62..39d7812 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -154,7 +154,8 @@ 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 451bb97..1f6eb45 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 :: Text -- ^ The realm host name +session :: Hostname -- ^ The realm host name -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the -- connection to the server is -- desired diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index dfb9710..06cc93e 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -45,8 +45,8 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - hn <- gets streamHostname - xmppDigestMd5' (fromJust hn) ac az pw + Just (Hostname hn) <- gets streamHostname + xmppDigestMd5' hn ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5' hostname authcid authzid password = do diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 0c7f908..80a9e69 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -113,7 +113,7 @@ startStream = runErrorT $ do case streamHostname state of Nothing -> throwError $ XmppOtherFailure "server sent no hostname" -- TODO: When does this happen? - Just hostname -> lift $ do + Just (Hostname hostname) -> lift $ do pushXmlDecl pushOpenElement $ pickleElem xpStream ( "1.0" @@ -134,7 +134,7 @@ startStream = runErrorT $ do closeStreamWithError StreamInvalidXml Nothing "stream has no language tag" -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) -> + | isJust from && (from /= Just (Jid Nothing (Text.pack $ show $ fromJust $ streamHostname state) Nothing)) -> closeStreamWithError StreamInvalidFrom Nothing "stream from is invalid" | to /= expectedTo -> @@ -258,7 +258,7 @@ streamS expectedTo = do -- | Connects to the XMPP server and opens the XMPP stream against the given -- realm. -openStream :: Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +openStream :: Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) openStream realm config = runErrorT $ do stream' <- createStream realm config result <- liftIO $ withStream startStream stream' @@ -409,8 +409,8 @@ xmppNoStream = Stream { zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" -createStream :: Text -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) -createStream realm config = do +createStream :: Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +createStream (Hostname realm) config = do result <- connect realm config case result of Just h -> ErrorT $ do @@ -439,7 +439,7 @@ createStream realm config = do , streamHandle = hand , streamEventSource = eSource , streamFeatures = StreamFeatures Nothing [] [] - , streamHostname = (Just realm) + , streamHostname = (Just $ Hostname realm) , streamFrom = Nothing , streamId = Nothing , streamLang = Nothing diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 315db1d..2e22c28 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -44,6 +44,8 @@ module Network.Xmpp.Types , fromTexts , StreamEnd(..) , InvalidXmppXml(..) + , Hostname(..) + , hostname ) where @@ -806,7 +808,7 @@ data Stream = Stream -- | Stream features advertised by the server , streamFeatures :: !StreamFeatures -- TODO: Maybe? -- | The hostname we specified for the connection - , streamHostname :: !(Maybe Text) + , streamHostname :: !(Maybe Hostname) -- | The hostname specified in the server's stream element's -- `from' attribute , streamFrom :: !(Maybe Jid) @@ -1039,3 +1041,39 @@ instance Default StreamConfiguration where , hardcodedTcpDetails = Nothing , resolvConf = defaultResolvConf } + +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 + where + eitherToMaybeHostname = either (const Nothing) (Just . Hostname) + +-- Validation of RFC 1123 hostnames. +hostnameP :: AP.Parser Text +hostnameP = do + -- Hostnames may not begin with a hyphen. + h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] + t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] + let label = Text.concat [Text.pack [h], t] + if Text.length label > 63 + then fail "Label too long." + else do + AP.endOfInput + return label + <|> do + _ <- AP.satisfy (== '.') + r <- hostnameP + if (Text.length label) + 1 + (Text.length r) > 255 + then fail "Hostname too long." + else return $ Text.concat [label, Text.pack ".", r] From a59af1bc4d4c0c29adc257028bce32de213576f0 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 7 Mar 2013 16:04:35 +0100 Subject: [PATCH 4/5] Allow connection through IPv4 and IPv6 addresses --- source/Network/Xmpp/Concurrent.hs | 2 +- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 4 +- source/Network/Xmpp/Stream.hs | 54 +++++++++++-------- source/Network/Xmpp/Types.hs | 9 ++-- 4 files changed, 41 insertions(+), 28 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 1f6eb45..317806d 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -141,7 +141,7 @@ session :: Hostname -- ^ The realm host name -- the server decide) -> IO (Either XmppFailure (Session, Maybe AuthFailure)) session realm mbTls mbSasl = runErrorT $ do - con <- ErrorT $ openStream realm def + con <- ErrorT $ openStream (Right realm) def case mbTls of Nothing -> return () Just tls -> ErrorT $ startTls tls con diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 06cc93e..21ea08f 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -45,8 +45,8 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - Just (Hostname hn) <- gets streamHostname - xmppDigestMd5' hn ac az pw + Just address <- gets streamAddress + xmppDigestMd5' address ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5' hostname authcid authzid password = do diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 80a9e69..eff80fc 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -110,15 +110,15 @@ startStream = runErrorT $ do (Secured, (Just (jid, _))) -> Just jid (Plain, Nothing) -> Nothing (Secured, Nothing) -> Nothing - case streamHostname state of + case streamAddress state of Nothing -> throwError $ XmppOtherFailure "server sent no hostname" -- TODO: When does this happen? - Just (Hostname hostname) -> lift $ do + Just address -> lift $ do pushXmlDecl pushOpenElement $ pickleElem xpStream ( "1.0" , expectedTo - , Just (Jid Nothing hostname Nothing) + , Just (Jid Nothing address Nothing) , Nothing , preferredLang $ streamConfiguration state ) @@ -134,7 +134,7 @@ startStream = runErrorT $ do closeStreamWithError StreamInvalidXml Nothing "stream has no language tag" -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (Text.pack $ show $ fromJust $ streamHostname state) Nothing)) -> + | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress state) Nothing)) -> closeStreamWithError StreamInvalidFrom Nothing "stream from is invalid" | to /= expectedTo -> @@ -258,9 +258,9 @@ streamS expectedTo = do -- | Connects to the XMPP server and opens the XMPP stream against the given -- realm. -openStream :: Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) -openStream realm config = runErrorT $ do - stream' <- createStream realm config +openStream :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +openStream destination config = runErrorT $ do + stream' <- createStream destination config result <- liftIO $ withStream startStream stream' return stream' @@ -398,7 +398,7 @@ xmppNoStream = Stream { } , streamEventSource = DCI.ResumableSource zeroSource (return ()) , streamFeatures = StreamFeatures Nothing [] [] - , streamHostname = Nothing + , streamAddress = Nothing , streamFrom = Nothing , streamId = Nothing , streamLang = Nothing @@ -409,11 +409,15 @@ xmppNoStream = Stream { zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" -createStream :: Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) -createStream (Hostname realm) config = do - result <- connect realm config +createStream :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +createStream destination config = do + result <- connect destination 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 @@ -439,7 +443,7 @@ createStream (Hostname realm) config = do , streamHandle = hand , streamEventSource = eSource , streamFeatures = StreamFeatures Nothing [] [] - , streamHostname = (Just $ Hostname realm) + , streamAddress = (Just address) , streamFrom = Nothing , streamId = Nothing , streamLang = Nothing @@ -459,15 +463,23 @@ createStream (Hostname realm) config = do "." return d --- `connect' will perform one or many DNS lookups for the provided --- realm host (unless `hardcodedTcpDetails' has been specified, in which case --- those details are used instead). Will return the Handle acquired, if any. -connect :: Text -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) -connect realm config = do - case hardcodedTcpDetails config of - Just (address, port) -> lift $ do - debugM "Pontarius.Xmpp" "Connecting to hardcoded TCP settings..." - connectTcp' [(address, port)] + + +-- 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)] Nothing -> do resolvSeed <- lift $ makeResolvSeed (resolvConf config) lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 2e22c28..ccfefb9 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -84,6 +84,7 @@ import Network import Network.DNS import Data.Default +import Data.IP -- | -- Wraps a string of random characters that, when using an appropriate @@ -807,8 +808,8 @@ data Stream = Stream , streamEventSource :: ResumableSource IO Event -- | Stream features advertised by the server , streamFeatures :: !StreamFeatures -- TODO: Maybe? - -- | The hostname we specified for the connection - , streamHostname :: !(Maybe Hostname) + -- | The hostname or IP specified for the connection + , streamAddress :: !(Maybe Text) -- | The hostname specified in the server's stream element's -- `from' attribute , streamFrom :: !(Maybe Jid) @@ -1029,7 +1030,7 @@ data StreamConfiguration = -- | By specifying these details, Pontarius XMPP will -- connect to the provided address and port, and will -- not perform a DNS look-up - , hardcodedTcpDetails :: Maybe (Text, PortNumber) + , srvOverrideDetails :: Maybe (Hostname, PortNumber) -- | DNS resolver configuration , resolvConf :: ResolvConf } @@ -1038,7 +1039,7 @@ data StreamConfiguration = instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing - , hardcodedTcpDetails = Nothing + , srvOverrideDetails = Nothing , resolvConf = defaultResolvConf } From 679726519368ad984b2580429b7f90ef66195d8b Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 7 Mar 2013 16:11:40 +0100 Subject: [PATCH 5/5] Define minimum dependency versions of the `dns' and `iproute' packages --- pontarius-xmpp.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 9b049a9..ef0f4fd 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -36,9 +36,9 @@ Library , crypto-random-api >=0.2 , cryptohash >=0.6.1 , data-default >=0.2 - , dns + , dns >=0.3.0 , hslogger >=1.1.0 - , iproute + , iproute >=1.2.4 , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 , network >=2.3