Jon Kristensen
14 years ago
12 changed files with 427 additions and 182 deletions
@ -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 <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> 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) |
||||||
|
|
||||||
@ -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 <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> 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) |
|
||||||
@ -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 |
||||||
|
) |
||||||
@ -1,16 +1,31 @@ |
|||||||
module Network.Xmpp.Sasl.Types where |
module Network.Xmpp.Sasl.Types where |
||||||
|
|
||||||
import Control.Monad.Error |
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 |
import Network.Xmpp.Types |
||||||
|
|
||||||
data AuthError = AuthXmlError |
data AuthError = AuthXmlError |
||||||
| AuthMechanismError [Text] -- ^ Wraps mechanisms offered |
| AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms |
||||||
|
-- offered |
||||||
| AuthChallengeError |
| AuthChallengeError |
||||||
|
| AuthServerAuthError -- ^ The server failed to authenticate |
||||||
|
-- himself |
||||||
| AuthStreamError StreamError -- ^ Stream error on stream restart |
| AuthStreamError StreamError -- ^ Stream error on stream restart |
||||||
| AuthConnectionError -- ^ No host name set in state |
| AuthConnectionError -- ^ No host name set in state |
||||||
| AuthError -- General instance used for the Error instance |
| AuthError -- General instance used for the Error instance |
||||||
|
| AuthSaslFailure SaslFailure -- ^ defined SASL error condition |
||||||
deriving Show |
deriving Show |
||||||
|
|
||||||
instance Error AuthError where |
instance Error AuthError where |
||||||
noMsg = AuthError |
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 ()) |
||||||
Loading…
Reference in new issue