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

{-# LANGUAGE PolyKinds #-}

-- | We validate 'TransformFn' terms inside 'RequestTransform' before
-- dispatching Metadata actions in 'runMetadataQueryV1M'. Validation
-- follows the same HKD pattern from 'applyRequestTransform' but using
-- 'btraverseC' to call 'validate' from the 'Transform' class on all
-- the HKD fields.
module Hasura.RQL.DDL.Webhook.Transform.Validation
  ( Unvalidated (..),
    Unvalidated1 (..),
    unUnvalidate,
    unUnvalidate1,
    validateRequestTransform,
    validateTransforms,
  )
where

import Control.Lens (Lens', LensLike, lens, traverseOf)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as J
import Data.Functor.Barbie (FunctorB (bmap), btraverseC)
import Data.Functor.Compose (Compose (..))
import Data.Kind
import Data.Validation (Validation, toEither)
import Hasura.Base.Error (QErr)
import Hasura.EncJSON (EncJSON, encJFromJValue)
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform
import Hasura.RQL.DDL.Webhook.Transform.Body (validateBodyTransformFn)
import Hasura.RQL.DDL.Webhook.Transform.Class

-------------------------------------------------------------------------------

type Tuple1 a b = Compose ((,) a) b

type OptionalTuple1 a b = WithOptional (Tuple1 a b)

-- | A variation on 'RequestTransformFn' where 'TransformFn' is tupled
-- with 'TemplatingEngine'. This is necessary to validate the 'TransformFn'.
--
-- TODO: In the future we most likely want to embed the
-- 'TemplatingEngine' in the 'TransformFn' or the
-- 'Template'/'UnwrappedTemplate', in which case we would not need
-- this alias for validation.
type ValidationFields = RequestFields (OptionalTuple1 TemplatingEngine TransformFn)

-- TODO(SOLOMON): Add lens law unit tests

-- | A lens for zipping our defunctionalized transform with the
-- 'TemplatingEngine' for validation.
transformFns :: Lens' RequestTransform ValidationFields
transformFns = lens getter setter
  where
    getter :: RequestTransform -> ValidationFields
    getter RequestTransform {..} =
      bmap (WithOptional . fmap (Compose . (templateEngine,)) . getOptional) requestFields

    setter :: RequestTransform -> ValidationFields -> RequestTransform
    setter rt requestFields' =
      rt {requestFields = bmap (WithOptional . fmap (snd . getCompose) . getOptional) requestFields'}

-- | Validate all 'TransformFn a' fields in the 'RequestTransform'.
validateRequestTransform ::
  MonadError TransformErrorBundle m =>
  RequestTransform ->
  m RequestTransform
validateRequestTransform reqTransform =
  liftEither $ toEither $ transformFns (btraverseC @Transform validate') reqTransform
  where
    validate' ::
      (Transform a) =>
      OptionalTuple1 TemplatingEngine TransformFn a ->
      Validation TransformErrorBundle (OptionalTuple1 TemplatingEngine TransformFn a)
    validate' = \case
      fn@(WithOptional (Just (Compose (engine, transformFn)))) ->
        fn <$ validate engine transformFn
      fn -> pure fn

-------------------------------------------------------------------------------

-- | Used to annotate that a 'RequestTransform', or some record
-- containing a 'RequestTransform' has not yet been validated.
newtype Unvalidated a = Unvalidated {_unUnvalidate :: a}
  deriving newtype (FromJSON, ToJSON)

-- | A lens for focusing through 'Unvalidated' in 'validateTransforms'.
unUnvalidate :: Lens' (Unvalidated a) a
unUnvalidate = lens _unUnvalidate (\_ a -> Unvalidated a)

-- | Used to annotate that a higher kinded type containing a
-- 'RequestTransform' has not yet been validated.
--
-- This is needed specifically for 'CreateEventTriggerQuery' and any
-- other type that is paramterized by a 'BackendType'.
newtype Unvalidated1 (f :: k -> Type) (a :: k) = Unvalidated1 {_unUnvalidate1 :: f a}
  deriving newtype (FromJSON, ToJSON)

-- | A lens for focusing through 'Unvalidated1' in 'validateTransforms'.
unUnvalidate1 :: Lens' (Unvalidated1 f a) (f a)
unUnvalidate1 = lens _unUnvalidate1 (\_ a -> Unvalidated1 a)

-- | Used to focus into a records in 'RQLMetadataV1' and validate any
-- 'RequestTransform' terms present.
validateTransforms ::
  (MonadError QErr m) =>
  LensLike (Either TransformErrorBundle) api api RequestTransform RequestTransform ->
  LensLike (Either TransformErrorBundle) api api MetadataResponseTransform MetadataResponseTransform ->
  (api -> m EncJSON) ->
  api ->
  m EncJSON
validateTransforms focusRequestTransform focusResponseTransform f q =
  let validationRes = do
        q' <- traverseOf focusRequestTransform validateRequestTransform q
        traverseOf focusResponseTransform validateResponseTransform q'
   in case validationRes of
        Left error' -> pure $ encJFromJValue $ J.toJSON error'
        Right q' -> f q'

validateResponseTransform :: MetadataResponseTransform -> Either TransformErrorBundle MetadataResponseTransform
validateResponseTransform mrt@MetadataResponseTransform {..} =
  case mrtBodyTransform of
    Just bodyTransform -> toEither $ mrt <$ validateBodyTransformFn mrtTemplatingEngine bodyTransform
    Nothing -> pure mrt