{-# LANGUAGE OverloadedStrings #-}

module Network.Sasl.DigestMd5.DigestMd5 (
	DigestResponse(..), fromDigestResponse,
	mkStored, digestMd5,

	DigestMd5Challenge(..), fromDigestMd5Challenge,
) where

import Control.Applicative
import Crypto.Hash.MD5
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Numeric
import Data.Word

(+++) :: ByteString -> ByteString -> ByteString
(+++) = BS.append

hash32 :: ByteString -> ByteString
hash32 = BSC.pack . concatMap hex2 . BS.unpack . hash

hex2 :: Word8 -> String
hex2 w = replicate (2 - length s) '0' ++ s
	where
	s = showHex w ""

mkStored :: ByteString -> ByteString -> ByteString -> ByteString
mkStored username rlm password =
	hash $ username +++ ":" +++ rlm +++ ":" +++ password

digestMd5 :: Bool -> ByteString -> ByteString -> ByteString ->
	ByteString -> ByteString -> ByteString -> ByteString
digestMd5 isClient y q uri n nc cnonce = z
	where
	a1 = y +++ ":" +++ n +++ ":" +++ cnonce
	ha1 = hash32 a1
	a2 = (if isClient then "AUTHENTICATE" else "") +++ ":" +++ uri
	ha2 = hash32 a2
	kd = ha1 +++ ":" +++ n +++ ":" +++ nc +++ ":" +++ cnonce +++ ":" +++
		q +++ ":" +++ ha2
	z = hash32 kd

data DigestResponse = DR {
	drUserName :: BS.ByteString,
	drRealm :: BS.ByteString,
	drPassword :: BS.ByteString,
	drCnonce :: BS.ByteString,
	drNonce :: BS.ByteString,
	drNc :: BS.ByteString,
	drQop :: BS.ByteString,
	drDigestUri :: BS.ByteString,
	drCharset :: BS.ByteString }
	deriving Show

fromDigestResponse :: DigestResponse -> BS.ByteString
fromDigestResponse = kvsToS . responseToKvs True

kvsToS :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString
kvsToS [] = ""
kvsToS [(k, v)] = k `BS.append` "=" `BS.append` v
kvsToS ((k, v) : kvs) =
	k `BS.append` "=" `BS.append` v `BS.append` "," `BS.append` kvsToS kvs

responseToKvs :: Bool -> DigestResponse -> [(BS.ByteString, BS.ByteString)]
responseToKvs isClient rsp = [
	("username", quote $ drUserName rsp),
	("realm", quote $ drRealm rsp),
	("nonce", quote $ drNonce rsp),
	("cnonce", quote $ drCnonce rsp),
	("nc", drNc rsp),
	("qop", drQop rsp),
	("digest-uri", quote $ drDigestUri rsp),
	("response", calcMd5 isClient rsp),
	("charset", drCharset rsp)
	]

quote :: BS.ByteString -> BS.ByteString
quote = (`BS.append` "\"") . ("\"" `BS.append`)

calcMd5 :: Bool -> DigestResponse -> BS.ByteString
calcMd5 isClient = digestMd5 isClient
	<$> (mkStored <$> drUserName <*> drRealm <*> drPassword)
	<*> drQop <*> drDigestUri
	<*> drNonce <*> drNc <*> drCnonce

data DigestMd5Challenge = DigestMd5Challenge {
	realm :: BS.ByteString,
	nonce :: BS.ByteString,
	qop :: BS.ByteString,
	charset :: BS.ByteString,
	algorithm :: BS.ByteString }
	deriving Show

fromDigestMd5Challenge :: DigestMd5Challenge -> BS.ByteString
fromDigestMd5Challenge c = BS.concat [
	"realm=", BSC.pack . show $ realm c, ",",
	"nonce=", BSC.pack . show $ nonce c, ",",
	"qop=", BSC.pack . show $ qop c, ",",
	"charset=", charset c, ",", "algorithm=", algorithm c ]