{-# 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 -- ^ Authentication identity (authzid or username)
               -> Maybe Text -- ^ Authorization identity (authcid)
               -> Text -- ^ Password (authzid)
               -> 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 -- TODO: use authzid?
        -- Push element and receive the challenge.
        ()
_ <- Text
-> Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ()
saslInit Text
"DIGEST-MD5" forall a. Maybe a
Nothing -- TODO: Check boolean?
        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
        -- Produce the response to the challenge.
        createResponse :: Text
                       -> Pairs
                       -> BS.ByteString -- nonce
                       -> 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 -- TODO: proper handling
            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
            -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7)
            -- compatibility.

            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
        -- TODO: this only handles MD5-sess
        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 -- ^ Authentication identity (authcid or username)
          -> Maybe AuthZID -- ^ Authorization identity (authzid)
          -> Password -- ^ 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
    )