From cfb3597feb857af8b9c7ebd1232c207c4a8eefd8 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 9 Jun 2012 00:19:37 +0200 Subject: [PATCH] add scram add sAuthzid to XmppConnection add sAuthzid to XmppConnection more work on sasl infrastructure move more stuff from DigestMd5 to Common more work on sasl infrastructure --- pontarius.cabal | 2 + source/Network/Xmpp.hs | 4 +- source/Network/Xmpp/Monad.hs | 5 +- source/Network/Xmpp/Sasl.hs | 50 +++++---- source/Network/Xmpp/Sasl/Common.hs | 70 ++++++++---- source/Network/Xmpp/Sasl/DigestMD5.hs | 46 +++----- source/Network/Xmpp/Sasl/Plain.hs | 52 +++++---- source/Network/Xmpp/Sasl/Scram.hs | 152 ++++++++++++++++++++++++++ source/Network/Xmpp/Sasl/Types.hs | 20 ++-- source/Network/Xmpp/Types.hs | 1 + tests/Tests.hs | 10 +- 11 files changed, 300 insertions(+), 112 deletions(-) create mode 100644 source/Network/Xmpp/Sasl/Scram.hs 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 3c9a233..fae301c 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -145,6 +145,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 @@ -165,7 +167,7 @@ auth :: Text.Text -- ^ The username -- assign one -> XmppConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT $ xmppSasl [DigestMD5Credentials 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 34c504d..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 - DigestMD5Credentials 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 (DigestMD5Credentials _ _ _) = "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 index 84ee393..c56e7a9 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Sasl.Common where @@ -6,41 +7,55 @@ 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 Data.Text +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 -data SaslElement = SaslSuccess - | SaslChallenge (Maybe Text) +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 -> Maybe Text -> Element +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 -> Element +saslResponseE :: Maybe Text.Text -> Element saslResponseE resp = Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] (maybeToList $ NodeContent . ContentText <$> resp) -xpSuccess :: PU [Node] () -xpSuccess = xpElemBlank "{urn:ietf:params:xml:ns:xmpp-sasl}success" +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 @@ -71,23 +86,24 @@ xpFailure = xpWrap (xpUnit) (xpUnit)))) -- Challenge element pickler. -xpChallenge :: PU [Node] (Maybe Text) +xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" (xpOption $ xpContent xpId) xpSaslElement = xpAlt saslSel - [ xpWrap (const SaslSuccess) (const ()) xpSuccess + [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge ] where - saslSel SaslSuccess = 0 + saslSel (SaslSuccess _) = 0 saslSel (SaslChallenge _) = 1 quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text -> Maybe Text -> SaslM Bool -saslInit mechanism payload = lift . pushElement $ saslInitE mechanism payload +saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool +saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ + Text.decodeUtf8 . B64.encode <$> payload pullSaslElement :: SaslM SaslElement pullSaslElement = do @@ -96,29 +112,43 @@ pullSaslElement = do Left e ->throwError $ AuthSaslFailure e Right r -> return r -pullChallenge :: SaslM (Maybe Text) +pullChallenge :: SaslM (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement case e of - SaslChallenge sc -> return sc + SaslChallenge Nothing -> return Nothing + SaslChallenge (Just scb64) + | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 + -> return $ Just sc _ -> throwError AuthChallengeError saslFromJust :: Maybe a -> SaslM a saslFromJust Nothing = throwError $ AuthChallengeError saslFromJust (Just d) = return d -pullSuccess :: SaslM () +pullSuccess :: SaslM (Maybe Text.Text) pullSuccess = do e <- pullSaslElement case e of - SaslSuccess -> return () + SaslSuccess x -> return x _ -> throwError $ AuthXmlError -toPairs :: Text -> SaslM Pairs -toPairs ctext = case pairs <=< B64.decode . Text.encodeUtf8 $ ctext of +pullFinalMessage :: SaslM (Maybe Text.Text) +pullFinalMessage = do + challenge2 <- pullSaslElement + case challenge2 of + SaslSuccess x -> return x + SaslChallenge x -> do + _b <- respond Nothing + pullSuccess + return x + +toPairs :: BS.ByteString -> SaslM Pairs +toPairs ctext = case pairs ctext of Left _e -> throwError AuthChallengeError Right r -> return r -respond :: Maybe Text -> SaslM Bool -respond = lift . pushElement . saslResponseE +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 16361d4..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,7 +33,6 @@ import Network.Xmpp.Stream import Network.Xmpp.Types import Network.Xmpp.Pickle -import qualified System.Random as Random import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types @@ -46,46 +44,36 @@ xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid) -> Text -- Password (authzid) -> XmppConMonad (Either AuthError ()) xmppDigestMD5 authzid authcid passwd = runErrorT $ do - realm <- gets sHostname - case realm of - Just realm' -> do - xmppDigestMD5' 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 - xmppDigestMD5' :: Text -- ^ SASL realm - -> SaslM () - xmppDigestMD5' realm = do + 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 - g <- liftIO Random.newStdGen - _b <- respond . Just $ createResponse g realm pairs - challenge2 <- pullSaslElement - case challenge2 of - SaslSuccess -> return () - SaslChallenge Nothing -> do - _b <- respond Nothing - pullSuccess - _ -> throwError AuthChallengeError + 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 @@ -110,9 +98,7 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do , ["response" , digest ] , ["charset" , "utf-8" ] ] - in Text.decodeUtf8 $ B64.encode response - 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 ad8a032..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/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs new file mode 100644 index 0000000..4c4bca7 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -0,0 +1,152 @@ +{-# 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 + +xorBS x y = BS.pack $ BS.zipWith xor x y +merge = BS.intercalate "," + +type Hash = BS.ByteString -> BS.ByteString +type Hmac = BS.ByteString -> BS.ByteString -> BS.ByteString + + +-- -- mKey :: Crypto.Hash ctx d => d -> BS.ByteString -> MacKey ctx d +-- -- mKey x k = Crypto.MacKey k + +(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString +(+++) = BS.append + +hashToken :: (Crypto.Hash ctx hash) => hash +hashToken = undefined + +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 + -> Maybe Text.Text + -> Text.Text + -> 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 + respond . Just $ cFinalMessage nonce salt ic sFirstMessage cnonce + liftIO $ print ic + sFinalMessage <- pullFinalMessage + 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 + + cFinalMessage nonce salt ic sfm cnonce + = merge [ cFinalMessageWOProof + , "p=" +++ B64.encode clientProof] + 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 + +-- toOectets l = encode $ x + + + -- SaltedPassword := Hi(Normalize(password), salt, i) + -- ClientKey := HMAC(SaltedPassword, "Client Key") + -- StoredKey := H(ClientKey) + -- AuthMessage := client-first-message-bare + "," + + -- server-first-message + "," + + -- client-final-message-without-proof + -- ClientSignature := HMAC(StoredKey, AuthMessage) + -- ClientProof := ClientKey XOR ClientSignature + -- ServerKey := HMAC(SaltedPassword, "Server Key") + -- ServerSignature := HMAC(ServerKey, AuthMessage) + + + normalize = Text.encodeUtf8 . id -- TODO: stringprep + base64 = B64.encode + +scramSha1 :: SaslM Text.Text -> SaslHandler +scramSha1 passwd = ("SCRAM-SHA-1" + , \_hostname authcid authzid -> do + pw <- passwd + scram (hashToken :: Crypto.SHA1) authcid authzid pw + ) + +showBits x = [if testBit x i then '1' else '0' | i <- [0.. bitSize x -1]] + +toOctets :: (Binary a) => a -> [Word8] +toOctets x = LBS.unpack . encode $ x + +intToFourWord8s i = let w8s = toOctets $ i + in drop (length w8s -4) w8s \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index c7cf184..c931091 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -1,13 +1,14 @@ module Network.Xmpp.Sasl.Types where -import Control.Monad.Error -import Control.Monad.State.Strict -import Data.Text -import Network.Xmpp.Types -import Data.ByteString(ByteString) +import Control.Monad.Error +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 | AuthStreamError StreamError -- ^ Stream error on stream restart | AuthConnectionError -- ^ No host name set in state @@ -20,4 +21,9 @@ instance Error AuthError where type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a -type Pairs = [(ByteString, ByteString)] \ No newline at end of file +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 f7d278e..087874b 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -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)