From 3091a43914dc42928d53089e918fbea0d5ceb08b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 12 Jun 2012 14:07:43 +0200 Subject: [PATCH] move mechanisms to Sasl/Mechanisms factor out prepCredentials --- pontarius.cabal | 6 ++-- source/Network/Xmpp.hs | 33 +++++++++-------- source/Network/Xmpp/Sasl/Common.hs | 35 +++++++++++++++++-- source/Network/Xmpp/Sasl/Mechanisms.hs | 9 +++++ .../Xmpp/Sasl/{ => Mechanisms}/DigestMd5.hs | 31 ++++++---------- .../Xmpp/Sasl/{ => Mechanisms}/Plain.hs | 13 +++---- .../Xmpp/Sasl/{ => Mechanisms}/Scram.hs | 28 +++------------ 7 files changed, 83 insertions(+), 72 deletions(-) create mode 100644 source/Network/Xmpp/Sasl/Mechanisms.hs rename source/Network/Xmpp/Sasl/{ => Mechanisms}/DigestMd5.hs (85%) rename source/Network/Xmpp/Sasl/{ => Mechanisms}/Plain.hs (84%) rename source/Network/Xmpp/Sasl/{ => Mechanisms}/Scram.hs (89%) diff --git a/pontarius.cabal b/pontarius.cabal index 0225035..e0e39e8 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -61,9 +61,9 @@ Library , Network.Xmpp.Pickle , Network.Xmpp.Presence , Network.Xmpp.Sasl - , Network.Xmpp.Sasl.Plain - , Network.Xmpp.Sasl.DigestMd5 - , Network.Xmpp.Sasl.Scram + , Network.Xmpp.Sasl.Mechanisms.Plain + , Network.Xmpp.Sasl.Mechanisms.DigestMd5 + , Network.Xmpp.Sasl.Mechanisms.Scram , Network.Xmpp.Sasl.Types , Network.Xmpp.Session , Network.Xmpp.Stream diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index dc0cb0d..a5dc23a 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -146,26 +146,25 @@ module Network.Xmpp , exampleParams ) where -import Data.Text as Text +import Data.Text as Text -import Network +import Network import qualified Network.TLS as TLS -import Network.Xmpp.Bind -import Network.Xmpp.Concurrent -import Network.Xmpp.Concurrent.Types -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 -import Network.Xmpp.TLS -import Network.Xmpp.Types +import Network.Xmpp.Bind +import Network.Xmpp.Concurrent +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Message +import Network.Xmpp.Monad +import Network.Xmpp.Presence +import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Session +import Network.Xmpp.Stream +import Network.Xmpp.TLS +import Network.Xmpp.Types -import Control.Monad.Error +import Control.Monad.Error -- | Connect to host with given address. connect :: HostName -> Text -> XmppConMonad (Either StreamError ()) diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 03cb432..21065fe 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -10,19 +10,21 @@ import Control.Monad.Error import Control.Monad.State.Class import qualified Data.Attoparsec.ByteString.Char8 as AP +import Data.Bits 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.Word (Word8) 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 Network.Xmpp.Sasl.StringPrep import qualified System.Random as Random @@ -165,4 +167,33 @@ toPairs ctext = case pairs ctext of -- | Send a SASL response element. The content will be base64-encoded. respond :: Maybe BS.ByteString -> SaslM Bool respond = lift . pushElement . saslResponseE . - fmap (Text.decodeUtf8 . B64.encode) \ No newline at end of file + fmap (Text.decodeUtf8 . B64.encode) + + +-- | Run the appropriate stringprep profiles on the credentials. +-- May fail Fails with 'AuthStringPrepError' +prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text + -> SaslM (Text.Text, Maybe Text.Text, Text.Text) +prepCredentials authcid authzid password = case credentials of + Nothing -> throwError $ AuthStringPrepError + Just (ac, az, pw) -> return (ac, az, pw) + where + credentials = do + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) + +-- | 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 diff --git a/source/Network/Xmpp/Sasl/Mechanisms.hs b/source/Network/Xmpp/Sasl/Mechanisms.hs new file mode 100644 index 0000000..674d6dd --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms.hs @@ -0,0 +1,9 @@ +module Network.Xmpp.Sasl.Mechanisms + ( module Network.Xmpp.Sasl.Mechanisms.DigestMd5 + , module Network.Xmpp.Sasl.Mechanisms.Scram + , module Network.Xmpp.Sasl.Mechanisms.Plain + ) where + +import Network.Xmpp.Sasl.Mechanisms.DigestMd5 +import Network.Xmpp.Sasl.Mechanisms.Scram +import Network.Xmpp.Sasl.Mechanisms.Plain diff --git a/source/Network/Xmpp/Sasl/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs similarity index 85% rename from source/Network/Xmpp/Sasl/DigestMd5.hs rename to source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index e0125ab..2d0facb 100644 --- a/source/Network/Xmpp/Sasl/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.DigestMd5 where +module Network.Xmpp.Sasl.Mechanisms.DigestMd5 where import Control.Applicative import Control.Arrow (left) @@ -40,27 +40,18 @@ import Network.Xmpp.Sasl.Types -xmppDigestMd5 :: Maybe Text -- Authorization identity (authzid) - -> Text -- Authentication identity (authzid) +xmppDigestMd5 :: Text -- Authorization identity (authzid) + -> Maybe Text -- Authentication identity (authzid) -> Text -- Password (authzid) -> SaslM () -xmppDigestMd5 authzid authcid password = do - case credentials of - Nothing -> throwError $ AuthStringPrepError - Just (ac, az, pw) -> do - hn <- gets sHostname - case hn of - Just hn' -> do - xmppDigestMd5' hn' ac az pw - Nothing -> throwError AuthConnectionError +xmppDigestMd5 authcid authzid password = do + (ac, az, pw) <- prepCredentials authcid authzid password + hn <- gets sHostname + case hn of + Just hn' -> do + xmppDigestMd5' hn' ac az pw + Nothing -> throwError AuthConnectionError where - credentials = do - ac <- normalizeUsername authcid - az <- case authzid of - Nothing -> Just Nothing - Just az' -> Just <$> normalizeUsername az' - pw <- normalizePassword password - return (ac, az, pw) xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () xmppDigestMd5' hostname authcid authzid password = do -- Push element and receive the challenge (in SaslM). @@ -142,5 +133,5 @@ digestMd5 :: Maybe Text -- Authorization identity (authzid) -> Text -- Password (authzid) -> SaslHandler digestMd5 authzid authcid password = ( "DIGEST-MD5" - , xmppDigestMd5 authzid authcid password + , xmppDigestMd5 authcid authzid password ) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs similarity index 84% rename from source/Network/Xmpp/Sasl/Plain.hs rename to source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index 4a2ea1f..fcc1e20 100644 --- a/source/Network/Xmpp/Sasl/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Plain where +module Network.Xmpp.Sasl.Mechanisms.Plain where import Control.Applicative import Control.Arrow (left) @@ -50,18 +50,19 @@ xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) -> SaslM () -xmppPlain authcid authzid passwd = do - _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd) +xmppPlain authcid authzid password = do + (ac, az, pw) <- prepCredentials authcid authzid password + _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) _ <- pullSuccess return () where -- Converts an optional authorization identity, an authentication identity, -- and a password to a \NUL-separated PLAIN message. - plainMessage :: Maybe Text.Text -- Authorization identity (authzid) - -> Text.Text -- Authentication identity (authcid) + plainMessage :: Text.Text -- Authorization identity (authzid) + -> Maybe Text.Text -- Authentication identity (authcid) -> Text.Text -- Password -> BS.ByteString -- The PLAIN message - plainMessage authzid authcid passwd = BS.concat $ + plainMessage authcid authzid passwd = BS.concat $ [ authzid' , "\NUL" , Text.encodeUtf8 $ authcid diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs similarity index 89% rename from source/Network/Xmpp/Sasl/Scram.hs rename to source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 2d0b318..a949239 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Scram where +module Network.Xmpp.Sasl.Mechanisms.Scram where import Control.Applicative ((<$>)) import Control.Monad.Error @@ -11,7 +11,6 @@ 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) @@ -29,18 +28,6 @@ import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.StringPrep 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 @@ -57,17 +44,10 @@ scram :: (Crypto.Hash ctx hash) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password -> SaslM () -scram hashToken authcid authzid password = case credentials of - Nothing -> throwError $ AuthStringPrepError - Just (ac, az, pw) -> scramhelper hashToken ac az pw +scram hashToken authcid authzid password = do + (ac, az, pw) <- prepCredentials authcid authzid password + scramhelper hashToken ac az pw where - credentials = do - ac <- normalizeUsername authcid - az <- case authzid of - Nothing -> Just Nothing - Just az' -> Just <$> normalizeUsername az' - pw <- normalizePassword password - return (ac, az, pw) scramhelper hashToken authcid authzid' password = do cnonce <- liftIO $ makeNonce saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)