{-# OPTIONS_GHC -Wall #-}
module Stripe.Signature
( Sig (..), isSigValid, digest, signedPayload, natBytes, parseSig
) where
import qualified Data.List
import qualified Data.Maybe
import qualified Data.String
import Numeric.Natural (Natural)
import qualified Text.Read
import qualified Data.ByteString.Base16
import Data.ByteString (ByteString)
import qualified Data.ByteString
import Crypto.Hash (SHA256)
import Crypto.MAC.HMAC as HMAC
import qualified Data.ByteArray
import Stripe.Concepts (WebhookSecretKey (..))
import Data.Text (Text)
import qualified Data.Text
import qualified Data.Text.Encoding
isSigValid :: Sig -> WebhookSecretKey -> ByteString -> Bool
isSigValid :: Sig -> WebhookSecretKey -> ByteString -> Bool
isSigValid Sig
x WebhookSecretKey
secret ByteString
body =
(ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Data.List.any (HMAC SHA256 -> ByteString -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
Data.ByteArray.eq HMAC SHA256
correctDigest) (Sig -> [ByteString]
sigV1 Sig
x)
where
correctDigest :: HMAC SHA256
correctDigest = WebhookSecretKey -> Natural -> ByteString -> HMAC SHA256
digest WebhookSecretKey
secret (Sig -> Natural
sigTime Sig
x) ByteString
body
digest :: WebhookSecretKey -> Natural -> ByteString -> HMAC SHA256
digest :: WebhookSecretKey -> Natural -> ByteString -> HMAC SHA256
digest (WebhookSecretKey ByteString
secret) Natural
time ByteString
body =
ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
secret (Natural -> ByteString -> ByteString
signedPayload Natural
time ByteString
body)
signedPayload :: Natural -> ByteString -> ByteString
signedPayload :: Natural -> ByteString -> ByteString
signedPayload Natural
time ByteString
body =
[ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
[ Natural -> ByteString
natBytes Natural
time
, String -> ByteString
encodeAscii String
"."
, ByteString
body
]
natBytes :: Natural -> ByteString
natBytes :: Natural -> ByteString
natBytes = String -> ByteString
encodeAscii (String -> ByteString)
-> (Natural -> String) -> Natural -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> String
forall a. Show a => a -> String
show :: Natural -> String)
encodeAscii :: String -> ByteString
encodeAscii :: String -> ByteString
encodeAscii = String -> ByteString
forall a. IsString a => String -> a
Data.String.fromString
data Sig =
Sig
{ Sig -> Natural
sigTime :: Natural
, Sig -> [ByteString]
sigV1 :: [ByteString]
}
parseSig :: Text -> Maybe Sig
parseSig :: Text -> Maybe Sig
parseSig Text
txt =
let
parts :: [(Text, Text)]
parts :: [(Text, Text)]
parts = Text -> [(Text, Text)]
splitSig Text
txt
in
do
Natural
time <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Data.List.lookup (String -> Text
Data.Text.pack String
"t") [(Text, Text)]
parts
Maybe Text -> (Text -> Maybe Natural) -> Maybe Natural
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Maybe Natural
readNatural (String -> Maybe Natural)
-> (Text -> String) -> Text -> Maybe Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Data.Text.unpack)
let
v1 :: [ByteString]
v1 = ((Text, Text) -> Maybe ByteString)
-> [(Text, Text)] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
Data.Maybe.mapMaybe
( \(Text
k, Text
v) ->
if Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
Data.Text.pack String
"v1"
then Text -> Maybe ByteString
decodeHex Text
v
else Maybe ByteString
forall a. Maybe a
Nothing
)
[(Text, Text)]
parts
Sig -> Maybe Sig
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sig :: Natural -> [ByteString] -> Sig
Sig{ sigTime :: Natural
sigTime = Natural
time, sigV1 :: [ByteString]
sigV1 = [ByteString]
v1 }
splitSig :: Text -> [(Text, Text)]
splitSig :: Text -> [(Text, Text)]
splitSig =
[Maybe (Text, Text)] -> [(Text, Text)]
forall a. [Maybe a] -> [a]
Data.Maybe.catMaybes
([Maybe (Text, Text)] -> [(Text, Text)])
-> (Text -> [Maybe (Text, Text)]) -> Text -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Text, Text)) -> [Text] -> [Maybe (Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Maybe (Text, Text)
split2 (String -> Text
Data.Text.pack String
"="))
([Text] -> [Maybe (Text, Text)])
-> (Text -> [Text]) -> Text -> [Maybe (Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
Data.Text.splitOn (String -> Text
Data.Text.pack String
",")
split2 :: Text -> Text -> Maybe (Text, Text)
split2 :: Text -> Text -> Maybe (Text, Text)
split2 Text
pat Text
src =
let
(Text
x, Text
y) = Text -> Text -> (Text, Text)
Data.Text.breakOn Text
pat Text
src
y' :: Text
y' = Int -> Text -> Text
Data.Text.drop (Text -> Int
Data.Text.length Text
pat) Text
y
in
if Text -> Bool
Data.Text.null Text
y then Maybe (Text, Text)
forall a. Maybe a
Nothing else (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
x, Text
y')
readNatural :: String -> Maybe Natural
readNatural :: String -> Maybe Natural
readNatural = String -> Maybe Natural
forall a. Read a => String -> Maybe a
Text.Read.readMaybe
decodeHex :: Text -> Maybe ByteString
decodeHex :: Text -> Maybe ByteString
decodeHex Text
txt =
let
bs :: ByteString
bs = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
txt
(ByteString
x, ByteString
remainder) = ByteString -> (ByteString, ByteString)
Data.ByteString.Base16.decode ByteString
bs
in
if ByteString -> Bool
Data.ByteString.null ByteString
remainder then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x else Maybe ByteString
forall a. Maybe a
Nothing