{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}

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

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

import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as J
import Data.CaseInsensitive qualified as CI
import Data.HashMap.Strict qualified as M
import Data.Text.Encoding qualified as TE
import Data.Validation (Validation)
import Data.Validation qualified as V
import Hasura.Incremental (Cacheable)
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform.Class
  ( RequestTransformCtx (..),
    TemplatingEngine,
    Transform (..),
    TransformErrorBundle (..),
    UnescapedTemplate (..),
    runUnescapedRequestTemplateTransform',
    validateRequestUnescapedTemplateTransform',
  )
import Network.HTTP.Types qualified as HTTP.Types

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

-- | The actual header data we are transforming..
--
-- This newtype is necessary because otherwise we end up with an
-- orphan instance.
newtype Headers = Headers [HTTP.Types.Header]

instance Transform Headers where
  -- NOTE: GHC does not let us attach Haddock documentation to data family
  -- instances, so 'HeadersTransformFn' is defined separately from this
  -- wrapper.
  newtype TransformFn Headers = HeadersTransformFn_ HeadersTransformFn
    deriving stock (TransformFn Headers -> TransformFn Headers -> Bool
(TransformFn Headers -> TransformFn Headers -> Bool)
-> (TransformFn Headers -> TransformFn Headers -> Bool)
-> Eq (TransformFn Headers)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransformFn Headers -> TransformFn Headers -> Bool
$c/= :: TransformFn Headers -> TransformFn Headers -> Bool
== :: TransformFn Headers -> TransformFn Headers -> Bool
$c== :: TransformFn Headers -> TransformFn Headers -> Bool
Eq, (forall x. TransformFn Headers -> Rep (TransformFn Headers) x)
-> (forall x. Rep (TransformFn Headers) x -> TransformFn Headers)
-> Generic (TransformFn Headers)
forall x. Rep (TransformFn Headers) x -> TransformFn Headers
forall x. TransformFn Headers -> Rep (TransformFn Headers) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep (TransformFn Headers) x -> TransformFn Headers
$cfrom :: forall x. TransformFn Headers -> Rep (TransformFn Headers) x
Generic, Int -> TransformFn Headers -> ShowS
[TransformFn Headers] -> ShowS
TransformFn Headers -> String
(Int -> TransformFn Headers -> ShowS)
-> (TransformFn Headers -> String)
-> ([TransformFn Headers] -> ShowS)
-> Show (TransformFn Headers)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransformFn Headers] -> ShowS
$cshowList :: [TransformFn Headers] -> ShowS
show :: TransformFn Headers -> String
$cshow :: TransformFn Headers -> String
showsPrec :: Int -> TransformFn Headers -> ShowS
$cshowsPrec :: Int -> TransformFn Headers -> ShowS
Show)
    deriving newtype (Eq (TransformFn Headers)
Eq (TransformFn Headers)
-> (Accesses -> TransformFn Headers -> TransformFn Headers -> Bool)
-> Cacheable (TransformFn Headers)
Accesses -> TransformFn Headers -> TransformFn Headers -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> TransformFn Headers -> TransformFn Headers -> Bool
$cunchanged :: Accesses -> TransformFn Headers -> TransformFn Headers -> Bool
$cp1Cacheable :: Eq (TransformFn Headers)
Cacheable, TransformFn Headers -> ()
(TransformFn Headers -> ()) -> NFData (TransformFn Headers)
forall a. (a -> ()) -> NFData a
rnf :: TransformFn Headers -> ()
$crnf :: TransformFn Headers -> ()
NFData, Value -> Parser [TransformFn Headers]
Value -> Parser (TransformFn Headers)
(Value -> Parser (TransformFn Headers))
-> (Value -> Parser [TransformFn Headers])
-> FromJSON (TransformFn Headers)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TransformFn Headers]
$cparseJSONList :: Value -> Parser [TransformFn Headers]
parseJSON :: Value -> Parser (TransformFn Headers)
$cparseJSON :: Value -> Parser (TransformFn Headers)
FromJSON, [TransformFn Headers] -> Value
[TransformFn Headers] -> Encoding
TransformFn Headers -> Value
TransformFn Headers -> Encoding
(TransformFn Headers -> Value)
-> (TransformFn Headers -> Encoding)
-> ([TransformFn Headers] -> Value)
-> ([TransformFn Headers] -> Encoding)
-> ToJSON (TransformFn Headers)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TransformFn Headers] -> Encoding
$ctoEncodingList :: [TransformFn Headers] -> Encoding
toJSONList :: [TransformFn Headers] -> Value
$ctoJSONList :: [TransformFn Headers] -> Value
toEncoding :: TransformFn Headers -> Encoding
$ctoEncoding :: TransformFn Headers -> Encoding
toJSON :: TransformFn Headers -> Value
$ctoJSON :: TransformFn Headers -> Value
ToJSON)

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

  -- 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_ fn) =
    TemplatingEngine
-> HeadersTransformFn -> Validation TransformErrorBundle ()
validateHeadersTransformFn TemplatingEngine
engine HeadersTransformFn
fn

-- | The defunctionalized transformation on 'Headers'
newtype HeadersTransformFn
  = -- | Add or replace matching 'HTTP.Types.Header's.
    AddReplaceOrRemove AddReplaceOrRemoveFields
  deriving stock (HeadersTransformFn -> HeadersTransformFn -> Bool
(HeadersTransformFn -> HeadersTransformFn -> Bool)
-> (HeadersTransformFn -> HeadersTransformFn -> Bool)
-> Eq HeadersTransformFn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeadersTransformFn -> HeadersTransformFn -> Bool
$c/= :: HeadersTransformFn -> HeadersTransformFn -> Bool
== :: HeadersTransformFn -> HeadersTransformFn -> Bool
$c== :: HeadersTransformFn -> HeadersTransformFn -> Bool
Eq, (forall x. HeadersTransformFn -> Rep HeadersTransformFn x)
-> (forall x. Rep HeadersTransformFn x -> HeadersTransformFn)
-> Generic HeadersTransformFn
forall x. Rep HeadersTransformFn x -> HeadersTransformFn
forall x. HeadersTransformFn -> Rep HeadersTransformFn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HeadersTransformFn x -> HeadersTransformFn
$cfrom :: forall x. HeadersTransformFn -> Rep HeadersTransformFn x
Generic, Int -> HeadersTransformFn -> ShowS
[HeadersTransformFn] -> ShowS
HeadersTransformFn -> String
(Int -> HeadersTransformFn -> ShowS)
-> (HeadersTransformFn -> String)
-> ([HeadersTransformFn] -> ShowS)
-> Show HeadersTransformFn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeadersTransformFn] -> ShowS
$cshowList :: [HeadersTransformFn] -> ShowS
show :: HeadersTransformFn -> String
$cshow :: HeadersTransformFn -> String
showsPrec :: Int -> HeadersTransformFn -> ShowS
$cshowsPrec :: Int -> HeadersTransformFn -> ShowS
Show)
  deriving newtype (Eq HeadersTransformFn
Eq HeadersTransformFn
-> (Accesses -> HeadersTransformFn -> HeadersTransformFn -> Bool)
-> Cacheable HeadersTransformFn
Accesses -> HeadersTransformFn -> HeadersTransformFn -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> HeadersTransformFn -> HeadersTransformFn -> Bool
$cunchanged :: Accesses -> HeadersTransformFn -> HeadersTransformFn -> Bool
$cp1Cacheable :: Eq HeadersTransformFn
Cacheable, HeadersTransformFn -> ()
(HeadersTransformFn -> ()) -> NFData HeadersTransformFn
forall a. (a -> ()) -> NFData a
rnf :: HeadersTransformFn -> ()
$crnf :: HeadersTransformFn -> ()
NFData, Value -> Parser [HeadersTransformFn]
Value -> Parser HeadersTransformFn
(Value -> Parser HeadersTransformFn)
-> (Value -> Parser [HeadersTransformFn])
-> FromJSON HeadersTransformFn
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [HeadersTransformFn]
$cparseJSONList :: Value -> Parser [HeadersTransformFn]
parseJSON :: Value -> Parser HeadersTransformFn
$cparseJSON :: Value -> Parser HeadersTransformFn
FromJSON, [HeadersTransformFn] -> Value
[HeadersTransformFn] -> Encoding
HeadersTransformFn -> Value
HeadersTransformFn -> Encoding
(HeadersTransformFn -> Value)
-> (HeadersTransformFn -> Encoding)
-> ([HeadersTransformFn] -> Value)
-> ([HeadersTransformFn] -> Encoding)
-> ToJSON HeadersTransformFn
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [HeadersTransformFn] -> Encoding
$ctoEncodingList :: [HeadersTransformFn] -> Encoding
toJSONList :: [HeadersTransformFn] -> Value
$ctoJSONList :: [HeadersTransformFn] -> Value
toEncoding :: HeadersTransformFn -> Encoding
$ctoEncoding :: HeadersTransformFn -> Encoding
toJSON :: HeadersTransformFn -> Value
$ctoJSON :: HeadersTransformFn -> Value
ToJSON)

-- | The user can supply a set of header keys to be filtered from the
-- request and a set of headers to be added to the request.
data AddReplaceOrRemoveFields = AddReplaceOrRemoveFields
  { -- | A list of key-value pairs for 'HTTP.Types.Header's which
    -- should be added (if they don't exist) or replaced (if they do) within
    -- the HTTP message.
    AddReplaceOrRemoveFields -> [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders :: [(CI.CI Text, UnescapedTemplate)],
    -- | A list of 'HTTP.Type.Header' keys which should be removed from the
    -- HTTP message.
    AddReplaceOrRemoveFields -> [CI Text]
removeHeaders :: [CI.CI Text]
  }
  deriving stock (Int -> AddReplaceOrRemoveFields -> ShowS
[AddReplaceOrRemoveFields] -> ShowS
AddReplaceOrRemoveFields -> String
(Int -> AddReplaceOrRemoveFields -> ShowS)
-> (AddReplaceOrRemoveFields -> String)
-> ([AddReplaceOrRemoveFields] -> ShowS)
-> Show AddReplaceOrRemoveFields
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddReplaceOrRemoveFields] -> ShowS
$cshowList :: [AddReplaceOrRemoveFields] -> ShowS
show :: AddReplaceOrRemoveFields -> String
$cshow :: AddReplaceOrRemoveFields -> String
showsPrec :: Int -> AddReplaceOrRemoveFields -> ShowS
$cshowsPrec :: Int -> AddReplaceOrRemoveFields -> ShowS
Show, AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
(AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> (AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> Eq AddReplaceOrRemoveFields
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$c/= :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
== :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$c== :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
Eq, Eq AddReplaceOrRemoveFields
Eq AddReplaceOrRemoveFields
-> (AddReplaceOrRemoveFields
    -> AddReplaceOrRemoveFields -> Ordering)
-> (AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> (AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> (AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> (AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> (AddReplaceOrRemoveFields
    -> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields)
-> (AddReplaceOrRemoveFields
    -> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields)
-> Ord AddReplaceOrRemoveFields
AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Ordering
AddReplaceOrRemoveFields
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AddReplaceOrRemoveFields
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields
$cmin :: AddReplaceOrRemoveFields
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields
max :: AddReplaceOrRemoveFields
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields
$cmax :: AddReplaceOrRemoveFields
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields
>= :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$c>= :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
> :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$c> :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
<= :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$c<= :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
< :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$c< :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
compare :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Ordering
$ccompare :: AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Ordering
$cp1Ord :: Eq AddReplaceOrRemoveFields
Ord, (forall x.
 AddReplaceOrRemoveFields -> Rep AddReplaceOrRemoveFields x)
-> (forall x.
    Rep AddReplaceOrRemoveFields x -> AddReplaceOrRemoveFields)
-> Generic AddReplaceOrRemoveFields
forall x.
Rep AddReplaceOrRemoveFields x -> AddReplaceOrRemoveFields
forall x.
AddReplaceOrRemoveFields -> Rep AddReplaceOrRemoveFields x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep AddReplaceOrRemoveFields x -> AddReplaceOrRemoveFields
$cfrom :: forall x.
AddReplaceOrRemoveFields -> Rep AddReplaceOrRemoveFields x
Generic)
  deriving anyclass (AddReplaceOrRemoveFields -> ()
(AddReplaceOrRemoveFields -> ()) -> NFData AddReplaceOrRemoveFields
forall a. (a -> ()) -> NFData a
rnf :: AddReplaceOrRemoveFields -> ()
$crnf :: AddReplaceOrRemoveFields -> ()
NFData, Eq AddReplaceOrRemoveFields
Eq AddReplaceOrRemoveFields
-> (Accesses
    -> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool)
-> Cacheable AddReplaceOrRemoveFields
Accesses
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$cunchanged :: Accesses
-> AddReplaceOrRemoveFields -> AddReplaceOrRemoveFields -> Bool
$cp1Cacheable :: Eq AddReplaceOrRemoveFields
Cacheable)

-- | 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 :: 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 :: [CI ByteString]
removeHeadersBytes = (CI Text -> CI ByteString) -> [CI Text] -> [CI ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ByteString) -> CI Text -> CI ByteString
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 \(CI ByteString
key, ByteString
_val) ->
            CI ByteString
key CI ByteString -> [CI ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CI ByteString]
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 :: CI ByteString
key = (Text -> ByteString) -> CI Text -> CI ByteString
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 (CI ByteString
key, ByteString
value)

    Headers -> m Headers
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

instance FromJSON AddReplaceOrRemoveFields where
  parseJSON :: Value -> Parser AddReplaceOrRemoveFields
parseJSON = String
-> (Object -> Parser AddReplaceOrRemoveFields)
-> Value
-> Parser AddReplaceOrRemoveFields
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"AddReplaceRemoveFields" ((Object -> Parser AddReplaceOrRemoveFields)
 -> Value -> Parser AddReplaceOrRemoveFields)
-> (Object -> Parser AddReplaceOrRemoveFields)
-> Value
-> Parser AddReplaceOrRemoveFields
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    HashMap Text UnescapedTemplate
addOrReplaceHeadersTxt <- Object
o Object -> Key -> Parser (Maybe (HashMap Text UnescapedTemplate))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"add_headers" Parser (Maybe (HashMap Text UnescapedTemplate))
-> HashMap Text UnescapedTemplate
-> Parser (HashMap Text UnescapedTemplate)
forall a. Parser (Maybe a) -> a -> Parser a
J..!= HashMap Text UnescapedTemplate
forall a. Monoid a => a
mempty
    let addOrReplaceHeaders :: [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders = HashMap (CI Text) UnescapedTemplate
-> [(CI Text, UnescapedTemplate)]
forall k v. HashMap k v -> [(k, v)]
M.toList (HashMap (CI Text) UnescapedTemplate
 -> [(CI Text, UnescapedTemplate)])
-> HashMap (CI Text) UnescapedTemplate
-> [(CI Text, UnescapedTemplate)]
forall a b. (a -> b) -> a -> b
$ (Text -> CI Text)
-> HashMap Text UnescapedTemplate
-> HashMap (CI Text) UnescapedTemplate
forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
mapKeys Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk HashMap Text UnescapedTemplate
addOrReplaceHeadersTxt

    [HeaderKey]
removeHeadersTxt <- Object
o Object -> Key -> Parser (Maybe [HeaderKey])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"remove_headers" Parser (Maybe [HeaderKey]) -> [HeaderKey] -> Parser [HeaderKey]
forall a. Parser (Maybe a) -> a -> Parser a
J..!= [HeaderKey]
forall a. Monoid a => a
mempty
    -- NOTE: Ensure that the FromJSON instance is used for deserialization.
    let removeHeaders :: [CI Text]
removeHeaders = [HeaderKey] -> [CI Text]
coerce @[HeaderKey] [HeaderKey]
removeHeadersTxt

    pure AddReplaceOrRemoveFields :: [(CI Text, UnescapedTemplate)]
-> [CI Text] -> AddReplaceOrRemoveFields
AddReplaceOrRemoveFields {[(CI Text, UnescapedTemplate)]
addOrReplaceHeaders :: [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders :: [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders, [CI Text]
removeHeaders :: [CI Text]
removeHeaders :: [CI Text]
removeHeaders}

instance ToJSON AddReplaceOrRemoveFields where
  toJSON :: AddReplaceOrRemoveFields -> Value
toJSON AddReplaceOrRemoveFields {[(CI Text, UnescapedTemplate)]
[CI Text]
removeHeaders :: [CI Text]
addOrReplaceHeaders :: [(CI Text, UnescapedTemplate)]
removeHeaders :: AddReplaceOrRemoveFields -> [CI Text]
addOrReplaceHeaders :: AddReplaceOrRemoveFields -> [(CI Text, UnescapedTemplate)]
..} =
    [Pair] -> Value
J.object
      [ Key
"add_headers" Key -> HashMap Text UnescapedTemplate -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= [(Text, UnescapedTemplate)] -> HashMap Text UnescapedTemplate
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList (((CI Text, UnescapedTemplate) -> (Text, UnescapedTemplate))
-> [(CI Text, UnescapedTemplate)] -> [(Text, UnescapedTemplate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CI Text -> Text)
-> (CI Text, UnescapedTemplate) -> (Text, UnescapedTemplate)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CI Text -> Text
forall s. CI s -> s
CI.original) [(CI Text, UnescapedTemplate)]
addOrReplaceHeaders),
        Key
"remove_headers" Key -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= (CI Text -> Text) -> [CI Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CI Text -> Text
forall s. CI s -> s
CI.original [CI Text]
removeHeaders
      ]

-- | This newtype exists solely to anchor a `FromJSON` instance and is
-- eliminated in the `TransformHeaders` `FromJSON` instance.
newtype HeaderKey = HeaderKey {HeaderKey -> CI Text
unHeaderKey :: CI.CI Text}
  deriving stock (Int -> HeaderKey -> ShowS
[HeaderKey] -> ShowS
HeaderKey -> String
(Int -> HeaderKey -> ShowS)
-> (HeaderKey -> String)
-> ([HeaderKey] -> ShowS)
-> Show HeaderKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderKey] -> ShowS
$cshowList :: [HeaderKey] -> ShowS
show :: HeaderKey -> String
$cshow :: HeaderKey -> String
showsPrec :: Int -> HeaderKey -> ShowS
$cshowsPrec :: Int -> HeaderKey -> ShowS
Show, HeaderKey -> HeaderKey -> Bool
(HeaderKey -> HeaderKey -> Bool)
-> (HeaderKey -> HeaderKey -> Bool) -> Eq HeaderKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderKey -> HeaderKey -> Bool
$c/= :: HeaderKey -> HeaderKey -> Bool
== :: HeaderKey -> HeaderKey -> Bool
$c== :: HeaderKey -> HeaderKey -> Bool
Eq, Eq HeaderKey
Eq HeaderKey
-> (HeaderKey -> HeaderKey -> Ordering)
-> (HeaderKey -> HeaderKey -> Bool)
-> (HeaderKey -> HeaderKey -> Bool)
-> (HeaderKey -> HeaderKey -> Bool)
-> (HeaderKey -> HeaderKey -> Bool)
-> (HeaderKey -> HeaderKey -> HeaderKey)
-> (HeaderKey -> HeaderKey -> HeaderKey)
-> Ord HeaderKey
HeaderKey -> HeaderKey -> Bool
HeaderKey -> HeaderKey -> Ordering
HeaderKey -> HeaderKey -> HeaderKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HeaderKey -> HeaderKey -> HeaderKey
$cmin :: HeaderKey -> HeaderKey -> HeaderKey
max :: HeaderKey -> HeaderKey -> HeaderKey
$cmax :: HeaderKey -> HeaderKey -> HeaderKey
>= :: HeaderKey -> HeaderKey -> Bool
$c>= :: HeaderKey -> HeaderKey -> Bool
> :: HeaderKey -> HeaderKey -> Bool
$c> :: HeaderKey -> HeaderKey -> Bool
<= :: HeaderKey -> HeaderKey -> Bool
$c<= :: HeaderKey -> HeaderKey -> Bool
< :: HeaderKey -> HeaderKey -> Bool
$c< :: HeaderKey -> HeaderKey -> Bool
compare :: HeaderKey -> HeaderKey -> Ordering
$ccompare :: HeaderKey -> HeaderKey -> Ordering
$cp1Ord :: Eq HeaderKey
Ord, (forall x. HeaderKey -> Rep HeaderKey x)
-> (forall x. Rep HeaderKey x -> HeaderKey) -> Generic HeaderKey
forall x. Rep HeaderKey x -> HeaderKey
forall x. HeaderKey -> Rep HeaderKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HeaderKey x -> HeaderKey
$cfrom :: forall x. HeaderKey -> Rep HeaderKey x
Generic)
  deriving anyclass (HeaderKey -> ()
(HeaderKey -> ()) -> NFData HeaderKey
forall a. (a -> ()) -> NFData a
rnf :: HeaderKey -> ()
$crnf :: HeaderKey -> ()
NFData, Eq HeaderKey
Eq HeaderKey
-> (Accesses -> HeaderKey -> HeaderKey -> Bool)
-> Cacheable HeaderKey
Accesses -> HeaderKey -> HeaderKey -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> HeaderKey -> HeaderKey -> Bool
$cunchanged :: Accesses -> HeaderKey -> HeaderKey -> Bool
$cp1Cacheable :: Eq HeaderKey
Cacheable)

instance FromJSON HeaderKey where
  parseJSON :: Value -> Parser HeaderKey
parseJSON = String -> (Text -> Parser HeaderKey) -> Value -> Parser HeaderKey
forall a. String -> (Text -> Parser a) -> Value -> Parser a
J.withText String
"HeaderKey" \Text
txt -> case Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk Text
txt of
    CI Text
key -> HeaderKey -> Parser HeaderKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeaderKey -> Parser HeaderKey) -> HeaderKey -> Parser HeaderKey
forall a b. (a -> b) -> a -> b
$ CI Text -> HeaderKey
HeaderKey CI Text
key