diff --git a/Network/XMPP.hs b/Network/XMPP.hs index 2c93918..8e402c5 100644 --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -52,9 +52,6 @@ module Network.XMPP ( -- Network.XMPP.JID , fromString , fromStrings - -- Network.XMPP.SASL - , replyToChallenge1 - -- Network.XMPP.Session , ClientHandler (..) , ClientState (..) diff --git a/Network/XMPP/SASL.hs b/Network/XMPP/SASL.hs index 0f879d9..771cdfa 100644 --- a/Network/XMPP/SASL.hs +++ b/Network/XMPP/SASL.hs @@ -26,12 +26,12 @@ with Pontarius XMPP. If not, see . -- 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 --- Jabber server, the Jabber user name (JID), the password and a random and --- unique "cnonce" value and generates either an error or a response to that --- challenge. - --- 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 --- in the C1NotAllParametersSet case. - -replyToChallenge1 :: String -> String -> String -> String -> String -> - Either String Challenge1Error -replyToChallenge1 s h u p c = - -- Remove all new line characters. - let list = stringToList $ filter (/= '\n') s - in -- Count that there are no more than one nonce or algorithm directives. - case countDirectives "nonce" list <= 1 && - countDirectives "algorithm" list <= 1 of - True -> - let -- realm = lookupDirective "realm" list - nonce = lookupDirective "nonce" list - qop = lookupDirectiveWithDefault "qop" list "auth" - charset = lookupDirectiveWithDefault "charset" list "utf-8" - 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" +-- Implementation of "Hi()" as specified in the Notation section of RFC 5802 +-- ("SCRAM"). It takes a string "str", a salt, and an interation count, and +-- returns an octet string. The iteration count must be greater than zero. + +hi :: ByteString -> ByteString -> Integer -> ByteString + +hi str salt i | i > 0 = xorUs $ us (concat [salt, runPutLazy $ putWord32be 1]) i + where + + -- Calculates the U's (U1 ... Ui) using the HMAC algorithm + us :: ByteString -> Integer -> [ByteString] + us a 1 = [encodeLazy $ (hmac (MacKey (head $ toChunks str)) a :: SHA1)] + us a x = [encodeLazy $ (hmac (MacKey (head $ toChunks str)) a :: SHA1)] ++ (us (encodeLazy $ (hmac (MacKey (head $ toChunks str)) a :: SHA1)) (x - 1)) + + -- XORs the ByteStrings: U1 XOR U2 XOR ... XOR Ui + xorUs :: [ByteString] -> ByteString + xorUs (b:bs) = foldl (\ x y -> pack $ zipWith xor x y) b bs + + +-- TODO: Implement SCRAM. + +replyToChallenge = replyToChallenge -- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello". diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index 2510275..903ec64 100644 --- a/Network/XMPP/Session.hs +++ b/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 } - lift $ liftIO $ send "" handleOrTLSCtx + , stateAuthenticateCallback = Just callback + , stateSASLRValue = Just (toString rValue) } + lift $ liftIO $ putStrLn $ "__________" ++ ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") + lift $ liftIO $ send ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") 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 - case replyToChallenge1 challenge' serverHost userName password id of - Left reply -> do - let reply' = (filter (/= '\n') (CBBS.encode reply)) - lift $ liftIO $ send ("" ++ reply' ++ "") handleOrTLSCtx - put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource } - return () - Right error -> do - state' <- get - lift $ liftIO $ putStrLn $ show error - return () + -- TODO: replyToChallenge + return () AuthenticatingPreChallenge2 userName password resource -> do -- This is not the first challenge; [...] -- TODO: Can we assume "rspauth"? diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index f7b6b6c..6b0d34c 100644 --- a/Network/XMPP/Types.hs +++ b/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, - -- or the initiating entity does not - -- have the appropriate permissions to - -- authorize that ID + -- SASLInvalidAuthzid | -- The authzid has an incorrect format, + -- or the initiating entity does not + -- have the appropriate permissions to + -- authorize that ID SASLInvalidMechanism | -- ^ The mechanism is not supported by -- the receiving entity -- SASLMalformedRequest | -- Invalid syntax - should not happen diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 4b3d76e..ff0cbc2 100644 --- a/pontarius-xmpp.cabal +++ b/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, - time, certificate, ranges + stringprep, idna2008 ==0.0.1.0, asn1-data, cryptohash ==0.7.0, + time, certificate, ranges, uuid -- Other-Modules: -- HS-Source-Dirs: -- Extensions: