Merge remote-tracking branch 'nejla/master'

Conflicts:
	pontarius-xmpp.cabal

pontarius-xmpp.cabal

@@ -25,35 +25,35 @@ Tested-With: GHC ==7.0.4, GHC ==7.4.1
 Library
   hs-source-dirs: source
   Exposed: True
-  Build-Depends: base              >4 && <5
+  Build-Depends: attoparsec        >=0.10.0.3
-               , conduit           >=0.5
+               , base              >4 && <5
-               , void              >=0.5.5
-               , resourcet         >=0.3.0
-               , containers        >=0.4.0.0
-               , random            >=1.0.0.0
-               , tls               >=1.1.0
-               , tls-extra         >=0.5.0
-               , pureMD5           >=2.1.2.1
                , base64-bytestring >=0.1.0.0
                , binary            >=0.4.1
-               , attoparsec        >=0.10.0.3
+               , bytestring        >=0.9.1.9
+               , conduit           >=0.5 && <1.0
+               , containers        >=0.4.0.0
                , crypto-api        >=0.9
                , crypto-random-api >=0.2
                , cryptohash        >=0.6.1
-               , text              >=0.11.1.5
+               , data-default      >=0.2
-               , bytestring        >=0.9.1.9
+               , hslogger          >=1.1.0
-               , transformers      >=0.2.2.0
+               , lifted-base       >=0.1.0.1
                , mtl               >=2.0.0.0
                , network           >=2.3
-               , lifted-base       >=0.1.0.1
+               , pureMD5           >=2.1.2.1
+               , resourcet         >=0.3.0
+               , random            >=1.0.0.0
                , split             >=0.1.2.3
                , stm               >=2.1.2.1
+               , stringprep        >=0.1.3
+               , text              >=0.11.1.5
+               , tls               >=1.1.0
+               , tls-extra         >=0.5.0
+               , transformers      >=0.2.2.0
+               , void              >=0.5.5
                , xml-types         >=0.3.1
                , xml-conduit       >=1.0
                , xml-picklers      >=0.3
-               , data-default      >=0.2
-               , stringprep        >=0.1.3
-               , hslogger          >=1.1.0
   Exposed-modules: Network.Xmpp
                  , Network.Xmpp.Internal
                  , Network.Xmpp.IM

source/Network/Xmpp.hs

@@ -41,6 +41,8 @@ module Network.Xmpp
   , Jid(..)
   , isBare
   , isFull
+  , fromText
+  , fromTexts
   -- * Stanzas
   -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is
   -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in
@@ -144,13 +146,10 @@ module Network.Xmpp
   , XmppFailure(..)
   , StreamErrorInfo(..)
   , StreamErrorCondition(..)
-  , AuthFailure( AuthXmlFailure -- Does not export AuthStreamFailure
+  , AuthFailure( AuthNoAcceptableMechanism
-               , AuthNoAcceptableMechanism
-               , AuthChallengeFailure
-               , AuthNoStream
-               , AuthFailure
                , AuthSaslFailure
-               , AuthStringPrepFailure )
+               , AuthIllegalCredentials
+               , AuthOtherFailure )
 
   ) where
 

source/Network/Xmpp/Sasl.hs

@@ -67,7 +67,7 @@ xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their
                        -- corresponding handlers
          -> TMVar Stream
          -> IO (Either XmppFailure (Maybe AuthFailure))
-xmppSasl handlers = withStream $ do
+xmppSasl handlers stream = (flip withStream stream) $ do
     -- Chooses the first mechanism that is acceptable by both the client and the
     -- server.
     mechanisms <- gets $ streamSaslMechanisms . streamFeatures
@@ -76,14 +76,8 @@ xmppSasl handlers = withStream $ do
         (_name, handler):_ -> do
             cs <- gets streamState
             case cs of
-                Closed -> return . Right $ Just AuthNoStream
+                Closed -> return . Left $ XmppNoStream
-                _ -> do
+                _ -> lift $ handler stream
-                       r <- runErrorT handler
-                       case r of
-                           Left ae -> return $ Right $ Just ae
-                           Right a -> do
-                               _ <- runErrorT $ ErrorT restartStream
-                               return $ Right $ Nothing
 
 -- | Authenticate to the server using the first matching method and bind a
 -- resource.

source/Network/Xmpp/Sasl/Common.hs

@@ -134,11 +134,11 @@ pullChallenge = do
       SaslChallenge (Just scb64)
           | Right sc <- B64.decode . Text.encodeUtf8 $ scb64
              -> return $ Just sc
-      _ -> throwError AuthChallengeFailure
+      _ -> throwError AuthOtherFailure -- TODO: Log
 
--- | Extract value from Just, failing with AuthChallengeFailure on Nothing.
+-- | Extract value from Just, failing with AuthOtherFailure on Nothing.
 saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT Stream IO) a
-saslFromJust Nothing = throwError $ AuthChallengeFailure
+saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log
 saslFromJust (Just d) = return d
 
 -- | Pull the next element and check that it is success.
@@ -147,7 +147,7 @@ pullSuccess = do
     e <- pullSaslElement
     case e of
         SaslSuccess x -> return x
-        _ -> throwError $ AuthXmlFailure
+        _ -> throwError $ AuthOtherFailure -- TODO: Log
 
 -- | Pull the next element. When it's success, return it's payload.
 -- If it's a challenge, send an empty response and pull success.
@@ -163,13 +163,13 @@ pullFinalMessage = do
   where
     decode Nothing  = return Nothing
     decode (Just d) = case B64.decode $ Text.encodeUtf8 d of
-        Left _e -> throwError $ AuthChallengeFailure
+        Left _e -> throwError $ AuthOtherFailure -- TODO: Log
         Right x -> return $ Just x
 
 -- | Extract p=q pairs from a challenge.
 toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Pairs
 toPairs ctext = case pairs ctext of
-    Left _e -> throwError AuthChallengeFailure
+    Left _e -> throwError AuthOtherFailure -- TODO: Log
     Right r -> return r
 
 -- | Send a SASL response element. The content will be base64-encoded.
@@ -186,7 +186,7 @@ respond m = do
 prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text
                 -> ErrorT AuthFailure (StateT Stream IO) (Text.Text, Maybe Text.Text, Text.Text)
 prepCredentials authcid authzid password = case credentials of
-    Nothing -> throwError $ AuthStringPrepFailure
+    Nothing -> throwError $ AuthIllegalCredentials
     Just creds -> return creds
   where
     credentials = do

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

@@ -37,7 +37,7 @@ import           Network.Xmpp.Sasl.Common
 import           Network.Xmpp.Sasl.StringPrep
 import           Network.Xmpp.Sasl.Types
 
-
+import           Control.Concurrent.STM
 
 xmppDigestMd5 ::  Text -- ^ Authentication identity (authzid or username)
                -> Maybe Text -- ^ Authorization identity (authcid)
@@ -127,6 +127,25 @@ 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"
-                                     )
+    , \stream -> do
+        stream_ <- atomically $ readTMVar stream
+        r <- runErrorT $ do
+          -- Alrighty! The problem here is that `scramSha1' runs in the
+          -- `IO (Either XmppFailure (Maybe AuthFailure))' monad, while we need
+          -- to call an `ErrorT AuthFailure (StateT Stream IO) ()' calculation.
+          -- The key is to use `mapErrorT', which is called with the following
+          -- ypes:
+          -- 
+          -- mapErrorT :: (StateT Stream IO (Either AuthError ()) -> IO (Either AuthError ()))
+          --           -> ErrorT AuthError (StateT Stream IO) ()
+          --           -> ErrorT AuthError IO ()
+          mapErrorT
+            (\s -> runStateT s stream_ >>= \(r, _) -> return r)
+            (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

@@ -46,6 +46,8 @@ import qualified Data.Text as Text
 import           Network.Xmpp.Sasl.Common
 import           Network.Xmpp.Sasl.Types
 
+import           Control.Concurrent.STM
+
 -- TODO: stringprep
 xmppPlain :: Text.Text -- ^ Password
           -> Maybe Text.Text -- ^ Authorization identity (authzid)
@@ -77,4 +79,27 @@ 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"
+    , \stream -> do
+        stream_ <- atomically $ readTMVar stream
+        r <- runErrorT $ do
+          -- Alrighty! The problem here is that `scramSha1' runs in the
+          -- `IO (Either XmppFailure (Maybe AuthFailure))' monad, while we need
+          -- to call an `ErrorT AuthFailure (StateT Stream IO) ()' calculation.
+          -- The key is to use `mapErrorT', which is called with the following
+          -- ypes:
+          -- 
+          -- mapErrorT :: (StateT Stream IO (Either AuthError ()) -> IO (Either AuthError ()))
+          --           -> ErrorT AuthError (StateT Stream IO) ()
+          --           -> ErrorT AuthError IO ()
+          mapErrorT
+            (\s -> runStateT s stream_ >>= \(r, _) -> return r)
+            (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

@@ -31,8 +31,8 @@ import           Network.Xmpp.Sasl.StringPrep
 import           Network.Xmpp.Sasl.Types
 import           Network.Xmpp.Types
 
-
 import           Control.Monad.State.Strict
+import           Control.Concurrent.STM
 
 -- | A nicer name for undefined, for use as a dummy token to determin
 -- the hash function to use
@@ -63,7 +63,7 @@ scram hashToken authcid authzid password = do
         let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce
         respond $ Just cfm
         finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage
-        unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthFailure
+        unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log
         return ()
       where
         -- We need to jump through some hoops to get a polymorphic solution
@@ -106,7 +106,7 @@ scram hashToken authcid authzid password = do
                                , Just ic <- lookup "i" pairs
                                , [(i,"")] <- reads $ BS8.unpack ic
                                = return (nonce, salt, i)
-        fromPairs _ _ = throwError $ AuthChallengeFailure
+        fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log
 
         cFinalMessageAndVerifier :: BS.ByteString
                                  -> BS.ByteString
@@ -164,6 +164,24 @@ 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
+    , \stream -> do
+        stream_ <- atomically $ readTMVar stream
+        r <- runErrorT $ do
+          -- Alrighty! The problem here is that `scramSha1' runs in the
+          -- `IO (Either XmppFailure (Maybe AuthFailure))' monad, while we need
+          -- to call an `ErrorT AuthFailure (StateT Stream IO) ()' calculation.
+          -- The key is to use `mapErrorT', which is called with the following
+          -- ypes:
+          -- 
+          -- mapErrorT :: (StateT Stream IO (Either AuthError ()) -> IO (Either AuthError ()))
+          --           -> ErrorT AuthError (StateT Stream IO) ()
+          --           -> ErrorT AuthError IO ()
+          mapErrorT
+            (\s -> runStateT s stream_ >>= \(r, _) -> return r)
+            (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

@@ -6,23 +6,26 @@ import           Control.Monad.State.Strict
 import           Data.ByteString(ByteString)
 import qualified Data.Text as Text
 import           Network.Xmpp.Types
+import           Control.Concurrent.STM
 
-data AuthFailure = AuthXmlFailure
+-- | Signals a (non-fatal) SASL authentication error condition.
-               | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms
+data AuthFailure = -- | No mechanism offered by the server was matched
-                                                       -- offered
+                   -- by the provided acceptable mechanisms; wraps the
-               | AuthChallengeFailure
+                   -- mechanisms offered by the server
-               | AuthServerAuthFailure -- ^ The server failed to authenticate
+                   AuthNoAcceptableMechanism [Text.Text]
-                                     -- itself
+                 | AuthStreamFailure XmppFailure -- TODO: Remove
-               | AuthStreamFailure XmppFailure -- ^ Stream error on stream restart
+                   -- | A SASL failure element was encountered
-               -- TODO: Rename AuthConnectionFailure?
+                 | AuthSaslFailure SaslFailure
-               | AuthNoStream
+                   -- | The credentials provided did not conform to
-               | AuthFailure -- General instance used for the Error instance
+                   -- the SASLprep Stringprep profile
-               | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition
+                 | AuthIllegalCredentials
-               | AuthStringPrepFailure -- ^ StringPrep failed
+                   -- | Other failure; more information is available
+                   -- in the log
+                 | AuthOtherFailure
                  deriving Show
 
 instance Error AuthFailure where
-    noMsg = AuthFailure
+    noMsg = AuthOtherFailure
 
 data SaslElement = SaslSuccess   (Maybe Text.Text)
                  | SaslChallenge (Maybe Text.Text)
@@ -32,4 +35,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, (TMVar Stream -> IO (Either XmppFailure (Maybe AuthFailure))))

source/Network/Xmpp/Types.hs

@@ -39,7 +39,8 @@ module Network.Xmpp.Types
     , Jid(..)
     , isBare
     , isFull
-    , fromString
+    , fromText
+    , fromTexts
     , StreamEnd(..)
     , InvalidXmppXml(..)
     )
@@ -634,7 +635,7 @@ data StreamErrorInfo = StreamErrorInfo
     } deriving (Show, Eq)
 
 -- | Signals an XMPP stream error or another unpredicted stream-related
--- situation.
+-- situation. This error is fatal, and closes the XMPP stream.
 data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
                                                         -- element has been
                                                         -- encountered.
@@ -649,14 +650,19 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
                                               -- constructor wraps the
                                               -- elements collected so
                                               -- far.
-                 | TlsError TLS.TLSError
+                 | TlsError TLS.TLSError -- ^ An error occurred in the
-                 | TlsNoServerSupport
+                                         -- TLS layer
-                 | XmppNoStream
+                 | TlsNoServerSupport -- ^ The server does not support
+                                      -- the use of TLS
+                 | XmppNoStream -- ^ An action that required an active
+                                -- stream were performed when the
+                                -- 'StreamState' was 'Closed'
                  | TlsStreamSecured -- ^ Connection already secured
                  | XmppOtherFailure -- ^ Undefined condition. More
                                     -- information should be available
                                     -- in the log.
-                 | XmppIOException IOException
+                 | XmppIOException IOException -- ^ An 'IOException'
+                                               -- occurred
                  deriving (Show, Eq, Typeable)
 
 instance Exception XmppFailure
@@ -870,14 +876,14 @@ instance IsString Jid where
 fromText :: Text -> Maybe Jid
 fromText t = do
     (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t
-    fromStrings l d r
+    fromTexts l d r
   where
     eitherToMaybe = either (const Nothing) Just
 
 -- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the
 -- appropriate stringprep profiles and validates the parts.
-fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe Jid
+fromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid
-fromStrings l d r = do
+fromTexts l d r = do
     localPart <- case l of
         Nothing -> return Nothing
         Just l'-> do