diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index f34e821..3d6d09f 100644 --- a/pontarius-xmpp.cabal +++ b/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 - , conduit >=0.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 + Build-Depends: attoparsec >=0.10.0.3 + , base >4 && <5 , 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 - , bytestring >=0.9.1.9 - , transformers >=0.2.2.0 + , data-default >=0.2 + , hslogger >=1.1.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 diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 5087d89..276a764 100644 --- a/source/Network/Xmpp.hs +++ b/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 - , AuthNoAcceptableMechanism - , AuthChallengeFailure - , AuthNoStream - , AuthFailure + , AuthFailure( AuthNoAcceptableMechanism , AuthSaslFailure - , AuthStringPrepFailure ) + , AuthIllegalCredentials + , AuthOtherFailure ) ) where diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index d338c0c..4d8a952 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/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 - _ -> do - r <- runErrorT handler - case r of - Left ae -> return $ Right $ Just ae - Right a -> do - _ <- runErrorT $ ErrorT restartStream - return $ Right $ Nothing + Closed -> return . Left $ XmppNoStream + _ -> lift $ handler stream -- | Authenticate to the server using the first matching method and bind a -- resource. diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index eea0ce7..6a34aec 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/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 diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index bca3ab5..f75df3e 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/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" - , xmppDigestMd5 authcid authzid password - ) +digestMd5 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 + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index 3e85a50..545dd21 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/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 + ) + + diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 4262c63..618ffb9 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/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 (hashToken :: Crypto.SHA1) authcid authzid passwd + ( "SCRAM-SHA-1" + , \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 ) diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index c341585..fbdd408 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/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 - | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms - -- offered - | AuthChallengeFailure - | AuthServerAuthFailure -- ^ The server failed to authenticate - -- itself - | AuthStreamFailure XmppFailure -- ^ Stream error on stream restart - -- TODO: Rename AuthConnectionFailure? - | AuthNoStream - | AuthFailure -- General instance used for the Error instance - | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition - | AuthStringPrepFailure -- ^ StringPrep failed +-- | Signals a (non-fatal) SASL authentication error condition. +data AuthFailure = -- | No mechanism offered by the server was matched + -- by the provided acceptable mechanisms; wraps the + -- mechanisms offered by the server + AuthNoAcceptableMechanism [Text.Text] + | AuthStreamFailure XmppFailure -- TODO: Remove + -- | A SASL failure element was encountered + | AuthSaslFailure SaslFailure + -- | The credentials provided did not conform to + -- the SASLprep Stringprep profile + | AuthIllegalCredentials + -- | 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)))) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index be27003..6cfd51b 100644 --- a/source/Network/Xmpp/Types.hs +++ b/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 - | TlsNoServerSupport - | XmppNoStream + | TlsError TLS.TLSError -- ^ An error occurred in the + -- TLS layer + | 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 -fromStrings l d r = do +fromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid +fromTexts l d r = do localPart <- case l of Nothing -> return Nothing Just l'-> do