{-# 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 <- (StreamState -> Maybe Text)
-> ExceptT AuthFailure (StateT StreamState IO) (Maybe Text)
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" Maybe ByteString
forall a. Maybe a
Nothing
Pairs
prs <- ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs
toPairs (ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs)
-> ExceptT AuthFailure (StateT StreamState IO) ByteString
-> ExceptT AuthFailure (StateT StreamState IO) Pairs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ByteString
forall a. Maybe a -> ExceptT AuthFailure (StateT StreamState IO) a
saslFromJust (Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ByteString)
-> ExceptT AuthFailure (StateT StreamState IO) (Maybe ByteString)
-> ExceptT AuthFailure (StateT StreamState IO) ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT AuthFailure (StateT StreamState IO) (Maybe ByteString)
pullChallenge
ByteString
cnonce <- IO ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ByteString)
-> IO ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString
makeNonce
()
_b <- Maybe ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
respond (Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ())
-> (ByteString -> Maybe ByteString)
-> ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ExceptT AuthFailure (StateT StreamState IO) ())
-> ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
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
() -> ExceptT AuthFailure (StateT StreamState IO) ()
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 = ByteString -> Pairs -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup ByteString
"qop" Pairs
prs
Just ByteString
nonce = ByteString -> Pairs -> Maybe ByteString
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_
(ByteString -> Pairs -> Maybe ByteString
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
"," ([ByteString] -> ByteString)
-> ([[ByteString]] -> [ByteString]) -> [[ByteString]] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> ByteString) -> [[ByteString]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"=") ([[ByteString]] -> ByteString) -> [[ByteString]] -> ByteString
forall a b. (a -> b) -> a -> b
$
[[ByteString
"username", ByteString -> ByteString
quote ByteString
uname_]] [[ByteString]] -> [[ByteString]] -> [[ByteString]]
forall a. [a] -> [a] -> [a]
++
case ByteString -> Pairs -> Maybe ByteString
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 -> [] [[ByteString]] -> [[ByteString]] -> [[ByteString]]
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 (String -> ByteString)
-> ([ByteString] -> String) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MD5Digest -> String
forall a. Show a => a -> String
show
(MD5Digest -> String)
-> ([ByteString] -> MD5Digest) -> [ByteString] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> MD5Digest
forall ctx d. (Hash ctx d, Hash ctx d) => ByteString -> d
CC.hash' :: BS.ByteString -> MD5.MD5Digest)
(ByteString -> MD5Digest)
-> ([ByteString] -> ByteString) -> [ByteString] -> 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 (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MD5Digest -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode (MD5Digest -> ByteString)
-> ([ByteString] -> MD5Digest) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(ByteString -> MD5Digest
forall ctx d. (Hash ctx d, Hash ctx d) => ByteString -> d
CC.hash' :: BS.ByteString -> MD5.MD5Digest) (ByteString -> MD5Digest)
-> ([ByteString] -> ByteString) -> [ByteString] -> 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 ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
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, ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ByteString -> 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 <- ExceptT AuthFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either AuthFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AuthFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either AuthFailure ()))
-> ExceptT AuthFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either AuthFailure ())
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) -> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. a -> Either a b
Left XmppFailure
e
Left AuthFailure
e -> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. b -> Either a b
Right (Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure))
-> Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just AuthFailure
e
Right () -> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. b -> Either a b
Right Maybe AuthFailure
forall a. Maybe a
Nothing
)