diff --git a/source/Network/XMPP.hs b/source/Network/XMPP.hs
index 4de7ce9..91c9eb6 100644
--- a/source/Network/XMPP.hs
+++ b/source/Network/XMPP.hs
@@ -143,6 +143,7 @@ import Network.XMPP.Message
import Network.XMPP.Monad
import Network.XMPP.Presence
import Network.XMPP.SASL
+import Network.XMPP.SASL.Types
import Network.XMPP.Session
import Network.XMPP.Stream
import Network.XMPP.TLS
@@ -162,7 +163,7 @@ auth :: Text.Text -- ^ The username
-- assign one
-> XMPPConMonad (Either AuthError Text.Text)
auth username passwd resource = runErrorT $ do
- ErrorT $ xmppSASL username passwd
+ ErrorT $ xmppSASL [DIGEST_MD5Credentials Nothing username passwd]
res <- lift $ xmppBind resource
lift $ xmppStartSession
return res
diff --git a/source/Network/XMPP/SASL.hs b/source/Network/XMPP/SASL.hs
index 7fb1b99..105f591 100644
--- a/source/Network/XMPP/SASL.hs
+++ b/source/Network/XMPP/SASL.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
module Network.XMPP.SASL where
@@ -7,20 +7,17 @@ import Control.Arrow (left)
import Control.Monad
import Control.Monad.Error
import Control.Monad.State.Strict
+import Data.Maybe (fromJust, isJust)
import qualified Crypto.Classes as CC
-import qualified Data.Attoparsec.ByteString.Char8 as AP
import qualified Data.Binary as Binary
-import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.List as L
import Data.Word (Word8)
-import Data.XML.Pickle
-import Data.XML.Types
import qualified Data.Text as Text
import Data.Text (Text)
@@ -33,179 +30,33 @@ import Network.XMPP.Pickle
import qualified System.Random as Random
-data AuthError = AuthXmlError
- | AuthMechanismError [Text] -- ^ Wraps mechanisms offered
- | AuthChallengeError
- | AuthStreamError StreamError -- ^ Stream error on stream restart
- | AuthConnectionError -- ^ No host name set in state
- | AuthError -- General instance used for the Error instance
- deriving Show
+import Network.XMPP.SASL.SASL
+import Network.XMPP.SASL.DIGEST_MD5
+import Network.XMPP.SASL.Types
-instance Error AuthError where
- noMsg = AuthError
--- Uses the DIGEST-MD5 method (if available) to authenticate. Updates the
--- sUsername XMPPConMonad field with a `Just' value and restarts the stream upon
+-- Uses the first supported mechanism to authenticate, if any. Updates the
+-- XMPPConMonad state with non-password credentials and restarts the stream upon
-- success. This computation wraps an ErrorT computation, which means that
-- catchError can be used to catch any errors.
-xmppSASL :: Text -- ^ User name
- -> Text -- ^ Password
+xmppSASL :: [SASLCredentials] -- ^ Acceptable authentication mechanisms and
+ -- their corresponding credentials
-> XMPPConMonad (Either AuthError ())
-xmppSASL uname passwd = runErrorT $ do
- realm <- gets sHostname
- case realm of
- Just realm' -> do
- ErrorT $ xmppStartSASL realm'
- modify (\s -> s{sUsername = Just uname})
- Nothing -> throwError AuthConnectionError
+xmppSASL creds = runErrorT $ do
+ -- Chooses the first mechanism that is acceptable by both the client and the
+ -- server.
+ mechanisms <- gets $ saslMechanisms . sFeatures
+ let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds
+ unless (isJust cred) (throwError $ AuthMechanismError mechanisms)
+ case fromJust cred of
+ DIGEST_MD5Credentials authzid authcid passwd -> ErrorT $ xmppDIGEST_MD5
+ authzid
+ authcid
+ passwd
+ _ -> error "xmppSASL: Mechanism not caught"
where
- xmppStartSASL :: Text -- ^ SASL realm
- -> XMPPConMonad (Either AuthError ())
- xmppStartSASL realm = runErrorT $ do
- mechanisms <- gets $ saslMechanisms . sFeatures
- unless ("DIGEST-MD5" `elem` mechanisms) .
- throwError $ AuthMechanismError mechanisms
- -- Push element and receive the challenge (in XMPPConMonad).
- _ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean?
- challenge' <- lift $ B64.decode . Text.encodeUtf8 <$>
- pullPickle challengePickle
- challenge <- case challenge' of
- Left _e -> throwError AuthChallengeError
- Right r -> return r
- pairs <- case toPairs challenge of
- Left _ -> throwError AuthChallengeError
- Right p -> return p
- g <- liftIO Random.newStdGen
- _ <- lift . pushElement . -- TODO: Check boolean?
- saslResponseE $ createResponse g realm pairs
- challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle)
- case challenge2 of
- Left _x -> throwError AuthXmlError
- Right _ -> return ()
- lift $ pushElement saslResponse2E
- e <- lift pullElement
- case e of
- Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] ->
- return ()
- _ -> throwError AuthXmlError -- TODO: investigate
- -- The SASL authentication has succeeded; the stream is restarted.
- _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
- return ()
- -- The element.
- saslInitE :: Text -> Element
- saslInitE mechanism =
- Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
- [("mechanism", [ContentText mechanism])]
- []
- -- SASL response with text payload.
- saslResponseE :: Text -> Element
- saslResponseE resp =
- Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
- []
- [NodeContent $ ContentText resp]
- -- SASL response without payload.
- saslResponse2E :: Element
- saslResponse2E =
- Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
- []
- []
- -- Parses the incoming SASL data to a mapped list of pairs.
- toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
- toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
- AP.skipSpace
- name <- AP.takeWhile1 (/= '=')
- _ <- AP.char '='
- quote <- ((AP.char '"' >> return True) `mplus` return False)
- content <- AP.takeWhile1 (AP.notInClass [',', '"'])
- when quote . void $ AP.char '"'
- return (name, content)
- -- Produce the response to the challenge.
- createResponse :: Random.RandomGen g
- => g
- -> Text
- -> [(BS8.ByteString, BS8.ByteString)] -- Pairs
- -> Text
- createResponse g hostname pairs = let
- Just qop = L.lookup "qop" pairs
- Just nonce = L.lookup "nonce" pairs
- uname_ = Text.encodeUtf8 uname
- passwd_ = Text.encodeUtf8 passwd
- -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) compatibility.
- cnonce = BS.tail . BS.init .
- B64.encode . BS.pack . map toWord8 .
- take 8 $ Random.randoms g
- nc = "00000001"
- digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname
- digest = md5Digest
- uname_
- (lookup "realm" pairs)
- passwd_
- digestURI
- nc
- qop
- nonce
- cnonce
- response = BS.intercalate "," . map (BS.intercalate "=") $
- [["username", quote uname_]] ++
- case L.lookup "realm" pairs of
- Just realm -> [["realm" , quote realm ]]
- Nothing -> [] ++
- [ ["nonce" , quote nonce ]
- , ["cnonce" , quote cnonce ]
- , ["nc" , nc ]
- , ["qop" , qop ]
- , ["digest-uri", quote digestURI]
- , ["response" , digest ]
- , ["charset" , "utf-8" ]
- ]
- in Text.decodeUtf8 $ B64.encode response
- quote :: BS8.ByteString -> BS8.ByteString
- quote x = BS.concat ["\"",x,"\""]
- toWord8 :: Int -> Word8
- toWord8 x = fromIntegral x :: Word8
- hash :: [BS8.ByteString] -> BS8.ByteString
- hash = BS8.pack . show
- . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
- hashRaw :: [BS8.ByteString] -> BS8.ByteString
- hashRaw = toStrict . Binary.encode .
- (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
- toStrict :: BL.ByteString -> BS8.ByteString
- toStrict = BS.concat . BL.toChunks
- -- TODO: this only handles MD5-sess
- md5Digest :: BS8.ByteString
- -> Maybe BS8.ByteString
- -> BS8.ByteString
- -> BS8.ByteString
- -> BS8.ByteString
- -> BS8.ByteString
- -> BS8.ByteString
- -> BS8.ByteString
- -> BS8.ByteString
- md5Digest uname realm password digestURI nc qop nonce cnonce =
- let ha1 = hash [ hashRaw [uname, maybe "" id realm, password]
- , nonce
- , cnonce
- ]
- ha2 = hash ["AUTHENTICATE", digestURI]
- in hash [ha1, nonce, nc, cnonce, qop, ha2]
- -- Failure element pickler.
- failurePickle :: PU [Node] SaslFailure
- failurePickle = xpWrap
- (\(txt, (failure, _, _)) -> SaslFailure failure txt)
- (\(SaslFailure failure txt) -> (txt,(failure,(),())))
- (xpElemNodes
- "{urn:ietf:params:xml:ns:xmpp-sasl}failure"
- (xp2Tuple
- (xpOption $ xpElem
- "{urn:ietf:params:xml:ns:xmpp-sasl}text"
- xpLangTag
- (xpContent xpId))
- (xpElemByNamespace
- "urn:ietf:params:xml:ns:xmpp-sasl"
- xpPrim
- (xpUnit)
- (xpUnit))))
- -- Challenge element pickler.
- challengePickle :: PU [Node] Text.Text
- challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
- (xpIsolate $ xpContent xpId)
\ No newline at end of file
+ -- Converts the credentials to the appropriate mechanism name, corresponding to
+ -- the XMPP mechanism attribute.
+ credsToName :: SASLCredentials -> Text
+ credsToName (DIGEST_MD5Credentials _ _ _) = "DIGEST-MD5"
+ credsToName c = error $ "credsToName failed for " ++ (show c)
\ No newline at end of file
diff --git a/source/Network/XMPP/SASL/DIGEST_MD5.hs b/source/Network/XMPP/SASL/DIGEST_MD5.hs
new file mode 100644
index 0000000..b113569
--- /dev/null
+++ b/source/Network/XMPP/SASL/DIGEST_MD5.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.XMPP.SASL.DIGEST_MD5 where
+
+import Control.Applicative
+import Control.Arrow (left)
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.State.Strict
+import Data.Maybe (fromJust, isJust)
+
+import qualified Crypto.Classes as CC
+
+import qualified Data.Binary as Binary
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Digest.Pure.MD5 as MD5
+import qualified Data.List as L
+import Data.Word (Word8)
+
+import qualified Data.Text as Text
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+
+import Data.XML.Pickle
+
+import qualified Data.ByteString as BS
+
+import Data.XML.Types
+
+import Network.XMPP.Monad
+import Network.XMPP.Stream
+import Network.XMPP.Types
+import Network.XMPP.Pickle
+
+import qualified System.Random as Random
+
+import Network.XMPP.SASL.SASL
+import Network.XMPP.SASL.Types
+
+xmppDIGEST_MD5 :: Maybe Text -- Authorization identity (authzid)
+ -> Text -- Authentication identity (authzid)
+ -> Text -- Password (authzid)
+ -> XMPPConMonad (Either AuthError ())
+xmppDIGEST_MD5 authzid authcid passwd = runErrorT $ do
+ realm <- gets sHostname
+ case realm of
+ Just realm' -> do
+ ErrorT $ xmppDIGEST_MD5' realm'
+ -- TODO: Save authzid
+ modify (\s -> s{sUsername = Just authcid})
+ Nothing -> throwError AuthConnectionError
+ where
+ xmppDIGEST_MD5' :: Text -- ^ SASL realm
+ -> XMPPConMonad (Either AuthError ())
+ xmppDIGEST_MD5' realm = runErrorT $ do
+ -- Push element and receive the challenge (in XMPPConMonad).
+ _ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean?
+ challenge' <- lift $ B64.decode . Text.encodeUtf8 <$>
+ pullPickle challengePickle
+ challenge <- case challenge' of
+ Left _e -> throwError AuthChallengeError
+ Right r -> return r
+ pairs <- case toPairs challenge of
+ Left _ -> throwError AuthChallengeError
+ Right p -> return p
+ g <- liftIO Random.newStdGen
+ _ <- lift . pushElement . -- TODO: Check boolean?
+ saslResponseE $ createResponse g realm pairs
+ challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle)
+ case challenge2 of
+ Left _x -> throwError AuthXmlError
+ Right _ -> return ()
+ lift $ pushElement saslResponse2E
+ e <- lift pullElement
+ case e of
+ Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] ->
+ return ()
+ _ -> throwError AuthXmlError -- TODO: investigate
+ -- The SASL authentication has succeeded; the stream is restarted.
+ _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
+ return ()
+ -- Produce the response to the challenge.
+ createResponse :: Random.RandomGen g
+ => g
+ -> Text
+ -> [(BS8.ByteString, BS8.ByteString)] -- Pairs
+ -> Text
+ createResponse g hostname pairs = let
+ Just qop = L.lookup "qop" pairs
+ Just nonce = L.lookup "nonce" pairs
+ uname_ = Text.encodeUtf8 authcid
+ passwd_ = Text.encodeUtf8 passwd
+ -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) compatibility.
+ cnonce = BS.tail . BS.init .
+ B64.encode . BS.pack . map toWord8 .
+ take 8 $ Random.randoms g
+ nc = "00000001"
+ digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname
+ digest = md5Digest
+ uname_
+ (lookup "realm" pairs)
+ passwd_
+ digestURI
+ nc
+ qop
+ nonce
+ cnonce
+ response = BS.intercalate "," . map (BS.intercalate "=") $
+ [["username", quote uname_]] ++
+ case L.lookup "realm" pairs of
+ Just realm -> [["realm" , quote realm ]]
+ Nothing -> [] ++
+ [ ["nonce" , quote nonce ]
+ , ["cnonce" , quote cnonce ]
+ , ["nc" , nc ]
+ , ["qop" , qop ]
+ , ["digest-uri", quote digestURI]
+ , ["response" , digest ]
+ , ["charset" , "utf-8" ]
+ ]
+ in Text.decodeUtf8 $ B64.encode response
+ quote :: BS8.ByteString -> BS8.ByteString
+ quote x = BS.concat ["\"",x,"\""]
+ toWord8 :: Int -> Word8
+ toWord8 x = fromIntegral x :: Word8
+ hash :: [BS8.ByteString] -> BS8.ByteString
+ hash = BS8.pack . show
+ . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
+ hashRaw :: [BS8.ByteString] -> BS8.ByteString
+ hashRaw = toStrict . Binary.encode .
+ (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
+ toStrict :: BL.ByteString -> BS8.ByteString
+ toStrict = BS.concat . BL.toChunks
+ -- TODO: this only handles MD5-sess
+ md5Digest :: BS8.ByteString
+ -> Maybe BS8.ByteString
+ -> BS8.ByteString
+ -> BS8.ByteString
+ -> BS8.ByteString
+ -> BS8.ByteString
+ -> BS8.ByteString
+ -> BS8.ByteString
+ -> BS8.ByteString
+ md5Digest uname realm password digestURI nc qop nonce cnonce =
+ let ha1 = hash [ hashRaw [uname, maybe "" id realm, password]
+ , nonce
+ , cnonce
+ ]
+ ha2 = hash ["AUTHENTICATE", digestURI]
+ in hash [ha1, nonce, nc, cnonce, qop, ha2]
\ No newline at end of file
diff --git a/source/Network/XMPP/SASL/SASL.hs b/source/Network/XMPP/SASL/SASL.hs
new file mode 100644
index 0000000..8259664
--- /dev/null
+++ b/source/Network/XMPP/SASL/SASL.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.XMPP.SASL.SASL where
+
+import Network.XMPP.Types
+
+import Control.Monad.Error
+import Data.Text
+import qualified Data.Attoparsec.ByteString.Char8 as AP
+import Data.XML.Pickle
+import Data.XML.Types
+import qualified Data.ByteString as BS
+
+import Network.XMPP.Pickle
+
+-- The element.
+saslInitE :: Text -> Element
+saslInitE mechanism =
+ Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
+ [("mechanism", [ContentText mechanism])]
+ []
+-- SASL response with text payload.
+saslResponseE :: Text -> Element
+saslResponseE resp =
+ Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
+ []
+ [NodeContent $ ContentText resp]
+-- SASL response without payload.
+saslResponse2E :: Element
+saslResponse2E =
+ Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
+ []
+ []
+-- Parses the incoming SASL data to a mapped list of pairs.
+toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
+toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
+ AP.skipSpace
+ name <- AP.takeWhile1 (/= '=')
+ _ <- AP.char '='
+ quote <- ((AP.char '"' >> return True) `mplus` return False)
+ content <- AP.takeWhile1 (AP.notInClass [',', '"'])
+ when quote . void $ AP.char '"'
+ return (name, content)
+
+-- Failure element pickler.
+failurePickle :: PU [Node] SaslFailure
+failurePickle = xpWrap
+ (\(txt, (failure, _, _)) -> SaslFailure failure txt)
+ (\(SaslFailure failure txt) -> (txt,(failure,(),())))
+ (xpElemNodes
+ "{urn:ietf:params:xml:ns:xmpp-sasl}failure"
+ (xp2Tuple
+ (xpOption $ xpElem
+ "{urn:ietf:params:xml:ns:xmpp-sasl}text"
+ xpLangTag
+ (xpContent xpId))
+ (xpElemByNamespace
+ "urn:ietf:params:xml:ns:xmpp-sasl"
+ xpPrim
+ (xpUnit)
+ (xpUnit))))
+-- Challenge element pickler.
+challengePickle :: PU [Node] Text
+challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
+ (xpIsolate $ xpContent xpId)
\ No newline at end of file
diff --git a/source/Network/XMPP/SASL/Types.hs b/source/Network/XMPP/SASL/Types.hs
new file mode 100644
index 0000000..b8f93c6
--- /dev/null
+++ b/source/Network/XMPP/SASL/Types.hs
@@ -0,0 +1,16 @@
+module Network.XMPP.SASL.Types where
+
+import Control.Monad.Error
+import Data.Text
+import Network.XMPP.Types
+
+data AuthError = AuthXmlError
+ | AuthMechanismError [Text] -- ^ Wraps mechanisms offered
+ | AuthChallengeError
+ | AuthStreamError StreamError -- ^ Stream error on stream restart
+ | AuthConnectionError -- ^ No host name set in state
+ | AuthError -- General instance used for the Error instance
+ deriving Show
+
+instance Error AuthError where
+ noMsg = AuthError
\ No newline at end of file
diff --git a/source/Network/XMPP/Types.hs b/source/Network/XMPP/Types.hs
index 7706f0d..f3130c5 100644
--- a/source/Network/XMPP/Types.hs
+++ b/source/Network/XMPP/Types.hs
@@ -22,6 +22,8 @@ module Network.XMPP.Types
, PresenceType(..)
, SaslError(..)
, SaslFailure(..)
+ , SASLMechanism (..)
+ , SASLCredentials (..)
, ServerFeatures(..)
, Stanza(..)
, StanzaError(..)
@@ -50,6 +52,7 @@ import Control.Monad.Error
import qualified Data.ByteString as BS
import Data.Conduit
import Data.String(IsString(..))
+import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable(Typeable)
@@ -399,6 +402,15 @@ instance Read StanzaErrorCondition where
-- OTHER STUFF
-- =============================================================================
+data SASLCredentials = DIGEST_MD5Credentials (Maybe Text) Text Text
+
+instance Show SASLCredentials where
+ show (DIGEST_MD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++
+ (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++
+ " (password hidden)"
+
+data SASLMechanism = DIGEST_MD5 deriving Show
+
data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
, saslFailureText :: Maybe ( Maybe LangTag
, Text