diff --git a/pontarius.cabal b/pontarius.cabal
index 92d4224..49a8090 100644
--- a/pontarius.cabal
+++ b/pontarius.cabal
@@ -37,6 +37,7 @@ Library
, binary -any
, attoparsec -any
, crypto-api -any
+ , cryptohash -any
, text -any
, bytestring -any
, transformers -any
@@ -62,6 +63,7 @@ Library
, Network.Xmpp.Sasl
, Network.Xmpp.Sasl.Plain
, Network.Xmpp.Sasl.DigestMD5
+ , Network.Xmpp.Sasl.Scram
, Network.Xmpp.Sasl.Types
, Network.Xmpp.Session
, Network.Xmpp.Stream
diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs
index 700d6f5..985f99c 100644
--- a/source/Network/Xmpp.hs
+++ b/source/Network/Xmpp.hs
@@ -157,6 +157,8 @@ import Network.Xmpp.Message
import Network.Xmpp.Monad
import Network.Xmpp.Presence
import Network.Xmpp.Sasl
+import Network.Xmpp.Sasl.Scram
+import Network.Xmpp.Sasl.Plain
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Session
import Network.Xmpp.Stream
@@ -177,7 +179,7 @@ auth :: Text.Text -- ^ The username
-- assign one
-> XmppConMonad (Either AuthError Text.Text)
auth username passwd resource = runErrorT $ do
- ErrorT $ xmppSASL [DIGEST_MD5Credentials Nothing username passwd]
+ ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd]
res <- lift $ xmppBind resource
lift $ xmppStartSession
return res
diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs
index 14670a2..9843eb7 100644
--- a/source/Network/Xmpp/Monad.hs
+++ b/source/Network/Xmpp/Monad.hs
@@ -99,6 +99,7 @@ xmppNoConnection = XmppConnection
, sFeatures = SF Nothing [] []
, sConnectionState = XmppConnectionClosed
, sHostname = Nothing
+ , sAuthzid = Nothing
, sUsername = Nothing
, sResource = Nothing
, sCloseConnection = return ()
@@ -111,7 +112,6 @@ xmppNoConnection = XmppConnection
-- updates the XmppConMonad XmppConnection state.
xmppRawConnect :: HostName -> Text -> XmppConMonad ()
xmppRawConnect host hostname = do
- uname <- gets sUsername
con <- liftIO $ do
con <- connectTo host (PortNumber 5222)
hSetBuffering con NoBuffering
@@ -126,7 +126,8 @@ xmppRawConnect host hostname = do
(SF Nothing [] [])
XmppConnectionPlain
(Just hostname)
- uname
+ Nothing
+ Nothing
Nothing
(hClose con)
put st
diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs
index 569d2f3..b32b689 100644
--- a/source/Network/Xmpp/Sasl.hs
+++ b/source/Network/Xmpp/Sasl.hs
@@ -30,38 +30,42 @@ import Network.Xmpp.Pickle
import qualified System.Random as Random
-import Network.Xmpp.Sasl.Sasl
import Network.Xmpp.Sasl.DigestMD5
import Network.Xmpp.Sasl.Plain
import Network.Xmpp.Sasl.Types
+
+runSasl :: (Text.Text -> Text.Text -> Maybe Text.Text -> SaslM a)
+ -> Text.Text
+ -> Maybe Text.Text
+ -> XmppConMonad (Either AuthError a)
+runSasl authAction authcid authzid = runErrorT $ do
+ hn <- gets sHostname
+ case hn of
+ Just hn' -> do
+ r <- authAction hn' authcid authzid
+ modify (\s -> s{ sUsername = Just authcid
+ , sAuthzid = authzid
+ })
+ _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
+ return r
+ Nothing -> throwError AuthConnectionError
+
-- 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 :: [SASLCredentials] -- ^ Acceptable authentication mechanisms and
- -- their corresponding credentials
+xmppSasl :: Text.Text
+ -> Maybe Text.Text
+ -> [SaslHandler] -- ^ Acceptable authentication
+ -- mechanisms and their corresponding
+ -- handlers
-> XmppConMonad (Either AuthError ())
-xmppSASL creds = runErrorT $ do
+xmppSasl authcid authzid handlers = 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 $ xmppDigestMD5
- authzid
- authcid
- passwd
- PLAINCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN
- authzid
- authcid
- passwd
- _ -> error "xmppSASL: Mechanism not caught"
- where
- -- Converts the credentials to the appropriate mechanism name, corresponding to
- -- the XMPP mechanism attribute.
- credsToName :: SASLCredentials -> Text
- credsToName (DIGEST_MD5Credentials _ _ _) = "DIGEST-MD5"
- credsToName (PLAINCredentials _ _ _) = "PLAIN"
- credsToName c = error $ "credsToName failed for " ++ (show c)
\ No newline at end of file
+ case (filter (\(name,_) -> name `elem` mechanisms)) handlers of
+ [] -> return . Left $ AuthNoAcceptableMechanism mechanisms
+ (_name, handler):_ -> runSasl handler authcid authzid
+
diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs
new file mode 100644
index 0000000..c65328d
--- /dev/null
+++ b/source/Network/Xmpp/Sasl/Common.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Xmpp.Sasl.Common where
+
+import Network.Xmpp.Types
+
+import Control.Applicative ((<$>))
+import Control.Monad.Error
+import Control.Monad.State.Class
+
+import qualified Data.Attoparsec.ByteString.Char8 as AP
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import Data.Maybe (fromMaybe)
+import Data.Maybe (maybeToList)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.XML.Pickle
+import Data.XML.Types
+import Data.Word (Word8)
+
+import Network.Xmpp.Monad
+import Network.Xmpp.Pickle
+import Network.Xmpp.Sasl.Types
+
+import qualified System.Random as Random
+
+data SaslElement = SaslSuccess (Maybe Text.Text)
+ | SaslChallenge (Maybe Text.Text)
+
+--makeNonce :: SaslM BS.ByteString
+makeNonce :: IO BS.ByteString
+makeNonce = do
+ g <- liftIO Random.newStdGen
+ return $ B64.encode . BS.pack . map toWord8 . take 15 $ Random.randoms g
+ where
+ toWord8 :: Int -> Word8
+ toWord8 x = fromIntegral x :: Word8
+
+-- The element, with an
+-- optional round-trip value.
+saslInitE :: Text.Text -> Maybe Text.Text -> Element
+saslInitE mechanism rt =
+ Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
+ [("mechanism", [ContentText mechanism])]
+ (maybeToList $ NodeContent . ContentText <$> rt)
+
+-- SASL response with text payload.
+saslResponseE :: Maybe Text.Text -> Element
+saslResponseE resp =
+ Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
+ []
+ (maybeToList $ NodeContent . ContentText <$> resp)
+
+xpSuccess :: PU [Node] (Maybe Text.Text)
+xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success"
+ (xpOption $ xpContent xpId)
+
+-- Parses the incoming SASL data to a mapped list of pairs.
+pairs :: BS.ByteString -> Either String Pairs
+pairs = 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.
+xpFailure :: PU [Node] SaslFailure
+xpFailure = 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.
+xpChallenge :: PU [Node] (Maybe Text.Text)
+xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
+ (xpOption $ xpContent xpId)
+
+-- | pickler for SaslElement
+xpSaslElement :: PU [Node] SaslElement
+xpSaslElement = xpAlt saslSel
+ [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess
+ , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge
+ ]
+ where
+ saslSel (SaslSuccess _) = 0
+ saslSel (SaslChallenge _) = 1
+
+-- | Add quotationmarks around a byte string
+quote :: BS.ByteString -> BS.ByteString
+quote x = BS.concat ["\"",x,"\""]
+
+saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool
+saslInit mechanism payload = lift . pushElement . saslInitE mechanism $
+ Text.decodeUtf8 . B64.encode <$> payload
+
+-- | Pull the next element
+pullSaslElement :: SaslM SaslElement
+pullSaslElement = do
+ el <- lift $ pullPickle (xpEither xpFailure xpSaslElement)
+ case el of
+ Left e ->throwError $ AuthSaslFailure e
+ Right r -> return r
+
+-- | Pull the next element, checking that it is a challenge
+pullChallenge :: SaslM (Maybe BS.ByteString)
+pullChallenge = do
+ e <- pullSaslElement
+ case e of
+ SaslChallenge Nothing -> return Nothing
+ SaslChallenge (Just scb64)
+ | Right sc <- B64.decode . Text.encodeUtf8 $ scb64
+ -> return $ Just sc
+ _ -> throwError AuthChallengeError
+
+-- | Extract value from Just, failing with AuthChallengeError on Nothing
+saslFromJust :: Maybe a -> SaslM a
+saslFromJust Nothing = throwError $ AuthChallengeError
+saslFromJust (Just d) = return d
+
+-- | Pull the next element and check that it is success
+pullSuccess :: SaslM (Maybe Text.Text)
+pullSuccess = do
+ e <- pullSaslElement
+ case e of
+ SaslSuccess x -> return x
+ _ -> throwError $ AuthXmlError
+
+-- | Pull the next element. When it's success, return it's payload.
+-- If it's a challenge, send an empty response and pull success
+pullFinalMessage :: SaslM (Maybe BS.ByteString)
+pullFinalMessage = do
+ challenge2 <- pullSaslElement
+ case challenge2 of
+ SaslSuccess x -> decode x
+ SaslChallenge x -> do
+ _b <- respond Nothing
+ _s <- pullSuccess
+ decode x
+ where
+ decode Nothing = return Nothing
+ decode (Just d) = case B64.decode $ Text.encodeUtf8 d of
+ Left _e -> throwError $ AuthChallengeError
+ Right x -> return $ Just x
+
+-- | Extract p=q pairs from a challenge
+toPairs :: BS.ByteString -> SaslM Pairs
+toPairs ctext = case pairs ctext of
+ Left _e -> throwError AuthChallengeError
+ Right r -> return r
+
+-- | Send a SASL response element. The content will be base64-encoded for you
+respond :: Maybe BS.ByteString -> SaslM Bool
+respond = lift . pushElement . saslResponseE .
+ fmap (Text.decodeUtf8 . B64.encode)
+
diff --git a/source/Network/Xmpp/Sasl/DigestMD5.hs b/source/Network/Xmpp/Sasl/DigestMD5.hs
index 1872ded..80db9b5 100644
--- a/source/Network/Xmpp/Sasl/DigestMD5.hs
+++ b/source/Network/Xmpp/Sasl/DigestMD5.hs
@@ -17,7 +17,6 @@ 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)
@@ -34,68 +33,47 @@ 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.Common
import Network.Xmpp.Sasl.Types
+
+
xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid)
-> Text -- Authentication identity (authzid)
-> Text -- Password (authzid)
-> XmppConMonad (Either AuthError ())
xmppDigestMD5 authzid authcid passwd = runErrorT $ do
- realm <- gets sHostname
- case realm of
- Just realm' -> do
- ErrorT $ xmppDIGEST_MD5' realm'
+ hn <- gets sHostname
+ case hn of
+ Just hn' -> do
+ xmppDigestMD5' hn'
-- 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" Nothing -- 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.
+ xmppDigestMD5' :: Text -> SaslM ()
+ xmppDigestMD5' hostname = do
+ -- Push element and receive the challenge (in SaslM).
+ _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?
+ pairs <- toPairs =<< saslFromJust =<< pullChallenge
+ cnonce <- liftIO $ makeNonce
+ _b <- respond . Just $ createResponse hostname pairs cnonce
+ challenge2 <- pullFinalMessage
_ <- 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
+ createResponse :: Text
+ -> Pairs
+ -> BS.ByteString -- nonce
+ -> BS.ByteString
+ createResponse hostname pairs cnonce = 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
@@ -120,11 +98,7 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do
, ["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
+ in B64.encode response
hash :: [BS8.ByteString] -> BS8.ByteString
hash = BS8.pack . show
. (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Plain.hs
index e265230..32e8633 100644
--- a/source/Network/Xmpp/Sasl/Plain.hs
+++ b/source/Network/Xmpp/Sasl/Plain.hs
@@ -40,34 +40,38 @@ import Network.Xmpp.Pickle
import qualified System.Random as Random
import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
+import qualified Data.Text as Text
-import Network.Xmpp.Sasl.Sasl
+import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.Types
-xmppPLAIN :: Maybe T.Text
- -> T.Text
- -> T.Text
- -> XmppConMonad (Either AuthError ())
-xmppPLAIN authzid authcid passwd = runErrorT $ do
- _ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean?
- Just $ Text.decodeUtf8 $ B64.encode $ Text.encodeUtf8 $ plainMessage authzid authcid passwd
- 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
+-- TODO: stringprep
+xmppPlain :: SaslM Text.Text
+ -> a
+ -> Text.Text
+ -> Maybe Text.Text
+ -> SaslM ()
+xmppPlain pw _hostname authcid authzid = do
+ passwd <- pw
+ _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd)
+ _ <- pullSuccess
return ()
where
-- Converts an optional authorization identity, an authentication identity,
-- and a password to a \NUL-separated PLAIN message.
- plainMessage :: Maybe T.Text -- Authorization identity (authzid)
- -> T.Text -- Authentication identity (authcid)
- -> T.Text -- Password
- -> T.Text -- The PLAIN message
- plainMessage authzid authcid passwd =
- let authzid' = fromMaybe "" authzid in
- T.concat [authzid', "\NUL", authcid, "\NUL", passwd]
\ No newline at end of file
+ plainMessage :: Maybe Text.Text -- Authorization identity (authzid)
+ -> Text.Text -- Authentication identity (authcid)
+ -> Text.Text -- Password
+ -> BS.ByteString -- The PLAIN message
+ plainMessage authzid authcid passwd = BS.concat $
+ [ authzid'
+ , "\NUL"
+ , Text.encodeUtf8 $ authcid
+ , "\NUL"
+ , Text.encodeUtf8 $ passwd
+ ]
+ where
+ authzid' = maybe "" Text.encodeUtf8 authzid
+
+plain :: SaslM Text.Text -> SaslHandler
+plain passwd = ("PLAIN", xmppPlain passwd)
\ No newline at end of file
diff --git a/source/Network/Xmpp/Sasl/Sasl.hs b/source/Network/Xmpp/Sasl/Sasl.hs
deleted file mode 100644
index e72d6e4..0000000
--- a/source/Network/Xmpp/Sasl/Sasl.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# 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 Data.Maybe (fromMaybe)
-
-import Network.Xmpp.Pickle
-
--- The element, with an
--- optional round-trip value.
-saslInitE :: Text -> Maybe Text -> Element
-saslInitE mechanism rt =
- Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
- [("mechanism", [ContentText mechanism])]
- [NodeContent $ ContentText $ fromMaybe "" rt]
-
--- 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/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs
new file mode 100644
index 0000000..6750e85
--- /dev/null
+++ b/source/Network/Xmpp/Sasl/Scram.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Xmpp.Sasl.Scram where
+
+import Control.Applicative((<$>))
+import Control.Monad.Error
+import Control.Monad.Trans (liftIO)
+import qualified Crypto.Classes as Crypto
+import qualified Crypto.HMAC as Crypto
+import qualified Crypto.Hash.SHA1 as Crypto
+import Data.Binary(Binary,encode)
+import Data.Bits
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import Data.ByteString.Char8 as BS8 (unpack)
+import qualified Data.ByteString.Lazy as LBS
+import Data.List (foldl1')
+
+
+import qualified Data.Binary.Builder as Build
+
+import Data.Maybe (maybeToList)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Word(Word8)
+
+import Network.Xmpp.Sasl.Common
+import Network.Xmpp.Sasl.Types
+
+-- | Bit-wise xor of byte strings
+xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString
+xorBS x y = BS.pack $ BS.zipWith xor x y
+
+-- | Join byte strings with ","
+merge :: [BS.ByteString] -> BS.ByteString
+merge = BS.intercalate ","
+
+-- | Infix concatenation of byte strings
+(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString
+(+++) = BS.append
+
+-- | A nicer name for undefined, for use as a dummy token to determin
+-- the hash function to use
+hashToken :: (Crypto.Hash ctx hash) => hash
+hashToken = undefined
+
+-- | Salted Challenge Response Authentication Mechanism (SCRAM) SASL
+-- mechanism according to RFC 5802.
+--
+-- This implementation is independent and polymorphic in the used hash function.
+scram :: (Crypto.Hash ctx hash)
+ => hash -- ^ Dummy argument to determine the hash to use. You
+ -- can safely pass undefined or a 'hashToken' to it
+ -> Text.Text -- ^ authentication ID (username)
+ -> Maybe Text.Text -- ^ authorization ID
+ -> Text.Text -- ^ password
+ -> SaslM ()
+scram hashToken authcid authzid' password = do
+ cnonce <- liftIO $ makeNonce
+ saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)
+ liftIO $ putStrLn "pulling challenge"
+ sFirstMessage <- saslFromJust =<< pullChallenge
+ liftIO $ putStrLn "pulled challenge"
+ pairs <- toPairs sFirstMessage
+ (nonce, salt, ic) <- fromPairs pairs cnonce
+ let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce
+ respond $ Just cfm
+ finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage
+ unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError
+ return ()
+ where
+ -- We need to jump through some hoops to get a polymorphic solution
+ encode :: Crypto.Hash ctx hash => hash -> hash -> BS.ByteString
+ encode _hashtoken = Crypto.encode
+ hash str = encode hashToken $ Crypto.hash' str
+ hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str
+
+ authzid = (\z -> "a=" +++ normalize z) <$> authzid'
+ gs2CbindFlag = "n" -- we don't support channel binding yet
+ gs2Header = merge $ [ gs2CbindFlag
+ , maybe "" id authzid
+ , ""
+ ]
+ cbindData = "" -- we don't support channel binding yet
+ cFirstMessageBare cnonce = merge [ "n=" +++ normalize authcid
+ , "r=" +++ cnonce]
+ cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce
+
+ fromPairs :: Pairs
+ -> BS.ByteString
+ -> SaslM (BS.ByteString, BS.ByteString, Int)
+ fromPairs pairs cnonce | Just nonce <- lookup "r" pairs
+ , cnonce `BS.isPrefixOf` nonce
+ , Just salt' <- lookup "s" pairs
+ , Right salt <- B64.decode salt'
+ , Just ic <- lookup "i" pairs
+ , [(i,"")] <- reads $ BS8.unpack ic
+ = return (nonce, salt, i :: Int)
+ fromPairs _ _ = throwError $ AuthChallengeError
+
+ cFinalMessageAndVerifier nonce salt ic sfm cnonce
+ = (merge [ cFinalMessageWOProof
+ , "p=" +++ B64.encode clientProof
+ ]
+ , B64.encode serverSignature
+ )
+ where
+ cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header
+ , "r=" +++ nonce]
+ saltedPassword = hi (normalize password) salt ic
+ clientKey = hmac saltedPassword "Client Key"
+ storedKey = hash clientKey
+ authMessage = merge [ cFirstMessageBare cnonce
+ , sfm
+ , cFinalMessageWOProof
+ ]
+ clientSignature = hmac storedKey authMessage
+ clientProof = clientKey `xorBS` clientSignature
+ serverKey = hmac saltedPassword "Server Key"
+ serverSignature = hmac serverKey authMessage
+
+ -- helper
+ hi str salt ic = foldl1' xorBS (take ic us)
+ where
+ u1 = hmac str (salt +++ (BS.pack [0,0,0,1]))
+ us = iterate (hmac str) u1
+
+ normalize = Text.encodeUtf8 . id -- TODO: stringprep
+ base64 = B64.encode
+
+-- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler
+scramSha1 :: SaslM Text.Text -> SaslHandler
+scramSha1 passwd = ("SCRAM-SHA-1"
+ , \_hostname authcid authzid -> do
+ pw <- passwd
+ scram (hashToken :: Crypto.SHA1) authcid authzid pw
+ )
diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs
index f870c93..00ea74b 100644
--- a/source/Network/Xmpp/Sasl/Types.hs
+++ b/source/Network/Xmpp/Sasl/Types.hs
@@ -1,16 +1,31 @@
module Network.Xmpp.Sasl.Types where
import Control.Monad.Error
-import Data.Text
+import Control.Monad.State.Strict
+import Data.ByteString(ByteString)
+import qualified Data.Text as Text
import Network.Xmpp.Types
data AuthError = AuthXmlError
- | AuthMechanismError [Text] -- ^ Wraps mechanisms offered
+ | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms
+ -- offered
| AuthChallengeError
+ | AuthServerAuthError -- ^ The server failed to authenticate
+ -- himself
| AuthStreamError StreamError -- ^ Stream error on stream restart
| AuthConnectionError -- ^ No host name set in state
| AuthError -- General instance used for the Error instance
+ | AuthSaslFailure SaslFailure -- ^ defined SASL error condition
deriving Show
instance Error AuthError where
- noMsg = AuthError
\ No newline at end of file
+ noMsg = AuthError
+
+type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a
+
+type Pairs = [(ByteString, ByteString)]
+
+type SaslHandler = (Text.Text, Text.Text
+ -> Text.Text
+ -> Maybe Text.Text
+ -> SaslM ())
\ No newline at end of file
diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs
index 4be0af5..087874b 100644
--- a/source/Network/Xmpp/Types.hs
+++ b/source/Network/Xmpp/Types.hs
@@ -22,8 +22,8 @@ module Network.Xmpp.Types
, PresenceType(..)
, SaslError(..)
, SaslFailure(..)
- , SASLMechanism (..)
- , SASLCredentials (..)
+ , SaslMechanism (..)
+ , SaslCredentials (..)
, ServerFeatures(..)
, Stanza(..)
, StanzaError(..)
@@ -402,18 +402,18 @@ instance Read StanzaErrorCondition where
-- OTHER STUFF
-- =============================================================================
-data SASLCredentials = DIGEST_MD5Credentials (Maybe Text) Text Text
- | PLAINCredentials (Maybe Text) Text Text
+data SaslCredentials = DigestMD5Credentials (Maybe Text) Text Text
+ | PlainCredentials (Maybe Text) Text Text
-instance Show SASLCredentials where
- show (DIGEST_MD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++
+instance Show SaslCredentials where
+ show (DigestMD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++
(Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++
" (password hidden)"
- show (PLAINCredentials authzid authcid _) = "PLAINCredentials " ++
+ show (PlainCredentials authzid authcid _) = "PLAINCredentials " ++
(Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++
" (password hidden)"
-data SASLMechanism = DIGEST_MD5 deriving Show
+data SaslMechanism = DigestMD5 deriving Show
data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
, saslFailureText :: Maybe ( Maybe LangTag
@@ -655,6 +655,7 @@ data XmppConnection = XmppConnection
, sConnectionState :: XmppConnectionState
, sHostname :: Maybe Text
, sUsername :: Maybe Text
+ , sAuthzid :: Maybe Text
, sResource :: Maybe Text
, sCloseConnection :: IO ()
-- TODO: add default Language
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 76b826f..47f5ea3 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -12,9 +12,9 @@ import qualified Data.Text as Text
import Data.XML.Pickle
import Data.XML.Types
-import Network.XMPP
-import Network.XMPP.IM.Presence
-import Network.XMPP.Pickle
+import Network.Xmpp
+import Network.Xmpp.IM.Presence
+import Network.Xmpp.Pickle
import System.Environment
import Text.XML.Stream.Elements
@@ -29,7 +29,7 @@ supervisor :: JID
supervisor = read "uart14@species64739.dyndns.org"
-attXmpp :: STM a -> XMPP a
+attXmpp :: STM a -> Xmpp a
attXmpp = liftIO . atomically
testNS :: Text
@@ -70,7 +70,7 @@ iqResponder = do
liftIO $ threadDelay 1000000
endSession
-autoAccept :: XMPP ()
+autoAccept :: Xmpp ()
autoAccept = forever $ do
st <- waitForPresence isPresenceSubscribe
sendPresence $ presenceSubscribed (fromJust $ presenceFrom st)