{-# LANGUAGE AllowAmbiguousTypes #-}

-- | Crypto primitives for hmac signing.

module Servant.Auth.Hmac.Crypto
       ( -- * Crypto primitives
         SecretKey (..)
       , Signature (..)
       , sign
       , signSHA256

         -- * Request signing
       , RequestPayload (..)
       , requestSignature
       , verifySignatureHmac
       , whitelistHeaders
       , keepWhitelistedHeaders

         -- * Internals
       , 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

-- | The wraper for the secret key.
newtype SecretKey = SecretKey
    { SecretKey -> ByteString
unSecretKey :: ByteString
    }

-- | Hashed message used as the signature. Encoded in Base64.
newtype Signature = Signature
    { Signature -> ByteString
unSignature :: ByteString
    } deriving (Signature -> Signature -> Bool
(Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool) -> Eq Signature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signature -> Signature -> Bool
$c/= :: Signature -> Signature -> Bool
== :: Signature -> Signature -> Bool
$c== :: Signature -> Signature -> Bool
Eq)

{- | Compute the hashed message using the supplied hashing function. And then
encode the result in the Base64 encoding.
-}
sign :: forall algo . (HashAlgorithm algo)
     => SecretKey   -- ^ Secret key to use
     -> ByteString  -- ^ Message to MAC
     -> Signature   -- ^ Hashed message
sign :: SecretKey -> ByteString -> Signature
sign (SecretKey ByteString
sk) ByteString
msg = ByteString -> Signature
Signature
                        (ByteString -> Signature) -> ByteString -> Signature
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.encode
                        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest algo -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
                        (Digest algo -> ByteString) -> Digest algo -> ByteString
forall a b. (a -> b) -> a -> b
$ HMAC algo -> Digest algo
forall a. HMAC a -> Digest a
hmacGetDigest
                        (HMAC algo -> Digest algo) -> HMAC algo -> Digest algo
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HMAC algo
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac @_ @_ @algo ByteString
sk ByteString
msg
{-# INLINE sign #-}

-- | 'sign' function specialized for 'SHA256' cryptographic algorithm.
signSHA256 :: SecretKey -> ByteString -> Signature
signSHA256 :: SecretKey -> ByteString -> Signature
signSHA256 = HashAlgorithm SHA256 => SecretKey -> ByteString -> Signature
forall algo.
HashAlgorithm algo =>
SecretKey -> ByteString -> Signature
sign @SHA256
{-# INLINE signSHA256 #-}

----------------------------------------------------------------------------
-- Request signing
----------------------------------------------------------------------------

-- | Part of the HTTP request that will be signed.
data RequestPayload = RequestPayload
    { RequestPayload -> ByteString
rpMethod  :: !Method  -- ^ HTTP method
    , RequestPayload -> ByteString
rpContent :: !ByteString  -- ^ Raw content of HTTP body
    , RequestPayload -> RequestHeaders
rpHeaders :: !RequestHeaders  -- ^ All headers of HTTP request
    , RequestPayload -> ByteString
rpRawUrl  :: !ByteString  -- ^ Raw request URL with host, path pieces and parameters
    } deriving (Int -> RequestPayload -> ShowS
[RequestPayload] -> ShowS
RequestPayload -> String
(Int -> RequestPayload -> ShowS)
-> (RequestPayload -> String)
-> ([RequestPayload] -> ShowS)
-> Show RequestPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestPayload] -> ShowS
$cshowList :: [RequestPayload] -> ShowS
show :: RequestPayload -> String
$cshow :: RequestPayload -> String
showsPrec :: Int -> RequestPayload -> ShowS
$cshowsPrec :: Int -> RequestPayload -> ShowS
Show)

{- | This function signs HTTP request according to the following algorithm:

@
stringToSign = HTTP-Method       ++ "\n"
            ++ Content-MD5       ++ "\n"
            ++ HeadersNormalized ++ "\n"
            ++ RawURL

signature = encodeBase64
          $ signHmac yourSecretKey
          $ encodeUtf8 stringToSign
@

where @HeadersNormalized@ are headers decapitalzed, joined, sorted
alphabetically and intercalated with line break. So, if you have headers like
these:

@
User-Agent: Mozilla/5.0
Host: foo.bar.com
@

the result of header normalization will look like this:

@
hostfoo.bar.com
user-agentMozilla/5.0
@
-}
requestSignature
    :: (SecretKey -> ByteString -> Signature)  -- ^ Signing function
    -> SecretKey  -- ^ Secret key to use
    -> RequestPayload  -- ^ Payload to sign
    -> Signature
requestSignature :: (SecretKey -> ByteString -> Signature)
-> SecretKey -> RequestPayload -> Signature
requestSignature SecretKey -> ByteString -> Signature
signer SecretKey
sk = SecretKey -> ByteString -> Signature
signer SecretKey
sk (ByteString -> Signature)
-> (RequestPayload -> ByteString) -> RequestPayload -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestPayload -> ByteString
createStringToSign
  where
    createStringToSign :: RequestPayload -> ByteString
    createStringToSign :: RequestPayload -> ByteString
createStringToSign RequestPayload{RequestHeaders
ByteString
rpRawUrl :: ByteString
rpHeaders :: RequestHeaders
rpContent :: ByteString
rpMethod :: ByteString
rpRawUrl :: RequestPayload -> ByteString
rpHeaders :: RequestPayload -> RequestHeaders
rpContent :: RequestPayload -> ByteString
rpMethod :: RequestPayload -> ByteString
..} = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\n"
        [ ByteString
rpMethod
        , ByteString -> ByteString
hashMD5 ByteString
rpContent
        , RequestHeaders -> ByteString
normalizeHeaders RequestHeaders
rpHeaders
        , ByteString
rpRawUrl
        ]

    normalizeHeaders :: [Header] -> ByteString
    normalizeHeaders :: RequestHeaders -> ByteString
normalizeHeaders = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\n" ([ByteString] -> ByteString)
-> (RequestHeaders -> [ByteString]) -> RequestHeaders -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
sort ([ByteString] -> [ByteString])
-> (RequestHeaders -> [ByteString])
-> RequestHeaders
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> ByteString) -> RequestHeaders -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Header -> ByteString
normalize
      where
        normalize :: Header -> ByteString
        normalize :: Header -> ByteString
normalize (HeaderName
name, ByteString
value) = HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
value

{- | White-listed headers. Only these headers will be taken into consideration:

1. @Authentication@
2. @Host@
3. @Accept-Encoding@
-}
whitelistHeaders :: [HeaderName]
whitelistHeaders :: [HeaderName]
whitelistHeaders =
    [ HeaderName
authHeaderName
    , HeaderName
"Host"
    , HeaderName
"Accept-Encoding"
    ]

-- | Keeps only headers from 'whitelistHeaders'.
keepWhitelistedHeaders :: [Header] -> [Header]
keepWhitelistedHeaders :: RequestHeaders -> RequestHeaders
keepWhitelistedHeaders = (Header -> Bool) -> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
name, ByteString
_) -> HeaderName
name HeaderName -> [HeaderName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HeaderName]
whitelistHeaders)

{- | This function takes signing function @signer@ and secret key and expects
that given 'Request' has header:

@
Authentication: HMAC <signature>
@

It checks whether @<signature>@ is true request signature. Function returns 'Nothing'
if it is true, and 'Just' error message otherwise.
-}
verifySignatureHmac
    :: (SecretKey -> ByteString -> Signature)  -- ^ Signing function
    -> SecretKey  -- ^ Secret key that was used for signing 'Request'
    -> RequestPayload
    -> Maybe LBS.ByteString
verifySignatureHmac :: (SecretKey -> ByteString -> Signature)
-> SecretKey -> RequestPayload -> Maybe ByteString
verifySignatureHmac SecretKey -> ByteString -> Signature
signer SecretKey
sk RequestPayload
signedPayload = case Either ByteString (RequestPayload, Signature)
unsignedPayload of
    Left ByteString
err         -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
err
    Right (RequestPayload
pay, Signature
sig) -> if Signature
sig Signature -> Signature -> Bool
forall a. Eq a => a -> a -> Bool
== (SecretKey -> ByteString -> Signature)
-> SecretKey -> RequestPayload -> Signature
requestSignature SecretKey -> ByteString -> Signature
signer SecretKey
sk RequestPayload
pay
        then Maybe ByteString
forall a. Maybe a
Nothing
        else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"Signatures don't match"
  where
    -- Extracts HMAC signature from request and returns request with @authHeaderName@ header
    unsignedPayload :: Either LBS.ByteString (RequestPayload, Signature)
    unsignedPayload :: Either ByteString (RequestPayload, Signature)
unsignedPayload = case (Header -> Bool)
-> RequestHeaders -> (Maybe Header, RequestHeaders)
forall a. (a -> Bool) -> [a] -> (Maybe a, [a])
extractOn Header -> Bool
isAuthHeader (RequestHeaders -> (Maybe Header, RequestHeaders))
-> RequestHeaders -> (Maybe Header, RequestHeaders)
forall a b. (a -> b) -> a -> b
$ RequestPayload -> RequestHeaders
rpHeaders RequestPayload
signedPayload of
        (Maybe Header
Nothing, RequestHeaders
_) -> ByteString -> Either ByteString (RequestPayload, Signature)
forall a b. a -> Either a b
Left ByteString
"No 'Authentication' header"
        (Just (HeaderName
_, ByteString
val), RequestHeaders
headers) -> case ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"HMAC " ByteString
val of
            Just ByteString
sig -> (RequestPayload, Signature)
-> Either ByteString (RequestPayload, Signature)
forall a b. b -> Either a b
Right
                ( RequestPayload
signedPayload { rpHeaders :: RequestHeaders
rpHeaders = RequestHeaders
headers }
                , ByteString -> Signature
Signature ByteString
sig
                )
            Maybe ByteString
Nothing -> ByteString -> Either ByteString (RequestPayload, Signature)
forall a b. a -> Either a b
Left ByteString
"Can not strip 'HMAC' prefix in header"

----------------------------------------------------------------------------
-- Internals
----------------------------------------------------------------------------

authHeaderName :: HeaderName
authHeaderName :: HeaderName
authHeaderName = HeaderName
"Authentication"

isAuthHeader :: Header -> Bool
isAuthHeader :: Header -> Bool
isAuthHeader = (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
authHeaderName) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst

hashMD5 :: ByteString -> ByteString
hashMD5 :: ByteString -> ByteString
hashMD5 = Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest MD5 -> ByteString)
-> (ByteString -> Digest MD5) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteArrayAccess ByteString, HashAlgorithm MD5) =>
ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash @_ @MD5

{- | Removes and returns first element from list that satisfies given predicate.

>>> extractOn (== 3) [1..5]
(Just 3, [1,2,4,5])
>>> extractOn (== 3) [5..10]
(Nothing,[5,6,7,8,9,10])
-}
extractOn :: (a -> Bool) -> [a] -> (Maybe a, [a])
extractOn :: (a -> Bool) -> [a] -> (Maybe a, [a])
extractOn a -> Bool
p [a]
l =
    let ([a]
before, [a]
after) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p [a]
l
    in case [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
uncons [a]
after of
        Maybe (a, [a])
Nothing      -> (Maybe a
forall a. Maybe a
Nothing, [a]
l)
        Just (a
x, [a]
xs) -> (a -> Maybe a
forall a. a -> Maybe a
Just a
x, [a]
before [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs)