Make "A" DNS lookup; add setting for hardcoded address and port

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

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
+session :: Text                              -- ^ The realm host name
-        -> Text                              -- ^ The realm host name (to
-                                             -- distinguish the XMPP service)
-        -> PortID                            -- ^ Port to connect to
         -> 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
+session realm mbTls mbSasl = runErrorT $ do
-    con <- ErrorT $ openStream hostname port realm def
+    con <- ErrorT $ openStream realm def
     case mbTls of
         Nothing -> return ()
         Just tls -> ErrorT $ startTls tls con

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.
+-- realm.
-openStream :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream))
+openStream :: Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream))
-openStream address port hostname config = do
+openStream realm config = runErrorT $ do
-    stream <- connectTcp address port hostname config
+    (address, port) <- case hardcodedTcpDetails config of
-    case stream of
+        Nothing -> dnsLookup realm (resolvConf config)
-        Right stream' -> do
+        Just (address, port) -> return (address, port)
-            result <- withStream startStream stream'
+    stream' <- connectTcp (Text.unpack address) port realm config
-            liftIO $ print result
+    result <- liftIO $ withStream startStream stream'
-            return $ Right stream'
+    return stream'
-        Left e -> do
+
-            return $ Left e
+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 "</stream:stream>" 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 :: HostName -> PortID -> Text -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream)
-connectTcp host port hostname config = do
+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) ++ "."

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
                               }