Merge branch 'master' of git://github.com/jonkri/pontarius-xmpp

.gitmodules

@@ -1,6 +0,0 @@
-[submodule "stringprep-hs"]
-	path = stringprep-hs
-	url = git@github.com:Philonous/stringprep-hs.git
-[submodule "xml-picklers"]
-	path = xml-picklers
-	url = git@github.com:Philonous/xml-picklers.git

build.sh

@@ -1,8 +0,0 @@
-#!/bin/sh
-git submodule init
-git submodule update
-cabal-dev install ./xml-types-pickle
-cabal-dev install ./stringprep-hs
-cabal-dev install-deps
-cabal-dev configure
-cabal-dev build

examples/Example.hs

@@ -1,55 +0,0 @@
-{-# LANGUAGE PackageImports, OverloadedStrings #-}
-module Example where
-
-import Data.Text as T
-
-import Network.Xmpp
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Monad
-import Control.Monad.IO.Class
-
-philonous :: JID
-philonous = read "uart14@species64739.dyndns.org"
-
-attXmpp :: STM a -> XmppThread a
-attXmpp = liftIO . atomically
-
-autoAccept :: XmppThread ()
-autoAccept = forever $ do
-  st <- pullPresence
-  case st of
-    Presence from _ idq (Just Subscribe) _ _ _ _  ->
-      sendS . SPresence $
-           Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing []
-    _ -> return ()
-
-mirror :: XmppThread ()
-mirror = forever $ do
-  st <- pullMessage
-  case st of
-    Message (Just from) _ idq tp subject (Just bd) thr _ ->
-      sendS . SMessage $
-        Message Nothing from idq tp subject
-          (Just $ "you wrote: " `T.append` bd) thr []
-    _ -> return ()
-
-
-main :: IO ()
-main = do
-  sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do
---      singleThreaded $ xmppStartTLS exampleParams
-      singleThreaded $ xmppSASL "pwd"
-      xmppThreadedBind (Just "botsi")
---      singleThreaded $ xmppBind (Just "botsi")
-      singleThreaded $ xmppContext
-      forkXmpp autoAccept
-      forkXmpp mirror
-      sendS . SPresence $ Presence Nothing Nothing Nothing Nothing
-                (Just Available) Nothing Nothing []
-      sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing
-        (Just "bla") Nothing []
-      liftIO  . forever $ threadDelay 1000000
-      return ()
-  return ()
-

examples/IBR.hs

@@ -1,46 +0,0 @@
-{-
-
-Copyright © 2010-2012 Jon Kristensen.
-
-This file (IBR.hs) illustrates how to connect and perform an XEP-0077:
-In-Band Registration registration using Pontarius. The contents of
-this file may be used freely, as if it is in the public domain.
-
--}
-
-
-module Examples.IBR () where
-
-import Network.Xmpp
-
-
--- Server and authentication details.
-
-hostName = "nejla.com"
-portNumber = 5222
-userName = "test"
-password = ""
-
-
--- Start an XMPP session with the default settings, open the streams
--- to the XMPP server, send the `register' IQ, wait for and interpret
--- the response, and destroy the session.
-
-main :: IO ()
-
-main = session default $ do
-  liftIO $ putStrLn "Welcome to the Pontarius IBR example!"
-  openStreamsResult <- openStreams "nejla.com"
-  case openStreamsResult of
-    Nothing -> do
-      liftIO $ putStrLn "Streams opened, now registering!"
-      pushIQReq Nothing Set query Nothing $ \reply -> do
-        case reply of
-          Right (IQResponse {}) -> liftIO $ putStrLn "Registered!" -- TODO: iqRequestPayload may be empty!
-          Right (IQError {}) -> liftIO $ putStrLn "Registration error!" -- TODO: More details from error stanza
-          Left _ -> liftIO $ putStrLn "Registration error!" -- TODO: More details from error
-        destroy
-    Just error -> liftIO $ putStrLn "Error: " ++ $ show exception
-  where
-    query :: Element
-    query = undefined -- TODO: <query xmlns='jabber:iq:register'><username>userName</username><password>password</password></query>

examples/echoclient/EchoClient.hs

@@ -31,8 +31,6 @@ import           System.Log.Handler.Simple
 import           System.Log.Logger
 
 -- Server and authentication details.
-host     = "localhost"
-port     = PortNumber 5222
 realm    = "species64739.dyndns.org"
 username = "echo"
 password = "pwd"
@@ -57,9 +55,7 @@ main = do
     updateGlobalLogger "Pontarius.Xmpp" (addHandler handler)
 
     sess' <- session
-                host
                 realm
-                port
                 Nothing -- (Just defaultParamsClient)
                 (Just ([scramSha1 username Nothing password], resource))
     sess <- case sess' of

examples/echoclient/echoclient.cabal

@@ -0,0 +1,12 @@
+Name:           echoclient
+Version:        0.0.0.0
+Cabal-Version:  >= 1.6
+Build-Type:     Simple
+License:        OtherLicense
+Copyright:      Mahdi Abdinejadi, Jon Kristensen, Philipp Balzarek
+Maintainer:     info@jonkri.com
+Synopsis:       Echo client test program for Pontarius XMPP
+
+Executable echoclient
+  Build-Depends:  base, hslogger, mtl, pontarius-xmpp, text, tls
+  Main-Is:        EchoClient.hs

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/Sasl.hs

@@ -78,13 +78,13 @@ xmppSasl handlers = withStream $ do
             cs <- gets streamState
             case cs of
                 Closed -> return . Left $ XmppNoStream
-                _ -> do
+                _ -> runErrorT $ do
-                       r <- runErrorT handler
+                       r <- ErrorT handler
                        case r of
-                           Left ae -> return $ Right $ Just ae
+                           Just ae -> return $ Just ae
-                           Right a -> do
+                           Nothing -> do
-                               _ <- runErrorT $ ErrorT restartStream
+                               _ <- ErrorT restartStream
-                               return $ Right $ Nothing
+                               return Nothing
 
 -- | Authenticate to the server using the first matching method and bind a
 -- resource.

source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs

@@ -127,6 +127,12 @@ digestMd5 :: Text -- ^ Authentication identity (authcid or username)
           -> Maybe Text -- ^ Authorization identity (authzid)
           -> Text -- ^ Password
           -> SaslHandler
-digestMd5 authcid authzid password = ( "DIGEST-MD5"
+digestMd5 authcid authzid password =
-                                     , xmppDigestMd5 authcid authzid password
+    ( "DIGEST-MD5"
-                                     )
+    , do
+          r <- runErrorT $ xmppDigestMd5 authcid authzid password
+          case r of
+              Left (AuthStreamFailure e) -> return $ Left e
+              Left e -> return $ Right $ Just e
+              Right () -> return $ Right Nothing
+    )

source/Network/Xmpp/Sasl/Mechanisms/Plain.hs

@@ -77,4 +77,12 @@ plain :: Text.Text -- ^ authentication ID (username)
       -> Maybe Text.Text -- ^ authorization ID
       -> Text.Text -- ^ password
       -> SaslHandler
-plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd)
+plain authcid authzid passwd =
+    ( "PLAIN"
+    , do
+          r <- runErrorT $ xmppPlain authcid authzid passwd
+          case r of
+              Left (AuthStreamFailure e) -> return $ Left e
+              Left e -> return $ Right $ Just e
+              Right () -> return $ Right Nothing
+    )

source/Network/Xmpp/Sasl/Mechanisms/Scram.hs

@@ -164,6 +164,11 @@ scramSha1 :: Text.Text  -- ^ username
           -> Text.Text   -- ^ password
           -> SaslHandler
 scramSha1 authcid authzid passwd =
-    ("SCRAM-SHA-1"
+    ( "SCRAM-SHA-1"
-    , scram (hashToken :: Crypto.SHA1) authcid authzid passwd
+    , do
+          r <- runErrorT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd
+          case r of
+              Left (AuthStreamFailure e) -> return $ Left e
+              Left e -> return $ Right $ Just e
+              Right () -> return $ Right Nothing
     )

source/Network/Xmpp/Sasl/Types.hs

@@ -34,4 +34,4 @@ type Pairs = [(ByteString, ByteString)]
 -- | Tuple defining the SASL Handler's name, and a SASL mechanism computation.
 -- The SASL mechanism is a stateful @Stream@ computation, which has the
 -- possibility of resulting in an authentication error.
-type SaslHandler = (Text.Text, ErrorT AuthFailure (StateT Stream IO) ())
+type SaslHandler = (Text.Text, StateT Stream IO (Either XmppFailure (Maybe AuthFailure)))

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]
@@ -249,17 +252,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: 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 "</stream:stream>" and wait for the server to finish processing and to
 -- close the connection. Any remaining elements from the server are returned.
@@ -400,14 +429,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) ++ "."
@@ -418,17 +447,15 @@ connectTcp host port hostname config = do
                   ((sourceHandle h $= logConduit) $= XP.parseBytes def)
                   (return ())
     let hand = StreamHandle { streamSend = \d -> do
-                                     let d64 = encode d
                                      debugM "Pontarius.Xmpp" $
-                                       "Sending TCP data: " ++ (BSC8.unpack d64)
+                                       "Sending TCP data: " ++ (BSC8.unpack d)
                                        ++ "."
                                      catchPush $ BS.hPut h d
                                 , streamReceive = \n -> do
                                      d <- BS.hGetSome h n
-                                     let d64 = encode d
                                      debugM "Pontarius.Xmpp" $
                                        "Received TCP data: " ++
-                                       (BSC8.unpack d64) ++ "."
+                                       (BSC8.unpack d) ++ "."
                                      return d
                                 , streamFlush = hFlush h
                                 , streamClose = hClose h

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
                               }

stringprep-hs

@@ -1 +0,0 @@
-Subproject commit 7a6ca463b5e6d6636abf266bc9a782ede4e76b06

xml-picklers

@@ -1 +0,0 @@
-Subproject commit 1117559380711ed30d1b83a9fcfc636e20be2fd5