add stringprep to scram

rename DigestMD5 to DigestMd5
Don't thread credentials through xmppSasl

source/Network/Xmpp.hs

@@ -177,9 +177,9 @@ auth  :: Text.Text  -- ^ The username
       -> Text.Text  -- ^ The password
       -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server
                     -- assign one
-      -> XmppConMonad (Either AuthError Text.Text)
+      -> XmppConMonad (Either AuthError JID)
 auth username passwd resource = runErrorT $ do
-        ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd]
+        ErrorT $ xmppSasl [scramSha1 username Nothing passwd]
         res <- lift $ xmppBind resource
         lift $ xmppStartSession
         return res

source/Network/Xmpp/Bind.hs

@@ -24,12 +24,12 @@ bindBody = pickleElem $
 
 -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
 -- resource and extract the JID from the non-error response.
-xmppBind  :: Maybe Text -> XmppConMonad Text
+xmppBind  :: Maybe Text -> XmppConMonad JID
 xmppBind rsrc = do
     answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc)
     let Right IQResult{iqResultPayload = Just b} = answer -- TODO: Error handling
-    let Right (JID _n _d (Just r)) = unpickleElem jidP b
-    return r
+    let Right jid = unpickleElem jidP b
+    return jid
   where
     -- Extracts the character data in the `jid' element.
     jidP :: PU [Node] JID

source/Network/Xmpp/Concurrent/Threads.hs

@@ -54,7 +54,7 @@ readWorker messageC presenceC stanzaC iqHands handlers stateRef =
                    [ Ex.Handler $ \(Interrupt t) -> do
                          void $ handleInterrupts [t]
                          return Nothing
-                   , Ex.Handler $ \e -> noCon handlers (e :: StreamError)
+                   , Ex.Handler $ \(e :: StreamError) -> noCon handlers e
                    ]
         liftIO . atomically $ do
           case res of

source/Network/Xmpp/Sasl.hs

@@ -30,42 +30,32 @@ import           Network.Xmpp.Pickle
 
 import qualified System.Random as Random
 
-import Network.Xmpp.Sasl.DigestMD5
-import Network.Xmpp.Sasl.Plain
 import Network.Xmpp.Sasl.Types
 
 
-runSasl :: (Text.Text -> Text.Text -> Maybe Text.Text -> SaslM a)
-        -> Text.Text
-        -> Maybe Text.Text
-        -> XmppConMonad (Either AuthError a)
-runSasl authAction authcid authzid = runErrorT $ do
-    hn <- gets sHostname
-    case hn of
-        Just hn' -> do
-            r <- authAction hn' authcid authzid
-            modify (\s -> s{ sUsername = Just authcid
-                           , sAuthzid = authzid
-                           })
+runSasl :: SaslM a -> XmppConMonad (Either AuthError a)
+runSasl authAction = runErrorT $ do
+    cs <- gets sConnectionState
+    case cs of
+        XmppConnectionClosed -> throwError AuthConnectionError
+        _ -> do
+            r <- authAction
             _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
             return r
-        Nothing -> throwError AuthConnectionError
+
 
 -- Uses the first supported mechanism to authenticate, if any. Updates the
 -- XmppConMonad state with non-password credentials and restarts the stream upon
 -- success. This computation wraps an ErrorT computation, which means that
 -- catchError can be used to catch any errors.
-xmppSasl :: Text.Text
-         -> Maybe Text.Text
-         -> [SaslHandler] -- ^ Acceptable authentication
+xmppSasl :: [SaslHandler] -- ^ Acceptable authentication
                                         -- mechanisms and their corresponding
                                         -- handlers
          -> XmppConMonad (Either AuthError ())
-xmppSasl authcid authzid handlers = do
+xmppSasl handlers = do
     -- Chooses the first mechanism that is acceptable by both the client and the
     -- server.
     mechanisms <- gets $ saslMechanisms . sFeatures
     case (filter (\(name,_) -> name `elem` mechanisms)) handlers of
         [] -> return . Left $ AuthNoAcceptableMechanism mechanisms
-        (_name, handler):_ -> runSasl handler authcid authzid
-
+        (_name, handler):_ -> runSasl handler

source/Network/Xmpp/Sasl/DigestMd5

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Network.Xmpp.Sasl.DigestMD5 where
+module Network.Xmpp.Sasl.DigestMd5 where
 
 import           Control.Applicative
 import           Control.Arrow (left)
@@ -39,11 +39,11 @@ import Network.Xmpp.Sasl.Types
 
 
 
-xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid)
+xmppDigestMd5 :: Maybe Text -- Authorization identity (authzid)
                -> Text -- Authentication identity (authzid)
                -> Text -- Password (authzid)
-               -> XmppConMonad (Either AuthError ())
-xmppDigestMD5 authzid authcid passwd = runErrorT $ do
+               -> SaslM ()
+xmppDigestMd5 authzid authcid passwd = do
     hn <- gets sHostname
     case hn of
         Just hn' -> do
@@ -68,7 +68,7 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do
                    -> BS.ByteString -- nonce
                    -> BS.ByteString
     createResponse hostname pairs cnonce = let
-        Just qop   = L.lookup "qop" pairs
+        Just qop   = L.lookup "qop" pairs -- TODO: proper handling
         Just nonce = L.lookup "nonce" pairs
         uname_     = Text.encodeUtf8 authcid
         passwd_    = Text.encodeUtf8 passwd
@@ -124,3 +124,11 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do
                      ]
           ha2 = hash ["AUTHENTICATE", digestURI]
       in hash [ha1, nonce, nc, cnonce, qop, ha2]
+
+digestMd5 :: Maybe Text -- Authorization identity (authzid)
+          -> Text -- Authentication identity (authzid)
+          -> Text -- Password (authzid)
+          -> SaslHandler
+digestMd5 authzid authcid password = ( "DIGEST-MD5"
+                                     , xmppDigestMd5 authzid authcid password
+                                     )

source/Network/Xmpp/Sasl/Plain.hs

@@ -46,13 +46,11 @@ import Network.Xmpp.Sasl.Common
 import Network.Xmpp.Sasl.Types
 
 -- TODO: stringprep
-xmppPlain :: SaslM Text.Text
-          -> a
-          -> Text.Text
+xmppPlain :: Text.Text
           -> Maybe Text.Text
+          -> Text.Text
           -> SaslM ()
-xmppPlain pw _hostname authcid authzid  = do
-    passwd <- pw
+xmppPlain authcid authzid passwd  = do
     _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd)
     _ <- pullSuccess
     return ()
@@ -73,5 +71,5 @@ xmppPlain pw _hostname authcid authzid  = do
       where
         authzid' = maybe "" Text.encodeUtf8 authzid
 
-plain :: SaslM Text.Text -> SaslHandler
-plain passwd = ("PLAIN", xmppPlain passwd)
+plain :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslHandler
+plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd)

source/Network/Xmpp/Sasl/Scram.hs

@@ -27,6 +27,7 @@ import qualified Data.Text.Encoding as Text
 import           Data.Word(Word8)
 
 import           Network.Xmpp.Sasl.Common
+import           Network.Xmpp.Sasl.StringPrep
 import           Network.Xmpp.Sasl.Types
 
 -- | Bit-wise xor of byte strings
@@ -57,12 +58,21 @@ scram :: (Crypto.Hash ctx hash)
       -> Maybe Text.Text -- ^ authorization ID
       -> Text.Text       -- ^ password
       -> SaslM ()
-scram hashToken authcid authzid' password = do
+scram hashToken authcid authzid password = case credentials of
+    Nothing -> throwError $ AuthStringPrepError
+    Just (ac, az, pw) -> 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)
-    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
@@ -77,14 +87,14 @@ scram hashToken authcid authzid' password = do
         hash str = encode hashToken $ Crypto.hash' str
         hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str
 
-    authzid              = (\z -> "a=" +++ normalize z) <$> authzid'
+        authzid              = (\z -> "a=" +++ Text.encodeUtf8 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
+        cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid
                                          , "r=" +++ cnonce]
         cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce
 
@@ -109,7 +119,7 @@ scram hashToken authcid authzid' password = do
           where
             cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header
                                          , "r=" +++ nonce]
-        saltedPassword       = hi (normalize password) salt ic
+            saltedPassword       = hi (Text.encodeUtf8 password) salt ic
             clientKey            = hmac saltedPassword "Client Key"
             storedKey            = hash clientKey
             authMessage          = merge [ cFirstMessageBare cnonce
@@ -127,13 +137,12 @@ scram hashToken authcid authzid' password = do
                 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
+scramSha1 :: Text.Text  -- ^ username
+          -> Maybe Text.Text -- ^ authorization ID
+          -> Text.Text   -- ^ password
+          -> SaslHandler
+scramSha1 authcid authzid passwd =
+    ("SCRAM-SHA-1"
+    , scram (hashToken :: Crypto.SHA1) authcid authzid passwd
     )

source/Network/Xmpp/Sasl/StringPrep.hs

@@ -0,0 +1,39 @@
+module Network.Xmpp.Sasl.StringPrep where
+
+import Text.StringPrep
+
+saslPrepQuery = Profile
+    [b1]
+    True
+    [ c12
+    , c21
+    , c22
+    , c3
+    , c4
+    , c5
+    , c6
+    , c7
+    , c8
+    , c9
+    ]
+    True
+
+saslPrepStore = Profile
+    [b1]
+    True
+    [ a1
+    , c12
+    , c21
+    , c22
+    , c3
+    , c4
+    , c5
+    , c6
+    , c7
+    , c8
+    , c9
+    ]
+    True
+
+normalizePassword = runStringPrep saslPrepStore
+normalizeUsername = runStringPrep saslPrepQuery

source/Network/Xmpp/Sasl/Types.hs

@@ -16,6 +16,7 @@ data AuthError = AuthXmlError
                | AuthConnectionError -- ^ No host name set in state
                | AuthError -- General instance used for the Error instance
                | AuthSaslFailure SaslFailure -- ^ defined SASL error condition
+               | AuthStringPrepError -- ^ StringPrep failed
                  deriving Show
 
 instance Error AuthError where
@@ -25,7 +26,4 @@ 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 ())
+type SaslHandler = (Text.Text, SaslM ())