Jon Kristensen
14 years ago
12 changed files with 427 additions and 182 deletions
@ -0,0 +1,171 @@
@@ -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 @@
@@ -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 @@
@@ -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 @@
@@ -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 |
||||
|
||||
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