sent scram auth and implemented the hi() function of rfc 5802 ("scram")

Network/XMPP.hs

@@ -52,9 +52,6 @@ module Network.XMPP ( -- Network.XMPP.JID
                     , fromString
                     , fromStrings
 
-                      -- Network.XMPP.SASL
-                    , replyToChallenge1
-
                       -- Network.XMPP.Session
                     , ClientHandler (..)
                     , ClientState (..)

Network/XMPP/SASL.hs

@@ -26,12 +26,12 @@ with Pontarius XMPP. If not, see <http://www.gnu.org/licenses/>.
 -- TODO: Host is assumed to be ISO 8859-1; make list of assumptions.
 -- TODO: Can it contain newline characters?
 
-module Network.XMPP.SASL (replyToChallenge1) where
+module Network.XMPP.SASL (replyToChallenge) where
 
+import Prelude hiding (concat, zipWith)
 import Data.ByteString.Internal (c2w)
 import Data.Char (isLatin1)
 import Data.Digest.Pure.MD5
-import qualified Data.Binary as DBi (Binary, encode)
 import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack,
                                               fromChunks, toChunks, null)
 import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
@@ -40,6 +40,14 @@ import Data.Text (empty, singleton)
 import Text.StringPrep (StringPrepProfile (..), a1, b1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9, runStringPrep)
 import Data.Ranges (inRanges, ranges)
 
+import Crypto.HMAC (MacKey (MacKey), hmac)
+import Crypto.Hash.SHA1 (SHA1)
+import Data.Bits (xor)
+import Data.ByteString ()
+import Data.ByteString.Lazy (ByteString, concat, pack, toChunks, zipWith)
+import Data.Serialize (Serialize, encodeLazy)
+import Data.Serialize.Put (putWord32be, runPutLazy)
+
 data Challenge1Error = C1MultipleCriticalAttributes       |
                        C1NotAllParametersPresent          |
                        C1SomeParamtersPresentMoreThanOnce |
@@ -96,120 +104,28 @@ lookupDirectiveWithDefault di l de
     lookup = lookupDirective di l
 
 
--- Takes a challenge string (which is not Base64-encoded), the host name of the
+-- Implementation of "Hi()" as specified in the Notation section of RFC 5802
--- Jabber server, the Jabber user name (JID), the password and a random and
+-- ("SCRAM"). It takes a string "str", a salt, and an interation count, and
--- unique "cnonce" value and generates either an error or a response to that
+-- returns an octet string. The iteration count must be greater than zero.
--- challenge.
+
-
+hi :: ByteString -> ByteString -> Integer -> ByteString
--- We have broken replyToChallenge1 for non-TLS authentication. In order to
+
--- change it back, just uncomment the lines relevant to the realm and match it
+hi str salt i | i > 0 = xorUs $ us (concat [salt, runPutLazy $ putWord32be 1]) i
--- in the C1NotAllParametersSet case.
+    where
-
+
-replyToChallenge1 :: String -> String -> String -> String -> String ->
+        -- Calculates the U's (U1 ... Ui) using the HMAC algorithm
-                     Either String Challenge1Error
+        us :: ByteString -> Integer -> [ByteString]
-replyToChallenge1 s h u p c =
+        us a 1 = [encodeLazy $ (hmac (MacKey (head $ toChunks str)) a :: SHA1)]
-  -- Remove all new line characters.
+        us a x = [encodeLazy $ (hmac (MacKey (head $ toChunks str)) a :: SHA1)] ++ (us (encodeLazy $ (hmac (MacKey (head $ toChunks str)) a :: SHA1)) (x - 1))
-  let list = stringToList $ filter (/= '\n') s
+
-  in -- Count that there are no more than one nonce or algorithm directives.
+        -- XORs the ByteStrings: U1 XOR U2 XOR ... XOR Ui
-     case countDirectives "nonce"     list <= 1 &&
+        xorUs :: [ByteString] -> ByteString
-          countDirectives "algorithm" list <= 1 of
+        xorUs (b:bs) = foldl (\ x y -> pack $ zipWith xor x y) b bs
-       True ->
+
-         let -- realm     = lookupDirective "realm" list
+
-             nonce     = lookupDirective "nonce" list
+-- TODO: Implement SCRAM.
-             qop       = lookupDirectiveWithDefault "qop" list "auth"
+
-             charset   = lookupDirectiveWithDefault "charset" list "utf-8"
+replyToChallenge = replyToChallenge
-             algorithm = lookupDirective "algorithm" list
-
-         -- Verify that all necessary directives has been set.
-         in case (nonce, qop, charset, algorithm) of
-              (Just nonce', qop', charset', Just algorithm') ->
-
-                -- Strip quotations of the directives that need it.
-                let -- realm'' = stripQuotations realm'
-                    nonce'' = stripQuotations nonce'
-                    qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth
-                in
-                -- -- Verify that the realm is the same as the Jabber host.
-                -- case realm'' == h of
-                --      True ->
-
-                       -- Verify that QOP is "auth", charset is "utf-8" and that
-                       -- the algorithm is "md5-sess".
-                       case qop'' == "auth" of
-                         True ->
-                           case charset' == "utf-8" of
-                             True ->
-                               case algorithm' == "md5-sess" of
-                                 True ->
-
-                                   -- All data is valid; generate the reply.
-                                   Left (reply nonce'' qop'')
-
-                                 -- Errors are caught and reported below.
-                                 False -> Right C1UnsupportedAlgorithm
-                             False -> Right C1UnsupportedCharset
-                         False -> Right C1UnsupportedQOP
-                     -- False -> Right C1WrongRealm
-              _ -> Right C1NotAllParametersPresent
-  where
-    reply n q =
-      let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet
-          -- MD5 hash.
-
-          -- If the username or password values are in ISO-8859-1, we convert
-          -- them to ISO-8859-1 strings.
-          username = case all isLatin1 u of
-            True -> DBL.pack $ map c2w u
-            False -> DBLC.pack $ u
-          password = case all isLatin1 p of
-            True -> DBL.pack $ map c2w p
-            False -> DBLC.pack p
-
-          nc = "00000001"
-          digestUri = "xmpp/" ++ h
-
-          -- Build the "{ username-value, ":", realm-value, ":", passwd }"
-          -- bytestring, the rest of the bytestring and then join them.
-          a1a = DBi.encode $ md5 $ DBLC.append
-                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
-                password
-          a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append
-                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
-                password)
-          a1b = DBLC.pack (":" ++ n ++ ":" ++ c)
-          a1 = DBLC.append a1a a1b
-
-          -- Generate the "A2" value.
-          a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)
-
-          -- Produce the responseValue.
-          k = DBLC.pack (show $ md5 a1)
-          colon = DBLC.pack ":"
-          s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++
-                          q ++ ":")
-          s1 = DBLC.pack $ show $ md5 a2
-
-          s_ = DBLC.append s0 s1
-          -- append k:d and 16 octet hash it
-          kd = md5 (DBLC.append k (DBLC.append colon s_))
-
-          lol0 = DBLC.unpack s_
-          lol1 = show kd
-
-          response = show kd
-      in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++
-         "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++
-         digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"
-         -- "\n\n" ++
-         -- "a1aDebug: " ++ a1aDebug ++ "\n" ++
-         -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" ++
-         -- "a1: " ++ (DBLC.unpack a1) ++ "\n" ++
-         -- "a2: " ++ (DBLC.unpack a2) ++ "\n" ++
-         -- "k: " ++ (DBLC.unpack k) ++ "\n" ++
-         -- "colon: " ++ (DBLC.unpack colon) ++ "\n" ++
-         -- "s0: " ++ (DBLC.unpack s0) ++ "\n" ++
-         -- "s1: " ++ (DBLC.unpack s1) ++ "\n" ++
-         -- "s_: " ++ (DBLC.unpack s_) ++ "\n"
 
 
 -- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".

Network/XMPP/Session.hs

@@ -116,6 +116,10 @@ import qualified Data.Text.Lazy as DTL
 
 import Data.Certificate.X509 (X509)
 
+import Data.UUID (UUID, toString)
+
+import System.Random (randomIO)
+
 
 
 -- =============================================================================
@@ -226,7 +230,8 @@ defaultState c t h s i = State { stateClientHandlers = h
                                , stateMessageCallbacks = []
                                , stateIQCallbacks = []
                                , stateTimeoutStanzaIDs = []
-                               , stateIDGenerator = i } -- TODO: Prefix
+                               , stateIDGenerator = i
+                               , stateSASLRValue = Nothing } -- TODO: Prefix
 
 
 -- |
@@ -373,6 +378,7 @@ data MonadIO m => State s m =
         , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))]
         , stateTimeoutStanzaIDs :: [StanzaID]
         , stateIDGenerator :: IDGenerator
+        , stateSASLRValue :: Maybe String
         }
 
 
@@ -465,9 +471,13 @@ processEvent e = get >>= \ state ->
     -- CEB.assert (or [ stateConnectionState state == Connected
     --                , stateConnectionState state == TLSSecured ]) (return ())
     -- CEB.assert (stateHandle state /= Nothing) (return ())
+    -- let Connected (ServerAddress hostName _) _ = stateConnectionState state
+    rValue <- lift $ liftIO $ randomIO
     put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource
-                , stateAuthenticateCallback = Just callback }
+                , stateAuthenticateCallback = Just callback
-    lift $ liftIO $ send "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>" handleOrTLSCtx
+                , stateSASLRValue = Just (toString rValue) }
+    lift $ liftIO $ putStrLn $ "__________" ++ ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>")
+    lift $ liftIO $ send ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>") handleOrTLSCtx
     return Nothing
 
   IEE (EnumeratorXML (XEBeginStream stream)) -> do
@@ -532,22 +542,14 @@ processEvent e = get >>= \ state ->
     return Nothing
 
   IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do
-    let serverHost = "jonkristensen.com"
+    lift $ liftIO $ putStrLn challenge
+    let Connected (ServerAddress hostName _) _ = stateConnectionState state
     let challenge' = CBBS.decode challenge
     case stateAuthenticationState state of
       AuthenticatingPreChallenge1 userName password resource -> do
         id <- liftIO $ nextID $ stateIDGenerator state
-        -- This is the first challenge - we need to calculate the reply
+        -- TODO: replyToChallenge
-        case replyToChallenge1 challenge' serverHost userName password id of
+        return ()
-          Left reply -> do
-            let reply' = (filter (/= '\n') (CBBS.encode reply))
-            lift $ liftIO $ send ("<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++ reply' ++ "</response>") handleOrTLSCtx
-            put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource }
-            return ()
-          Right error -> do
-            state' <- get
-            lift $ liftIO $ putStrLn $ show error
-            return ()
       AuthenticatingPreChallenge2 userName password resource -> do
         -- This is not the first challenge; [...]
         -- TODO: Can we assume "rspauth"?

Network/XMPP/Types.hs

@@ -313,10 +313,10 @@ data SASLError = -- SASLAborted | -- Client aborted - should not happen
                                           --   with TLS)
                  -- SASLIncorrectEncoding | -- The base64 encoding is incorrect
                                             -- - should not happen
-                 SASLInvalidAuthzid | -- ^ The authzid has an incorrect format,
+                 -- SASLInvalidAuthzid | -- The authzid has an incorrect format,
-                                      --   or the initiating entity does not
+                                         -- or the initiating entity does not
-                                      --   have the appropriate permissions to
+                                         -- have the appropriate permissions to
-                                      --   authorize that ID
+                                         -- authorize that ID
                  SASLInvalidMechanism | -- ^ The mechanism is not supported by
                                         --   the receiving entity
                  -- SASLMalformedRequest | -- Invalid syntax - should not happen

pontarius-xmpp.cabal

@@ -27,12 +27,12 @@ Tested-With:        GHC ==7.0.2
 Library
   Exposed-Modules:   Network.XMPP
   Exposed:           True
-  Build-Depends:     base >= 2 && < 5, parsec, enumerator, crypto-api,
+  Build-Depends:     base >= 2 && < 5, parsec, enumerator, crypto-api ==0.6.3,
                      base64-string, pureMD5, utf8-string, network, xml-types,
-                     text, transformers, bytestring, binary, random,
+                     text, transformers, bytestring, cereal ==0.3.3.0, random,
                      xml-enumerator, tls, tls-extra, containers, mtl, text-icu,
-                     stringprep, idna2008 ==0.0.1.0, asn1-data, cryptohash,
+                     stringprep, idna2008 ==0.0.1.0, asn1-data, cryptohash ==0.7.0,
-                     time, certificate, ranges
+                     time, certificate, ranges, uuid
   -- Other-Modules:
   -- HS-Source-Dirs:
   -- Extensions: