From 4700ac44fb128b7f468102ed96b56a0b044eae9b Mon Sep 17 00:00:00 2001 From: Solomon Date: Sat, 15 Oct 2022 20:53:13 -0700 Subject: [PATCH] Webhook Transforms: Move RequestCtx into a type family PR-URL: https://github.com/hasura/graphql-engine-mono/pull/5975 GitOrigin-RevId: 08ad528b2600379deb4cef9d39968126c7c745d8 --- server/graphql-engine.cabal | 3 + server/src-lib/Hasura/Eventing/HTTP.hs | 26 +- .../src-lib/Hasura/GraphQL/Execute/Action.hs | 3 +- server/src-lib/Hasura/RQL/DDL/Metadata.hs | 3 +- .../Hasura/RQL/DDL/Webhook/Transform.hs | 225 ++++++++--------- .../Hasura/RQL/DDL/Webhook/Transform/Body.hs | 11 +- .../Hasura/RQL/DDL/Webhook/Transform/Class.hs | 234 +----------------- .../RQL/DDL/Webhook/Transform/Headers.hs | 11 +- .../RQL/DDL/Webhook/Transform/Method.hs | 9 +- .../RQL/DDL/Webhook/Transform/QueryParams.hs | 11 +- .../RQL/DDL/Webhook/Transform/Request.hs | 200 +++++++++++++++ .../RQL/DDL/Webhook/Transform/Response.hs | 79 ++++++ .../Hasura/RQL/DDL/Webhook/Transform/Url.hs | 15 +- .../RQL/DDL/Webhook/Transform/WithOptional.hs | 51 ++++ 14 files changed, 498 insertions(+), 383 deletions(-) create mode 100644 server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs create mode 100644 server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Response.hs create mode 100644 server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index f264cf005dd..0a5dbf1a680 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -784,8 +784,11 @@ library , Hasura.RQL.DDL.Webhook.Transform.Headers , Hasura.RQL.DDL.Webhook.Transform.Method , Hasura.RQL.DDL.Webhook.Transform.QueryParams + , Hasura.RQL.DDL.Webhook.Transform.Response + , Hasura.RQL.DDL.Webhook.Transform.Request , Hasura.RQL.DDL.Webhook.Transform.Validation , Hasura.RQL.DDL.Webhook.Transform.Url + , Hasura.RQL.DDL.Webhook.Transform.WithOptional , Hasura.RQL.DDL.SourceKinds , Hasura.RQL.DDL.Schema , Hasura.RQL.DDL.Schema.Cache diff --git a/server/src-lib/Hasura/Eventing/HTTP.hs b/server/src-lib/Hasura/Eventing/HTTP.hs index 28559de379a..837e27da40e 100644 --- a/server/src-lib/Hasura/Eventing/HTTP.hs +++ b/server/src-lib/Hasura/Eventing/HTTP.hs @@ -63,8 +63,7 @@ import Hasura.HTTP (HttpException (..), addDefaultHeaders) import Hasura.Logging import Hasura.Prelude import Hasura.RQL.DDL.Headers -import Hasura.RQL.DDL.Webhook.Transform -import Hasura.RQL.DDL.Webhook.Transform.Class (mkReqTransformCtx) +import Hasura.RQL.DDL.Webhook.Transform qualified as Transform import Hasura.RQL.Types.Common (ResolvedWebhook (..)) import Hasura.RQL.Types.EventTrigger import Hasura.RQL.Types.Eventing @@ -143,7 +142,7 @@ data RequestDetails = RequestDetails _rdOriginalSize :: Int64, _rdTransformedRequest :: Maybe HTTP.Request, _rdTransformedSize :: Maybe Int64, - _rdReqTransformCtx :: Maybe RequestTransformCtx, + _rdReqTransformCtx :: Maybe Transform.RequestContext, _rdSessionVars :: Maybe SessionVariables } @@ -276,7 +275,7 @@ runHTTP manager req = do data TransformableRequestError a = HTTPError J.Value (HTTPErr a) - | TransformationError J.Value TransformErrorBundle + | TransformationError J.Value Transform.TransformErrorBundle deriving (Show) mkRequest :: @@ -287,7 +286,7 @@ mkRequest :: -- log the request size. As the logging happens outside the function, we pass -- it the final request body, instead of 'Value' LBS.ByteString -> - Maybe RequestTransform -> + Maybe Transform.RequestTransform -> ResolvedWebhook -> m RequestDetails mkRequest headers timeout payload mRequestTransform (ResolvedWebhook webhook) = @@ -309,13 +308,14 @@ mkRequest headers timeout payload mRequestTransform (ResolvedWebhook webhook) = in case mRequestTransform of Nothing -> pure $ RequestDetails req (LBS.length payload) Nothing Nothing Nothing sessionVars - Just RequestTransform {..} -> - let reqTransformCtx = mkReqTransformCtx webhook sessionVars templateEngine - in case applyRequestTransform reqTransformCtx requestFields req of + Just Transform.RequestTransform {..} -> + let reqTransformCtx = Transform.mkReqTransformCtx webhook sessionVars templateEngine + requestContext = fmap Transform.mkRequestContext reqTransformCtx + in case Transform.applyRequestTransform requestContext requestFields req of Left err -> throwError $ TransformationError body err Right transformedReq -> let transformedReqSize = HTTP.getReqSize transformedReq - in pure $ RequestDetails req (LBS.length payload) (Just transformedReq) (Just transformedReqSize) (Just $ reqTransformCtx req) sessionVars + in pure $ RequestDetails req (LBS.length payload) (Just transformedReq) (Just transformedReqSize) (Just $ requestContext req) sessionVars invokeRequest :: ( MonadReader r m, @@ -326,7 +326,7 @@ invokeRequest :: MonadTrace m ) => RequestDetails -> - Maybe ResponseTransform -> + Maybe Transform.ResponseTransform -> Maybe SessionVariables -> ((Either (HTTPErr a) (HTTPResp a)) -> RequestDetails -> m ()) -> m (HTTPResp a) @@ -343,9 +343,9 @@ invokeRequest reqDetails@RequestDetails {..} respTransform' sessionVars logger = Nothing -> pure resp Just respTransform -> do let respBody = SB.toLBS $ hrsBody resp - engine = respTransformTemplateEngine respTransform - respTransformCtx = buildRespTransformCtx _rdReqTransformCtx sessionVars engine respBody - in case applyResponseTransform respTransform respTransformCtx of + engine = Transform.respTransformTemplateEngine respTransform + respTransformCtx = Transform.buildRespTransformCtx _rdReqTransformCtx sessionVars engine respBody + in case Transform.applyResponseTransform respTransform respTransformCtx of Left err -> do -- Log The Response Transformation Error logger' :: Logger Hasura <- asks getter diff --git a/server/src-lib/Hasura/GraphQL/Execute/Action.hs b/server/src-lib/Hasura/GraphQL/Execute/Action.hs index c3cee6fb552..f82a8fe9d38 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Action.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Action.hs @@ -60,7 +60,6 @@ import Hasura.Name qualified as Name import Hasura.Prelude import Hasura.RQL.DDL.Headers import Hasura.RQL.DDL.Webhook.Transform -import Hasura.RQL.DDL.Webhook.Transform.Class (mkReqTransformCtx) import Hasura.RQL.IR.Action qualified as IR import Hasura.RQL.IR.BoolExp import Hasura.RQL.IR.Select qualified as RS @@ -557,7 +556,7 @@ callWebhook (transformedReq, transformedReqSize, reqTransformCtx) <- case metadataRequestTransform of Nothing -> pure (Nothing, Nothing, Nothing) Just RequestTransform {..} -> - let reqTransformCtx = mkReqTransformCtx webhookUrl sessionVars templateEngine + let reqTransformCtx = fmap mkRequestContext $ mkReqTransformCtx webhookUrl sessionVars templateEngine in case applyRequestTransform reqTransformCtx requestFields req of Left err -> do -- Log The Transformation Error diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index abe6dc89024..0b092c2e37e 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -60,7 +60,6 @@ import Hasura.RQL.DDL.ScheduledTrigger import Hasura.RQL.DDL.Schema import Hasura.RQL.DDL.Schema.Source import Hasura.RQL.DDL.Webhook.Transform -import Hasura.RQL.DDL.Webhook.Transform.Class (mkReqTransformCtx) import Hasura.RQL.Types.Allowlist import Hasura.RQL.Types.ApiLimit import Hasura.RQL.Types.Backend @@ -682,7 +681,7 @@ runTestWebhookTransform (TestWebhookTransform env headers urlE payload rt _ sv) let req = initReq & HTTP.body .~ pure (J.encode payload) & HTTP.headers .~ headers' reqTransform = requestFields rt engine = templateEngine rt - reqTransformCtx = mkReqTransformCtx url sv engine + reqTransformCtx = fmap mkRequestContext $ mkReqTransformCtx url sv engine hoistEither $ first (RequestTransformationError req) $ applyRequestTransform reqTransformCtx reqTransform req case result of diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs index b076cc0a83a..27e769b4249 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs @@ -34,6 +34,9 @@ module Hasura.RQL.DDL.Webhook.Transform -- * Request Transformation Context RequestTransformCtx (..), + RequestContext, + mkRequestContext, + mkReqTransformCtx, TransformErrorBundle (..), -- * Optional Functor @@ -54,12 +57,10 @@ where import Control.Lens (Lens', lens, set, traverseOf, view) import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson.Extended qualified as J -import Data.Aeson.Kriti.Functions qualified as KFunc -import Data.Bifunctor (first) +import Data.Aeson.Extended ((.!=), (.:?), (.=), (.=?)) +import Data.Aeson.Extended qualified as Aeson import Data.ByteString.Lazy qualified as BL import Data.CaseInsensitive qualified as CI -import Data.Coerce (Coercible) import Data.Functor.Barbie (AllBF, ApplicativeB, ConstraintsB, FunctorB, TraversableB) import Data.Functor.Barbie qualified as B import Data.Text.Encoding qualified as TE @@ -69,10 +70,13 @@ import Hasura.Prelude hiding (first) import Hasura.RQL.DDL.Webhook.Transform.Body (Body (..), BodyTransformFn, TransformFn (BodyTransformFn_)) import Hasura.RQL.DDL.Webhook.Transform.Body qualified as Body import Hasura.RQL.DDL.Webhook.Transform.Class -import Hasura.RQL.DDL.Webhook.Transform.Headers (Headers (..), HeadersTransformFn (..), TransformFn (HeadersTransformFn_)) +import Hasura.RQL.DDL.Webhook.Transform.Headers import Hasura.RQL.DDL.Webhook.Transform.Method import Hasura.RQL.DDL.Webhook.Transform.QueryParams +import Hasura.RQL.DDL.Webhook.Transform.Request +import Hasura.RQL.DDL.Webhook.Transform.Response import Hasura.RQL.DDL.Webhook.Transform.Url +import Hasura.RQL.DDL.Webhook.Transform.WithOptional (WithOptional (..), withOptional) import Hasura.Session (SessionVariables) import Network.HTTP.Client.Transformable qualified as HTTP @@ -93,17 +97,17 @@ data RequestTransform = RequestTransform deriving anyclass (NFData, Cacheable) instance FromJSON RequestTransform where - parseJSON = J.withObject "RequestTransform" \o -> do - version <- o J..:? "version" J..!= V1 - method <- o J..:? "method" - url <- o J..:? "url" + parseJSON = Aeson.withObject "RequestTransform" \o -> do + version <- o .:? "version" .!= V1 + method <- o .:? "method" + url <- o .:? "url" body <- case version of V1 -> do - template :: Maybe Template <- o J..:? "body" + template :: Maybe Template <- o .:? "body" pure $ fmap Body.ModifyAsJSON template - V2 -> o J..:? "body" - queryParams <- o J..:? "query_params" - headers <- o J..:? "request_headers" + V2 -> o .:? "body" + queryParams <- o .:? "query_params" + headers <- o .:? "request_headers" let requestFields = RequestFields { method = withOptional @MethodTransformFn method, @@ -112,7 +116,7 @@ instance FromJSON RequestTransform where queryParams = withOptional @QueryParamsTransformFn queryParams, requestHeaders = withOptional @HeadersTransformFn headers } - templateEngine <- o J..:? "template_engine" J..!= Kriti + templateEngine <- o .:? "template_engine" .!= Kriti pure $ RequestTransform {..} instance ToJSON RequestTransform where @@ -121,24 +125,24 @@ instance ToJSON RequestTransform where body' = case version of V1 -> case (getOptional body) of Just (BodyTransformFn_ (Body.ModifyAsJSON template)) -> - Just ("body", J.toJSON template) + Just ("body", Aeson.toJSON template) _ -> Nothing - V2 -> "body" J..=? getOptional body - in J.object $ - [ "version" J..= version, - "template_engine" J..= templateEngine + V2 -> "body" .=? getOptional body + in Aeson.object $ + [ "version" .= version, + "template_engine" .= templateEngine ] <> catMaybes - [ "method" J..=? getOptional method, - "url" J..=? getOptional url, - "query_params" J..=? getOptional queryParams, - "request_headers" J..=? getOptional requestHeaders, + [ "method" .=? getOptional method, + "url" .=? getOptional url, + "query_params" .=? getOptional queryParams, + "request_headers" .=? getOptional requestHeaders, body' ] ------------------------------------------------------------------------------- --- | Defunctionalized Webhook Transformation +-- | Defunctionalized Webhook Request Transformation -- -- We represent a defunctionalized request transformation by parameterizing -- our HKD with 'WithOptional'@ @'TransformFn', which marks each of the fields @@ -184,12 +188,12 @@ deriving anyclass instance -- NOTE: It is likely that we can derive these instances. Possibly if -- we move the aeson instances onto the *Transform types. instance FromJSON RequestTransformFns where - parseJSON = J.withObject "RequestTransformFns" $ \o -> do - method <- o J..:? "method" - url <- o J..:? "url" - body <- o J..:? "body" - queryParams <- o J..:? "query_params" - headers <- o J..:? "request_headers" + parseJSON = Aeson.withObject "RequestTransformFns" $ \o -> do + method <- o .:? "method" + url <- o .:? "url" + body <- o .:? "body" + queryParams <- o .:? "query_params" + headers <- o .:? "request_headers" pure $ RequestFields { method = withOptional @MethodTransformFn method, @@ -201,14 +205,37 @@ instance FromJSON RequestTransformFns where instance ToJSON RequestTransformFns where toJSON RequestFields {..} = - J.object . catMaybes $ - [ "method" J..=? getOptional method, - "url" J..=? getOptional url, - "body" J..=? getOptional body, - "query_params" J..=? getOptional queryParams, - "request_headers" J..=? getOptional requestHeaders + Aeson.object . catMaybes $ + [ "method" .=? getOptional method, + "url" .=? getOptional url, + "body" .=? getOptional body, + "query_params" .=? getOptional queryParams, + "request_headers" .=? getOptional requestHeaders ] +type RequestContext = RequestFields TransformCtx + +instance ToJSON RequestContext where + toJSON RequestFields {..} = + Aeson.object + [ "method" .= coerce @_ @RequestTransformCtx method, + "url" .= coerce @_ @RequestTransformCtx url, + "body" .= coerce @_ @RequestTransformCtx body, + "query_params" .= coerce @_ @RequestTransformCtx queryParams, + "request_headers" .= coerce @_ @RequestTransformCtx requestHeaders + ] + +mkRequestContext :: RequestTransformCtx -> RequestContext +mkRequestContext ctx = + -- NOTE: Type Applications are here for documentation purposes. + RequestFields + { method = coerce @RequestTransformCtx @(TransformCtx Method) ctx, + url = coerce @RequestTransformCtx @(TransformCtx Url) ctx, + body = coerce @RequestTransformCtx @(TransformCtx Body) ctx, + queryParams = coerce @RequestTransformCtx @(TransformCtx QueryParams) ctx, + requestHeaders = coerce @RequestTransformCtx @(TransformCtx Headers) ctx + } + ------------------------------------------------------------------------------- -- TODO(SOLOMON): Add lens law unit tests @@ -228,14 +255,14 @@ requestL = lens getter setter RequestFields { method = coerce $ CI.mk $ TE.decodeUtf8 $ view HTTP.method req, url = coerce $ view HTTP.url req, - body = coerce $ JSONBody $ J.decode =<< view HTTP.body req, + body = coerce $ JSONBody $ Aeson.decode =<< view HTTP.body req, queryParams = coerce $ view HTTP.queryParams req, requestHeaders = coerce $ view HTTP.headers req } serializeBody :: Body -> Maybe BL.ByteString serializeBody = \case - JSONBody body -> fmap J.encode body + JSONBody body -> fmap Aeson.encode body RawBody "" -> Nothing RawBody bs -> Just bs @@ -260,7 +287,7 @@ requestL = lens getter setter applyRequestTransform :: forall m. MonadError TransformErrorBundle m => - (HTTP.Request -> RequestTransformCtx) -> + (HTTP.Request -> RequestContext) -> RequestTransformFns -> HTTP.Request -> m HTTP.Request @@ -272,10 +299,11 @@ applyRequestTransform mkCtx transformations request = where -- Apply all of the provided request transformation functions to the -- request data extracted from the given 'HTTP.Request'. - transformReqData ctx reqData = + transformReqData transformCtx reqData = B.bsequence' $ - B.bzipWithC @Transform - (transformField ctx) + B.bzipWith3C @Transform + transformField + transformCtx transformations reqData -- Apply a transformation to some request data, if it exists; otherwise @@ -285,44 +313,6 @@ applyRequestTransform mkCtx transformations request = Nothing -> pure a Just fn -> transform fn ctx a -------------------------------------------------------------------------------- - --- | Enrich a 'Functor' @f@ with optionality; this is primarily useful when --- one wants to annotate fields as optional when using the Higher-Kinded Data --- pattern. --- --- 'WithOptional'@ f@ is equivalent to @Compose Maybe f@. -newtype WithOptional f result = WithOptional - { getOptional :: Maybe (f result) - } - deriving stock (Eq, Functor, Foldable, Generic, Show) - deriving newtype (FromJSON, ToJSON) - -deriving newtype instance - (Cacheable (f result)) => - Cacheable (WithOptional f result) - -deriving newtype instance - (NFData (f result)) => - NFData (WithOptional f result) - --- | 'WithOptional' smart constructor for the special case of optional values --- that are representationally equivalent to some "wrapper" type. --- --- For example: --- @ --- withOptional \@HeaderTransformsAction headers == WithOptional $ fmap HeadersTransform headers --- @ --- --- In other words: this function observes the isomorphism between @'Maybe' a@ --- and @'WithOptional' f b@ if an isomorphism exists between @a@ and @f b@. -withOptional :: - forall a b f. - Coercible a (f b) => - Maybe a -> - WithOptional f b -withOptional = coerce - ------------------------------------------------------------------------------- -- TODO(SOLOMON): Rewrite with HKD @@ -330,7 +320,7 @@ withOptional = coerce -- 'MetadataResponseTransform'. 'Nothing' means use the original -- response value. data ResponseTransform = ResponseTransform - { respTransformBody :: Maybe (ResponseTransformCtx -> Either TransformErrorBundle J.Value), + { respTransformBody :: Maybe (ResponseTransformCtx -> Either TransformErrorBundle Aeson.Value), respTransformTemplateEngine :: TemplatingEngine } @@ -342,39 +332,39 @@ data MetadataResponseTransform = MetadataResponseTransform deriving stock (Show, Eq, Generic) deriving anyclass (NFData, Cacheable) -instance J.FromJSON MetadataResponseTransform where - parseJSON = J.withObject "MetadataResponseTransform" $ \o -> do - mrtVersion <- o J..:? "version" J..!= V1 +instance FromJSON MetadataResponseTransform where + parseJSON = Aeson.withObject "MetadataResponseTransform" $ \o -> do + mrtVersion <- o .:? "version" .!= V1 mrtBodyTransform <- case mrtVersion of V1 -> do - template :: (Maybe Template) <- o J..:? "body" + template :: (Maybe Template) <- o .:? "body" pure $ fmap Body.ModifyAsJSON template - V2 -> o J..:? "body" - templateEngine <- o J..:? "template_engine" + V2 -> o .:? "body" + templateEngine <- o .:? "template_engine" let mrtTemplatingEngine = fromMaybe Kriti templateEngine pure $ MetadataResponseTransform {..} -instance J.ToJSON MetadataResponseTransform where +instance ToJSON MetadataResponseTransform where toJSON MetadataResponseTransform {..} = let body = case mrtVersion of V1 -> case mrtBodyTransform of - Just (Body.ModifyAsJSON template) -> Just ("body", J.toJSON template) + Just (Body.ModifyAsJSON template) -> Just ("body", Aeson.toJSON template) _ -> Nothing - V2 -> "body" J..=? mrtBodyTransform - in J.object $ - [ "template_engine" J..= mrtTemplatingEngine, - "version" J..= mrtVersion + V2 -> "body" .=? mrtBodyTransform + in Aeson.object $ + [ "template_engine" .= mrtTemplatingEngine, + "version" .= mrtVersion ] - <> catMaybes [body] + <> maybeToList body --- | A helper function for constructing the 'RespTransformCtx' -buildRespTransformCtx :: Maybe RequestTransformCtx -> Maybe SessionVariables -> TemplatingEngine -> BL.ByteString -> ResponseTransformCtx -buildRespTransformCtx reqCtx sessionVars engine respBody = +-- | A helper function for constructing the 'ResponseTransformCtx' +buildRespTransformCtx :: Maybe RequestContext -> Maybe SessionVariables -> TemplatingEngine -> BL.ByteString -> ResponseTransformCtx +buildRespTransformCtx requestContext sessionVars engine respBody = ResponseTransformCtx - { responseTransformBody = fromMaybe J.Null $ J.decode @J.Value respBody, - responseTransformReqCtx = J.toJSON reqCtx, - responseTransformEngine = engine, - responseTransformFunctions = KFunc.sessionFunctions sessionVars + { responseTransformBody = fromMaybe Aeson.Null $ Aeson.decode @Aeson.Value respBody, + responseTransformReqCtx = Aeson.toJSON requestContext, + responseSessionVariables = sessionVars, + responseTransformEngine = engine } -- | Construct a Template Transformation function for Responses @@ -383,32 +373,27 @@ buildRespTransformCtx reqCtx sessionVars engine respBody = -- impure exception when the supplied 'ByteString' cannot be decoded into valid -- UTF8 text! mkRespTemplateTransform :: - TemplatingEngine -> BodyTransformFn -> ResponseTransformCtx -> - Either TransformErrorBundle J.Value -mkRespTemplateTransform _ Body.Remove _ = pure J.Null -mkRespTemplateTransform engine (Body.ModifyAsJSON (Template template)) ResponseTransformCtx {..} = - let context = [("$body", responseTransformBody), ("$request", responseTransformReqCtx)] - in case engine of - Kriti -> first (TransformErrorBundle . pure . J.toJSON) $ KFunc.runKriti template context -mkRespTemplateTransform engine (Body.ModifyAsFormURLEncoded formTemplates) context = - case engine of - Kriti -> do - result <- - liftEither . V.toEither . for formTemplates $ - runUnescapedResponseTemplateTransform' context - pure . J.String . TE.decodeUtf8 . BL.toStrict $ Body.foldFormEncoded result + Either TransformErrorBundle Aeson.Value +mkRespTemplateTransform Body.Remove _ = pure Aeson.Null +mkRespTemplateTransform (Body.ModifyAsJSON template) context = + runResponseTemplateTransform template context +mkRespTemplateTransform (Body.ModifyAsFormURLEncoded formTemplates) context = do + result <- + liftEither . V.toEither . for formTemplates $ + runUnescapedResponseTemplateTransform' context + pure . Aeson.String . TE.decodeUtf8 . BL.toStrict $ Body.foldFormEncoded result mkResponseTransform :: MetadataResponseTransform -> ResponseTransform mkResponseTransform MetadataResponseTransform {..} = - let bodyTransform = mkRespTemplateTransform mrtTemplatingEngine <$> mrtBodyTransform + let bodyTransform = mkRespTemplateTransform <$> mrtBodyTransform in ResponseTransform bodyTransform mrtTemplatingEngine -- | At the moment we only transform the body of -- Responses. 'http-client' does not export the constructors for --- 'Response'. If we want to transform then we will need additional --- 'apply' functions. +-- 'Response'. If we want to transform other fields then we will need +-- additional 'apply' functions. applyResponseTransform :: ResponseTransform -> ResponseTransformCtx -> @@ -418,5 +403,5 @@ applyResponseTransform ResponseTransform {..} ctx@ResponseTransformCtx {..} = bodyFunc body = case respTransformBody of Nothing -> pure body - Just f -> J.encode <$> f ctx - in bodyFunc (J.encode responseTransformBody) + Just f -> Aeson.encode <$> f ctx + in bodyFunc (Aeson.encode responseTransformBody) diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs index 6413f410664..42d79a1da89 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs @@ -5,6 +5,7 @@ module Hasura.RQL.DDL.Webhook.Transform.Body ( -- * Body Transformations Body (..), TransformFn (..), + TransformCtx (..), BodyTransformFn (..), foldFormEncoded, ) @@ -25,12 +26,14 @@ import Data.Validation qualified as V import Hasura.Incremental (Cacheable) import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class - ( RequestTransformCtx (..), - Template (..), + ( Template (..), TemplatingEngine, Transform (..), TransformErrorBundle (..), UnescapedTemplate, + ) +import Hasura.RQL.DDL.Webhook.Transform.Request + ( RequestTransformCtx, runRequestTemplateTransform, runUnescapedRequestTemplateTransform', validateRequestTemplateTransform', @@ -53,9 +56,11 @@ instance Transform Body where deriving stock (Eq, Generic, Show) deriving newtype (Cacheable, NFData, FromJSON, ToJSON) + newtype TransformCtx Body = TransformCtx RequestTransformCtx + -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'applyBodyTransformFn' is defined separately. - transform (BodyTransformFn_ fn) = applyBodyTransformFn fn + transform (BodyTransformFn_ fn) (TransformCtx reqCtx) = applyBodyTransformFn fn reqCtx -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'validateBodyTransformFn' is defined diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs index 44fa3d6c02d..729e1cbad1b 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs @@ -12,53 +12,30 @@ module Hasura.RQL.DDL.Webhook.Transform.Class TransformErrorBundle (..), throwErrorBundle, - -- ** Request Transformation Context - RequestTransformCtx (..), - ResponseTransformCtx (..), - mkReqTransformCtx, - -- * Templating TemplatingEngine (..), Template (..), - Version (..), - runRequestTemplateTransform, - validateRequestTemplateTransform, - validateRequestTemplateTransform', -- * Unescaped UnescapedTemplate (..), wrapUnescapedTemplate, - runUnescapedRequestTemplateTransform, - runUnescapedRequestTemplateTransform', - runUnescapedResponseTemplateTransform, - runUnescapedResponseTemplateTransform', - validateRequestUnescapedTemplateTransform, - validateRequestUnescapedTemplateTransform', + encodeScalar, ) where ------------------------------------------------------------------------------- -import Control.Arrow (left) -import Control.Lens (bimap, view) import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) import Data.Aeson qualified as J -import Data.Aeson.Kriti.Functions as KFunc import Data.ByteString (ByteString) import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Builder.Scientific (scientificBuilder) import Data.ByteString.Lazy qualified as LBS -import Data.HashMap.Strict qualified as M import Data.Kind (Constraint, Type) import Data.Text.Encoding (encodeUtf8) -import Data.Text.Encoding qualified as TE -import Data.Validation (Validation, fromEither) +import Data.Validation (Validation) import Hasura.Incremental (Cacheable) import Hasura.Prelude -import Hasura.Session (SessionVariables) -import Kriti.Error qualified as Kriti (CustomFunctionError (..), serialize) -import Kriti.Parser qualified as Kriti (parser) -import Network.HTTP.Client.Transformable qualified as HTTP ------------------------------------------------------------------------------- @@ -73,6 +50,8 @@ class Transform a where -- the transformation. data TransformFn a :: Type + data TransformCtx a :: Type + -- | 'transform' is a function which takes 'TransformFn' of @a@ and reifies -- it into a function of the form: -- @@ -82,7 +61,7 @@ class Transform a where transform :: MonadError TransformErrorBundle m => TransformFn a -> - RequestTransformCtx -> + TransformCtx a -> a -> m a @@ -121,69 +100,6 @@ throwErrorBundle msg val = do ------------------------------------------------------------------------------- --- | Common context that is made available to all request transformations. -data RequestTransformCtx = RequestTransformCtx - { rtcBaseUrl :: Maybe J.Value, - rtcBody :: J.Value, - rtcSessionVariables :: J.Value, - rtcQueryParams :: Maybe J.Value, - rtcEngine :: TemplatingEngine, - rtcFunctions :: M.HashMap Text (J.Value -> Either Kriti.CustomFunctionError J.Value) - } - -instance ToJSON RequestTransformCtx where - toJSON RequestTransformCtx {..} = - let required = - [ "body" J..= rtcBody, - "session_variables" J..= rtcSessionVariables - ] - optional = - [ ("base_url" J..=) <$> rtcBaseUrl, - ("query_params" J..=) <$> rtcQueryParams - ] - in J.object (required <> catMaybes optional) - --- | 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 url sessionVars rtcEngine reqData = - let rtcBaseUrl = Just $ J.toJSON url - rtcBody = - let mBody = view HTTP.body reqData >>= J.decode @J.Value - in fromMaybe J.Null mBody - rtcSessionVariables = J.toJSON sessionVars - rtcQueryParams = - let queryParams = - view HTTP.queryParams reqData & fmap \(key, val) -> - (TE.decodeUtf8 key, fmap TE.decodeUtf8 val) - in Just $ J.toJSON queryParams - in RequestTransformCtx - { rtcBaseUrl, - rtcBody, - rtcSessionVariables, - rtcQueryParams, - rtcEngine, - rtcFunctions = KFunc.sessionFunctions sessionVars - } - --- | Common context that is made available to all response transformations. -data ResponseTransformCtx = ResponseTransformCtx - { responseTransformBody :: J.Value, - responseTransformReqCtx :: J.Value, - responseTransformFunctions :: M.HashMap Text (J.Value -> Either Kriti.CustomFunctionError J.Value), - responseTransformEngine :: TemplatingEngine - } - -------------------------------------------------------------------------------- - -- | Available templating engines. data TemplatingEngine = Kriti @@ -226,86 +142,6 @@ instance J.FromJSON Template where instance J.ToJSON Template where toJSON = J.String . coerce --- | 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 {rtcEngine = Kriti, ..} = - let context = - [ ("$body", rtcBody), - ("$session_variables", rtcSessionVariables) - ] - <> catMaybes - [ ("$query_params",) <$> rtcQueryParams, - ("$base_url",) <$> rtcBaseUrl - ] - eResult = KFunc.runKritiWith (unTemplate $ template) context rtcFunctions - in eResult & left \kritiErr -> - let renderedErr = J.toJSON kritiErr - in TransformErrorBundle [renderedErr] - --- TODO: Should this live in 'Hasura.RQL.DDL.Webhook.Transform.Validation'? -validateRequestTemplateTransform :: - TemplatingEngine -> - Template -> - Either TransformErrorBundle () -validateRequestTemplateTransform Kriti (Template template) = - bimap packBundle (const ()) $ Kriti.parser $ TE.encodeUtf8 template - where - packBundle = TransformErrorBundle . pure . J.toJSON . Kriti.serialize - -validateRequestTemplateTransform' :: - TemplatingEngine -> - Template -> - Validation TransformErrorBundle () -validateRequestTemplateTransform' engine = - fromEither . validateRequestTemplateTransform engine - --- | A helper function for executing transformations from a 'Template' --- and a 'ResponseTransformCtx'. --- --- 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. -runResponseTemplateTransform :: - Template -> - ResponseTransformCtx -> - Either TransformErrorBundle J.Value -runResponseTemplateTransform template ResponseTransformCtx {responseTransformEngine = Kriti, ..} = - let context = [("$body", responseTransformBody), ("$request", responseTransformReqCtx)] - eResult = KFunc.runKritiWith (unTemplate $ template) context responseTransformFunctions - in eResult & left \kritiErr -> - let renderedErr = J.toJSON kritiErr - in TransformErrorBundle [renderedErr] - -------------------------------------------------------------------------------- - --- | 'RequestTransform' Versioning -data Version - = V1 - | V2 - deriving stock (Eq, Generic, Show) - deriving anyclass (Cacheable, Hashable, NFData) - -instance J.FromJSON Version where - parseJSON v = do - version :: Int <- J.parseJSON v - case version of - 1 -> pure V1 - 2 -> pure V2 - i -> fail $ "expected 1 or 2, encountered " ++ show i - -instance J.ToJSON Version where - toJSON = \case - V1 -> J.toJSON @Int 1 - V2 -> J.toJSON @Int 2 - ------------------------------------------------------------------------------- -- | Validated textual transformation template /for string @@ -330,66 +166,6 @@ instance J.ToJSON UnescapedTemplate where wrapUnescapedTemplate :: UnescapedTemplate -> Template wrapUnescapedTemplate (UnescapedTemplate txt) = Template $ "\"" <> txt <> "\"" --- | 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 context unescapedTemplate = do - result <- - runRequestTemplateTransform - (wrapUnescapedTemplate unescapedTemplate) - context - encodeScalar result - --- | Run a Kriti transformation with an unescaped template in --- 'Validation' instead of 'Either'. -runUnescapedRequestTemplateTransform' :: - RequestTransformCtx -> - UnescapedTemplate -> - Validation TransformErrorBundle ByteString -runUnescapedRequestTemplateTransform' context unescapedTemplate = - fromEither $ - runUnescapedRequestTemplateTransform context unescapedTemplate - --- TODO: Should this live in 'Hasura.RQL.DDL.Webhook.Transform.Validation'? -validateRequestUnescapedTemplateTransform :: - TemplatingEngine -> - UnescapedTemplate -> - Either TransformErrorBundle () -validateRequestUnescapedTemplateTransform engine = - validateRequestTemplateTransform engine . wrapUnescapedTemplate - -validateRequestUnescapedTemplateTransform' :: - TemplatingEngine -> - UnescapedTemplate -> - Validation TransformErrorBundle () -validateRequestUnescapedTemplateTransform' engine = - fromEither . validateRequestUnescapedTemplateTransform engine - --- | Run an 'UnescapedTemplate' with a 'ResponseTransformCtx'. -runUnescapedResponseTemplateTransform :: - ResponseTransformCtx -> - UnescapedTemplate -> - Either TransformErrorBundle ByteString -runUnescapedResponseTemplateTransform context unescapedTemplate = do - result <- runResponseTemplateTransform (wrapUnescapedTemplate unescapedTemplate) context - encodeScalar result - --- | Run an 'UnescapedTemplate' with a 'ResponseTransformCtx' in 'Validation'. -runUnescapedResponseTemplateTransform' :: - ResponseTransformCtx -> - UnescapedTemplate -> - Validation TransformErrorBundle ByteString -runUnescapedResponseTemplateTransform' context unescapedTemplate = - fromEither $ - runUnescapedResponseTemplateTransform context unescapedTemplate - ------------------------------------------------------------------------------- -- Utility functions. diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs index 02d146796fd..a9913fac7f2 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs @@ -6,6 +6,7 @@ module Hasura.RQL.DDL.Webhook.Transform.Headers ( -- * Header Transformations Headers (..), TransformFn (..), + TransformCtx (..), HeadersTransformFn (..), AddReplaceOrRemoveFields (..), ) @@ -23,11 +24,13 @@ import Data.Validation qualified as V import Hasura.Incremental (Cacheable) import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class - ( RequestTransformCtx (..), - TemplatingEngine, + ( TemplatingEngine, Transform (..), TransformErrorBundle (..), UnescapedTemplate (..), + ) +import Hasura.RQL.DDL.Webhook.Transform.Request + ( RequestTransformCtx, runUnescapedRequestTemplateTransform', validateRequestUnescapedTemplateTransform', ) @@ -49,10 +52,12 @@ instance Transform Headers where deriving stock (Eq, Generic, Show) deriving newtype (Cacheable, NFData, FromJSON, ToJSON) + newtype TransformCtx Headers = TransformCtx RequestTransformCtx + -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'applyHeadersTransformFn' is defined -- separately. - transform (HeadersTransformFn_ fn) = applyHeadersTransformFn fn + transform (HeadersTransformFn_ fn) (TransformCtx reqCtx) = applyHeadersTransformFn fn reqCtx -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'validateHeadersTransformFn' is defined diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs index f980bb72999..23070a693f9 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs @@ -4,6 +4,7 @@ module Hasura.RQL.DDL.Webhook.Transform.Method ( -- * Method transformations Method (..), TransformFn (..), + TransformCtx (..), MethodTransformFn (..), ) where @@ -18,11 +19,11 @@ import Data.Validation import Hasura.Incremental (Cacheable) import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class - ( RequestTransformCtx (..), - TemplatingEngine, + ( TemplatingEngine, Transform (..), TransformErrorBundle (..), ) +import Hasura.RQL.DDL.Webhook.Transform.Request (RequestTransformCtx) ------------------------------------------------------------------------------- @@ -49,10 +50,12 @@ instance Transform Method where deriving stock (Eq, Generic, Show) deriving newtype (Cacheable, NFData, FromJSON, ToJSON) + newtype TransformCtx Method = TransformCtx RequestTransformCtx + -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'applyMethodTransformFn' is defined -- separately. - transform (MethodTransformFn_ fn) = applyMethodTransformFn fn + transform (MethodTransformFn_ fn) (TransformCtx reqCtx) = applyMethodTransformFn fn reqCtx -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'validateMethodTransformFn' is defined diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs index 8f8d5602b37..364c3e88d7f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs @@ -4,6 +4,7 @@ module Hasura.RQL.DDL.Webhook.Transform.QueryParams ( -- * Query transformations QueryParams (..), TransformFn (..), + TransformCtx (..), QueryParamsTransformFn (..), ) where @@ -18,11 +19,13 @@ import Data.Validation qualified as V import Hasura.Incremental (Cacheable) import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class - ( RequestTransformCtx (..), - TemplatingEngine, + ( TemplatingEngine, Transform (..), TransformErrorBundle (..), UnescapedTemplate (..), + ) +import Hasura.RQL.DDL.Webhook.Transform.Request + ( RequestTransformCtx, runUnescapedRequestTemplateTransform', validateRequestUnescapedTemplateTransform', ) @@ -45,10 +48,12 @@ instance Transform QueryParams where deriving stock (Show, Eq, Generic) deriving newtype (NFData, Cacheable, FromJSON, ToJSON) + newtype TransformCtx QueryParams = TransformCtx RequestTransformCtx + -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'applyQueryParamsTransformFn' is defined -- separately. - transform (QueryParamsTransformFn_ fn) = applyQueryParamsTransformFn fn + transform (QueryParamsTransformFn_ fn) (TransformCtx reqCtx) = applyQueryParamsTransformFn fn reqCtx -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'validateQueryParamsTransformFn' is defined diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs new file mode 100644 index 00000000000..04958119097 --- /dev/null +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- | 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 (FromJSON, ToJSON, (.=)) +import Data.Aeson qualified as Aeson +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.Incremental (Cacheable) +import Hasura.Prelude +import Hasura.RQL.DDL.Webhook.Transform.Class (Template (..), TemplatingEngine (..), TransformErrorBundle (..), UnescapedTemplate, encodeScalar, wrapUnescapedTemplate) +import Hasura.Session (SessionVariables) +import Kriti.Error qualified as Kriti +import Kriti.Parser qualified as Kriti +import Network.HTTP.Client.Transformable qualified as HTTP + +------------------------------------------------------------------------------- + +-- | Common context that is made available to all request transformations. +data RequestTransformCtx = RequestTransformCtx + { rtcBaseUrl :: Maybe Aeson.Value, + rtcBody :: Aeson.Value, + rtcSessionVariables :: Maybe SessionVariables, + rtcQueryParams :: Maybe Aeson.Value, + rtcEngine :: TemplatingEngine + } + +instance ToJSON RequestTransformCtx where + toJSON RequestTransformCtx {..} = + let required = + [ "body" .= rtcBody, + "session_variables" .= rtcSessionVariables + ] + optional = + [ ("base_url" .=) <$> rtcBaseUrl, + ("query_params" .=) <$> rtcQueryParams + ] + in Aeson.object (required <> catMaybes optional) + +-- | 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 url sessionVars rtcEngine reqData = + let rtcBaseUrl = Just $ Aeson.toJSON url + rtcBody = + let mBody = Lens.view HTTP.body reqData >>= Aeson.decode @Aeson.Value + in fromMaybe Aeson.Null mBody + rtcSessionVariables = sessionVars + rtcQueryParams = + let queryParams = + Lens.view HTTP.queryParams reqData & fmap \(key, val) -> + (TE.decodeUtf8 key, fmap TE.decodeUtf8 val) + in Just $ Aeson.toJSON queryParams + in RequestTransformCtx {..} + +------------------------------------------------------------------------------- + +-- | 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 Aeson.Value +runRequestTemplateTransform template RequestTransformCtx {rtcEngine = Kriti, ..} = + let context = + [ ("$body", rtcBody), + ("$session_variables", Aeson.toJSON rtcSessionVariables) + ] + <> catMaybes + [ ("$query_params",) <$> rtcQueryParams, + ("$base_url",) <$> rtcBaseUrl + ] + kritiFuncs = KFunc.sessionFunctions rtcSessionVariables + eResult = KFunc.runKritiWith (unTemplate $ template) context kritiFuncs + in eResult & left \kritiErr -> + let renderedErr = Aeson.toJSON kritiErr + in TransformErrorBundle [renderedErr] + +-- TODO: Should this live in 'Hasura.RQL.DDL.Webhook.Transform.Validation'? +validateRequestTemplateTransform :: + TemplatingEngine -> + Template -> + Either TransformErrorBundle () +validateRequestTemplateTransform Kriti (Template template) = + bimap packBundle (const ()) $ Kriti.parser $ TE.encodeUtf8 template + where + packBundle = TransformErrorBundle . pure . Aeson.toJSON . Kriti.serialize + +validateRequestTemplateTransform' :: + TemplatingEngine -> + Template -> + Validation TransformErrorBundle () +validateRequestTemplateTransform' engine = + fromEither . validateRequestTemplateTransform engine + +------------------------------------------------------------------------------- + +-- | 'RequestTransform' Versioning +data Version + = V1 + | V2 + deriving stock (Eq, Generic, Show) + deriving anyclass (Cacheable, Hashable, NFData) + +instance FromJSON Version where + parseJSON v = do + version :: Int <- Aeson.parseJSON v + case version of + 1 -> pure V1 + 2 -> pure V2 + i -> fail $ "expected 1 or 2, encountered " ++ show i + +instance ToJSON Version where + toJSON = \case + V1 -> Aeson.toJSON @Int 1 + V2 -> Aeson.toJSON @Int 2 + +------------------------------------------------------------------------------- + +-- | 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 context unescapedTemplate = do + result <- + runRequestTemplateTransform + (wrapUnescapedTemplate unescapedTemplate) + context + encodeScalar result + +-- | Run a Kriti transformation with an unescaped template in +-- 'Validation' instead of 'Either'. +runUnescapedRequestTemplateTransform' :: + RequestTransformCtx -> + UnescapedTemplate -> + Validation TransformErrorBundle ByteString +runUnescapedRequestTemplateTransform' context unescapedTemplate = + fromEither $ + runUnescapedRequestTemplateTransform context unescapedTemplate + +-- TODO: Should this live in 'Hasura.RQL.DDL.Webhook.Transform.Validation'? +validateRequestUnescapedTemplateTransform :: + TemplatingEngine -> + UnescapedTemplate -> + Either TransformErrorBundle () +validateRequestUnescapedTemplateTransform engine = + validateRequestTemplateTransform engine . wrapUnescapedTemplate + +validateRequestUnescapedTemplateTransform' :: + TemplatingEngine -> + UnescapedTemplate -> + Validation TransformErrorBundle () +validateRequestUnescapedTemplateTransform' engine = + fromEither . validateRequestUnescapedTemplateTransform engine diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Response.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Response.hs new file mode 100644 index 00000000000..0864cfa2781 --- /dev/null +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Response.hs @@ -0,0 +1,79 @@ +-- | Types and subroutines related to constructing transformations on +-- HTTP responses. +module Hasura.RQL.DDL.Webhook.Transform.Response + ( -- ** Request Transformation Context + ResponseTransformCtx (..), + runResponseTemplateTransform, + + -- * Unescaped + runUnescapedResponseTemplateTransform, + runUnescapedResponseTemplateTransform', + ) +where + +------------------------------------------------------------------------------- + +import Control.Arrow (left) +import Data.Aeson qualified as Aeson +import Data.Aeson.Kriti.Functions as KFunc +import Data.ByteString (ByteString) +import Data.Validation (Validation, fromEither) +import Hasura.Prelude +import Hasura.RQL.DDL.Webhook.Transform.Class + ( Template (..), + TemplatingEngine (Kriti), + TransformErrorBundle (..), + UnescapedTemplate, + encodeScalar, + wrapUnescapedTemplate, + ) +import Hasura.Session (SessionVariables) + +------------------------------------------------------------------------------- + +-- | Common context that is made available to all response transformations. +data ResponseTransformCtx = ResponseTransformCtx + { responseTransformBody :: Aeson.Value, + -- NOTE: This is a @Nothing@ if you have a Response Transform but no Request Transform: + responseTransformReqCtx :: Aeson.Value, + responseSessionVariables :: Maybe SessionVariables, + responseTransformEngine :: TemplatingEngine + } + +------------------------------------------------------------------------------- + +-- | A helper function for executing transformations from a 'Template' +-- and a 'ResponseTransformCtx'. +-- +-- 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. +runResponseTemplateTransform :: + Template -> + ResponseTransformCtx -> + Either TransformErrorBundle Aeson.Value +runResponseTemplateTransform template ResponseTransformCtx {responseTransformEngine = Kriti, ..} = + let context = [("$body", responseTransformBody), ("$request", Aeson.toJSON responseTransformReqCtx)] + customFunctions = KFunc.sessionFunctions responseSessionVariables + eResult = KFunc.runKritiWith (unTemplate $ template) context customFunctions + in eResult & left \kritiErr -> + let renderedErr = Aeson.toJSON kritiErr + in TransformErrorBundle [renderedErr] + +-- | Run an 'UnescapedTemplate' with a 'ResponseTransformCtx'. +runUnescapedResponseTemplateTransform :: + ResponseTransformCtx -> + UnescapedTemplate -> + Either TransformErrorBundle ByteString +runUnescapedResponseTemplateTransform context unescapedTemplate = do + result <- runResponseTemplateTransform (wrapUnescapedTemplate unescapedTemplate) context + encodeScalar result + +-- | Run an 'UnescapedTemplate' with a 'ResponseTransformCtx' in 'Validation'. +runUnescapedResponseTemplateTransform' :: + ResponseTransformCtx -> + UnescapedTemplate -> + Validation TransformErrorBundle ByteString +runUnescapedResponseTemplateTransform' context unescapedTemplate = + fromEither $ + runUnescapedResponseTemplateTransform context unescapedTemplate diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs index 8fad23ff7e0..0e78a5e6360 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs @@ -2,6 +2,7 @@ module Hasura.RQL.DDL.Webhook.Transform.Url ( -- * Url Transformations Url (..), TransformFn (..), + TransformCtx (..), UrlTransformFn (..), ) where @@ -15,16 +16,18 @@ import Data.Validation import Hasura.Incremental (Cacheable) import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class - ( RequestTransformCtx (..), - TemplatingEngine, + ( TemplatingEngine, Transform (..), TransformErrorBundle (..), UnescapedTemplate (..), - runRequestTemplateTransform, throwErrorBundle, - validateRequestUnescapedTemplateTransform', wrapUnescapedTemplate, ) +import Hasura.RQL.DDL.Webhook.Transform.Request + ( RequestTransformCtx, + runRequestTemplateTransform, + validateRequestUnescapedTemplateTransform', + ) import Network.URI (parseURI) ------------------------------------------------------------------------------- @@ -44,9 +47,11 @@ instance Transform Url where deriving stock (Eq, Generic, Show) deriving newtype (Cacheable, NFData, FromJSON, ToJSON) + newtype TransformCtx Url = TransformCtx RequestTransformCtx + -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'applyUrlTransformFn' is defined separately. - transform (UrlTransformFn_ fn) = applyUrlTransformFn fn + transform (UrlTransformFn_ fn) (TransformCtx reqCtx) = applyUrlTransformFn fn reqCtx -- NOTE: GHC does not let us attach Haddock documentation to typeclass -- method implementations, so 'validateUrlTransformFn' is defined separately. diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs new file mode 100644 index 00000000000..aeb810f3774 --- /dev/null +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs @@ -0,0 +1,51 @@ +-- | The 'WithOptional' Functor and associated operations. +module Hasura.RQL.DDL.Webhook.Transform.WithOptional + ( WithOptional (..), + withOptional, + ) +where + +------------------------------------------------------------------------------- + +import Data.Aeson (FromJSON, ToJSON) +import Data.Coerce (Coercible) +import Hasura.Incremental (Cacheable) +import Hasura.Prelude + +------------------------------------------------------------------------------- + +-- | Enrich a 'Functor' @f@ with optionality; this is primarily useful when +-- one wants to annotate fields as optional when using the Higher-Kinded Data +-- pattern. +-- +-- 'WithOptional'@ f@ is equivalent to @Compose Maybe f@. +newtype WithOptional f result = WithOptional + { getOptional :: Maybe (f result) + } + deriving stock (Eq, Functor, Foldable, Generic, Show) + deriving newtype (FromJSON, ToJSON) + +deriving newtype instance + (Cacheable (f result)) => + Cacheable (WithOptional f result) + +deriving newtype instance + (NFData (f result)) => + NFData (WithOptional f result) + +-- | 'WithOptional' smart constructor for the special case of optional values +-- that are representationally equivalent to some "wrapper" type. +-- +-- For example: +-- @ +-- withOptional \@HeaderTransformsAction headers == WithOptional $ fmap HeadersTransform headers +-- @ +-- +-- In other words: this function observes the isomorphism between @'Maybe' a@ +-- and @'WithOptional' f b@ if an isomorphism exists between @a@ and @f b@. +withOptional :: + forall a b f. + Coercible a (f b) => + Maybe a -> + WithOptional f b +withOptional = coerce