mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 20:41:49 +03:00
4d6604ba08
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
108 lines
3.6 KiB
Haskell
108 lines
3.6 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
|
|
module Hasura.RQL.DDL.Webhook.Transform.Method
|
|
( -- * Method transformations
|
|
Method (..),
|
|
TransformFn (..),
|
|
TransformCtx (..),
|
|
MethodTransformFn (..),
|
|
)
|
|
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
|
|
( TemplatingEngine,
|
|
Transform (..),
|
|
TransformErrorBundle (..),
|
|
)
|
|
import Hasura.RQL.DDL.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)
|
|
|
|
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.
|
|
transform (MethodTransformFn_ fn) (TransformCtx reqCtx) = applyMethodTransformFn fn reqCtx
|
|
|
|
-- NOTE: GHC does not let us attach Haddock documentation to typeclass
|
|
-- method implementations, so 'validateMethodTransformFn' is defined
|
|
-- 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'.
|
|
--
|
|
-- If one views 'MethodTransformFn' as an interface describing HTTP method
|
|
-- transformations, this can be seen as an implementation of these
|
|
-- transformations as normal Haskell functions.
|
|
applyMethodTransformFn ::
|
|
MonadError TransformErrorBundle m =>
|
|
MethodTransformFn ->
|
|
RequestTransformCtx ->
|
|
Method ->
|
|
m Method
|
|
applyMethodTransformFn fn _context _oldMethod = case fn of
|
|
Replace newMethod -> pure newMethod
|
|
|
|
-- | Validate that the provided 'MethodTransformFn' is correct in the context
|
|
-- of a particular 'TemplatingEngine'.
|
|
--
|
|
-- This is a product of the fact that the correctness of a given transformation
|
|
-- may be dependent on zero, one, or more of the templated transformations
|
|
-- encoded within the given 'MethodTransformFn'.
|
|
--
|
|
-- XXX: Do we want to validate the HTTP method verb?
|
|
validateMethodTransformFn ::
|
|
TemplatingEngine ->
|
|
MethodTransformFn ->
|
|
Validation TransformErrorBundle ()
|
|
validateMethodTransformFn _engine = \case
|
|
Replace _method -> pure ()
|