-- | Types and subroutines related to constructing transformations on
-- HTTP requests.
module Hasura.RQL.DDL.Webhook.Transform.Request
  ( -- ** Request Transformation Context
    RequestTransformCtx (..),
    mkReqTransformCtx,

    -- * Templating
    TemplatingEngine (..),
    Template (..),
    Version (..),
    runRequestTemplateTransform,
    validateRequestTemplateTransform,
    validateRequestTemplateTransform',

    -- * Unescaped
    runUnescapedRequestTemplateTransform,
    runUnescapedRequestTemplateTransform',
    validateRequestUnescapedTemplateTransform,
    validateRequestUnescapedTemplateTransform',
  )
where

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

import Control.Arrow (left)
import Control.Lens qualified as Lens
import Data.Aeson qualified as J
import Data.Aeson.Kriti.Functions qualified as KFunc
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Text.Encoding qualified as TE
import Data.Validation (Validation, fromEither)
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform.Class (Template (..), TemplatingEngine (..), TransformErrorBundle (..), UnescapedTemplate, encodeScalar, wrapUnescapedTemplate)
import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx (..), Version (..))
import Hasura.Session (SessionVariables)
import Kriti.Error qualified as Kriti
import Kriti.Parser qualified as Kriti
import Network.HTTP.Client.Transformable qualified as HTTP

-- | A smart constructor for constructing the 'RequestTransformCtx'
--
-- 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!
mkReqTransformCtx ::
  Text ->
  Maybe SessionVariables ->
  TemplatingEngine ->
  HTTP.Request ->
  RequestTransformCtx
mkReqTransformCtx :: Text
-> Maybe SessionVariables
-> TemplatingEngine
-> Request
-> RequestTransformCtx
mkReqTransformCtx Text
url Maybe SessionVariables
sessionVars TemplatingEngine
rtcEngine Request
reqData =
  let rtcBaseUrl :: Maybe Value
rtcBaseUrl = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON Text
url
      rtcBody :: Value
rtcBody =
        let mBody :: Maybe Value
mBody = Getting (First ByteString) Request ByteString
-> Request -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview ((RequestBody -> Const (First ByteString) RequestBody)
-> Request -> Const (First ByteString) Request
Lens' Request RequestBody
HTTP.body ((RequestBody -> Const (First ByteString) RequestBody)
 -> Request -> Const (First ByteString) Request)
-> ((ByteString -> Const (First ByteString) ByteString)
    -> RequestBody -> Const (First ByteString) RequestBody)
-> Getting (First ByteString) Request ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (First ByteString) ByteString)
-> RequestBody -> Const (First ByteString) RequestBody
Prism' RequestBody ByteString
HTTP._RequestBodyLBS) Request
reqData Maybe ByteString -> (ByteString -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FromJSON a => ByteString -> Maybe a
J.decode @J.Value
         in Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
J.Null Maybe Value
mBody
      rtcSessionVariables :: Maybe SessionVariables
rtcSessionVariables = Maybe SessionVariables
sessionVars
      rtcQueryParams :: Maybe Value
rtcQueryParams =
        let queryParams :: [(Text, Maybe Text)]
queryParams =
              Getting Query Request Query -> Request -> Query
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
Lens.view Getting Query Request Query
Lens' Request Query
HTTP.queryParams Request
reqData Query -> (Query -> [(Text, Maybe Text)]) -> [(Text, Maybe Text)]
forall a b. a -> (a -> b) -> b
& ((ByteString, Maybe ByteString) -> (Text, Maybe Text))
-> Query -> [(Text, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \(ByteString
key, Maybe ByteString
val) ->
                (ByteString -> Text
TE.decodeUtf8 ByteString
key, (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 Maybe ByteString
val)
         in Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [(Text, Maybe Text)] -> Value
forall a. ToJSON a => a -> Value
J.toJSON [(Text, Maybe Text)]
queryParams
   in RequestTransformCtx {Maybe Value
Maybe SessionVariables
Value
TemplatingEngine
rtcEngine :: TemplatingEngine
rtcBaseUrl :: Maybe Value
rtcBody :: Value
rtcSessionVariables :: Maybe SessionVariables
rtcQueryParams :: Maybe Value
rtcBaseUrl :: Maybe Value
rtcBody :: Value
rtcSessionVariables :: Maybe SessionVariables
rtcQueryParams :: Maybe Value
rtcEngine :: TemplatingEngine
..}

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

-- | A helper function for executing transformations from a 'Template'
-- and a 'RequestTransformCtx'.
--
-- NOTE: This and all related funtions are hard-coded to Kriti at the
-- moment. When we add additional template engines this function will
-- need to take a 'TemplatingEngine' parameter.
runRequestTemplateTransform ::
  Template ->
  RequestTransformCtx ->
  Either TransformErrorBundle J.Value
runRequestTemplateTransform :: Template
-> RequestTransformCtx -> Either TransformErrorBundle Value
runRequestTemplateTransform Template
template RequestTransformCtx {rtcEngine :: RequestTransformCtx -> TemplatingEngine
rtcEngine = TemplatingEngine
Kriti, Maybe Value
Maybe SessionVariables
Value
rtcBaseUrl :: RequestTransformCtx -> Maybe Value
rtcBody :: RequestTransformCtx -> Value
rtcSessionVariables :: RequestTransformCtx -> Maybe SessionVariables
rtcQueryParams :: RequestTransformCtx -> Maybe Value
rtcBaseUrl :: Maybe Value
rtcBody :: Value
rtcSessionVariables :: Maybe SessionVariables
rtcQueryParams :: Maybe Value
..} =
  let context :: [(Text, Value)]
context =
        [ (Text
"$body", Value
rtcBody),
          (Text
"$session_variables", Maybe SessionVariables -> Value
forall a. ToJSON a => a -> Value
J.toJSON Maybe SessionVariables
rtcSessionVariables)
        ]
          [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [Maybe (Text, Value)] -> [(Text, Value)]
forall a. [Maybe a] -> [a]
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes
            [ (Text
"$query_params",) (Value -> (Text, Value)) -> Maybe Value -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
rtcQueryParams,
              (Text
"$base_url",) (Value -> (Text, Value)) -> Maybe Value -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
rtcBaseUrl
            ]
      kritiFuncs :: HashMap Text KritiFunc
kritiFuncs = Maybe SessionVariables -> HashMap Text KritiFunc
KFunc.sessionFunctions Maybe SessionVariables
rtcSessionVariables
      eResult :: Either SerializedError Value
eResult = Text
-> [(Text, Value)]
-> HashMap Text KritiFunc
-> Either SerializedError Value
KFunc.runKritiWith (Template -> Text
unTemplate (Template -> Text) -> Template -> Text
forall a b. (a -> b) -> a -> b
$ Template
template) [(Text, Value)]
context HashMap Text KritiFunc
kritiFuncs
   in Either SerializedError Value
eResult Either SerializedError Value
-> (Either SerializedError Value
    -> Either TransformErrorBundle Value)
-> Either TransformErrorBundle Value
forall a b. a -> (a -> b) -> b
& (SerializedError -> TransformErrorBundle)
-> Either SerializedError Value
-> Either TransformErrorBundle Value
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left \SerializedError
kritiErr ->
        let renderedErr :: Value
renderedErr = SerializedError -> Value
forall a. ToJSON a => a -> Value
J.toJSON SerializedError
kritiErr
         in [Value] -> TransformErrorBundle
TransformErrorBundle [Value
renderedErr]

-- TODO: Should this live in 'Hasura.RQL.DDL.Webhook.Transform.Validation'?
validateRequestTemplateTransform ::
  TemplatingEngine ->
  Template ->
  Either TransformErrorBundle ()
validateRequestTemplateTransform :: TemplatingEngine -> Template -> Either TransformErrorBundle ()
validateRequestTemplateTransform TemplatingEngine
Kriti (Template Text
template) =
  (ParseError -> TransformErrorBundle)
-> (ValueExt -> ())
-> Either ParseError ValueExt
-> Either TransformErrorBundle ()
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseError -> TransformErrorBundle
packBundle (() -> ValueExt -> ()
forall a b. a -> b -> a
const ()) (Either ParseError ValueExt -> Either TransformErrorBundle ())
-> Either ParseError ValueExt -> Either TransformErrorBundle ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ParseError ValueExt
Kriti.parser (ByteString -> Either ParseError ValueExt)
-> ByteString -> Either ParseError ValueExt
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
template
  where
    packBundle :: ParseError -> TransformErrorBundle
packBundle = [Value] -> TransformErrorBundle
TransformErrorBundle ([Value] -> TransformErrorBundle)
-> (ParseError -> [Value]) -> ParseError -> TransformErrorBundle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Value]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> [Value])
-> (ParseError -> Value) -> ParseError -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerializedError -> Value
forall a. ToJSON a => a -> Value
J.toJSON (SerializedError -> Value)
-> (ParseError -> SerializedError) -> ParseError -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> SerializedError
forall e. SerializeError e => e -> SerializedError
Kriti.serialize

validateRequestTemplateTransform' ::
  TemplatingEngine ->
  Template ->
  Validation TransformErrorBundle ()
validateRequestTemplateTransform' :: TemplatingEngine -> Template -> Validation TransformErrorBundle ()
validateRequestTemplateTransform' TemplatingEngine
engine =
  Either TransformErrorBundle ()
-> Validation TransformErrorBundle ()
forall e a. Either e a -> Validation e a
fromEither (Either TransformErrorBundle ()
 -> Validation TransformErrorBundle ())
-> (Template -> Either TransformErrorBundle ())
-> Template
-> Validation TransformErrorBundle ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplatingEngine -> Template -> Either TransformErrorBundle ()
validateRequestTemplateTransform TemplatingEngine
engine

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

-- | A helper function for executing Kriti transformations from a
-- 'UnescapedTemplate' and a 'RequestTrasformCtx'.
--
-- The difference from 'runRequestTemplateTransform' is that this
-- function will wrap the template text in double quotes before
-- running Kriti.
runUnescapedRequestTemplateTransform ::
  RequestTransformCtx ->
  UnescapedTemplate ->
  Either TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform :: RequestTransformCtx
-> UnescapedTemplate -> Either TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform RequestTransformCtx
context UnescapedTemplate
unescapedTemplate = do
  Value
result <-
    Template
-> RequestTransformCtx -> Either TransformErrorBundle Value
runRequestTemplateTransform
      (UnescapedTemplate -> Template
wrapUnescapedTemplate UnescapedTemplate
unescapedTemplate)
      RequestTransformCtx
context
  Value -> Either TransformErrorBundle ByteString
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
Value -> m ByteString
encodeScalar Value
result

-- | Run a Kriti transformation with an unescaped template in
-- 'Validation' instead of 'Either'.
runUnescapedRequestTemplateTransform' ::
  RequestTransformCtx ->
  UnescapedTemplate ->
  Validation TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform' :: RequestTransformCtx
-> UnescapedTemplate -> Validation TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform' RequestTransformCtx
context UnescapedTemplate
unescapedTemplate =
  Either TransformErrorBundle ByteString
-> Validation TransformErrorBundle ByteString
forall e a. Either e a -> Validation e a
fromEither
    (Either TransformErrorBundle ByteString
 -> Validation TransformErrorBundle ByteString)
-> Either TransformErrorBundle ByteString
-> Validation TransformErrorBundle ByteString
forall a b. (a -> b) -> a -> b
$ RequestTransformCtx
-> UnescapedTemplate -> Either TransformErrorBundle ByteString
runUnescapedRequestTemplateTransform RequestTransformCtx
context UnescapedTemplate
unescapedTemplate

-- TODO: Should this live in 'Hasura.RQL.DDL.Webhook.Transform.Validation'?
validateRequestUnescapedTemplateTransform ::
  TemplatingEngine ->
  UnescapedTemplate ->
  Either TransformErrorBundle ()
validateRequestUnescapedTemplateTransform :: TemplatingEngine
-> UnescapedTemplate -> Either TransformErrorBundle ()
validateRequestUnescapedTemplateTransform TemplatingEngine
engine =
  TemplatingEngine -> Template -> Either TransformErrorBundle ()
validateRequestTemplateTransform TemplatingEngine
engine (Template -> Either TransformErrorBundle ())
-> (UnescapedTemplate -> Template)
-> UnescapedTemplate
-> Either TransformErrorBundle ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnescapedTemplate -> Template
wrapUnescapedTemplate

validateRequestUnescapedTemplateTransform' ::
  TemplatingEngine ->
  UnescapedTemplate ->
  Validation TransformErrorBundle ()
validateRequestUnescapedTemplateTransform' :: TemplatingEngine
-> UnescapedTemplate -> Validation TransformErrorBundle ()
validateRequestUnescapedTemplateTransform' TemplatingEngine
engine =
  Either TransformErrorBundle ()
-> Validation TransformErrorBundle ()
forall e a. Either e a -> Validation e a
fromEither (Either TransformErrorBundle ()
 -> Validation TransformErrorBundle ())
-> (UnescapedTemplate -> Either TransformErrorBundle ())
-> UnescapedTemplate
-> Validation TransformErrorBundle ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplatingEngine
-> UnescapedTemplate -> Either TransformErrorBundle ()
validateRequestUnescapedTemplateTransform TemplatingEngine
engine