Allow connection through IPv4 and IPv6 addresses

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

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
+    Just address <- gets streamAddress
-    xmppDigestMd5' hn ac az pw
+    xmppDigestMd5' address ac az pw
   where
     xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) ()
     xmppDigestMd5' hostname authcid authzid password = do

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 :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream))
-openStream realm config = runErrorT $ do
+openStream destination config = runErrorT $ do
-    stream' <- createStream realm config
+    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 :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream)
-createStream (Hostname realm) config = do
+createStream destination config = do
-    result <- connect realm config
+    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.
+-- Connects to the provided hostname or IP address. If a hostname is provided,
-connect :: Text -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle)
+-- one or many DNS lookups are performed, starting with a SRV lookup (unless
-connect realm config = do
+-- `srvOverrideDetails' has been specified, in which case those details are used
-    case hardcodedTcpDetails config of
+-- instead). Will return the Handle acquired, if any.
-        Just (address, port) -> lift $ do
+connect :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle)
-            debugM "Pontarius.Xmpp" "Connecting to hardcoded TCP settings..."
+connect (Left (ip, portNumber)) config = do
-            connectTcp' [(address, port)]
+    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..."

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
+      -- | The hostname or IP specified for the connection
-    , streamHostname :: !(Maybe Hostname)
+    , 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
                               }