{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Xmpp.Sasl.Mechanisms.DigestMd5
( digestMd5
) where
import Control.Monad.Except
import Control.Monad.State.Strict
import qualified Crypto.Classes as CC
import qualified Data.Binary as Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.List as L
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Types
xmppDigestMd5 :: Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5 :: Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5 Text
authcid' Maybe Text
authzid' Text
password' = do
(Text
ac, Maybe Text
az, Text
pw) <- Text
-> Maybe Text
-> Text
-> ExceptT
AuthFailure (StateT StreamState IO) (Text, Maybe Text, Text)
prepCredentials Text
authcid' Maybe Text
authzid' Text
password'
Just Text
address <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> Maybe Text
streamAddress
Text
-> Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5' Text
address Text
ac Maybe Text
az Text
pw
where
xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5' :: Text
-> Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5' Text
hostname Text
authcid Maybe Text
_authzid Text
password = do
()
_ <- Text
-> Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ()
saslInit Text
"DIGEST-MD5" forall a. Maybe a
Nothing
Pairs
prs <- ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs
toPairs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Maybe a -> ExceptT AuthFailure (StateT StreamState IO) a
saslFromJust forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT AuthFailure (StateT StreamState IO) (Maybe ByteString)
pullChallenge
ByteString
cnonce <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ByteString
makeNonce
()
_b <- Maybe ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
respond forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Pairs -> ByteString -> ByteString
createResponse Text
hostname Pairs
prs ByteString
cnonce
Maybe ByteString
_challenge2 <- ExceptT AuthFailure (StateT StreamState IO) (Maybe ByteString)
pullFinalMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
createResponse :: Text
-> Pairs
-> BS.ByteString
-> BS.ByteString
createResponse :: Text -> Pairs -> ByteString -> ByteString
createResponse Text
hname Pairs
prs ByteString
cnonce = let
Just ByteString
qop = forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup ByteString
"qop" Pairs
prs
Just ByteString
nonce = forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup ByteString
"nonce" Pairs
prs
uname_ :: ByteString
uname_ = Text -> ByteString
Text.encodeUtf8 Text
authcid
passwd_ :: ByteString
passwd_ = Text -> ByteString
Text.encodeUtf8 Text
password
nc :: ByteString
nc = ByteString
"00000001"
digestURI :: ByteString
digestURI = ByteString
"xmpp/" ByteString -> ByteString -> ByteString
`BS.append` Text -> ByteString
Text.encodeUtf8 Text
hname
digest :: ByteString
digest = ByteString
-> Maybe ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
md5Digest
ByteString
uname_
(forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"realm" Pairs
prs)
ByteString
passwd_
ByteString
digestURI
ByteString
nc
ByteString
qop
ByteString
nonce
ByteString
cnonce
response :: ByteString
response = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"=") forall a b. (a -> b) -> a -> b
$
[[ByteString
"username", ByteString -> ByteString
quote ByteString
uname_]] forall a. [a] -> [a] -> [a]
++
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup ByteString
"realm" Pairs
prs of
Just ByteString
realm -> [[ByteString
"realm" , ByteString -> ByteString
quote ByteString
realm ]]
Maybe ByteString
Nothing -> [] forall a. [a] -> [a] -> [a]
++
[ [ByteString
"nonce" , ByteString -> ByteString
quote ByteString
nonce ]
, [ByteString
"cnonce" , ByteString -> ByteString
quote ByteString
cnonce ]
, [ByteString
"nc" , ByteString
nc ]
, [ByteString
"qop" , ByteString
qop ]
, [ByteString
"digest-uri", ByteString -> ByteString
quote ByteString
digestURI]
, [ByteString
"response" , ByteString
digest ]
, [ByteString
"charset" , ByteString
"utf-8" ]
]
in ByteString -> ByteString
B64.encode ByteString
response
hash :: [BS8.ByteString] -> BS8.ByteString
hash :: [ByteString] -> ByteString
hash = String -> ByteString
BS8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall ctx d. (Hash ctx d, Hash ctx d) => ByteString -> d
CC.hash' :: BS.ByteString -> MD5.MD5Digest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
BS.intercalate (ByteString
":")
hashRaw :: [BS8.ByteString] -> BS8.ByteString
hashRaw :: [ByteString] -> ByteString
hashRaw = ByteString -> ByteString
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
Binary.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(forall ctx d. (Hash ctx d, Hash ctx d) => ByteString -> d
CC.hash' :: BS.ByteString -> MD5.MD5Digest) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
BS.intercalate (ByteString
":")
toStrict :: BL.ByteString -> BS8.ByteString
toStrict :: ByteString -> ByteString
toStrict = [ByteString] -> ByteString
BS.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks
md5Digest :: BS8.ByteString
-> Maybe BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
md5Digest :: ByteString
-> Maybe ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
md5Digest ByteString
uname Maybe ByteString
realm ByteString
pwd ByteString
digestURI ByteString
nc ByteString
qop ByteString
nonce ByteString
cnonce =
let ha1 :: ByteString
ha1 = [ByteString] -> ByteString
hash [ [ByteString] -> ByteString
hashRaw [ByteString
uname, forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" forall a. a -> a
id Maybe ByteString
realm, ByteString
pwd]
, ByteString
nonce
, ByteString
cnonce
]
ha2 :: ByteString
ha2 = [ByteString] -> ByteString
hash [ByteString
"AUTHENTICATE", ByteString
digestURI]
in [ByteString] -> ByteString
hash [ByteString
ha1, ByteString
nonce, ByteString
nc, ByteString
cnonce, ByteString
qop, ByteString
ha2]
digestMd5 :: Username
-> Maybe AuthZID
-> Password
-> SaslHandler
digestMd5 :: Text -> Maybe Text -> Text -> SaslHandler
digestMd5 Text
authcid Maybe Text
authzid Text
password =
( Text
"DIGEST-MD5"
, do
Either AuthFailure ()
r <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5 Text
authcid Maybe Text
authzid Text
password
case Either AuthFailure ()
r of
Left (AuthStreamFailure XmppFailure
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
Left AuthFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just AuthFailure
e
Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
)