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

module Hasura.RQL.DDL.Webhook.Transform.Body
  ( -- * Body Transformations
    Body (..),
    TransformFn (..),
    BodyTransformFn (..),
    foldFormEncoded,
  )
where

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

import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as J
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.HashMap.Internal.Strict qualified as M
import Data.List qualified as L
import Data.Text qualified as T
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 (..),
    Template (..),
    TemplatingEngine,
    Transform (..),
    TransformErrorBundle (..),
    UnescapedTemplate,
    runRequestTemplateTransform,
    runUnescapedRequestTemplateTransform',
    validateRequestTemplateTransform',
    validateRequestUnescapedTemplateTransform',
  )
import Network.URI.Extended qualified as URI

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

-- | HTTP message body being transformed.
data Body
  = JSONBody (Maybe J.Value)
  | RawBody LBS.ByteString
  deriving stock (Body -> Body -> Bool
(Body -> Body -> Bool) -> (Body -> Body -> Bool) -> Eq Body
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Body -> Body -> Bool
$c/= :: Body -> Body -> Bool
== :: Body -> Body -> Bool
$c== :: Body -> Body -> Bool
Eq, Int -> Body -> ShowS
[Body] -> ShowS
Body -> String
(Int -> Body -> ShowS)
-> (Body -> String) -> ([Body] -> ShowS) -> Show Body
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Body] -> ShowS
$cshowList :: [Body] -> ShowS
show :: Body -> String
$cshow :: Body -> String
showsPrec :: Int -> Body -> ShowS
$cshowsPrec :: Int -> Body -> ShowS
Show)

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

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

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

-- | The transformations which can be applied to an HTTP message body.
data BodyTransformFn
  = -- | Remove the HTTP message body.
    Remove
  | -- | Modify the JSON message body by applying a 'Template' transformation.
    ModifyAsJSON Template
  | -- | Modify the JSON message body by applying 'UnescapedTemplate'
    -- transformations to each field with a matching 'Text' key.
    ModifyAsFormURLEncoded (M.HashMap Text UnescapedTemplate)
  deriving stock (BodyTransformFn -> BodyTransformFn -> Bool
(BodyTransformFn -> BodyTransformFn -> Bool)
-> (BodyTransformFn -> BodyTransformFn -> Bool)
-> Eq BodyTransformFn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BodyTransformFn -> BodyTransformFn -> Bool
$c/= :: BodyTransformFn -> BodyTransformFn -> Bool
== :: BodyTransformFn -> BodyTransformFn -> Bool
$c== :: BodyTransformFn -> BodyTransformFn -> Bool
Eq, (forall x. BodyTransformFn -> Rep BodyTransformFn x)
-> (forall x. Rep BodyTransformFn x -> BodyTransformFn)
-> Generic BodyTransformFn
forall x. Rep BodyTransformFn x -> BodyTransformFn
forall x. BodyTransformFn -> Rep BodyTransformFn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BodyTransformFn x -> BodyTransformFn
$cfrom :: forall x. BodyTransformFn -> Rep BodyTransformFn x
Generic, Int -> BodyTransformFn -> ShowS
[BodyTransformFn] -> ShowS
BodyTransformFn -> String
(Int -> BodyTransformFn -> ShowS)
-> (BodyTransformFn -> String)
-> ([BodyTransformFn] -> ShowS)
-> Show BodyTransformFn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BodyTransformFn] -> ShowS
$cshowList :: [BodyTransformFn] -> ShowS
show :: BodyTransformFn -> String
$cshow :: BodyTransformFn -> String
showsPrec :: Int -> BodyTransformFn -> ShowS
$cshowsPrec :: Int -> BodyTransformFn -> ShowS
Show)
  deriving anyclass (Eq BodyTransformFn
Eq BodyTransformFn
-> (Accesses -> BodyTransformFn -> BodyTransformFn -> Bool)
-> Cacheable BodyTransformFn
Accesses -> BodyTransformFn -> BodyTransformFn -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> BodyTransformFn -> BodyTransformFn -> Bool
$cunchanged :: Accesses -> BodyTransformFn -> BodyTransformFn -> Bool
$cp1Cacheable :: Eq BodyTransformFn
Cacheable, BodyTransformFn -> ()
(BodyTransformFn -> ()) -> NFData BodyTransformFn
forall a. (a -> ()) -> NFData a
rnf :: BodyTransformFn -> ()
$crnf :: BodyTransformFn -> ()
NFData)

-- | Provide an implementation for the transformations defined by
-- 'BodyTransformFn'.
--
-- If one views 'BodyTransformFn' as an interface describing HTTP message body
-- transformations, this can be seen as an implementation of these
-- transformations as normal Haskell functions.
applyBodyTransformFn ::
  MonadError TransformErrorBundle m =>
  BodyTransformFn ->
  RequestTransformCtx ->
  Body ->
  m Body
applyBodyTransformFn :: BodyTransformFn -> RequestTransformCtx -> Body -> m Body
applyBodyTransformFn BodyTransformFn
fn RequestTransformCtx
context Body
_originalBody = case BodyTransformFn
fn of
  BodyTransformFn
Remove ->
    Body -> m Body
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Body -> m Body) -> Body -> m Body
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Body
JSONBody Maybe Value
forall a. Maybe a
Nothing
  ModifyAsJSON Template
template -> do
    Value
result <- Either TransformErrorBundle Value -> m Value
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either TransformErrorBundle Value -> m Value)
-> Either TransformErrorBundle Value -> m Value
forall a b. (a -> b) -> a -> b
$ Template
-> RequestTransformCtx -> Either TransformErrorBundle Value
runRequestTemplateTransform Template
template RequestTransformCtx
context
    Body -> m Body
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Body -> m Body) -> (Value -> Body) -> Value -> m Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Value -> Body
JSONBody (Maybe Value -> Body) -> (Value -> Maybe Value) -> Value -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> m Body) -> Value -> m Body
forall a b. (a -> b) -> a -> b
$ Value
result
  ModifyAsFormURLEncoded HashMap Text UnescapedTemplate
formTemplates -> do
    HashMap Text ByteString
result <-
      Either TransformErrorBundle (HashMap Text ByteString)
-> m (HashMap Text ByteString)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either TransformErrorBundle (HashMap Text ByteString)
 -> m (HashMap Text ByteString))
-> ((UnescapedTemplate
     -> Validation TransformErrorBundle ByteString)
    -> Either TransformErrorBundle (HashMap Text ByteString))
-> (UnescapedTemplate
    -> Validation TransformErrorBundle ByteString)
-> m (HashMap Text ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation TransformErrorBundle (HashMap Text ByteString)
-> Either TransformErrorBundle (HashMap Text ByteString)
forall e a. Validation e a -> Either e a
V.toEither (Validation TransformErrorBundle (HashMap Text ByteString)
 -> Either TransformErrorBundle (HashMap Text ByteString))
-> ((UnescapedTemplate
     -> Validation TransformErrorBundle ByteString)
    -> Validation TransformErrorBundle (HashMap Text ByteString))
-> (UnescapedTemplate
    -> Validation TransformErrorBundle ByteString)
-> Either TransformErrorBundle (HashMap Text ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text UnescapedTemplate
-> (UnescapedTemplate
    -> Validation TransformErrorBundle ByteString)
-> Validation TransformErrorBundle (HashMap Text ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for HashMap Text UnescapedTemplate
formTemplates ((UnescapedTemplate -> Validation TransformErrorBundle ByteString)
 -> m (HashMap Text ByteString))
-> (UnescapedTemplate
    -> Validation TransformErrorBundle ByteString)
-> m (HashMap Text ByteString)
forall a b. (a -> b) -> a -> b
$
        RequestTransformCtx
-> UnescapedTemplate -> Validation TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform' RequestTransformCtx
context
    Body -> m Body
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Body -> m Body) -> (ByteString -> Body) -> ByteString -> m Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Body
RawBody (ByteString -> m Body) -> ByteString -> m Body
forall a b. (a -> b) -> a -> b
$ HashMap Text ByteString -> ByteString
foldFormEncoded HashMap Text ByteString
result

-- | Validate that the provided 'BodyTransformFn' 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 'BodyTransformFn'.
validateBodyTransformFn ::
  TemplatingEngine ->
  BodyTransformFn ->
  Validation TransformErrorBundle ()
validateBodyTransformFn :: TemplatingEngine
-> BodyTransformFn -> Validation TransformErrorBundle ()
validateBodyTransformFn TemplatingEngine
engine = \case
  BodyTransformFn
Remove ->
    () -> Validation TransformErrorBundle ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ModifyAsJSON Template
template ->
    TemplatingEngine -> Template -> Validation TransformErrorBundle ()
validateRequestTemplateTransform' TemplatingEngine
engine Template
template
  ModifyAsFormURLEncoded HashMap Text UnescapedTemplate
templateMap ->
    (UnescapedTemplate -> Validation TransformErrorBundle ())
-> HashMap Text 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) HashMap Text UnescapedTemplate
templateMap

-- | Fold a 'M.HashMap' of header key/value pairs into an
-- @x-www-form-urlencoded@ message body.
foldFormEncoded :: M.HashMap Text ByteString -> LBS.ByteString
foldFormEncoded :: HashMap Text ByteString -> ByteString
foldFormEncoded =
  (Monoid ByteString => [ByteString] -> ByteString
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold @[] @LBS.ByteString)
    ([ByteString] -> ByteString)
-> (HashMap Text ByteString -> [ByteString])
-> HashMap Text ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
L.intersperse ByteString
"&"
    ([ByteString] -> [ByteString])
-> (HashMap Text ByteString -> [ByteString])
-> HashMap Text ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> ByteString -> [ByteString])
-> HashMap Text ByteString -> [ByteString]
forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
M.foldMapWithKey @[LBS.ByteString]
      \Text
k ByteString
v ->
        [ ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
            Text -> ByteString
TE.encodeUtf8 (Text -> Text
escapeURIText Text
k)
              ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"="
              ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
escapeURIBS ByteString
v
        ]

-- | URI-escape 'Text' blobs.
escapeURIText :: T.Text -> T.Text
escapeURIText :: Text -> Text
escapeURIText =
  String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- | URI-escape 'ByteString' blobs, which are presumed to represent 'Text'.
--
-- XXX: This function makes internal usage of 'TE.decodeUtf8', which throws an
-- impure exception when the supplied 'ByteString' cannot be decoded into valid
-- UTF8 text!
escapeURIBS :: ByteString -> ByteString
escapeURIBS :: ByteString -> ByteString
escapeURIBS =
  Text -> ByteString
TE.encodeUtf8
    (Text -> ByteString)
-> (ByteString -> Text) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent
    ShowS -> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
    (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8

instance FromJSON BodyTransformFn where
  parseJSON :: Value -> Parser BodyTransformFn
parseJSON = String
-> (Object -> Parser BodyTransformFn)
-> Value
-> Parser BodyTransformFn
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"BodyTransformFn" \Object
o -> do
    Text
action <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"action"
    case (Text
action :: Text) of
      Text
"remove" -> BodyTransformFn -> Parser BodyTransformFn
forall (f :: * -> *) a. Applicative f => a -> f a
pure BodyTransformFn
Remove
      Text
"transform" -> do
        Template
template <- Object
o Object -> Key -> Parser Template
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"template"
        BodyTransformFn -> Parser BodyTransformFn
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BodyTransformFn -> Parser BodyTransformFn)
-> BodyTransformFn -> Parser BodyTransformFn
forall a b. (a -> b) -> a -> b
$ Template -> BodyTransformFn
ModifyAsJSON Template
template
      Text
"x_www_form_urlencoded" -> do
        HashMap Text UnescapedTemplate
formTemplates <- Object
o Object -> Key -> Parser (HashMap Text UnescapedTemplate)
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"form_template"
        BodyTransformFn -> Parser BodyTransformFn
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BodyTransformFn -> Parser BodyTransformFn)
-> BodyTransformFn -> Parser BodyTransformFn
forall a b. (a -> b) -> a -> b
$ HashMap Text UnescapedTemplate -> BodyTransformFn
ModifyAsFormURLEncoded HashMap Text UnescapedTemplate
formTemplates
      Text
_ -> String -> Parser BodyTransformFn
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid transform action"

instance ToJSON BodyTransformFn where
  toJSON :: BodyTransformFn -> Value
toJSON = \case
    BodyTransformFn
Remove -> [Pair] -> Value
J.object [Key
"action" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= (Text
"remove" :: Text)]
    ModifyAsJSON Template
a ->
      [Pair] -> Value
J.object
        [ Key
"action" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= (Text
"transform" :: Text),
          Key
"template" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= Template -> Value
forall a. ToJSON a => a -> Value
J.toJSON Template
a
        ]
    ModifyAsFormURLEncoded HashMap Text UnescapedTemplate
formTemplates ->
      [Pair] -> Value
J.object
        [ Key
"action" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= (Text
"x_www_form_urlencoded" :: Text),
          Key
"form_template" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
J..= HashMap Text UnescapedTemplate -> Value
forall a. ToJSON a => a -> Value
J.toJSON HashMap Text UnescapedTemplate
formTemplates
        ]