From b69f8e839e3318fae27ed8775777972617bbf249 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 9 Jun 2012 14:00:33 +0200 Subject: [PATCH] add documentation to Scram.hs and Common.hs --- source/Network/Xmpp/Sasl/Common.hs | 12 +++++++ source/Network/Xmpp/Sasl/Scram.hs | 53 ++++++++++-------------------- 2 files changed, 30 insertions(+), 35 deletions(-) diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index c56e7a9..f6c8920 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -85,11 +85,14 @@ xpFailure = xpWrap 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 @@ -98,6 +101,7 @@ xpSaslElement = xpAlt saslSel saslSel (SaslSuccess _) = 0 saslSel (SaslChallenge _) = 1 +-- | Add quotationmarks around a byte string quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] @@ -105,6 +109,7 @@ 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) @@ -112,6 +117,7 @@ pullSaslElement = do 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 @@ -122,10 +128,12 @@ pullChallenge = do -> 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 @@ -133,6 +141,8 @@ pullSuccess = do 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 Text.Text) pullFinalMessage = do challenge2 <- pullSaslElement @@ -143,11 +153,13 @@ pullFinalMessage = do pullSuccess return 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/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index 4c4bca7..abbc146 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -29,28 +29,33 @@ 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 -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 +-- | 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 - -> Maybe Text.Text - -> Text.Text + => 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 @@ -118,35 +123,13 @@ scram hashToken authcid authzid' password = do 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 +-- | '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 ) - -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