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
@@ -123,4 +123,12 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do
                      , cnonce
                      ]
           ha2 = hash ["AUTHENTICATE", digestURI]
-      in hash [ha1, nonce, nc, cnonce, qop, ha2]
+      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,83 +58,91 @@ scram :: (Crypto.Hash ctx hash)
       -> 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 ()
+scram hashToken authcid authzid password = case credentials of
+    Nothing -> throwError $ AuthStringPrepError
+    Just (ac, az, pw) -> scramhelper hashToken ac az pw
   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
-          )
+    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)
+        sFirstMessage <- saslFromJust =<< pullChallenge
+        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
-        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)
+        -- 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=" +++ 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=" +++ Text.encodeUtf8 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
-            u1 = hmac str (salt +++ (BS.pack [0,0,0,1]))
-            us = iterate (hmac str) u1
-
-    normalize = Text.encodeUtf8 . id -- TODO: stringprep
-    base64 = B64.encode
+            cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header
+                                         , "r=" +++ nonce]
+            saltedPassword       = hi (Text.encodeUtf8 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
 
 -- | '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 ())