diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 4442d9e..79a2b11 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -36,6 +36,7 @@ Library , crypto-random-api >=0.2 , cryptohash >=0.6.1 , data-default >=0.2 + , dns , hslogger >=1.1.0 , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index d9f2512..451bb97 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -132,10 +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 -- ^ Host to connect to - -> Text -- ^ The realm host name (to - -- distinguish the XMPP service) - -> PortID -- ^ Port to connect to +session :: Text -- ^ The realm host name -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the -- connection to the server is -- desired @@ -143,8 +140,8 @@ session :: HostName -- ^ Host to connect to -- JID resource (or Nothing to let -- the server decide) -> IO (Either XmppFailure (Session, Maybe AuthFailure)) -session hostname realm port mbTls mbSasl = runErrorT $ do - con <- ErrorT $ openStream hostname port realm def +session realm mbTls mbSasl = runErrorT $ do + con <- ErrorT $ openStream realm def 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 f37694c..02fd316 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -44,6 +44,9 @@ import Text.XML.Unresolved(InvalidEventStream(..)) import Control.Monad.Trans.Resource as R import Network.Xmpp.Utilities +import Network.DNS hiding (encode, lookup) + + -- import Text.XML.Stream.Elements mbl :: Maybe [a] -> [a] @@ -248,17 +251,43 @@ streamS expectedTo = do Just r -> streamUnpickleElem xpStreamFeatures r -- | Connects to the XMPP server and opens the XMPP stream against the given --- host name, port, and realm. -openStream :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) -openStream address port hostname config = do - stream <- connectTcp address port hostname config - case stream of - Right stream' -> do - result <- withStream startStream stream' - liftIO $ print result - return $ Right stream' - Left e -> do - return $ Left e +-- 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 + 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: How to connect to IPv6 address? Doesn't seem to work + -- with connectTo. + + -- 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. @@ -396,14 +425,14 @@ xmppNoStream = Stream { , streamId = Nothing , streamLang = Nothing , streamJid = Nothing - , streamConfiguration = StreamConfiguration Nothing Nothing + , streamConfiguration = def } where zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" -connectTcp :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) -connectTcp host port hostname config = do +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) ++ "." diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 29a9e56..131c6b7 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -78,6 +78,9 @@ import Data.String (IsString(..)) import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP +import Network +import Network.DNS + import Data.Default -- | @@ -653,6 +656,8 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream -- constructor wraps the -- elements collected so -- far. + | DnsLookupFailed -- ^ An IP address to connect to could not be + -- resolved. | TlsError TLS.TLSError -- ^ An error occurred in the -- TLS layer | TlsNoServerSupport -- ^ The server does not support @@ -1016,10 +1021,18 @@ 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 + , hardcodedTcpDetails :: Maybe (Text, PortID) + -- | DNS resolver configuration + , resolvConf :: ResolvConf } instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing + , hardcodedTcpDetails = Nothing + , resolvConf = defaultResolvConf }