{-# LANGUAGE AllowAmbiguousTypes #-}
module Servant.Auth.Hmac.Crypto
(
SecretKey (..)
, Signature (..)
, sign
, signSHA256
, RequestPayload (..)
, requestSignature
, verifySignatureHmac
, authHeaderName
) where
import Crypto.Hash (hash)
import Crypto.Hash.Algorithms (MD5, SHA256)
import Crypto.Hash.IO (HashAlgorithm)
import Crypto.MAC.HMAC (HMAC (hmacGetDigest), hmac)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (foldedCase)
import Data.List (sort, uncons)
import Network.HTTP.Types (Header, HeaderName, Method, RequestHeaders)
import qualified Data.ByteArray as BA (convert)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as LBS
newtype SecretKey = SecretKey
{ unSecretKey :: ByteString
}
newtype Signature = Signature
{ unSignature :: ByteString
} deriving (Eq)
sign :: forall algo . (HashAlgorithm algo)
=> SecretKey
-> ByteString
-> Signature
sign (SecretKey sk) msg = Signature
$ Base64.encode
$ BA.convert
$ hmacGetDigest
$ hmac @_ @_ @algo sk msg
{-# INLINE sign #-}
signSHA256 :: SecretKey -> ByteString -> Signature
signSHA256 = sign @SHA256
{-# INLINE signSHA256 #-}
data RequestPayload = RequestPayload
{ rpMethod :: !Method
, rpContent :: !ByteString
, rpHeaders :: !RequestHeaders
, rpRawUrl :: !ByteString
} deriving (Show)
requestSignature
:: (SecretKey -> ByteString -> Signature)
-> SecretKey
-> RequestPayload
-> Signature
requestSignature signer sk = signer sk . createStringToSign
where
createStringToSign :: RequestPayload -> ByteString
createStringToSign RequestPayload{..} = BS.intercalate "\n"
[ rpMethod
, hashMD5 rpContent
, normalizeHeaders rpHeaders
, rpRawUrl
]
normalizeHeaders :: [Header] -> ByteString
normalizeHeaders = BS.intercalate "\n" . sort . map normalize
where
normalize :: Header -> ByteString
normalize (name, value) = foldedCase name <> value
verifySignatureHmac
:: (SecretKey -> ByteString -> Signature)
-> SecretKey
-> RequestPayload
-> Maybe LBS.ByteString
verifySignatureHmac signer sk signedPayload = case unsignedPayload of
Left err -> Just err
Right (pay, sig) -> if sig == requestSignature signer sk pay
then Nothing
else Just "Signatures don't match"
where
unsignedPayload :: Either LBS.ByteString (RequestPayload, Signature)
unsignedPayload = case extractOn isAuthHeader $ rpHeaders signedPayload of
(Nothing, _) -> Left "No 'Authentication' header"
(Just (_, val), headers) -> case BS.stripPrefix "HMAC " val of
Just sig -> Right
( signedPayload { rpHeaders = headers }
, Signature sig
)
Nothing -> Left "Can not strip 'HMAC' prefix in header"
authHeaderName :: HeaderName
authHeaderName = "Authentication"
isAuthHeader :: Header -> Bool
isAuthHeader = (== authHeaderName) . fst
hashMD5 :: ByteString -> ByteString
hashMD5 = BA.convert . hash @_ @MD5
extractOn :: (a -> Bool) -> [a] -> (Maybe a, [a])
extractOn p l =
let (before, after) = break p l
in case uncons after of
Nothing -> (Nothing, l)
Just (x, xs) -> (Just x, before ++ xs)