{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Hasura.RQL.DDL.Webhook.Transform.Headers
  ( -- * Header Transformations
    Headers (..),
    TransformFn (..),
    TransformCtx (..),
    HeadersTransformFn (..),
    AddReplaceOrRemoveFields (..),
  )
where

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

import Data.CaseInsensitive qualified as CI
import Data.Text.Encoding qualified as TE
import Data.Validation (Validation)
import Data.Validation qualified as V
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform.Class
  ( TemplatingEngine,
    Transform (..),
    TransformErrorBundle (..),
  )
import Hasura.RQL.DDL.Webhook.Transform.Request
  ( RequestTransformCtx,
    runUnescapedRequestTemplateTransform',
    validateRequestUnescapedTemplateTransform',
  )
import Hasura.RQL.Types.Webhook.Transform.Headers (AddReplaceOrRemoveFields (..), Headers (..), HeadersTransformFn (..), TransformCtx (..), TransformFn (..))

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

instance Transform Headers where
  -- NOTE: GHC does not let us attach Haddock documentation to typeclass
  -- method implementations, so 'applyHeadersTransformFn' is defined
  -- separately.
  transform :: forall (m :: * -> *).
MonadError TransformErrorBundle m =>
TransformFn Headers -> TransformCtx Headers -> Headers -> m Headers
transform (HeadersTransformFn_ HeadersTransformFn
fn) (TransformCtx RequestTransformCtx
reqCtx) = HeadersTransformFn -> RequestTransformCtx -> Headers -> m Headers
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
HeadersTransformFn -> RequestTransformCtx -> Headers -> m Headers
applyHeadersTransformFn HeadersTransformFn
fn RequestTransformCtx
reqCtx

  -- NOTE: GHC does not let us attach Haddock documentation to typeclass
  -- method implementations, so 'validateHeadersTransformFn' is defined
  -- separately.
  validate :: TemplatingEngine
-> TransformFn Headers -> Validation TransformErrorBundle ()
validate TemplatingEngine
engine (HeadersTransformFn_ HeadersTransformFn
fn) =
    TemplatingEngine
-> HeadersTransformFn -> Validation TransformErrorBundle ()
validateHeadersTransformFn TemplatingEngine
engine HeadersTransformFn
fn

-- | Provide an implementation for the transformations defined by
-- 'HeadersTransformFn'.
--
-- If one views 'HeadersTransformFn' as an interface describing HTTP message
-- header transformations, this can be seen as an implementation of these
-- transformations as normal Haskell functions.
applyHeadersTransformFn ::
  (MonadError TransformErrorBundle m) =>
  HeadersTransformFn ->
  RequestTransformCtx ->
  Headers ->
  m Headers
applyHeadersTransformFn :: forall (m :: * -> *).
MonadError TransformErrorBundle m =>
HeadersTransformFn -> RequestTransformCtx -> Headers -> m Headers
applyHeadersTransformFn HeadersTransformFn
fn RequestTransformCtx
context (Headers [Header]
originalHeaders) = case HeadersTransformFn
fn of
  AddReplaceOrRemove AddReplaceOrRemoveFields
fields -> do
    -- NOTE: 'TE.decodeUtf8' can fail with an impure exception; conversion
    -- to bytes is infallible.
    let AddReplaceOrRemoveFields {[(CI Text, UnescapedTemplate)]
addOrReplaceHeaders :: [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders :: AddReplaceOrRemoveFields -> [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders, [CI Text]
removeHeaders :: [CI Text]
removeHeaders :: AddReplaceOrRemoveFields -> [CI Text]
removeHeaders} = AddReplaceOrRemoveFields
fields
        removeHeadersBytes :: [HeaderName]
removeHeadersBytes = (CI Text -> HeaderName) -> [CI Text] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ByteString) -> CI Text -> HeaderName
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map Text -> ByteString
TE.encodeUtf8) [CI Text]
removeHeaders
        filteredHeaders :: [Header]
filteredHeaders =
          [Header]
originalHeaders [Header] -> ([Header] -> [Header]) -> [Header]
forall a b. a -> (a -> b) -> b
& (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter \(HeaderName
key, ByteString
_val) ->
            HeaderName
key HeaderName -> [HeaderName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [HeaderName]
removeHeadersBytes

    -- NOTE: We use `ApplicativeDo` here to take advantage of Validation's
    -- applicative sequencing
    [Header]
newHeaders <- Either TransformErrorBundle [Header] -> m [Header]
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either TransformErrorBundle [Header] -> m [Header])
-> (Validation TransformErrorBundle [Header]
    -> Either TransformErrorBundle [Header])
-> Validation TransformErrorBundle [Header]
-> m [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation TransformErrorBundle [Header]
-> Either TransformErrorBundle [Header]
forall e a. Validation e a -> Either e a
V.toEither
      (Validation TransformErrorBundle [Header] -> m [Header])
-> Validation TransformErrorBundle [Header] -> m [Header]
forall a b. (a -> b) -> a -> b
$ [(CI Text, UnescapedTemplate)]
-> ((CI Text, UnescapedTemplate)
    -> Validation TransformErrorBundle Header)
-> Validation TransformErrorBundle [Header]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders \(CI Text
rawKey, UnescapedTemplate
rawValue) -> do
        let key :: HeaderName
key = (Text -> ByteString) -> CI Text -> HeaderName
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map Text -> ByteString
TE.encodeUtf8 CI Text
rawKey
        ByteString
value <- RequestTransformCtx
-> UnescapedTemplate -> Validation TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform' RequestTransformCtx
context UnescapedTemplate
rawValue
        pure (HeaderName
key, ByteString
value)

    Headers -> m Headers
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers -> m Headers)
-> ([Header] -> Headers) -> [Header] -> m Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> Headers
Headers ([Header] -> m Headers) -> [Header] -> m Headers
forall a b. (a -> b) -> a -> b
$ [Header]
filteredHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
newHeaders

-- | Validate that the provided 'HeadersTransformFn' is correct in the context
-- of a particular 'TemplatingEngine'.
--
-- This is a product of the fact that the correctness of a given transformation
-- may be dependent on zero, one, or more of the templated transformations
-- encoded within the given 'HeadersTransformFn'.
validateHeadersTransformFn ::
  TemplatingEngine ->
  HeadersTransformFn ->
  Validation TransformErrorBundle ()
validateHeadersTransformFn :: TemplatingEngine
-> HeadersTransformFn -> Validation TransformErrorBundle ()
validateHeadersTransformFn TemplatingEngine
engine = \case
  AddReplaceOrRemove AddReplaceOrRemoveFields
fields -> do
    let templates :: [UnescapedTemplate]
templates = AddReplaceOrRemoveFields
fields AddReplaceOrRemoveFields
-> (AddReplaceOrRemoveFields -> [(CI Text, UnescapedTemplate)])
-> [(CI Text, UnescapedTemplate)]
forall a b. a -> (a -> b) -> b
& AddReplaceOrRemoveFields -> [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders [(CI Text, UnescapedTemplate)]
-> ([(CI Text, UnescapedTemplate)] -> [UnescapedTemplate])
-> [UnescapedTemplate]
forall a b. a -> (a -> b) -> b
& ((CI Text, UnescapedTemplate) -> UnescapedTemplate)
-> [(CI Text, UnescapedTemplate)] -> [UnescapedTemplate]
forall a b. (a -> b) -> [a] -> [b]
map (CI Text, UnescapedTemplate) -> UnescapedTemplate
forall a b. (a, b) -> b
snd
    (UnescapedTemplate -> Validation TransformErrorBundle ())
-> [UnescapedTemplate] -> Validation TransformErrorBundle ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (TemplatingEngine
-> UnescapedTemplate -> Validation TransformErrorBundle ()
validateRequestUnescapedTemplateTransform' TemplatingEngine
engine) [UnescapedTemplate]
templates