diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 5033fdebc93..c2eaca1ae0f 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -842,6 +842,17 @@ library , Hasura.RQL.Types.SourceCustomization , Hasura.RQL.Types.Subscription , Hasura.RQL.Types.Table + + , Hasura.RQL.Types.Webhook.Transform + , Hasura.RQL.Types.Webhook.Transform.Body + , Hasura.RQL.Types.Webhook.Transform.Class + , Hasura.RQL.Types.Webhook.Transform.Headers + , Hasura.RQL.Types.Webhook.Transform.Method + , Hasura.RQL.Types.Webhook.Transform.QueryParams + , Hasura.RQL.Types.Webhook.Transform.Request + , Hasura.RQL.Types.Webhook.Transform.Url + , Hasura.RQL.Types.Webhook.Transform.WithOptional + , Hasura.RQL.DDL.Action , Hasura.RQL.DDL.ApiLimit , Hasura.RQL.DDL.ComputedField @@ -875,7 +886,6 @@ library , 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/RQL/DDL/Webhook/Transform.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs index 31c13cecb9b..fc9af203a5d 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -58,21 +57,15 @@ where ------------------------------------------------------------------------------- -import Autodocodec (HasCodec, dimapCodec, disjointEitherCodec, optionalField', optionalFieldWithDefault') -import Autodocodec qualified as AC -import Autodocodec.Extended (optionalVersionField, versionField) import Control.Lens (Lens', lens, preview, set, traverseOf, view) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson.Extended ((.!=), (.:?), (.=), (.=?)) import Data.Aeson.Extended qualified as J import Data.ByteString.Lazy qualified as BL import Data.CaseInsensitive qualified as CI -import Data.Functor.Barbie (AllBF, ApplicativeB, ConstraintsB, FunctorB, TraversableB) import Data.Functor.Barbie qualified as B import Data.Text.Encoding qualified as TE import Data.Validation qualified as V import Hasura.Prelude hiding (first) -import Hasura.RQL.DDL.Webhook.Transform.Body (Body (..), BodyTransformFn, TransformFn (BodyTransformFn_)) +import Hasura.RQL.DDL.Webhook.Transform.Body (Body (..), 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 @@ -81,204 +74,13 @@ 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, withOptionalField') +import Hasura.RQL.Types.Webhook.Transform (MetadataResponseTransform (..), RequestContext, RequestData, RequestFields (..), RequestTransform (..), RequestTransformFns) +import Hasura.RQL.Types.Webhook.Transform.WithOptional (WithOptional (..), withOptional) import Hasura.Session (SessionVariables) import Network.HTTP.Client.Transformable qualified as HTTP ------------------------------------------------------------------------------- --- | 'RequestTransform' is the metadata representation of a request --- transformation. It consists of a record of higher kinded data (HKD) --- along with some regular data. We seperate the HKD data into its own --- record field called 'requestFields' which we nest inside our --- non-HKD record. The actual transformation operations are contained --- in the HKD. -data RequestTransform = RequestTransform - { version :: Version, - requestFields :: RequestFields (WithOptional TransformFn), - templateEngine :: TemplatingEngine - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - -instance HasCodec RequestTransform where - codec = - dimapCodec - (either id id) - (\rt -> case version rt of V1 -> Left rt; V2 -> Right rt) - $ disjointEitherCodec transformV1 transformV2 - where - transformV1 = - AC.object "RequestTransformV1" $ - RequestTransform - <$> (V1 <$ optionalVersionField 1) - <*> requestFieldsCodec bodyV1 AC..= requestFields - <*> transformCommon - - transformV2 = - AC.object "RequestTransformV2" $ - RequestTransform - <$> (V2 <$ versionField 2) - <*> requestFieldsCodec bodyV2 AC..= requestFields - <*> transformCommon - - transformCommon = optionalFieldWithDefault' "template_engine" Kriti AC..= templateEngine - - requestFieldsCodec bodyCodec = - RequestFields - <$> withOptionalField' @MethodTransformFn "method" AC..= method - <*> withOptionalField' @UrlTransformFn "url" AC..= url - <*> bodyCodec AC..= body - <*> withOptionalField' @QueryParamsTransformFn "query_params" AC..= queryParams - <*> withOptionalField' @HeadersTransformFn "request_headers" AC..= requestHeaders - - bodyV1 = dimapCodec dec enc $ optionalField' @Template "body" - where - dec template = withOptional $ fmap Body.ModifyAsJSON template - enc body = case getOptional body of - Just (BodyTransformFn_ (Body.ModifyAsJSON template)) -> Just template - _ -> Nothing - - bodyV2 = withOptionalField' @BodyTransformFn "body" - -instance FromJSON RequestTransform where - parseJSON = J.withObject "RequestTransform" \o -> do - version <- o .:? "version" .!= V1 - method <- o .:? "method" - url <- o .:? "url" - body <- case version of - V1 -> do - template :: Maybe Template <- o .:? "body" - pure $ fmap Body.ModifyAsJSON template - V2 -> o .:? "body" - queryParams <- o .:? "query_params" - headers <- o .:? "request_headers" - let requestFields = - RequestFields - { method = withOptional @MethodTransformFn method, - url = withOptional @UrlTransformFn url, - body = withOptional @BodyTransformFn body, - queryParams = withOptional @QueryParamsTransformFn queryParams, - requestHeaders = withOptional @HeadersTransformFn headers - } - templateEngine <- o .:? "template_engine" .!= Kriti - pure $ RequestTransform {..} - -instance ToJSON RequestTransform where - toJSON RequestTransform {..} = - let RequestFields {..} = requestFields - body' = case version of - V1 -> case (getOptional body) of - Just (BodyTransformFn_ (Body.ModifyAsJSON template)) -> - Just ("body", J.toJSON template) - _ -> Nothing - V2 -> "body" .=? getOptional body - in J.object $ - [ "version" .= version, - "template_engine" .= templateEngine - ] - <> catMaybes - [ "method" .=? getOptional method, - "url" .=? getOptional url, - "query_params" .=? getOptional queryParams, - "request_headers" .=? getOptional requestHeaders, - body' - ] - -------------------------------------------------------------------------------- - --- | Defunctionalized Webhook Request Transformation --- --- We represent a defunctionalized request transformation by parameterizing --- our HKD with 'WithOptional'@ @'TransformFn', which marks each of the fields --- as optional and supplies the appropriate transformation function to them if --- if they are provided. -type RequestTransformFns = RequestFields (WithOptional TransformFn) - --- | Actual Request Data --- --- We represent the actual request data by parameterizing our HKD with --- 'Identity', which allows us to trivially unwrap the fields (which should --- exist after any transformations have been applied). -type RequestData = RequestFields Identity - --- | This is our HKD type. It is a record with fields for each --- component of an 'HTTP.Request' we wish to transform. -data RequestFields f = RequestFields - { method :: f Method, - url :: f Url, - body :: f Body, - queryParams :: f QueryParams, - requestHeaders :: f Headers - } - deriving stock (Generic) - deriving anyclass (FunctorB, ApplicativeB, TraversableB, ConstraintsB) - -deriving stock instance - AllBF Show f RequestFields => - Show (RequestFields f) - -deriving stock instance - AllBF Eq f RequestFields => - Eq (RequestFields f) - -deriving anyclass instance - AllBF NFData f RequestFields => - NFData (RequestFields f) - --- 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 .:? "method" - url <- o .:? "url" - body <- o .:? "body" - queryParams <- o .:? "query_params" - headers <- o .:? "request_headers" - pure $ - RequestFields - { method = withOptional @MethodTransformFn method, - url = withOptional @UrlTransformFn url, - body = withOptional @BodyTransformFn body, - queryParams = withOptional @QueryParamsTransformFn queryParams, - requestHeaders = withOptional @HeadersTransformFn headers - } - -instance ToJSON RequestTransformFns where - toJSON RequestFields {..} = - J.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 {..} = - J.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 -- | A 'Lens\'' for viewing a 'HTTP.Request' as our 'RequestData' HKD; it does @@ -366,70 +168,6 @@ data ResponseTransform = ResponseTransform respTransformTemplateEngine :: TemplatingEngine } -data MetadataResponseTransform = MetadataResponseTransform - { mrtVersion :: Version, - mrtBodyTransform :: Maybe BodyTransformFn, - mrtTemplatingEngine :: TemplatingEngine - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - -instance HasCodec MetadataResponseTransform where - codec = - dimapCodec - (either id id) - (\rt -> case mrtVersion rt of V1 -> Left rt; V2 -> Right rt) - $ disjointEitherCodec transformV1 transformV2 - where - transformV1 = - AC.object "ResponseTransformV1" $ - MetadataResponseTransform - <$> (V1 <$ optionalVersionField 1) - <*> bodyV1 AC..= mrtBodyTransform - <*> transformCommon - - transformV2 = - AC.object "ResponseTransformV2" $ - MetadataResponseTransform - <$> (V2 <$ versionField 2) - <*> bodyV2 AC..= mrtBodyTransform - <*> transformCommon - - transformCommon = optionalFieldWithDefault' "template_engine" Kriti AC..= mrtTemplatingEngine - - bodyV1 = - dimapCodec - (fmap Body.ModifyAsJSON) - (\case Just (Body.ModifyAsJSON template) -> Just template; _ -> Nothing) - $ optionalField' @Template "body" - - bodyV2 = optionalField' @BodyTransformFn "body" - -instance FromJSON MetadataResponseTransform where - parseJSON = J.withObject "MetadataResponseTransform" $ \o -> do - mrtVersion <- o .:? "version" .!= V1 - mrtBodyTransform <- case mrtVersion of - V1 -> do - template :: (Maybe Template) <- o .:? "body" - pure $ fmap Body.ModifyAsJSON template - V2 -> o .:? "body" - templateEngine <- o .:? "template_engine" - let mrtTemplatingEngine = fromMaybe Kriti templateEngine - pure $ MetadataResponseTransform {..} - -instance ToJSON MetadataResponseTransform where - toJSON MetadataResponseTransform {..} = - let body = case mrtVersion of - V1 -> case mrtBodyTransform of - Just (Body.ModifyAsJSON template) -> Just ("body", J.toJSON template) - _ -> Nothing - V2 -> "body" .=? mrtBodyTransform - in J.object $ - [ "template_engine" .= mrtTemplatingEngine, - "version" .= mrtVersion - ] - <> maybeToList body - -- | A helper function for constructing the 'ResponseTransformCtx' buildRespTransformCtx :: Maybe RequestContext -> Maybe SessionVariables -> TemplatingEngine -> BL.ByteString -> ResponseTransformCtx buildRespTransformCtx requestContext sessionVars engine respBody = @@ -478,3 +216,14 @@ applyResponseTransform ResponseTransform {..} ctx@ResponseTransformCtx {..} = Nothing -> pure body Just f -> J.encode <$> f ctx in bodyFunc (J.encode responseTransformBody) + +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 + } 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 d1f8a455428..280bcc95472 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Hasura.RQL.DDL.Webhook.Transform.Body ( -- * Body Transformations @@ -14,10 +14,6 @@ where ------------------------------------------------------------------------------- -import Autodocodec (HasCodec, codec, dimapCodec, disjointEitherCodec, object, requiredField', (.=)) -import Autodocodec.Extended (discriminatorField) -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 @@ -28,11 +24,9 @@ import Data.Validation (Validation) import Data.Validation qualified as V import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class - ( Template (..), - TemplatingEngine, + ( TemplatingEngine, Transform (..), TransformErrorBundle (..), - UnescapedTemplate, ) import Hasura.RQL.DDL.Webhook.Transform.Request ( RequestTransformCtx, @@ -41,25 +35,12 @@ import Hasura.RQL.DDL.Webhook.Transform.Request validateRequestTemplateTransform', validateRequestUnescapedTemplateTransform', ) +import Hasura.RQL.Types.Webhook.Transform.Body (Body (..), BodyTransformFn (..), TransformCtx (..), TransformFn (..)) import Network.URI.Extended qualified as URI ------------------------------------------------------------------------------- --- | HTTP message body being transformed. -data Body - = JSONBody (Maybe J.Value) - | RawBody LBS.ByteString - deriving stock (Eq, 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 (Eq, Generic, Show) - deriving newtype (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) (TransformCtx reqCtx) = applyBodyTransformFn fn reqCtx @@ -69,18 +50,6 @@ instance Transform Body where -- separately. validate engine (BodyTransformFn_ fn) = validateBodyTransformFn engine 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 (Eq, Generic, Show) - deriving anyclass (NFData) - -- | Provide an implementation for the transformations defined by -- 'BodyTransformFn'. -- @@ -154,60 +123,3 @@ escapeURIBS = . URI.escapeURIString URI.isUnescapedInURIComponent . T.unpack . TE.decodeUtf8 - -instance HasCodec BodyTransformFn where - codec = - dimapCodec dec enc $ - disjointEitherCodec removeCodec $ - disjointEitherCodec modifyAsJSONCodec modifyAsFormURLEncodecCodec - where - removeCodec = object "BodyTransformFn_Remove" $ discriminatorField "action" "remove" - - modifyAsJSONCodec = - dimapCodec snd ((),) $ - object "BodyTransformFn_ModifyAsJSON" $ - (,) - <$> discriminatorField "action" "transform" .= fst - <*> requiredField' @Template "template" .= snd - - modifyAsFormURLEncodecCodec = - dimapCodec snd ((),) $ - object "BodyTransformFn_ModifyAsFormURLEncoded" $ - (,) - <$> discriminatorField "action" "x_www_form_urlencoded" .= fst - <*> requiredField' @(M.HashMap Text UnescapedTemplate) "form_template" .= snd - - dec (Left _) = Remove - dec (Right (Left template)) = ModifyAsJSON template - dec (Right (Right hashMap)) = ModifyAsFormURLEncoded hashMap - - enc Remove = Left () - enc (ModifyAsJSON template) = Right $ Left template - enc (ModifyAsFormURLEncoded hashMap) = Right $ Right hashMap - -instance FromJSON BodyTransformFn where - parseJSON = J.withObject "BodyTransformFn" \o -> do - action <- o J..: "action" - case (action :: Text) of - "remove" -> pure Remove - "transform" -> do - template <- o J..: "template" - pure $ ModifyAsJSON template - "x_www_form_urlencoded" -> do - formTemplates <- o J..: "form_template" - pure $ ModifyAsFormURLEncoded formTemplates - _ -> fail "invalid transform action" - -instance ToJSON BodyTransformFn where - toJSON = \case - Remove -> J.object ["action" J..= ("remove" :: Text)] - ModifyAsJSON a -> - J.object - [ "action" J..= ("transform" :: Text), - "template" J..= J.toJSON a - ] - ModifyAsFormURLEncoded formTemplates -> - J.object - [ "action" J..= ("x_www_form_urlencoded" :: Text), - "form_template" J..= J.toJSON formTemplates - ] 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 0fa14172613..ddbd761083b 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,32 +24,19 @@ where ------------------------------------------------------------------------------- -import Autodocodec (HasCodec (codec), dimapCodec, stringConstCodec) -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) import Data.Aeson qualified as J import Data.ByteString (ByteString) import Data.ByteString.Builder.Extra (toLazyByteStringWith, untrimmedStrategy) import Data.ByteString.Builder.Scientific (scientificBuilder) import Data.ByteString.Lazy qualified as LBS -import Data.Kind (Type) import Data.Text.Encoding (encodeUtf8) import Data.Validation (Validation) import Hasura.Prelude - -------------------------------------------------------------------------------- +import Hasura.RQL.Types.Webhook.Transform.Class (Template (..), TemplatingEngine (..), TransformCtx, TransformErrorBundle (..), TransformFn, UnescapedTemplate (..)) -- | 'Transform' describes how to reify a defunctionalized transformation for -- a particular request field. class Transform a where - -- | The associated type 'TransformFn a' is the defunctionalized version - -- of some transformation that should be applied to a given request field. - -- - -- In most cases it is some variation on a piece of template text describing - -- 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: -- @@ -72,14 +58,6 @@ class Transform a where ------------------------------------------------------------------------------- --- | We use collect all transformation failures as a '[J.Value]'. -newtype TransformErrorBundle = TransformErrorBundle - { tebMessages :: [J.Value] - } - deriving stock (Eq, Generic, Show) - deriving newtype (Monoid, Semigroup, FromJSON, ToJSON) - deriving anyclass (NFData) - -- | A helper function for serializing transformation errors to JSON. throwErrorBundle :: MonadError TransformErrorBundle m => @@ -99,77 +77,6 @@ throwErrorBundle msg val = do ------------------------------------------------------------------------------- --- | Available templating engines. -data TemplatingEngine - = Kriti - deriving stock (Bounded, Enum, Eq, Generic, Show) - deriving anyclass (NFData) - -instance HasCodec TemplatingEngine where - codec = stringConstCodec [(Kriti, "Kriti")] - --- XXX(jkachmar): We need roundtrip tests for these instances. -instance FromJSON TemplatingEngine where - parseJSON = - J.genericParseJSON - J.defaultOptions - { J.tagSingleConstructors = True - } - --- XXX(jkachmar): We need roundtrip tests for these instances. -instance ToJSON TemplatingEngine where - toJSON = - J.genericToJSON - J.defaultOptions - { J.tagSingleConstructors = True - } - - toEncoding = - J.genericToEncoding - J.defaultOptions - { J.tagSingleConstructors = True - } - --- | Textual transformation template. -newtype Template = Template - { unTemplate :: Text - } - deriving stock (Eq, Generic, Ord, Show) - deriving newtype (Hashable, FromJSONKey, ToJSONKey) - deriving anyclass (NFData) - -instance HasCodec Template where - codec = dimapCodec Template unTemplate codec - -instance J.FromJSON Template where - parseJSON = J.withText "Template" (pure . Template) - -instance J.ToJSON Template where - toJSON = J.String . coerce - -------------------------------------------------------------------------------- - --- | Validated textual transformation template /for string --- interpolation only/. --- --- This is necessary due to Kriti not distinguishing between string --- literals and string templates. -newtype UnescapedTemplate = UnescapedTemplate - { getUnescapedTemplate :: Text - } - deriving stock (Eq, Generic, Ord, Show) - deriving newtype (Hashable, FromJSONKey, ToJSONKey) - deriving anyclass (NFData) - -instance HasCodec UnescapedTemplate where - codec = dimapCodec UnescapedTemplate getUnescapedTemplate codec - -instance J.FromJSON UnescapedTemplate where - parseJSON = J.withText "Template" (pure . UnescapedTemplate) - -instance J.ToJSON UnescapedTemplate where - toJSON = J.String . coerce - -- | Wrap an 'UnescapedTemplate' with escaped double quotes. wrapUnescapedTemplate :: UnescapedTemplate -> Template wrapUnescapedTemplate (UnescapedTemplate txt) = Template $ "\"" <> txt <> "\"" 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 769e1d7b172..5d9d27e9d35 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Hasura.RQL.DDL.Webhook.Transform.Headers ( -- * Header Transformations @@ -14,12 +14,7 @@ where ------------------------------------------------------------------------------- -import Autodocodec -import Autodocodec.Extended (caseInsensitiveHashMapCodec, caseInsensitiveTextCodec) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as J import Data.CaseInsensitive qualified as CI -import Data.HashMap.Strict qualified as HashMap import Data.Text.Encoding qualified as TE import Data.Validation (Validation) import Data.Validation qualified as V @@ -28,33 +23,17 @@ import Hasura.RQL.DDL.Webhook.Transform.Class ( TemplatingEngine, Transform (..), TransformErrorBundle (..), - UnescapedTemplate (..), ) import Hasura.RQL.DDL.Webhook.Transform.Request ( RequestTransformCtx, runUnescapedRequestTemplateTransform', validateRequestUnescapedTemplateTransform', ) -import Network.HTTP.Types qualified as HTTP.Types +import Hasura.RQL.Types.Webhook.Transform.Headers (AddReplaceOrRemoveFields (..), Headers (..), HeadersTransformFn (..), TransformCtx (..), TransformFn (..)) ------------------------------------------------------------------------------- --- | The actual header data we are transforming.. --- --- This newtype is necessary because otherwise we end up with an --- orphan instance. -newtype Headers = Headers [HTTP.Types.Header] - instance Transform Headers where - -- NOTE: GHC does not let us attach Haddock documentation to data family - -- instances, so 'HeadersTransformFn' is defined separately from this - -- wrapper. - newtype TransformFn Headers = HeadersTransformFn_ HeadersTransformFn - deriving stock (Eq, Generic, Show) - deriving newtype (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. @@ -66,30 +45,6 @@ instance Transform Headers where validate engine (HeadersTransformFn_ fn) = validateHeadersTransformFn engine fn --- | The defunctionalized transformation on 'Headers' -newtype HeadersTransformFn - = -- | Add or replace matching 'HTTP.Types.Header's. - AddReplaceOrRemove AddReplaceOrRemoveFields - deriving stock (Eq, Generic, Show) - deriving newtype (NFData, FromJSON, ToJSON) - -instance HasCodec HeadersTransformFn where - codec = dimapCodec AddReplaceOrRemove coerce codec - --- | The user can supply a set of header keys to be filtered from the --- request and a set of headers to be added to the request. -data AddReplaceOrRemoveFields = AddReplaceOrRemoveFields - { -- | A list of key-value pairs for 'HTTP.Types.Header's which - -- should be added (if they don't exist) or replaced (if they do) within - -- the HTTP message. - addOrReplaceHeaders :: [(CI.CI Text, UnescapedTemplate)], - -- | A list of 'HTTP.Type.Header' keys which should be removed from the - -- HTTP message. - removeHeaders :: [CI.CI Text] - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -- | Provide an implementation for the transformations defined by -- 'HeadersTransformFn'. -- @@ -136,41 +91,3 @@ validateHeadersTransformFn engine = \case AddReplaceOrRemove fields -> do let templates = fields & addOrReplaceHeaders & map snd traverse_ (validateRequestUnescapedTemplateTransform' engine) templates - -instance HasCodec AddReplaceOrRemoveFields where - codec = - object "AddReplaceOrRemoveFields" $ - AddReplaceOrRemoveFields - <$> optionalFieldWithDefaultWith' "add_headers" addCodec mempty .= addOrReplaceHeaders - <*> optionalFieldWithDefaultWith' "remove_headers" removeCodec mempty .= removeHeaders - where - addCodec = dimapCodec HashMap.toList HashMap.fromList $ caseInsensitiveHashMapCodec codec - removeCodec = listCodec caseInsensitiveTextCodec - -instance FromJSON AddReplaceOrRemoveFields where - parseJSON = J.withObject "AddReplaceRemoveFields" $ \o -> do - addOrReplaceHeadersTxt <- o J..:? "add_headers" J..!= mempty - let addOrReplaceHeaders = HashMap.toList $ mapKeys CI.mk addOrReplaceHeadersTxt - - removeHeadersTxt <- o J..:? "remove_headers" J..!= mempty - -- NOTE: Ensure that the FromJSON instance is used for deserialization. - let removeHeaders = coerce @[HeaderKey] removeHeadersTxt - - pure AddReplaceOrRemoveFields {addOrReplaceHeaders, removeHeaders} - -instance ToJSON AddReplaceOrRemoveFields where - toJSON AddReplaceOrRemoveFields {..} = - J.object - [ "add_headers" J..= HashMap.fromList (fmap (first CI.original) addOrReplaceHeaders), - "remove_headers" J..= fmap CI.original removeHeaders - ] - --- | This newtype exists solely to anchor a `FromJSON` instance and is --- eliminated in the `TransformHeaders` `FromJSON` instance. -newtype HeaderKey = HeaderKey {unHeaderKey :: CI.CI Text} - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -instance FromJSON HeaderKey where - parseJSON = J.withText "HeaderKey" \txt -> case CI.mk txt of - key -> pure $ HeaderKey key 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 2209d473462..1d622d31699 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Hasura.RQL.DDL.Webhook.Transform.Method ( -- * Method transformations @@ -11,12 +11,6 @@ where ------------------------------------------------------------------------------- -import Autodocodec (HasCodec (codec), dimapCodec) -import Autodocodec.Extended (caseInsensitiveTextCodec) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as J -import Data.CaseInsensitive qualified as CI -import Data.Text qualified as T import Data.Validation import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform.Class @@ -25,37 +19,11 @@ import Hasura.RQL.DDL.Webhook.Transform.Class TransformErrorBundle (..), ) import Hasura.RQL.DDL.Webhook.Transform.Request (RequestTransformCtx) +import Hasura.RQL.Types.Webhook.Transform.Method (Method (..), MethodTransformFn (..), TransformCtx (..), TransformFn (..)) ------------------------------------------------------------------------------- --- | The actual request method we are transforming. --- --- This newtype is necessary because otherwise we end up with an --- orphan instance. -newtype Method = Method (CI.CI T.Text) - deriving stock (Generic) - deriving newtype (Show, Eq) - deriving anyclass (NFData) - -instance HasCodec Method where - codec = dimapCodec Method coerce caseInsensitiveTextCodec - -instance J.ToJSON Method where - toJSON = J.String . CI.original . coerce - -instance J.FromJSON Method where - parseJSON = J.withText "Method" (pure . coerce . CI.mk) - instance Transform Method where - -- NOTE: GHC does not let us attach Haddock documentation to data family - -- instances, so 'MethodTransformFn' is defined separately from this - -- wrapper. - newtype TransformFn Method = MethodTransformFn_ MethodTransformFn - deriving stock (Eq, Generic, Show) - deriving newtype (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. @@ -66,16 +34,6 @@ instance Transform Method where -- separately. validate engine (MethodTransformFn_ fn) = validateMethodTransformFn engine fn --- | The defunctionalized transformation on 'Method'. -newtype MethodTransformFn - = -- | Replace the HTTP existing 'Method' with a new one. - Replace Method - deriving stock (Eq, Generic, Show) - deriving newtype (NFData, FromJSON, ToJSON) - -instance HasCodec MethodTransformFn where - codec = dimapCodec Replace coerce codec - -- | Provide an implementation for the transformations defined by -- 'MethodTransformFn'. -- 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 21e661d1fb1..818f1af7823 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Hasura.RQL.DDL.Webhook.Transform.QueryParams ( -- * Query transformations @@ -12,10 +12,6 @@ where ------------------------------------------------------------------------------- -import Autodocodec (HasCodec (codec), dimapCodec, disjointEitherCodec, hashMapCodec) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as J -import Data.HashMap.Strict qualified as HashMap import Data.Validation (Validation) import Data.Validation qualified as V import Hasura.Prelude @@ -23,35 +19,18 @@ import Hasura.RQL.DDL.Webhook.Transform.Class ( TemplatingEngine, Transform (..), TransformErrorBundle (..), - UnescapedTemplate (..), ) import Hasura.RQL.DDL.Webhook.Transform.Request ( RequestTransformCtx, runUnescapedRequestTemplateTransform', validateRequestUnescapedTemplateTransform', ) -import Network.HTTP.Client.Transformable qualified as HTTP +import Hasura.RQL.Types.Webhook.Transform.QueryParams (QueryParams (..), QueryParamsTransformFn (..), TransformCtx (..), TransformFn (..)) import Network.HTTP.Types.URI (parseQuery) ------------------------------------------------------------------------------- --- | The actual query params we are transforming. --- --- This newtype is necessary because otherwise we end up with an --- orphan instance. -newtype QueryParams = QueryParams {unQueryParams :: HTTP.Query} - instance Transform QueryParams where - -- NOTE: GHC does not let us attach Haddock documentation to data family - -- instances, so 'QueryParamsTransformFn' is defined separately from this - -- wrapper. - newtype TransformFn QueryParams - = QueryParamsTransformFn_ QueryParamsTransformFn - deriving stock (Show, Eq, Generic) - deriving newtype (NFData, 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. @@ -63,13 +42,6 @@ instance Transform QueryParams where validate engine (QueryParamsTransformFn_ fn) = validateQueryParamsTransformFn engine fn --- | The defunctionalized transformation 'QueryParams' -data QueryParamsTransformFn - = AddOrReplace [(UnescapedTemplate, Maybe UnescapedTemplate)] - | ParamTemplate UnescapedTemplate - deriving (NFData) - deriving stock (Eq, Generic, Show) - -- | Provide an implementation for the transformations defined by -- 'QueryParamsTransformFn'. -- @@ -123,24 +95,3 @@ validateQueryParamsTransformFn engine = \case validateRequestUnescapedTemplateTransform' engine template pure () {-# ANN validateQueryParamsTransformFn ("HLint: ignore Redundant pure" :: String) #-} - -instance HasCodec QueryParamsTransformFn where - codec = dimapCodec dec enc $ disjointEitherCodec addOrReplaceCodec templateCodec - where - addOrReplaceCodec = hashMapCodec (codec @(Maybe UnescapedTemplate)) - templateCodec = codec @UnescapedTemplate - - dec (Left qps) = AddOrReplace $ HashMap.toList qps - dec (Right template) = ParamTemplate template - - enc (AddOrReplace addOrReplace) = Left $ HashMap.fromList addOrReplace - enc (ParamTemplate template) = Right template - -instance J.ToJSON QueryParamsTransformFn where - toJSON (AddOrReplace addOrReplace) = J.toJSON $ HashMap.fromList addOrReplace - toJSON (ParamTemplate template) = J.toJSON template - -instance J.FromJSON QueryParamsTransformFn where - parseJSON xs@(J.Object _) = AddOrReplace . HashMap.toList <$> J.parseJSON xs - parseJSON xs@(J.String _) = ParamTemplate <$> J.parseJSON xs - parseJSON _ = fail "Invalid query parameter" diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs index c51e69385e8..1a4f2b2831e 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Request.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} - -- | Types and subroutines related to constructing transformations on -- HTTP requests. module Hasura.RQL.DDL.Webhook.Transform.Request @@ -27,7 +25,6 @@ where import Control.Arrow (left) import Control.Lens qualified as Lens -import Data.Aeson (FromJSON, ToJSON, (.=)) import Data.Aeson qualified as J import Data.Aeson.Kriti.Functions qualified as KFunc import Data.Bifunctor @@ -36,34 +33,12 @@ 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 -------------------------------------------------------------------------------- - --- | Common context that is made available to all request transformations. -data RequestTransformCtx = RequestTransformCtx - { rtcBaseUrl :: Maybe J.Value, - rtcBody :: J.Value, - rtcSessionVariables :: Maybe SessionVariables, - rtcQueryParams :: Maybe J.Value, - rtcEngine :: TemplatingEngine - } - -instance ToJSON RequestTransformCtx where - toJSON RequestTransformCtx {..} = - let required = - [ "body" .= rtcBody, - "session_variables" .= rtcSessionVariables - ] - optional = - [ ("base_url" .=) <$> rtcBaseUrl, - ("query_params" .=) <$> 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 @@ -134,28 +109,6 @@ validateRequestTemplateTransform' engine = ------------------------------------------------------------------------------- --- | 'RequestTransform' Versioning -data Version - = V1 - | V2 - deriving stock (Eq, Generic, Show) - deriving anyclass (Hashable, NFData) - -instance 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 ToJSON Version where - toJSON = \case - V1 -> J.toJSON @Int 1 - V2 -> J.toJSON @Int 2 - -------------------------------------------------------------------------------- - -- | A helper function for executing Kriti transformations from a -- 'UnescapedTemplate' and a 'RequestTrasformCtx'. -- 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 ce4a55d9ffc..39dc7df535d 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + module Hasura.RQL.DDL.Webhook.Transform.Url ( -- * Url Transformations Url (..), @@ -9,8 +11,6 @@ where ------------------------------------------------------------------------------- -import Autodocodec (HasCodec (codec), dimapCodec) -import Data.Aeson (FromJSON, ToJSON) import Data.Aeson qualified as J import Data.Text qualified as T import Data.Validation @@ -19,7 +19,6 @@ import Hasura.RQL.DDL.Webhook.Transform.Class ( TemplatingEngine, Transform (..), TransformErrorBundle (..), - UnescapedTemplate (..), throwErrorBundle, wrapUnescapedTemplate, ) @@ -28,27 +27,12 @@ import Hasura.RQL.DDL.Webhook.Transform.Request runRequestTemplateTransform, validateRequestUnescapedTemplateTransform', ) +import Hasura.RQL.Types.Webhook.Transform.Url (TransformCtx (..), TransformFn (..), Url (..), UrlTransformFn (..)) import Network.URI (parseURI) ------------------------------------------------------------------------------- --- | The actual URL string we are transforming. --- --- This newtype is necessary because otherwise we end up with an --- orphan instance. -newtype Url = Url {unUrl :: Text} - deriving stock (Eq, Show) - instance Transform Url where - -- NOTE: GHC does not let us attach Haddock documentation to data family - -- instances, so 'UrlTransformFn' is defined separately from this - -- wrapper. - newtype TransformFn Url = UrlTransformFn_ UrlTransformFn - deriving stock (Eq, Generic, Show) - deriving newtype (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) (TransformCtx reqCtx) = applyUrlTransformFn fn reqCtx @@ -57,15 +41,6 @@ instance Transform Url where -- method implementations, so 'validateUrlTransformFn' is defined separately. validate engine (UrlTransformFn_ fn) = validateUrlTransformFn engine fn --- | The defunctionalized transformation function on 'Url' -newtype UrlTransformFn - = Modify UnescapedTemplate - deriving stock (Eq, Generic, Show) - deriving newtype (NFData, FromJSON, ToJSON) - -instance HasCodec UrlTransformFn where - codec = dimapCodec Modify coerce codec - -- | Provide an implementation for the transformations defined by -- 'UrlTransformFn'. -- diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Validation.hs b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Validation.hs index 58d9594e124..a21f752317f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Validation.hs +++ b/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Validation.hs @@ -28,6 +28,7 @@ import Hasura.Prelude import Hasura.RQL.DDL.Webhook.Transform import Hasura.RQL.DDL.Webhook.Transform.Body (validateBodyTransformFn) import Hasura.RQL.DDL.Webhook.Transform.Class +import Hasura.RQL.Types.Webhook.Transform.Class ------------------------------------------------------------------------------- diff --git a/server/src-lib/Hasura/RQL/Types/Action.hs b/server/src-lib/Hasura/RQL/Types/Action.hs index c9e0e4577fa..4fa7add0a4f 100644 --- a/server/src-lib/Hasura/RQL/Types/Action.hs +++ b/server/src-lib/Hasura/RQL/Types/Action.hs @@ -71,13 +71,13 @@ import Database.PG.Query qualified as PG import Database.PG.Query.PTI qualified as PTI import Hasura.Base.Error import Hasura.Prelude -import Hasura.RQL.DDL.Webhook.Transform (MetadataResponseTransform, RequestTransform) import Hasura.RQL.Types.Common import Hasura.RQL.Types.CustomTypes import Hasura.RQL.Types.Eventing (EventId (..)) import Hasura.RQL.Types.Headers (HeaderConf) import Hasura.RQL.Types.Roles (RoleName) import Hasura.RQL.Types.Session (SessionVariables) +import Hasura.RQL.Types.Webhook.Transform (MetadataResponseTransform, RequestTransform) import Language.GraphQL.Draft.Syntax qualified as G import Network.HTTP.Types qualified as HTTP import PostgreSQL.Binary.Encoding qualified as PE diff --git a/server/src-lib/Hasura/RQL/Types/EventTrigger.hs b/server/src-lib/Hasura/RQL/Types/EventTrigger.hs index 6877b55f939..9167d389ef1 100644 --- a/server/src-lib/Hasura/RQL/Types/EventTrigger.hs +++ b/server/src-lib/Hasura/RQL/Types/EventTrigger.hs @@ -60,13 +60,13 @@ import Data.Text.NonEmpty import Data.Time.Clock qualified as Time import Database.PG.Query qualified as PG import Hasura.Prelude -import Hasura.RQL.DDL.Webhook.Transform (MetadataResponseTransform, RequestTransform) import Hasura.RQL.Types.Backend import Hasura.RQL.Types.BackendTag (backendPrefix) import Hasura.RQL.Types.BackendType import Hasura.RQL.Types.Common (EnvRecord, InputWebhook, ResolvedWebhook, SourceName (..), TriggerOnReplication (..)) import Hasura.RQL.Types.Eventing import Hasura.RQL.Types.Headers (HeaderConf (..)) +import Hasura.RQL.Types.Webhook.Transform (MetadataResponseTransform, RequestTransform) import System.Cron (CronSchedule) import Text.Regex.TDFA qualified as TDFA diff --git a/server/src-lib/Hasura/RQL/Types/ScheduledTrigger.hs b/server/src-lib/Hasura/RQL/Types/ScheduledTrigger.hs index bded7c16e4c..f58f05092b1 100644 --- a/server/src-lib/Hasura/RQL/Types/ScheduledTrigger.hs +++ b/server/src-lib/Hasura/RQL/Types/ScheduledTrigger.hs @@ -59,10 +59,10 @@ import Data.Time.Clock.Units import Data.Time.Format.ISO8601 import Database.PG.Query qualified as PG import Hasura.Prelude -import Hasura.RQL.DDL.Webhook.Transform (MetadataResponseTransform, RequestTransform) import Hasura.RQL.Types.Common (InputWebhook (..)) import Hasura.RQL.Types.EventTrigger import Hasura.RQL.Types.Eventing +import Hasura.RQL.Types.Webhook.Transform (MetadataResponseTransform, RequestTransform) import PostgreSQL.Binary.Decoding qualified as PD import Refined (NonNegative, Refined, refineTH) import System.Cron.Types diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 25c8b046371..ff1430f33e8 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -131,7 +131,6 @@ import Hasura.Function.Cache import Hasura.GraphQL.Context (GQLContext, RoleContext) import Hasura.LogicalModel.Types (LogicalModelName) import Hasura.Prelude -import Hasura.RQL.DDL.Webhook.Transform import Hasura.RQL.IR.BoolExp import Hasura.RQL.Types.Action import Hasura.RQL.Types.Allowlist @@ -157,6 +156,7 @@ import Hasura.RQL.Types.SchemaCacheTypes import Hasura.RQL.Types.Session (UserInfoM) import Hasura.RQL.Types.Source import Hasura.RQL.Types.Table +import Hasura.RQL.Types.Webhook.Transform import Hasura.RemoteSchema.Metadata import Hasura.RemoteSchema.SchemaCache.Types import Hasura.SQL.AnyBackend qualified as AB diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform.hs new file mode 100644 index 00000000000..457be356701 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE UndecidableInstances #-} + +module Hasura.RQL.Types.Webhook.Transform + ( MetadataResponseTransform (..), + RequestTransform (..), + RequestTransformFns, + RequestContext, + RequestData, + RequestFields (..), + ) +where + +import Autodocodec (HasCodec, dimapCodec, disjointEitherCodec, optionalField', optionalFieldWithDefault') +import Autodocodec qualified as AC +import Autodocodec.Extended (optionalVersionField, versionField) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as J +import Data.Aeson.Extended ((.!=), (.:?), (.=), (.=?)) +import Data.Functor.Barbie (AllBF, ApplicativeB, ConstraintsB, FunctorB, TraversableB) +import Data.Functor.Barbie qualified as B +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Body (Body, BodyTransformFn, TransformCtx (..), TransformFn (..)) +import Hasura.RQL.Types.Webhook.Transform.Body qualified as Body +import Hasura.RQL.Types.Webhook.Transform.Class (Template, TemplatingEngine (..)) +import Hasura.RQL.Types.Webhook.Transform.Headers (Headers, HeadersTransformFn, TransformCtx (..), TransformFn (..)) +import Hasura.RQL.Types.Webhook.Transform.Method (Method, MethodTransformFn, TransformCtx (..), TransformFn (..)) +import Hasura.RQL.Types.Webhook.Transform.QueryParams (QueryParams, QueryParamsTransformFn, TransformCtx (..), TransformFn (..)) +import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx, Version (..)) +import Hasura.RQL.Types.Webhook.Transform.Url (TransformCtx (..), TransformFn (..), Url, UrlTransformFn (..)) +import Hasura.RQL.Types.Webhook.Transform.WithOptional (WithOptional (..), withOptional, withOptionalField') + +------------------------------------------------------------------------------- +-- TODO(SOLOMON): Rewrite with HKD + +data MetadataResponseTransform = MetadataResponseTransform + { mrtVersion :: Version, + mrtBodyTransform :: Maybe BodyTransformFn, + mrtTemplatingEngine :: TemplatingEngine + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +instance HasCodec MetadataResponseTransform where + codec = + dimapCodec + (either id id) + (\rt -> case mrtVersion rt of V1 -> Left rt; V2 -> Right rt) + $ disjointEitherCodec transformV1 transformV2 + where + transformV1 = + AC.object "ResponseTransformV1" $ + MetadataResponseTransform + <$> (V1 <$ optionalVersionField 1) + <*> bodyV1 AC..= mrtBodyTransform + <*> transformCommon + + transformV2 = + AC.object "ResponseTransformV2" $ + MetadataResponseTransform + <$> (V2 <$ versionField 2) + <*> bodyV2 AC..= mrtBodyTransform + <*> transformCommon + + transformCommon = optionalFieldWithDefault' "template_engine" Kriti AC..= mrtTemplatingEngine + + bodyV1 = + dimapCodec + (fmap Body.ModifyAsJSON) + (\case Just (Body.ModifyAsJSON template) -> Just template; _ -> Nothing) + $ optionalField' @Template "body" + + bodyV2 = optionalField' @BodyTransformFn "body" + +instance FromJSON MetadataResponseTransform where + parseJSON = J.withObject "MetadataResponseTransform" $ \o -> do + mrtVersion <- o .:? "version" .!= V1 + mrtBodyTransform <- case mrtVersion of + V1 -> do + template :: (Maybe Template) <- o .:? "body" + pure $ fmap Body.ModifyAsJSON template + V2 -> o .:? "body" + templateEngine <- o .:? "template_engine" + let mrtTemplatingEngine = fromMaybe Kriti templateEngine + pure $ MetadataResponseTransform {..} + +instance ToJSON MetadataResponseTransform where + toJSON MetadataResponseTransform {..} = + let body = case mrtVersion of + V1 -> case mrtBodyTransform of + Just (Body.ModifyAsJSON template) -> Just ("body", J.toJSON template) + _ -> Nothing + V2 -> "body" .=? mrtBodyTransform + in J.object $ + [ "template_engine" .= mrtTemplatingEngine, + "version" .= mrtVersion + ] + <> maybeToList body + +------------------------------------------------------------------------------- + +-- | 'RequestTransform' is the metadata representation of a request +-- transformation. It consists of a record of higher kinded data (HKD) +-- along with some regular data. We seperate the HKD data into its own +-- record field called 'requestFields' which we nest inside our +-- non-HKD record. The actual transformation operations are contained +-- in the HKD. +data RequestTransform = RequestTransform + { version :: Version, + requestFields :: RequestFields (WithOptional TransformFn), + templateEngine :: TemplatingEngine + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +instance HasCodec RequestTransform where + codec = + dimapCodec + (either id id) + (\rt -> case version rt of V1 -> Left rt; V2 -> Right rt) + $ disjointEitherCodec transformV1 transformV2 + where + transformV1 = + AC.object "RequestTransformV1" $ + RequestTransform + <$> (V1 <$ optionalVersionField 1) + <*> requestFieldsCodec bodyV1 AC..= requestFields + <*> transformCommon + + transformV2 = + AC.object "RequestTransformV2" $ + RequestTransform + <$> (V2 <$ versionField 2) + <*> requestFieldsCodec bodyV2 AC..= requestFields + <*> transformCommon + + transformCommon = optionalFieldWithDefault' "template_engine" Kriti AC..= templateEngine + + requestFieldsCodec bodyCodec = + RequestFields + <$> withOptionalField' @MethodTransformFn "method" AC..= method + <*> withOptionalField' @UrlTransformFn "url" AC..= url + <*> bodyCodec AC..= body + <*> withOptionalField' @QueryParamsTransformFn "query_params" AC..= queryParams + <*> withOptionalField' @HeadersTransformFn "request_headers" AC..= requestHeaders + + bodyV1 = dimapCodec dec enc $ optionalField' @Template "body" + where + dec template = withOptional $ fmap Body.ModifyAsJSON template + enc body = case getOptional body of + Just (BodyTransformFn_ (Body.ModifyAsJSON template)) -> Just template + _ -> Nothing + + bodyV2 = withOptionalField' @BodyTransformFn "body" + +instance FromJSON RequestTransform where + parseJSON = J.withObject "RequestTransform" \o -> do + version <- o .:? "version" .!= V1 + method <- o .:? "method" + url <- o .:? "url" + body <- case version of + V1 -> do + template :: Maybe Template <- o .:? "body" + pure $ fmap Body.ModifyAsJSON template + V2 -> o .:? "body" + queryParams <- o .:? "query_params" + headers <- o .:? "request_headers" + let requestFields = + RequestFields + { method = withOptional @MethodTransformFn method, + url = withOptional @UrlTransformFn url, + body = withOptional @BodyTransformFn body, + queryParams = withOptional @QueryParamsTransformFn queryParams, + requestHeaders = withOptional @HeadersTransformFn headers + } + templateEngine <- o .:? "template_engine" .!= Kriti + pure $ RequestTransform {..} + +instance ToJSON RequestTransform where + toJSON RequestTransform {..} = + let RequestFields {..} = requestFields + body' = case version of + V1 -> case (getOptional body) of + Just (BodyTransformFn_ (Body.ModifyAsJSON template)) -> + Just ("body", J.toJSON template) + _ -> Nothing + V2 -> "body" .=? getOptional body + in J.object $ + [ "version" .= version, + "template_engine" .= templateEngine + ] + <> catMaybes + [ "method" .=? getOptional method, + "url" .=? getOptional url, + "query_params" .=? getOptional queryParams, + "request_headers" .=? getOptional requestHeaders, + body' + ] + +------------------------------------------------------------------------------- + +-- | Defunctionalized Webhook Request Transformation +-- +-- We represent a defunctionalized request transformation by parameterizing +-- our HKD with 'WithOptional'@ @'TransformFn', which marks each of the fields +-- as optional and supplies the appropriate transformation function to them if +-- if they are provided. +type RequestTransformFns = RequestFields (WithOptional TransformFn) + +-- | Actual Request Data +-- +-- We represent the actual request data by parameterizing our HKD with +-- 'Identity', which allows us to trivially unwrap the fields (which should +-- exist after any transformations have been applied). +type RequestData = RequestFields Identity + +-- | This is our HKD type. It is a record with fields for each +-- component of an 'HTTP.Request' we wish to transform. +data RequestFields f = RequestFields + { method :: f Method, + url :: f Url, + body :: f Body, + queryParams :: f QueryParams, + requestHeaders :: f Headers + } + deriving stock (Generic) + deriving anyclass (FunctorB, ApplicativeB, TraversableB, ConstraintsB) + +deriving stock instance + AllBF Show f RequestFields => + Show (RequestFields f) + +deriving stock instance + AllBF Eq f RequestFields => + Eq (RequestFields f) + +deriving anyclass instance + AllBF NFData f RequestFields => + NFData (RequestFields f) + +-- 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 .:? "method" + url <- o .:? "url" + body <- o .:? "body" + queryParams <- o .:? "query_params" + headers <- o .:? "request_headers" + pure $ + RequestFields + { method = withOptional @MethodTransformFn method, + url = withOptional @UrlTransformFn url, + body = withOptional @BodyTransformFn body, + queryParams = withOptional @QueryParamsTransformFn queryParams, + requestHeaders = withOptional @HeadersTransformFn headers + } + +instance ToJSON RequestTransformFns where + toJSON RequestFields {..} = + J.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 {..} = + J.object + [ "method" .= coerce @_ @RequestTransformCtx method, + "url" .= coerce @_ @RequestTransformCtx url, + "body" .= coerce @_ @RequestTransformCtx body, + "query_params" .= coerce @_ @RequestTransformCtx queryParams, + "request_headers" .= coerce @_ @RequestTransformCtx requestHeaders + ] diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Body.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Body.hs new file mode 100644 index 00000000000..8866e6146d1 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Body.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hasura.RQL.Types.Webhook.Transform.Body + ( Body (..), + BodyTransformFn (..), + TransformFn (..), + TransformCtx (..), + ) +where + +import Autodocodec (HasCodec, codec, dimapCodec, disjointEitherCodec, object, requiredField', (.=)) +import Autodocodec.Extended (discriminatorField) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as J +import Data.ByteString.Lazy qualified as LBS +import Data.HashMap.Internal.Strict qualified as M +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Class (Template (..), TransformCtx, TransformFn, UnescapedTemplate (..)) +import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx (..)) + +-- | HTTP message body being transformed. +data Body + = JSONBody (Maybe J.Value) + | RawBody LBS.ByteString + deriving stock (Eq, Show) + +-- | 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 (Eq, Generic, Show) + deriving anyclass (NFData) + +instance FromJSON BodyTransformFn where + parseJSON = J.withObject "BodyTransformFn" \o -> do + action <- o J..: "action" + case (action :: Text) of + "remove" -> pure Remove + "transform" -> do + template <- o J..: "template" + pure $ ModifyAsJSON template + "x_www_form_urlencoded" -> do + formTemplates <- o J..: "form_template" + pure $ ModifyAsFormURLEncoded formTemplates + _ -> fail "invalid transform action" + +instance ToJSON BodyTransformFn where + toJSON = \case + Remove -> J.object ["action" J..= ("remove" :: Text)] + ModifyAsJSON a -> + J.object + [ "action" J..= ("transform" :: Text), + "template" J..= J.toJSON a + ] + ModifyAsFormURLEncoded formTemplates -> + J.object + [ "action" J..= ("x_www_form_urlencoded" :: Text), + "form_template" J..= J.toJSON formTemplates + ] + +-- NOTE: GHC does not let us attach Haddock documentation to data family +-- instances, so 'BodyTransformFn' is defined separately from this wrapper. +newtype instance TransformFn Body = BodyTransformFn_ BodyTransformFn + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +newtype instance TransformCtx Body = TransformCtx RequestTransformCtx + +instance HasCodec BodyTransformFn where + codec = + dimapCodec dec enc $ + disjointEitherCodec removeCodec $ + disjointEitherCodec modifyAsJSONCodec modifyAsFormURLEncodecCodec + where + removeCodec = object "BodyTransformFn_Remove" $ discriminatorField "action" "remove" + + modifyAsJSONCodec = + dimapCodec snd ((),) $ + object "BodyTransformFn_ModifyAsJSON" $ + (,) + <$> discriminatorField "action" "transform" .= fst + <*> requiredField' @Template "template" .= snd + + modifyAsFormURLEncodecCodec = + dimapCodec snd ((),) $ + object "BodyTransformFn_ModifyAsFormURLEncoded" $ + (,) + <$> discriminatorField "action" "x_www_form_urlencoded" .= fst + <*> requiredField' @(M.HashMap Text UnescapedTemplate) "form_template" .= snd + + dec (Left _) = Remove + dec (Right (Left template)) = ModifyAsJSON template + dec (Right (Right hashMap)) = ModifyAsFormURLEncoded hashMap + + enc Remove = Left () + enc (ModifyAsJSON template) = Right $ Left template + enc (ModifyAsFormURLEncoded hashMap) = Right $ Right hashMap diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Class.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Class.hs new file mode 100644 index 00000000000..916d4d9ea27 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Class.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLists #-} + +module Hasura.RQL.Types.Webhook.Transform.Class + ( Template (..), + TemplatingEngine (..), + TransformFn, + TransformCtx, + TransformErrorBundle (..), + UnescapedTemplate (..), + ) +where + +import Autodocodec (HasCodec (codec), dimapCodec, stringConstCodec) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Aeson qualified as J +import Data.Kind (Type) +import Hasura.Prelude + +-- | Textual transformation template. +newtype Template = Template + { unTemplate :: Text + } + deriving stock (Eq, Generic, Ord, Show) + deriving newtype (Hashable, FromJSONKey, ToJSONKey) + deriving anyclass (NFData) + +instance HasCodec Template where + codec = dimapCodec Template unTemplate codec + +instance J.FromJSON Template where + parseJSON = J.withText "Template" (pure . Template) + +instance J.ToJSON Template where + toJSON = J.String . coerce + +-- | Validated textual transformation template /for string +-- interpolation only/. +-- +-- This is necessary due to Kriti not distinguishing between string +-- literals and string templates. +newtype UnescapedTemplate = UnescapedTemplate + { getUnescapedTemplate :: Text + } + deriving stock (Eq, Generic, Ord, Show) + deriving newtype (Hashable, FromJSONKey, ToJSONKey) + deriving anyclass (NFData) + +instance HasCodec UnescapedTemplate where + codec = dimapCodec UnescapedTemplate getUnescapedTemplate codec + +instance J.FromJSON UnescapedTemplate where + parseJSON = J.withText "Template" (pure . UnescapedTemplate) + +instance J.ToJSON UnescapedTemplate where + toJSON = J.String . coerce + +------------------------------------------------------------------------------- + +-- | Available templating engines. +data TemplatingEngine + = Kriti + deriving stock (Bounded, Enum, Eq, Generic, Show) + deriving anyclass (NFData) + +instance HasCodec TemplatingEngine where + codec = stringConstCodec [(Kriti, "Kriti")] + +-- XXX(jkachmar): We need roundtrip tests for these instances. +instance FromJSON TemplatingEngine where + parseJSON = + J.genericParseJSON + J.defaultOptions + { J.tagSingleConstructors = True + } + +-- XXX(jkachmar): We need roundtrip tests for these instances. +instance ToJSON TemplatingEngine where + toJSON = + J.genericToJSON + J.defaultOptions + { J.tagSingleConstructors = True + } + + toEncoding = + J.genericToEncoding + J.defaultOptions + { J.tagSingleConstructors = True + } + +-- | The associated type 'TransformFn a' is the defunctionalized version +-- of some transformation that should be applied to a given request field. +-- +-- In most cases it is some variation on a piece of template text describing +-- the transformation. +data family TransformFn a :: Type + +data family TransformCtx a :: Type + +------------------------------------------------------------------------------- + +-- | We use collect all transformation failures as a '[J.Value]'. +newtype TransformErrorBundle = TransformErrorBundle + { tebMessages :: [J.Value] + } + deriving stock (Eq, Generic, Show) + deriving newtype (Monoid, Semigroup, FromJSON, ToJSON) + deriving anyclass (NFData) diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Headers.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Headers.hs new file mode 100644 index 00000000000..8d387f91bb2 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Headers.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hasura.RQL.Types.Webhook.Transform.Headers + ( AddReplaceOrRemoveFields (..), + Headers (..), + HeadersTransformFn (..), + TransformCtx (..), + TransformFn (..), + ) +where + +import Autodocodec +import Autodocodec.Extended (caseInsensitiveHashMapCodec, caseInsensitiveTextCodec) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as J +import Data.CaseInsensitive qualified as CI +import Data.HashMap.Strict qualified as HashMap +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Class (TransformCtx, TransformFn, UnescapedTemplate (..)) +import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx) +import Network.HTTP.Types qualified as HTTP.Types + +-- | The actual header data we are transforming.. +-- +-- This newtype is necessary because otherwise we end up with an +-- orphan instance. +newtype Headers = Headers [HTTP.Types.Header] + +-- | The defunctionalized transformation on 'Headers' +newtype HeadersTransformFn + = -- | Add or replace matching 'HTTP.Types.Header's. + AddReplaceOrRemove AddReplaceOrRemoveFields + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +instance HasCodec HeadersTransformFn where + codec = dimapCodec AddReplaceOrRemove coerce codec + +-- | The user can supply a set of header keys to be filtered from the +-- request and a set of headers to be added to the request. +data AddReplaceOrRemoveFields = AddReplaceOrRemoveFields + { -- | A list of key-value pairs for 'HTTP.Types.Header's which + -- should be added (if they don't exist) or replaced (if they do) within + -- the HTTP message. + addOrReplaceHeaders :: [(CI.CI Text, UnescapedTemplate)], + -- | A list of 'HTTP.Type.Header' keys which should be removed from the + -- HTTP message. + removeHeaders :: [CI.CI Text] + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +instance HasCodec AddReplaceOrRemoveFields where + codec = + object "AddReplaceOrRemoveFields" $ + AddReplaceOrRemoveFields + <$> optionalFieldWithDefaultWith' "add_headers" addCodec mempty .= addOrReplaceHeaders + <*> optionalFieldWithDefaultWith' "remove_headers" removeCodec mempty .= removeHeaders + where + addCodec = dimapCodec HashMap.toList HashMap.fromList $ caseInsensitiveHashMapCodec codec + removeCodec = listCodec caseInsensitiveTextCodec + +instance FromJSON AddReplaceOrRemoveFields where + parseJSON = J.withObject "AddReplaceRemoveFields" $ \o -> do + addOrReplaceHeadersTxt <- o J..:? "add_headers" J..!= mempty + let addOrReplaceHeaders = HashMap.toList $ mapKeys CI.mk addOrReplaceHeadersTxt + + removeHeadersTxt <- o J..:? "remove_headers" J..!= mempty + -- NOTE: Ensure that the FromJSON instance is used for deserialization. + let removeHeaders = coerce @[HeaderKey] removeHeadersTxt + + pure AddReplaceOrRemoveFields {addOrReplaceHeaders, removeHeaders} + +instance ToJSON AddReplaceOrRemoveFields where + toJSON AddReplaceOrRemoveFields {..} = + J.object + [ "add_headers" J..= HashMap.fromList (fmap (first CI.original) addOrReplaceHeaders), + "remove_headers" J..= fmap CI.original removeHeaders + ] + +-- | This newtype exists solely to anchor a `FromJSON` instance and is +-- eliminated in the `TransformHeaders` `FromJSON` instance. +newtype HeaderKey = HeaderKey {unHeaderKey :: CI.CI Text} + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +instance FromJSON HeaderKey where + parseJSON = J.withText "HeaderKey" \txt -> case CI.mk txt of + key -> pure $ HeaderKey key + +-- NOTE: GHC does not let us attach Haddock documentation to data family +-- instances, so 'HeadersTransformFn' is defined separately from this +-- wrapper. +newtype instance TransformFn Headers = HeadersTransformFn_ HeadersTransformFn + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +newtype instance TransformCtx Headers = TransformCtx RequestTransformCtx diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Method.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Method.hs new file mode 100644 index 00000000000..eea13d47ab8 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Method.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Hasura.RQL.Types.Webhook.Transform.Method + ( Method (..), + MethodTransformFn (..), + TransformCtx (..), + TransformFn (..), + ) +where + +import Autodocodec (HasCodec (codec), dimapCodec) +import Autodocodec.Extended (caseInsensitiveTextCodec) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as J +import Data.CaseInsensitive qualified as CI +import Data.Text qualified as T +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Class (TransformCtx, TransformFn) +import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx) + +-- | The actual request method we are transforming. +-- +-- This newtype is necessary because otherwise we end up with an +-- orphan instance. +newtype Method = Method (CI.CI T.Text) + deriving stock (Generic) + deriving newtype (Show, Eq) + deriving anyclass (NFData) + +instance HasCodec Method where + codec = dimapCodec Method coerce caseInsensitiveTextCodec + +instance J.ToJSON Method where + toJSON = J.String . CI.original . coerce + +instance J.FromJSON Method where + parseJSON = J.withText "Method" (pure . coerce . CI.mk) + +-- | The defunctionalized transformation on 'Method'. +newtype MethodTransformFn + = -- | Replace the HTTP existing 'Method' with a new one. + Replace Method + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +instance HasCodec MethodTransformFn where + codec = dimapCodec Replace coerce codec + +-- NOTE: GHC does not let us attach Haddock documentation to data family +-- instances, so 'MethodTransformFn' is defined separately from this +-- wrapper. +newtype instance TransformFn Method = MethodTransformFn_ MethodTransformFn + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +newtype instance TransformCtx Method = TransformCtx RequestTransformCtx diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/QueryParams.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/QueryParams.hs new file mode 100644 index 00000000000..98cd736ad5e --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/QueryParams.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hasura.RQL.Types.Webhook.Transform.QueryParams + ( QueryParams (..), + QueryParamsTransformFn (..), + TransformCtx (..), + TransformFn (..), + ) +where + +import Autodocodec (HasCodec (codec), dimapCodec, disjointEitherCodec, hashMapCodec) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as J +import Data.HashMap.Strict qualified as HashMap +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Class (TransformCtx, TransformFn, UnescapedTemplate) +import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx) +import Network.HTTP.Client.Transformable qualified as HTTP + +-- | The actual query params we are transforming. +-- +-- This newtype is necessary because otherwise we end up with an +-- orphan instance. +newtype QueryParams = QueryParams {unQueryParams :: HTTP.Query} + +-- | The defunctionalized transformation 'QueryParams' +data QueryParamsTransformFn + = AddOrReplace [(UnescapedTemplate, Maybe UnescapedTemplate)] + | ParamTemplate UnescapedTemplate + deriving (NFData) + deriving stock (Eq, Generic, Show) + +instance HasCodec QueryParamsTransformFn where + codec = dimapCodec dec enc $ disjointEitherCodec addOrReplaceCodec templateCodec + where + addOrReplaceCodec = hashMapCodec (codec @(Maybe UnescapedTemplate)) + templateCodec = codec @UnescapedTemplate + + dec (Left qps) = AddOrReplace $ HashMap.toList qps + dec (Right template) = ParamTemplate template + + enc (AddOrReplace addOrReplace) = Left $ HashMap.fromList addOrReplace + enc (ParamTemplate template) = Right template + +instance J.ToJSON QueryParamsTransformFn where + toJSON (AddOrReplace addOrReplace) = J.toJSON $ HashMap.fromList addOrReplace + toJSON (ParamTemplate template) = J.toJSON template + +instance J.FromJSON QueryParamsTransformFn where + parseJSON xs@(J.Object _) = AddOrReplace . HashMap.toList <$> J.parseJSON xs + parseJSON xs@(J.String _) = ParamTemplate <$> J.parseJSON xs + parseJSON _ = fail "Invalid query parameter" + +-- NOTE: GHC does not let us attach Haddock documentation to data family +-- instances, so 'QueryParamsTransformFn' is defined separately from this +-- wrapper. +newtype instance TransformFn QueryParams + = QueryParamsTransformFn_ QueryParamsTransformFn + deriving stock (Show, Eq, Generic) + deriving newtype (NFData, FromJSON, ToJSON) + +newtype instance TransformCtx QueryParams = TransformCtx RequestTransformCtx diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Request.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Request.hs new file mode 100644 index 00000000000..ec5fbeef963 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Request.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hasura.RQL.Types.Webhook.Transform.Request + ( RequestTransformCtx (..), + Version (..), + ) +where + +import Data.Aeson (FromJSON, ToJSON, (.=)) +import Data.Aeson qualified as J +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Class (TemplatingEngine (..)) +import Hasura.Session (SessionVariables) + +-- | Common context that is made available to all request transformations. +data RequestTransformCtx = RequestTransformCtx + { rtcBaseUrl :: Maybe J.Value, + rtcBody :: J.Value, + rtcSessionVariables :: Maybe SessionVariables, + rtcQueryParams :: Maybe J.Value, + rtcEngine :: TemplatingEngine + } + +instance ToJSON RequestTransformCtx where + toJSON RequestTransformCtx {..} = + let required = + [ "body" .= rtcBody, + "session_variables" .= rtcSessionVariables + ] + optional = + [ ("base_url" .=) <$> rtcBaseUrl, + ("query_params" .=) <$> rtcQueryParams + ] + in J.object (required <> catMaybes optional) + +------------------------------------------------------------------------------- + +-- | 'RequestTransform' Versioning +data Version + = V1 + | V2 + deriving stock (Eq, Generic, Show) + deriving anyclass (Hashable, NFData) + +instance 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 ToJSON Version where + toJSON = \case + V1 -> J.toJSON @Int 1 + V2 -> J.toJSON @Int 2 diff --git a/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Url.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Url.hs new file mode 100644 index 00000000000..3a94dbc5f8b --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/Url.hs @@ -0,0 +1,38 @@ +module Hasura.RQL.Types.Webhook.Transform.Url + ( Url (..), + UrlTransformFn (..), + TransformCtx (..), + TransformFn (..), + ) +where + +import Autodocodec (HasCodec, codec, dimapCodec) +import Data.Aeson (FromJSON, ToJSON) +import Hasura.Prelude +import Hasura.RQL.Types.Webhook.Transform.Class (TransformCtx, TransformFn, UnescapedTemplate (..)) +import Hasura.RQL.Types.Webhook.Transform.Request (RequestTransformCtx (..)) + +-- | The actual URL string we are transforming. +-- +-- This newtype is necessary because otherwise we end up with an +-- orphan instance. +newtype Url = Url {unUrl :: Text} + deriving stock (Eq, Show) + +-- | The defunctionalized transformation function on 'Url' +newtype UrlTransformFn + = Modify UnescapedTemplate + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +instance HasCodec UrlTransformFn where + codec = dimapCodec Modify coerce codec + +-- NOTE: GHC does not let us attach Haddock documentation to data family +-- instances, so 'UrlTransformFn' is defined separately from this +-- wrapper. +newtype instance TransformFn Url = UrlTransformFn_ UrlTransformFn + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, FromJSON, ToJSON) + +newtype instance TransformCtx Url = TransformCtx RequestTransformCtx diff --git a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/WithOptional.hs similarity index 91% rename from server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs rename to server/src-lib/Hasura/RQL/Types/Webhook/Transform/WithOptional.hs index 9b515e578b0..6a180834620 100644 --- a/server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs +++ b/server/src-lib/Hasura/RQL/Types/Webhook/Transform/WithOptional.hs @@ -1,5 +1,4 @@ --- | The 'WithOptional' Functor and associated operations. -module Hasura.RQL.DDL.Webhook.Transform.WithOptional +module Hasura.RQL.Types.Webhook.Transform.WithOptional ( WithOptional (..), withOptional, withOptionalField', @@ -7,15 +6,11 @@ module Hasura.RQL.DDL.Webhook.Transform.WithOptional ) where -------------------------------------------------------------------------------- - import Autodocodec (HasCodec (codec), ObjectCodec, ValueCodec, dimapCodec, optionalFieldWith') import Data.Aeson (FromJSON, ToJSON) import Data.Coerce (Coercible) 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. @@ -31,6 +26,8 @@ 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. --