2022-03-08 03:42:06 +03:00
|
|
|
{-# LANGUAGE ApplicativeDo #-}
|
|
|
|
|
|
|
|
module Hasura.RQL.DDL.Webhook.Transform.QueryParams
|
|
|
|
( -- * Query transformations
|
|
|
|
QueryParams (..),
|
|
|
|
TransformFn (..),
|
2022-10-16 06:53:13 +03:00
|
|
|
TransformCtx (..),
|
2022-03-23 23:23:46 +03:00
|
|
|
QueryParamsTransformFn (..),
|
2022-03-08 03:42:06 +03:00
|
|
|
)
|
|
|
|
where
|
|
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
import Data.Aeson (FromJSON, ToJSON)
|
2022-03-08 03:42:06 +03:00
|
|
|
import Data.Aeson qualified as J
|
|
|
|
import Data.HashMap.Strict qualified as M
|
2022-03-11 02:22:54 +03:00
|
|
|
import Data.Validation (Validation)
|
2022-03-08 03:42:06 +03:00
|
|
|
import Data.Validation qualified as V
|
|
|
|
import Hasura.Incremental (Cacheable)
|
|
|
|
import Hasura.Prelude
|
|
|
|
import Hasura.RQL.DDL.Webhook.Transform.Class
|
2022-10-16 06:53:13 +03:00
|
|
|
( TemplatingEngine,
|
2022-03-08 03:42:06 +03:00
|
|
|
Transform (..),
|
|
|
|
TransformErrorBundle (..),
|
|
|
|
UnescapedTemplate (..),
|
2022-10-16 06:53:13 +03:00
|
|
|
)
|
|
|
|
import Hasura.RQL.DDL.Webhook.Transform.Request
|
|
|
|
( RequestTransformCtx,
|
2022-03-11 02:22:54 +03:00
|
|
|
runUnescapedRequestTemplateTransform',
|
|
|
|
validateRequestUnescapedTemplateTransform',
|
2022-03-08 03:42:06 +03:00
|
|
|
)
|
|
|
|
import Network.HTTP.Client.Transformable qualified as HTTP
|
|
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
-- | The actual query params we are transforming.
|
2022-03-08 03:42:06 +03:00
|
|
|
--
|
2022-03-23 23:23:46 +03:00
|
|
|
-- This newtype is necessary because otherwise we end up with an
|
2022-03-08 03:42:06 +03:00
|
|
|
-- orphan instance.
|
|
|
|
newtype QueryParams = QueryParams {unQueryParams :: HTTP.Query}
|
|
|
|
|
|
|
|
instance Transform QueryParams where
|
2022-03-23 23:23:46 +03:00
|
|
|
-- 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
|
2022-03-08 03:42:06 +03:00
|
|
|
deriving stock (Show, Eq, Generic)
|
2022-03-23 23:23:46 +03:00
|
|
|
deriving newtype (NFData, Cacheable, FromJSON, ToJSON)
|
|
|
|
|
2022-10-16 06:53:13 +03:00
|
|
|
newtype TransformCtx QueryParams = TransformCtx RequestTransformCtx
|
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
-- NOTE: GHC does not let us attach Haddock documentation to typeclass
|
|
|
|
-- method implementations, so 'applyQueryParamsTransformFn' is defined
|
|
|
|
-- separately.
|
2022-10-16 06:53:13 +03:00
|
|
|
transform (QueryParamsTransformFn_ fn) (TransformCtx reqCtx) = applyQueryParamsTransformFn fn reqCtx
|
2022-03-08 03:42:06 +03:00
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
-- NOTE: GHC does not let us attach Haddock documentation to typeclass
|
|
|
|
-- method implementations, so 'validateQueryParamsTransformFn' is defined
|
|
|
|
-- separately.
|
|
|
|
validate engine (QueryParamsTransformFn_ fn) =
|
|
|
|
validateQueryParamsTransformFn engine fn
|
2022-03-08 03:42:06 +03:00
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
-- | The defunctionalized transformation 'QueryParams'
|
|
|
|
newtype QueryParamsTransformFn
|
|
|
|
= AddOrReplace [(UnescapedTemplate, Maybe UnescapedTemplate)]
|
|
|
|
deriving stock (Eq, Generic, Show)
|
|
|
|
deriving newtype (Cacheable, NFData)
|
|
|
|
|
|
|
|
-- | Provide an implementation for the transformations defined by
|
|
|
|
-- 'QueryParamsTransformFn'.
|
|
|
|
--
|
|
|
|
-- If one views 'QueryParamsTransformFn' as an interface describing HTTP method
|
|
|
|
-- transformations, this can be seen as an implementation of these
|
|
|
|
-- transformations as normal Haskell functions.
|
|
|
|
applyQueryParamsTransformFn ::
|
|
|
|
MonadError TransformErrorBundle m =>
|
|
|
|
QueryParamsTransformFn ->
|
|
|
|
RequestTransformCtx ->
|
|
|
|
QueryParams ->
|
|
|
|
m QueryParams
|
|
|
|
applyQueryParamsTransformFn fn context _oldQueryParams = case fn of
|
|
|
|
AddOrReplace addOrReplaceParams -> do
|
|
|
|
-- NOTE: We use `ApplicativeDo` here to take advantage of Validation's
|
|
|
|
-- applicative sequencing
|
|
|
|
queryParams <- liftEither . V.toEither $
|
|
|
|
for addOrReplaceParams \(rawKey, rawValue) -> do
|
|
|
|
key <- runUnescapedRequestTemplateTransform' context rawKey
|
|
|
|
value <- traverse (runUnescapedRequestTemplateTransform' context) rawValue
|
2022-10-21 21:39:03 +03:00
|
|
|
pure $
|
|
|
|
if key == "null" || value == Just "null"
|
|
|
|
then Nothing
|
|
|
|
else Just (key, value)
|
|
|
|
pure $ QueryParams (catMaybes queryParams)
|
2022-03-23 23:23:46 +03:00
|
|
|
|
|
|
|
-- | Validate that the provided 'QueryParamsTransformFn' 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 'QueryParamsTransformFn'.
|
|
|
|
validateQueryParamsTransformFn ::
|
|
|
|
TemplatingEngine ->
|
|
|
|
QueryParamsTransformFn ->
|
|
|
|
Validation TransformErrorBundle ()
|
|
|
|
validateQueryParamsTransformFn engine = \case
|
|
|
|
AddOrReplace addOrReplaceParams ->
|
|
|
|
-- NOTE: We use `ApplicativeDo` here to take advantage of
|
|
|
|
-- Validation's applicative sequencing
|
|
|
|
for_ addOrReplaceParams \(key, val) -> do
|
2022-03-11 02:22:54 +03:00
|
|
|
validateRequestUnescapedTemplateTransform' engine key
|
|
|
|
traverse_ (validateRequestUnescapedTemplateTransform' engine) val
|
2022-03-23 23:23:46 +03:00
|
|
|
-- NOTE: There's a bug in `ApplicativeDo` which infers a `Monad`
|
|
|
|
-- constraint on this block if it doens't end with `pure ()`
|
2022-03-11 02:22:54 +03:00
|
|
|
pure ()
|
2022-03-23 23:23:46 +03:00
|
|
|
{-# ANN validateQueryParamsTransformFn ("HLint: ignore Redundant pure" :: String) #-}
|
2022-03-11 02:22:54 +03:00
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
instance J.ToJSON QueryParamsTransformFn where
|
|
|
|
toJSON (AddOrReplace addOrReplace) = J.toJSON $ M.fromList addOrReplace
|
2022-03-08 03:42:06 +03:00
|
|
|
|
2022-03-23 23:23:46 +03:00
|
|
|
instance J.FromJSON QueryParamsTransformFn where
|
|
|
|
parseJSON v = AddOrReplace . M.toList <$> J.parseJSON v
|