move mechanisms to Sasl/Mechanisms

factor out prepCredentials

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

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 ())

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
 
@@ -166,3 +168,32 @@ toPairs ctext = case pairs ctext of
 respond :: Maybe BS.ByteString -> SaslM Bool
 respond = lift . pushElement . saslResponseE .
     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

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

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
                                      )

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

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)