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

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

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

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.Prelude
import Hasura.RQL.DDL.Webhook.Transform.Class
  ( TemplatingEngine,
    Transform (..),
    TransformErrorBundle (..),
  )
import Hasura.RQL.DDL.Webhook.Transform.Request
  ( RequestTransformCtx,
    runRequestTemplateTransform,
    runUnescapedRequestTemplateTransform',
    validateRequestTemplateTransform',
    validateRequestUnescapedTemplateTransform',
  )
import Hasura.RQL.Types.Webhook.Transform.Body (Body (..), BodyTransformFn (..), TransformCtx (..), TransformFn (..))
import Network.URI.Extended qualified as URI

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

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

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

-- | 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 :: forall (m :: * -> *).
MonadError TransformErrorBundle m =>
BodyTransformFn -> RequestTransformCtx -> Body -> m Body
applyBodyTransformFn BodyTransformFn
fn RequestTransformCtx
context Body
_originalBody = case BodyTransformFn
fn of
  BodyTransformFn
Remove ->
    Body -> m Body
forall a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 a. a -> Validation TransformErrorBundle a
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 =
  (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
. 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
          | ByteString
v ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"null"
        ]

-- | 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) -> String -> String
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent (String -> String) -> (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) -> String -> String
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent
    (String -> String)
-> (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