{-# OPTIONS_GHC -Wall #-}

{- | For a typical webhook server implemented with Scotty, probably the only
thing you need from this module is one of these two actions:

  - 'requireSig' - If your live mode and test mode webhooks use separate
    URLs.

  - 'requireSig_eitherMode' - If your live mode and test mode webhooks use
    the same URL. -}

module Stripe.Scotty
  ( requireSig, requireSig_eitherMode
  , hasValidSig, getSig, getSigText
  ) where

-- aeson
import qualified Data.Aeson
import qualified Data.Aeson.Key
import qualified Data.Aeson.KeyMap

-- base
import Control.Monad (when, (>=>))
import Control.Monad.IO.Class (MonadIO)

-- bytestring
import qualified Data.ByteString
import qualified Data.ByteString.Lazy

-- http-types
import qualified Network.HTTP.Types.Status

-- scotty
import qualified Web.Scotty.Trans as Scotty

-- stripe-concepts
import qualified Stripe.Concepts as Stripe

-- stripe-signature
import qualified Stripe.Signature as Stripe

-- text
import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder

{- | Terminates request processing if the request does not contain a valid
Stripe signature header.

This action returns the request body as a strict byte string; it has to fully
evaluate the request body to do the signature check, so we might as well return
this information to you for subsequent use. -}

requireSig
    :: (MonadIO m, Scotty.ScottyError e) =>
    Stripe.WebhookSecretKey
    -> Scotty.ActionT e m Data.ByteString.ByteString

requireSig :: forall (m :: * -> *) e.
(MonadIO m, ScottyError e) =>
WebhookSecretKey -> ActionT e m ByteString
requireSig WebhookSecretKey
secret =
  do
    ByteString
body <- forall (m :: * -> *) e.
(MonadIO m, ScottyError e) =>
ActionT e m ByteString
getBody
    Bool
okay <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
WebhookSecretKey -> ByteString -> ActionT e m Bool
hasValidSig WebhookSecretKey
secret ByteString
body

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
okay) forall (m :: * -> *) e a. (Monad m, ScottyError e) => ActionT e m a
invalidSigAction

    forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
body

{- | Terminates request processing if the request does not contain a valid
Stripe signature header.

This action returns the mode and JSON request body; it has to do this much
parsing to determine the mode so that we can know which secret key to use in the
verification, so we might as well return this information to you for subsequent
use. -}

requireSig_eitherMode
    :: (MonadIO m, Scotty.ScottyError e) =>
    Stripe.BothModes (Maybe Stripe.WebhookSecretKey)
    -> Scotty.ActionT e m (Stripe.Mode, Data.Aeson.Value)

requireSig_eitherMode :: forall (m :: * -> *) e.
(MonadIO m, ScottyError e) =>
BothModes (Maybe WebhookSecretKey) -> ActionT e m (Mode, Value)
requireSig_eitherMode BothModes (Maybe WebhookSecretKey)
secrets =
  do
    ByteString
body   <- forall (m :: * -> *) e.
(MonadIO m, ScottyError e) =>
ActionT e m ByteString
getBody
    Value
value  <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
ByteString -> ActionT e m Value
parseBody ByteString
body
    Mode
mode   <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
Value -> ActionT e m Mode
getMode Value
value
    WebhookSecretKey
secret <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
Mode
-> BothModes (Maybe WebhookSecretKey)
-> ActionT e m WebhookSecretKey
chooseSecret Mode
mode BothModes (Maybe WebhookSecretKey)
secrets
    Bool
okay   <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
WebhookSecretKey -> ByteString -> ActionT e m Bool
hasValidSig WebhookSecretKey
secret ByteString
body

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
okay) forall (m :: * -> *) e a. (Monad m, ScottyError e) => ActionT e m a
invalidSigAction

    forall (m :: * -> *) a. Monad m => a -> m a
return (Mode
mode, Value
value)

getBody :: (MonadIO m, Scotty.ScottyError e) =>
    Scotty.ActionT e m Data.ByteString.ByteString
getBody :: forall (m :: * -> *) e.
(MonadIO m, ScottyError e) =>
ActionT e m ByteString
getBody = ByteString -> ByteString
Data.ByteString.Lazy.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
ActionT e m ByteString
Scotty.body

invalidSigAction :: (Monad m, Scotty.ScottyError e) => Scotty.ActionT e m a
invalidSigAction :: forall (m :: * -> *) e a. (Monad m, ScottyError e) => ActionT e m a
invalidSigAction =
  do
    forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
Scotty.status Status
Network.HTTP.Types.Status.forbidden403
    forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
Scotty.text (String -> Text
Data.Text.Lazy.pack String
"Invalid Stripe signature")
    forall e (m :: * -> *) a. (ScottyError e, Monad m) => ActionT e m a
Scotty.finish

missingKeyAction :: (Monad m, Scotty.ScottyError e) =>
    Stripe.Mode -> Scotty.ActionT e m a
missingKeyAction :: forall (m :: * -> *) e a.
(Monad m, ScottyError e) =>
Mode -> ActionT e m a
missingKeyAction Mode
mode =
  do
    forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
Scotty.status Status
Network.HTTP.Types.Status.internalServerError500
    forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
Scotty.text Text
message
    forall e (m :: * -> *) a. (ScottyError e, Monad m) => ActionT e m a
Scotty.finish
  where
    message :: Text
message =
        Builder -> Text
Data.Text.Lazy.Builder.toLazyText forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> Builder
Data.Text.Lazy.Builder.fromString
                [ String
"Configuration error: No webhook secret for "
                , case Mode
mode of
                    Mode
Stripe.LiveMode -> String
"live"
                    Mode
Stripe.TestMode -> String
"test"
                , String
" mode."
                ]

chooseSecret
    :: (Monad m, Scotty.ScottyError e) =>
    Stripe.Mode
    -> Stripe.BothModes (Maybe Stripe.WebhookSecretKey)
    -> Scotty.ActionT e m Stripe.WebhookSecretKey
chooseSecret :: forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
Mode
-> BothModes (Maybe WebhookSecretKey)
-> ActionT e m WebhookSecretKey
chooseSecret Mode
mode BothModes (Maybe WebhookSecretKey)
secrets =
    case forall a. Mode -> BothModes a -> a
Stripe.applyMode Mode
mode BothModes (Maybe WebhookSecretKey)
secrets of
        Just WebhookSecretKey
x -> forall (m :: * -> *) a. Monad m => a -> m a
return WebhookSecretKey
x
        Maybe WebhookSecretKey
Nothing -> forall (m :: * -> *) e a.
(Monad m, ScottyError e) =>
Mode -> ActionT e m a
missingKeyAction Mode
mode

parseBody
    :: (Monad m, Scotty.ScottyError e) =>
    Data.ByteString.ByteString
    -> Scotty.ActionT e m Data.Aeson.Value
parseBody :: forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
ByteString -> ActionT e m Value
parseBody ByteString
bs =
    case forall a. FromJSON a => ByteString -> Either String a
Data.Aeson.eitherDecode (ByteString -> ByteString
Data.ByteString.Lazy.fromStrict ByteString
bs) of
        Left String
x ->
          do
            forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
Scotty.status Status
Network.HTTP.Types.Status.badRequest400
            forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
Scotty.text (String -> Text
Data.Text.Lazy.pack String
x)
            forall e (m :: * -> *) a. (ScottyError e, Monad m) => ActionT e m a
Scotty.finish
        Right Value
x ->
            forall (m :: * -> *) a. Monad m => a -> m a
return Value
x

getMode :: (Monad m, Scotty.ScottyError e) =>
    Data.Aeson.Value -> Scotty.ActionT e m Stripe.Mode
getMode :: forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
Value -> ActionT e m Mode
getMode Value
val =
    case (String -> Value -> Maybe Value
aesonAttr String
"livemode" forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Maybe Bool
aesonBool) Value
val of

      Maybe Bool
Nothing ->
        do
          forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
Scotty.status Status
Network.HTTP.Types.Status.badRequest400
          forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
Scotty.text (String -> Text
Data.Text.Lazy.pack
              String
"Webhook attribute \"livemode\" is missing.")
          forall e (m :: * -> *) a. (ScottyError e, Monad m) => ActionT e m a
Scotty.finish

      Just Bool
livemode ->
          forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Mode
Stripe.isLiveMode' Bool
livemode)

{- | Determines whether the request contains a valid Stripe signature header. -}

hasValidSig
    :: (Monad m, Scotty.ScottyError e) =>
    Stripe.WebhookSecretKey
    -> Data.ByteString.ByteString
    -> Scotty.ActionT e m Bool
hasValidSig :: forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
WebhookSecretKey -> ByteString -> ActionT e m Bool
hasValidSig WebhookSecretKey
secret ByteString
body =
  do
    Maybe Sig
sigMaybe <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
ActionT e m (Maybe Sig)
getSig
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        case Maybe Sig
sigMaybe of
            Maybe Sig
Nothing -> Bool
False
            Just Sig
sig -> Sig -> WebhookSecretKey -> ByteString -> Bool
Stripe.isSigValid Sig
sig WebhookSecretKey
secret ByteString
body

getSigText :: (Monad m, Scotty.ScottyError e) =>
    Scotty.ActionT e m (Maybe Data.Text.Text)
getSigText :: forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
ActionT e m (Maybe Text)
getSigText =
  do
    Maybe Text
x <- forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m (Maybe Text)
Scotty.header (String -> Text
Data.Text.Lazy.pack String
"Stripe-Signature")
    forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
Data.Text.Lazy.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
x)

getSig :: (Monad m, Scotty.ScottyError e) =>
    Scotty.ActionT e m (Maybe Stripe.Sig)
getSig :: forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
ActionT e m (Maybe Sig)
getSig =
  do
    Maybe Text
x <- forall (m :: * -> *) e.
(Monad m, ScottyError e) =>
ActionT e m (Maybe Text)
getSigText
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Sig
Stripe.parseSig)

------------------------------------------------------------

-- Internal Aeson decoding functions

aesonAttr :: String -> Data.Aeson.Value -> Maybe Data.Aeson.Value
aesonAttr :: String -> Value -> Maybe Value
aesonAttr String
x = Value -> Maybe Object
aesonObject forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall v. Key -> KeyMap v -> Maybe v
Data.Aeson.KeyMap.lookup (String -> Key
Data.Aeson.Key.fromString String
x)

aesonObject :: Data.Aeson.Value -> Maybe Data.Aeson.Object
aesonObject :: Value -> Maybe Object
aesonObject (Data.Aeson.Object Object
x) = forall a. a -> Maybe a
Just Object
x
aesonObject Value
_ = forall a. Maybe a
Nothing

aesonBool :: Data.Aeson.Value -> Maybe Bool
aesonBool :: Value -> Maybe Bool
aesonBool (Data.Aeson.Bool Bool
x) = forall a. a -> Maybe a
Just Bool
x
aesonBool Value
_ = forall a. Maybe a
Nothing