server: event trigger codecs

Codecs for event triggers, including webhook transforms. These are not hooked into the higher-up table metadata codec yet because some backend implementations implement event triggers with `error` which causes an error when codecs are evaluated. I plan to follow up with another PR to resolve that.

Ticket: https://hasurahq.atlassian.net/browse/GDC-585

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7237
GitOrigin-RevId: 8ce40fe6fedcf8b109d6ca50a505333df855a8ce

server/graphql-engine.cabal

@@ -1135,6 +1135,7 @@ test-suite graphql-engine-tests
     Hasura.IncrementalSpec
     Hasura.Metadata.DTO.MetadataDTOSpec
     Hasura.QuickCheck.Instances
+    Hasura.RQL.DDL.Webhook.TransformSpec
     Hasura.RQL.IR.Generator
     Hasura.RQL.IR.SelectSpec
     Hasura.RQL.MetadataSpec

server/src-lib/Autodocodec/Extended.hs

@@ -1,5 +1,7 @@
 module Autodocodec.Extended
-  ( graphQLFieldNameCodec,
+  ( caseInsensitiveHashMapCodec,
+    caseInsensitiveTextCodec,
+    graphQLFieldNameCodec,
     graphQLValueCodec,
     graphQLSchemaDocumentCodec,
     hashSetCodec,
@@ -13,6 +15,9 @@ module Autodocodec.Extended
 where
 
 import Autodocodec
+import Data.Aeson (FromJSONKey, ToJSONKey)
+import Data.CaseInsensitive qualified as CI
+import Data.HashMap.Strict qualified as M
 import Data.HashSet qualified as HashSet
 import Data.Scientific (Scientific (base10Exponent), floatingOrInteger)
 import Data.Text qualified as T
@@ -24,6 +29,23 @@ import Language.GraphQL.Draft.Printer qualified as GPrinter
 import Language.GraphQL.Draft.Syntax qualified as G
 import Text.Builder qualified as TB
 
+-- | Like 'hashMapCodec', but with case-insensitive keys.
+caseInsensitiveHashMapCodec ::
+  forall k a.
+  (CI.FoldCase k, Hashable k, FromJSONKey k, ToJSONKey k) =>
+  JSONCodec a ->
+  JSONCodec (M.HashMap (CI.CI k) a)
+caseInsensitiveHashMapCodec elemCodec =
+  dimapCodec
+    (mapKeys CI.mk)
+    (mapKeys CI.original)
+    $ hashMapCodec elemCodec
+
+-- | Codec for case-insensitive strings / text. The underlying value may be
+-- @Text@ or another type that implements @FoldCase@ and @HasCodec@.
+caseInsensitiveTextCodec :: forall a. (CI.FoldCase a, HasCodec a) => JSONCodec (CI.CI a)
+caseInsensitiveTextCodec = dimapCodec CI.mk CI.original codec
+
 -- | Codec for a GraphQL field name
 graphQLFieldNameCodec :: JSONCodec G.Name
 graphQLFieldNameCodec = named "GraphQLName" $ bimapCodec dec enc codec

server/src-lib/Hasura/Base/Instances.hs

@@ -5,6 +5,7 @@
 -- | This module defines all missing instances of third party libraries.
 module Hasura.Base.Instances () where
 
+import Autodocodec qualified as AC
 import Control.Monad.Fix
 import Data.Aeson qualified as J
 import Data.Fixed (Fixed (..))
@@ -102,6 +103,15 @@ instance (GCompare f, GCompare g) => GCompare (Product f g) where
       GGT -> GGT
     GGT -> GGT
 
+--------------------------------------------------------------------------------
+-- HasCodec
+
+instance AC.HasCodec C.CronSchedule where
+  codec =
+    AC.named "CronSchedule" $
+      AC.bimapCodec C.parseCronSchedule C.serializeCronSchedule $
+        AC.codec @Text
+
 --------------------------------------------------------------------------------
 -- JSON
 

server/src-lib/Hasura/Metadata/DTO/Utils.hs

@@ -1,24 +1,16 @@
 -- | Utility functions for use defining autodocodec codecs.
 module Hasura.Metadata.DTO.Utils
-  ( codecNamePrefix,
+  ( boolConstCodec,
+    codecNamePrefix,
+    discriminatorField,
     fromEnvCodec,
-    versionField,
     optionalVersionField,
     typeableName,
+    versionField,
   )
 where
 
 import Autodocodec
-  ( Codec (EqCodec),
-    JSONCodec,
-    ObjectCodec,
-    object,
-    optionalFieldWith',
-    requiredField',
-    requiredFieldWith',
-    scientificCodec,
-    (.=),
-  )
 import Data.Char (isAlphaNum)
 import Data.Scientific (Scientific)
 import Data.Text qualified as T
@@ -27,6 +19,16 @@ import Data.Typeable (Proxy (Proxy), Typeable, typeRep)
 import Hasura.Prelude
 import Hasura.SQL.Tag (HasTag (backendTag), reify)
 
+-- | Map a fixed set of two values to boolean values when serializing. The first
+-- argument is the value to map to @True@, the second is the value to map to
+-- @False@.
+boolConstCodec :: Eq a => a -> a -> JSONCodec a
+boolConstCodec trueCase falseCase =
+  dimapCodec
+    (bool trueCase falseCase)
+    (== trueCase)
+    $ codec @Bool
+
 -- | Defines a required object field named @version@ that must have the given
 -- integer value. On serialization the field will have the given value
 -- automatically. On deserialization parsing will fail unless the field has the
@@ -46,6 +48,13 @@ optionalVersionField v =
   where
     n = fromInteger v
 
+-- | Useful in an object codec for a field that indicates the type of the
+-- object within a union.
+discriminatorField :: Text -> Text -> ObjectCodec () ()
+discriminatorField name value =
+  dimapCodec (const ()) (const value) $
+    requiredFieldWith' name (literalTextCodec value)
+
 -- | Provides a title-cased name for a database kind, inferring the appropriate
 -- database kind from type context.
 codecNamePrefix :: forall b. (HasTag b) => Text

server/src-lib/Hasura/RQL/DDL/Headers.hs

@@ -6,7 +6,7 @@ module Hasura.RQL.DDL.Headers
   )
 where
 
-import Autodocodec (HasCodec (codec), dimapCodec, disjointEitherCodec, requiredField')
+import Autodocodec (HasCodec (codec), bimapCodec, disjointEitherCodec, requiredField')
 import Autodocodec qualified as AC
 import Data.Aeson
 import Data.CaseInsensitive qualified as CI
@@ -34,19 +34,9 @@ instance NFData HeaderValue
 instance Hashable HeaderValue
 
 instance HasCodec HeaderConf where
-  codec =
+  codec = bimapCodec dec enc $ disjointEitherCodec valCodec fromEnvCodec
-    dimapCodec
-      ( either
-          (\(name, value) -> HeaderConf name (HVValue value))
-          (\(name, value) -> HeaderConf name (HVEnv value))
-      )
-      ( \case
-          HeaderConf name (HVValue value) -> Left (name, value)
-          HeaderConf name (HVEnv value) -> Right (name, value)
-      )
-      $ disjointEitherCodec valueCodec fromEnvCodec
     where
-      valueCodec =
+      valCodec =
         AC.object "HeaderConfValue" $
           (,)
             <$> requiredField' "name" AC..= fst
@@ -58,6 +48,15 @@ instance HasCodec HeaderConf where
             <$> requiredField' "name" AC..= fst
             <*> requiredField' "value_from_env" AC..= snd
 
+      dec (Left (name, value)) = Right $ HeaderConf name (HVValue value)
+      dec (Right (name, valueFromEnv)) =
+        if T.isPrefixOf "HASURA_GRAPHQL_" valueFromEnv
+          then Left $ "env variables starting with \"HASURA_GRAPHQL_\" are not allowed in value_from_env: " <> T.unpack valueFromEnv
+          else Right $ HeaderConf name (HVEnv valueFromEnv)
+
+      enc (HeaderConf name (HVValue val)) = Left (name, val)
+      enc (HeaderConf name (HVEnv val)) = Right (name, val)
+
 instance FromJSON HeaderConf where
   parseJSON (Object o) = do
     name <- o .: "name"

server/src-lib/Hasura/RQL/DDL/Webhook/Transform.hs

@@ -55,6 +55,8 @@ where
 
 -------------------------------------------------------------------------------
 
+import Autodocodec (HasCodec, dimapCodec, disjointEitherCodec, optionalField', optionalFieldWithDefault')
+import Autodocodec qualified as AC
 import Control.Lens (Lens', lens, set, traverseOf, view)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson.Extended ((.!=), (.:?), (.=), (.=?))
@@ -65,6 +67,7 @@ import Data.Functor.Barbie (AllBF, ApplicativeB, ConstraintsB, FunctorB, Travers
 import Data.Functor.Barbie qualified as B
 import Data.Text.Encoding qualified as TE
 import Data.Validation qualified as V
+import Hasura.Metadata.DTO.Utils (optionalVersionField, versionField)
 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
@@ -75,7 +78,7 @@ 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.RQL.DDL.Webhook.Transform.WithOptional (WithOptional (..), withOptional, withOptionalField')
 import Hasura.Session (SessionVariables)
 import Network.HTTP.Client.Transformable qualified as HTTP
 
@@ -95,6 +98,46 @@ data RequestTransform = RequestTransform
   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 = Aeson.withObject "RequestTransform" \o -> do
     version <- o .:? "version" .!= V1
@@ -328,6 +371,37 @@ data MetadataResponseTransform = MetadataResponseTransform
   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 = Aeson.withObject "MetadataResponseTransform" $ \o -> do
     mrtVersion <- o .:? "version" .!= V1

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Body.hs

@@ -14,6 +14,7 @@ where
 
 -------------------------------------------------------------------------------
 
+import Autodocodec (HasCodec, codec, dimapCodec, disjointEitherCodec, object, requiredField', (.=))
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as J
 import Data.ByteString (ByteString)
@@ -24,6 +25,7 @@ import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
 import Data.Validation (Validation)
 import Data.Validation qualified as V
+import Hasura.Metadata.DTO.Utils (discriminatorField)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Webhook.Transform.Class
   ( Template (..),
@@ -153,6 +155,36 @@ escapeURIBS =
     . 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"

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Class.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -25,6 +26,7 @@ where
 
 -------------------------------------------------------------------------------
 
+import Autodocodec (HasCodec (codec), dimapCodec, stringConstCodec)
 import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
 import Data.Aeson qualified as J
 import Data.ByteString (ByteString)
@@ -105,6 +107,9 @@ data TemplatingEngine
   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 =
@@ -135,6 +140,9 @@ newtype Template = Template
   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)
 
@@ -155,6 +163,9 @@ newtype UnescapedTemplate = UnescapedTemplate
   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)
 

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Headers.hs

@@ -14,6 +14,8 @@ 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
@@ -71,6 +73,9 @@ newtype HeadersTransformFn
   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
@@ -132,6 +137,16 @@ validateHeadersTransformFn engine = \case
     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 M.toList M.fromList $ caseInsensitiveHashMapCodec codec
+      removeCodec = listCodec caseInsensitiveTextCodec
+
 instance FromJSON AddReplaceOrRemoveFields where
   parseJSON = J.withObject "AddReplaceRemoveFields" $ \o -> do
     addOrReplaceHeadersTxt <- o J..:? "add_headers" J..!= mempty

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Method.hs

@@ -11,6 +11,8 @@ 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
@@ -35,6 +37,9 @@ newtype Method = Method (CI.CI T.Text)
   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
 
@@ -68,6 +73,9 @@ newtype MethodTransformFn
   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'.
 --

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/QueryParams.hs

@@ -12,6 +12,7 @@ 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 M
@@ -123,6 +124,18 @@ validateQueryParamsTransformFn engine = \case
     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 $ M.toList qps
+      dec (Right template) = ParamTemplate template
+
+      enc (AddOrReplace addOrReplace) = Left $ M.fromList addOrReplace
+      enc (ParamTemplate template) = Right template
+
 instance J.ToJSON QueryParamsTransformFn where
   toJSON (AddOrReplace addOrReplace) = J.toJSON $ M.fromList addOrReplace
   toJSON (ParamTemplate template) = J.toJSON template

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/Url.hs

@@ -9,6 +9,7 @@ where
 
 -------------------------------------------------------------------------------
 
+import Autodocodec (HasCodec (codec), dimapCodec)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as J
 import Data.Text qualified as T
@@ -62,6 +63,9 @@ newtype UrlTransformFn
   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'.
 --

server/src-lib/Hasura/RQL/DDL/Webhook/Transform/WithOptional.hs

@@ -2,11 +2,14 @@
 module Hasura.RQL.DDL.Webhook.Transform.WithOptional
   ( WithOptional (..),
     withOptional,
+    withOptionalField',
+    withOptionalFieldWith',
   )
 where
 
 -------------------------------------------------------------------------------
 
+import Autodocodec (HasCodec (codec), ObjectCodec, ValueCodec, dimapCodec, optionalFieldWith')
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Coerce (Coercible)
 import Hasura.Prelude
@@ -44,3 +47,26 @@ withOptional ::
   Maybe a ->
   WithOptional f b
 withOptional = coerce
+
+-- | Define a field in an object codec that applies 'withOptional' when
+-- decoding, and applies 'getOptional' when encoding.
+withOptionalField' ::
+  forall a b f.
+  (Coercible a (f b), HasCodec a) =>
+  Text ->
+  ObjectCodec (WithOptional f b) (WithOptional f b)
+withOptionalField' name = withOptionalFieldWith' name (codec @a)
+
+-- | Define a field in an object codec that applies 'withOptional' when
+-- decoding, and applies 'getOptional' when encoding.
+--
+-- This version takes a codec for the underlying value type as an argument.
+withOptionalFieldWith' ::
+  forall a b f.
+  Coercible a (f b) =>
+  Text ->
+  ValueCodec a a ->
+  ObjectCodec (WithOptional f b) (WithOptional f b)
+withOptionalFieldWith' name aCodec =
+  dimapCodec withOptional (fmap coerce . getOptional) $
+    optionalFieldWith' name aCodec

server/src-lib/Hasura/RQL/Types/Common.hs

@@ -82,7 +82,7 @@ import Hasura.Base.ErrorValue qualified as ErrorValue
 import Hasura.Base.ToErrorValue
 import Hasura.EncJSON
 import Hasura.GraphQL.Schema.Options qualified as Options
-import Hasura.Metadata.DTO.Utils (fromEnvCodec, typeableName)
+import Hasura.Metadata.DTO.Utils (boolConstCodec, fromEnvCodec, typeableName)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Headers ()
 import Language.GraphQL.Draft.Syntax qualified as G
@@ -645,6 +645,9 @@ data TriggerOnReplication
 
 instance NFData TriggerOnReplication
 
+instance HasCodec TriggerOnReplication where
+  codec = boolConstCodec TOREnableTrigger TORDisableTrigger
+
 instance FromJSON TriggerOnReplication where
   parseJSON = withBool "TriggerOnReplication" $ \case
     True -> pure TOREnableTrigger

server/src-lib/Hasura/RQL/Types/EventTrigger.hs

@@ -37,6 +37,8 @@ module Hasura.RQL.Types.EventTrigger
   )
 where
 
+import Autodocodec (HasCodec, codec, dimapCodec, disjointEitherCodec, listCodec, literalTextCodec, optionalField', optionalFieldWithDefault', requiredField')
+import Autodocodec qualified as AC
 import Data.Aeson
 import Data.Aeson.Extended ((.=?))
 import Data.Aeson.TH
@@ -46,6 +48,7 @@ import Data.Text.Extended
 import Data.Text.NonEmpty
 import Data.Time.Clock qualified as Time
 import Database.PG.Query qualified as PG
+import Hasura.Metadata.DTO.Utils (boolConstCodec, codecNamePrefix)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Headers
 import Hasura.RQL.DDL.Webhook.Transform (MetadataResponseTransform, RequestTransform)
@@ -72,6 +75,9 @@ newtype TriggerName = TriggerName {unTriggerName :: NonEmptyText}
       PG.FromCol
     )
 
+instance HasCodec TriggerName where
+  codec = dimapCodec TriggerName unTriggerName codec
+
 triggerNameToTxt :: TriggerName -> Text
 triggerNameToTxt = unNonEmptyText . unTriggerName
 
@@ -88,6 +94,13 @@ deriving instance Backend b => Eq (SubscribeColumns b)
 
 instance Backend b => NFData (SubscribeColumns b)
 
+instance Backend b => HasCodec (SubscribeColumns b) where
+  codec =
+    dimapCodec
+      (either (const SubCStar) SubCArray)
+      (\case SubCStar -> Left "*"; SubCArray cols -> Right cols)
+      $ disjointEitherCodec (literalTextCodec "*") (listCodec codec)
+
 instance Backend b => FromJSON (SubscribeColumns b) where
   parseJSON (String s) = case s of
     "*" -> return SubCStar
@@ -110,6 +123,13 @@ data SubscribeOpSpec (b :: BackendType) = SubscribeOpSpec
 
 instance (Backend b) => NFData (SubscribeOpSpec b)
 
+instance Backend b => HasCodec (SubscribeOpSpec b) where
+  codec =
+    AC.object (codecNamePrefix @b <> "SubscribeOpSpec") $
+      SubscribeOpSpec
+        <$> requiredField' "columns" AC..= sosColumns
+        <*> optionalField' "payload" AC..= sosPayload
+
 instance Backend b => FromJSON (SubscribeOpSpec b) where
   parseJSON = genericParseJSON hasuraJSON {omitNothingFields = True}
 
@@ -137,6 +157,14 @@ data RetryConf = RetryConf
 
 instance NFData RetryConf
 
+instance HasCodec RetryConf where
+  codec =
+    AC.object "RetryConf" $
+      RetryConf
+        <$> requiredField' "num_retries" AC..= rcNumRetries
+        <*> requiredField' "interval_sec" AC..= rcIntervalSec
+        <*> optionalField' "timeout_sec" AC..= rcTimeoutSec
+
 $(deriveJSON hasuraJSON {omitNothingFields = True} ''RetryConf)
 
 data EventHeaderInfo = EventHeaderInfo
@@ -187,6 +215,15 @@ data TriggerOpsDef (b :: BackendType) = TriggerOpsDef
 
 instance Backend b => NFData (TriggerOpsDef b)
 
+instance Backend b => HasCodec (TriggerOpsDef b) where
+  codec =
+    AC.object (codecNamePrefix @b <> "TriggerOpsDef") $
+      TriggerOpsDef
+        <$> optionalField' "insert" AC..= tdInsert
+        <*> optionalField' "update" AC..= tdUpdate
+        <*> optionalField' "delete" AC..= tdDelete
+        <*> optionalField' "enable_manual" AC..= tdEnableManual
+
 instance Backend b => FromJSON (TriggerOpsDef b) where
   parseJSON = genericParseJSON hasuraJSON {omitNothingFields = True}
 
@@ -197,6 +234,9 @@ data EventTriggerCleanupStatus = ETCSPaused | ETCSUnpaused deriving (Show, Eq, G
 
 instance NFData EventTriggerCleanupStatus
 
+instance HasCodec EventTriggerCleanupStatus where
+  codec = boolConstCodec ETCSPaused ETCSUnpaused
+
 instance ToJSON EventTriggerCleanupStatus where
   toJSON = Bool . (ETCSPaused ==)
 
@@ -224,6 +264,17 @@ data AutoTriggerLogCleanupConfig = AutoTriggerLogCleanupConfig
 
 instance NFData AutoTriggerLogCleanupConfig
 
+instance HasCodec AutoTriggerLogCleanupConfig where
+  codec =
+    AC.object "AutoTriggerLogCleanupConfig" $
+      AutoTriggerLogCleanupConfig
+        <$> requiredField' "schedule" AC..= _atlccSchedule
+        <*> optionalFieldWithDefault' "batch_size" 10000 AC..= _atlccBatchSize
+        <*> requiredField' "clear_older_than" AC..= _atlccClearOlderThan
+        <*> optionalFieldWithDefault' "timeout" 60 AC..= _atlccTimeout
+        <*> optionalFieldWithDefault' "clean_invocation_logs" False AC..= _atlccCleanInvocationLogs
+        <*> optionalFieldWithDefault' "paused" ETCSUnpaused AC..= _atlccPaused
+
 instance FromJSON AutoTriggerLogCleanupConfig where
   parseJSON =
     withObject "AutoTriggerLogCleanupConfig" $ \o -> do
@@ -341,6 +392,21 @@ data EventTriggerConf (b :: BackendType) = EventTriggerConf
   }
   deriving (Show, Eq, Generic)
 
+instance (Backend b) => HasCodec (EventTriggerConf b) where
+  codec =
+    AC.object (codecNamePrefix @b <> "EventTriggerConfEventTriggerConf") $
+      EventTriggerConf
+        <$> requiredField' "name" AC..= etcName
+        <*> requiredField' "definition" AC..= etcDefinition
+        <*> optionalField' "webhook" AC..= etcWebhook
+        <*> optionalField' "webhook_from_env" AC..= etcWebhookFromEnv
+        <*> requiredField' "retry_conf" AC..= etcRetryConf
+        <*> optionalField' "headers" AC..= etcHeaders
+        <*> optionalField' "request_transform" AC..= etcRequestTransform
+        <*> optionalField' "response_transform" AC..= etcResponseTransform
+        <*> optionalField' "cleanup_config" AC..= etcCleanupConfig
+        <*> optionalFieldWithDefault' "trigger_on_replication" (defaultTriggerOnReplication @b) AC..= etcTriggerOnReplication
+
 instance Backend b => FromJSON (EventTriggerConf b) where
   parseJSON = withObject "EventTriggerConf" \o -> do
     name <- o .: "name"

server/src-test/Hasura/RQL/DDL/Webhook/TransformSpec.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Hasura.RQL.DDL.Webhook.TransformSpec (spec) where
+
+import Autodocodec (HasCodec, parseJSONViaCodec, toJSONViaCodec)
+import Data.Aeson (FromJSON, ToJSON, Value, fromJSON, toJSON)
+import Data.Aeson.QQ (aesonQQ)
+import Data.Aeson.Types (parse, parseEither)
+import Data.CaseInsensitive qualified as CI
+import Hasura.Prelude
+import Hasura.RQL.DDL.Webhook.Transform (RequestFields (..), RequestTransform (..), WithOptional (getOptional))
+import Hasura.RQL.DDL.Webhook.Transform.Body (BodyTransformFn (..), TransformFn (BodyTransformFn_))
+import Hasura.RQL.DDL.Webhook.Transform.Class (Template (..), UnescapedTemplate (..))
+import Hasura.RQL.DDL.Webhook.Transform.Headers
+  ( AddReplaceOrRemoveFields (..),
+    HeadersTransformFn (..),
+    TransformFn (..),
+  )
+import Test.Hspec
+
+v2Input :: Value
+v2Input =
+  [aesonQQ|{
+      version: 2,
+      method: "get",
+      url: "https://test.com/webhook",
+      query_params: {
+        secret: "hunter2",
+        limit: "4"
+      },
+      request_headers: {
+        add_headers: {
+          authorization: "Bearer hunter2",
+          "x-power-level": "9000"
+        },
+        remove_headers: ["Cookie"]
+      },
+      body: {
+        action: "transform",
+        template: "{{cats}}"
+      }
+    }|]
+
+v1Input :: Value
+v1Input =
+  [aesonQQ|{
+      version: 1,
+      method: "get",
+      url: "https://test.com/webhook",
+      query_params: {
+        secret: "hunter2",
+        limit: "4"
+      },
+      request_headers: {
+        add_headers: {
+          authorization: "Bearer hunter2",
+          "x-power-level": "9000"
+        },
+        remove_headers: ["Cookie"]
+      },
+      body: "{{cats}}"
+    }|]
+
+v2Parsed :: Either String RequestTransform
+v2Parsed = parseEither (parseJSONViaCodec @RequestTransform) v2Input
+
+v1Parsed :: Either String RequestTransform
+v1Parsed = parseEither (parseJSONViaCodec @RequestTransform) v1Input
+
+spec :: Spec
+spec = do
+  describe "Webhook Transform" do
+    it "should serialize v2 equivalently with codecs or with Aeson" do
+      shouldRoundTripEquivalentlyToJSON @RequestTransform v2Input
+
+    it "should serialize v1 equivalently with codecs or with Aeson" do
+      shouldRoundTripEquivalentlyToJSON @RequestTransform v1Input
+
+    it "parses request headers" do
+      let expected =
+            AddReplaceOrRemoveFields
+              { addOrReplaceHeaders =
+                  [ (CI.mk "Authorization", UnescapedTemplate "Bearer hunter2"),
+                    (CI.mk "X-Power-Level", UnescapedTemplate "9000")
+                  ],
+                removeHeaders = ["Cookie"]
+              }
+      let headers = collapseOptional $ getOptional . requestHeaders . requestFields <$> v2Parsed
+      (sortOn fst . addOrReplaceHeaders . coerce <$> headers) `shouldBe` (Right (addOrReplaceHeaders expected))
+      (sort . removeHeaders . coerce <$> headers) `shouldBe` (Right (removeHeaders expected))
+
+    it "parses v1 body" do
+      let expected = BodyTransformFn_ $ ModifyAsJSON $ Template "{{cats}}"
+      let actualBody = collapseOptional $ getOptional . body . requestFields <$> v1Parsed
+      actualBody `shouldBe` Right expected
+
+    it "parses v2 body" do
+      let expected = BodyTransformFn_ $ ModifyAsJSON $ Template "{{cats}}"
+      let actualBody = collapseOptional $ getOptional . body . requestFields <$> v2Parsed
+      actualBody `shouldBe` Right expected
+
+shouldRoundTripEquivalentlyToJSON :: forall a. (Eq a, HasCodec a, FromJSON a, ToJSON a, Show a) => Value -> Expectation
+shouldRoundTripEquivalentlyToJSON input = do
+  decodedViaCodec `shouldBe` decodedViaJSON
+  encodedViaCodec `shouldBe` encodedViaJSON
+  where
+    decodedViaCodec = parse (parseJSONViaCodec @a) input
+    decodedViaJSON = fromJSON @a input
+    encodedViaCodec = toJSONViaCodec <$> decodedViaCodec
+    encodedViaJSON = toJSON <$> decodedViaJSON
+
+collapseOptional :: Either String (Maybe a) -> Either String a
+collapseOptional (Right (Just val)) = Right val
+collapseOptional (Right Nothing) = Left "Got @Nothing@"
+collapseOptional (Left e) = Left e