{-# 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.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 :: (ValidationFields -> f ValidationFields)
-> RequestTransform -> f RequestTransform
transformFns = (RequestTransform -> ValidationFields)
-> (RequestTransform -> ValidationFields -> RequestTransform)
-> Lens
     RequestTransform RequestTransform ValidationFields ValidationFields
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens RequestTransform -> ValidationFields
getter RequestTransform -> ValidationFields -> RequestTransform
setter
  where
    getter :: RequestTransform -> ValidationFields
    getter :: RequestTransform -> ValidationFields
getter RequestTransform {Version
TemplatingEngine
RequestFields (WithOptional TransformFn)
templateEngine :: RequestTransform -> TemplatingEngine
requestFields :: RequestTransform -> RequestFields (WithOptional TransformFn)
version :: RequestTransform -> Version
templateEngine :: TemplatingEngine
requestFields :: RequestFields (WithOptional TransformFn)
version :: Version
..} =
      (forall a.
 WithOptional TransformFn a
 -> OptionalTuple1 TemplatingEngine TransformFn a)
-> RequestFields (WithOptional TransformFn) -> ValidationFields
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (Maybe (Compose ((,) TemplatingEngine) TransformFn a)
-> WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
forall (f :: * -> *) result.
Maybe (f result) -> WithOptional f result
WithOptional (Maybe (Compose ((,) TemplatingEngine) TransformFn a)
 -> WithOptional (Compose ((,) TemplatingEngine) TransformFn) a)
-> (WithOptional TransformFn a
    -> Maybe (Compose ((,) TemplatingEngine) TransformFn a))
-> WithOptional TransformFn a
-> WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransformFn a -> Compose ((,) TemplatingEngine) TransformFn a)
-> Maybe (TransformFn a)
-> Maybe (Compose ((,) TemplatingEngine) TransformFn a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TemplatingEngine, TransformFn a)
-> Compose ((,) TemplatingEngine) TransformFn a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((TemplatingEngine, TransformFn a)
 -> Compose ((,) TemplatingEngine) TransformFn a)
-> (TransformFn a -> (TemplatingEngine, TransformFn a))
-> TransformFn a
-> Compose ((,) TemplatingEngine) TransformFn a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TemplatingEngine
templateEngine,)) (Maybe (TransformFn a)
 -> Maybe (Compose ((,) TemplatingEngine) TransformFn a))
-> (WithOptional TransformFn a -> Maybe (TransformFn a))
-> WithOptional TransformFn a
-> Maybe (Compose ((,) TemplatingEngine) TransformFn a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOptional TransformFn a -> Maybe (TransformFn a)
forall (f :: * -> *) result.
WithOptional f result -> Maybe (f result)
getOptional) RequestFields (WithOptional TransformFn)
requestFields

    setter :: RequestTransform -> ValidationFields -> RequestTransform
    setter :: RequestTransform -> ValidationFields -> RequestTransform
setter RequestTransform
rt ValidationFields
requestFields' =
      RequestTransform
rt {requestFields :: RequestFields (WithOptional TransformFn)
requestFields = (forall a.
 OptionalTuple1 TemplatingEngine TransformFn a
 -> WithOptional TransformFn a)
-> ValidationFields -> RequestFields (WithOptional TransformFn)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (Maybe (TransformFn a) -> WithOptional TransformFn a
forall (f :: * -> *) result.
Maybe (f result) -> WithOptional f result
WithOptional (Maybe (TransformFn a) -> WithOptional TransformFn a)
-> (WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
    -> Maybe (TransformFn a))
-> WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
-> WithOptional TransformFn a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Compose ((,) TemplatingEngine) TransformFn a -> TransformFn a)
-> Maybe (Compose ((,) TemplatingEngine) TransformFn a)
-> Maybe (TransformFn a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TemplatingEngine, TransformFn a) -> TransformFn a
forall a b. (a, b) -> b
snd ((TemplatingEngine, TransformFn a) -> TransformFn a)
-> (Compose ((,) TemplatingEngine) TransformFn a
    -> (TemplatingEngine, TransformFn a))
-> Compose ((,) TemplatingEngine) TransformFn a
-> TransformFn a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose ((,) TemplatingEngine) TransformFn a
-> (TemplatingEngine, TransformFn a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose) (Maybe (Compose ((,) TemplatingEngine) TransformFn a)
 -> Maybe (TransformFn a))
-> (WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
    -> Maybe (Compose ((,) TemplatingEngine) TransformFn a))
-> WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
-> Maybe (TransformFn a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOptional (Compose ((,) TemplatingEngine) TransformFn) a
-> Maybe (Compose ((,) TemplatingEngine) TransformFn a)
forall (f :: * -> *) result.
WithOptional f result -> Maybe (f result)
getOptional) ValidationFields
requestFields'}

-- | Validate all 'TransformFn a' fields in the 'RequestTransform'.
validateRequestTransform ::
  MonadError TransformErrorBundle m =>
  RequestTransform ->
  m RequestTransform
validateRequestTransform :: RequestTransform -> m RequestTransform
validateRequestTransform RequestTransform
reqTransform =
  Either TransformErrorBundle RequestTransform -> m RequestTransform
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either TransformErrorBundle RequestTransform
 -> m RequestTransform)
-> Either TransformErrorBundle RequestTransform
-> m RequestTransform
forall a b. (a -> b) -> a -> b
$ Validation TransformErrorBundle RequestTransform
-> Either TransformErrorBundle RequestTransform
forall e a. Validation e a -> Either e a
toEither (Validation TransformErrorBundle RequestTransform
 -> Either TransformErrorBundle RequestTransform)
-> Validation TransformErrorBundle RequestTransform
-> Either TransformErrorBundle RequestTransform
forall a b. (a -> b) -> a -> b
$ (ValidationFields
 -> Validation TransformErrorBundle ValidationFields)
-> RequestTransform
-> Validation TransformErrorBundle RequestTransform
Lens
  RequestTransform RequestTransform ValidationFields ValidationFields
transformFns ((forall a.
 Transform a =>
 OptionalTuple1 TemplatingEngine TransformFn a
 -> Validation
      TransformErrorBundle
      (OptionalTuple1 TemplatingEngine TransformFn a))
-> ValidationFields
-> Validation TransformErrorBundle ValidationFields
forall k (c :: k -> Constraint) (b :: (k -> *) -> *) (f :: k -> *)
       (g :: k -> *) (e :: * -> *).
(TraversableB b, ConstraintsB b, AllB c b, Applicative e) =>
(forall (a :: k). c a => f a -> e (g a)) -> b f -> e (b g)
btraverseC @Transform forall a.
Transform a =>
OptionalTuple1 TemplatingEngine TransformFn a
-> Validation
     TransformErrorBundle
     (OptionalTuple1 TemplatingEngine TransformFn a)
validate') RequestTransform
reqTransform
  where
    validate' ::
      (Transform a) =>
      OptionalTuple1 TemplatingEngine TransformFn a ->
      Validation TransformErrorBundle (OptionalTuple1 TemplatingEngine TransformFn a)
    validate' :: OptionalTuple1 TemplatingEngine TransformFn a
-> Validation
     TransformErrorBundle
     (OptionalTuple1 TemplatingEngine TransformFn a)
validate' = \case
      fn :: OptionalTuple1 TemplatingEngine TransformFn a
fn@(WithOptional (Just (Compose (TemplatingEngine
engine, TransformFn a
transformFn)))) ->
        OptionalTuple1 TemplatingEngine TransformFn a
fn OptionalTuple1 TemplatingEngine TransformFn a
-> Validation TransformErrorBundle ()
-> Validation
     TransformErrorBundle
     (OptionalTuple1 TemplatingEngine TransformFn a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TemplatingEngine
-> TransformFn a -> Validation TransformErrorBundle ()
forall a.
Transform a =>
TemplatingEngine
-> TransformFn a -> Validation TransformErrorBundle ()
validate TemplatingEngine
engine TransformFn a
transformFn
      OptionalTuple1 TemplatingEngine TransformFn a
fn -> OptionalTuple1 TemplatingEngine TransformFn a
-> Validation
     TransformErrorBundle
     (OptionalTuple1 TemplatingEngine TransformFn a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure OptionalTuple1 TemplatingEngine TransformFn a
fn

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

-- | Used to annotate that a 'RequestTransform', or some record
-- containing a 'RequestTransform' has not yet been validated.
newtype Unvalidated a = Unvalidated {Unvalidated a -> a
_unUnvalidate :: a}
  deriving newtype (Value -> Parser [Unvalidated a]
Value -> Parser (Unvalidated a)
(Value -> Parser (Unvalidated a))
-> (Value -> Parser [Unvalidated a]) -> FromJSON (Unvalidated a)
forall a. FromJSON a => Value -> Parser [Unvalidated a]
forall a. FromJSON a => Value -> Parser (Unvalidated a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Unvalidated a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Unvalidated a]
parseJSON :: Value -> Parser (Unvalidated a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Unvalidated a)
FromJSON, [Unvalidated a] -> Value
[Unvalidated a] -> Encoding
Unvalidated a -> Value
Unvalidated a -> Encoding
(Unvalidated a -> Value)
-> (Unvalidated a -> Encoding)
-> ([Unvalidated a] -> Value)
-> ([Unvalidated a] -> Encoding)
-> ToJSON (Unvalidated a)
forall a. ToJSON a => [Unvalidated a] -> Value
forall a. ToJSON a => [Unvalidated a] -> Encoding
forall a. ToJSON a => Unvalidated a -> Value
forall a. ToJSON a => Unvalidated a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Unvalidated a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Unvalidated a] -> Encoding
toJSONList :: [Unvalidated a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Unvalidated a] -> Value
toEncoding :: Unvalidated a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Unvalidated a -> Encoding
toJSON :: Unvalidated a -> Value
$ctoJSON :: forall a. ToJSON a => Unvalidated a -> Value
ToJSON)

-- | A lens for focusing through 'Unvalidated' in 'validateTransforms'.
unUnvalidate :: Lens' (Unvalidated a) a
unUnvalidate :: (a -> f a) -> Unvalidated a -> f (Unvalidated a)
unUnvalidate = (Unvalidated a -> a)
-> (Unvalidated a -> a -> Unvalidated a)
-> Lens (Unvalidated a) (Unvalidated a) a a
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Unvalidated a -> a
forall a. Unvalidated a -> a
_unUnvalidate (\Unvalidated a
_ a
a -> a -> Unvalidated a
forall a. a -> Unvalidated a
Unvalidated a
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 {Unvalidated1 f a -> f a
_unUnvalidate1 :: f a}
  deriving newtype (Value -> Parser [Unvalidated1 f a]
Value -> Parser (Unvalidated1 f a)
(Value -> Parser (Unvalidated1 f a))
-> (Value -> Parser [Unvalidated1 f a])
-> FromJSON (Unvalidated1 f a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
forall k (f :: k -> *) (a :: k).
FromJSON (f a) =>
Value -> Parser [Unvalidated1 f a]
forall k (f :: k -> *) (a :: k).
FromJSON (f a) =>
Value -> Parser (Unvalidated1 f a)
parseJSONList :: Value -> Parser [Unvalidated1 f a]
$cparseJSONList :: forall k (f :: k -> *) (a :: k).
FromJSON (f a) =>
Value -> Parser [Unvalidated1 f a]
parseJSON :: Value -> Parser (Unvalidated1 f a)
$cparseJSON :: forall k (f :: k -> *) (a :: k).
FromJSON (f a) =>
Value -> Parser (Unvalidated1 f a)
FromJSON, [Unvalidated1 f a] -> Value
[Unvalidated1 f a] -> Encoding
Unvalidated1 f a -> Value
Unvalidated1 f a -> Encoding
(Unvalidated1 f a -> Value)
-> (Unvalidated1 f a -> Encoding)
-> ([Unvalidated1 f a] -> Value)
-> ([Unvalidated1 f a] -> Encoding)
-> ToJSON (Unvalidated1 f a)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
[Unvalidated1 f a] -> Value
forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
[Unvalidated1 f a] -> Encoding
forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
Unvalidated1 f a -> Value
forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
Unvalidated1 f a -> Encoding
toEncodingList :: [Unvalidated1 f a] -> Encoding
$ctoEncodingList :: forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
[Unvalidated1 f a] -> Encoding
toJSONList :: [Unvalidated1 f a] -> Value
$ctoJSONList :: forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
[Unvalidated1 f a] -> Value
toEncoding :: Unvalidated1 f a -> Encoding
$ctoEncoding :: forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
Unvalidated1 f a -> Encoding
toJSON :: Unvalidated1 f a -> Value
$ctoJSON :: forall k (f :: k -> *) (a :: k).
ToJSON (f a) =>
Unvalidated1 f a -> Value
ToJSON)

-- | A lens for focusing through 'Unvalidated1' in 'validateTransforms'.
unUnvalidate1 :: Lens' (Unvalidated1 f a) (f a)
unUnvalidate1 :: (f a -> f (f a)) -> Unvalidated1 f a -> f (Unvalidated1 f a)
unUnvalidate1 = (Unvalidated1 f a -> f a)
-> (Unvalidated1 f a -> f a -> Unvalidated1 f a)
-> Lens (Unvalidated1 f a) (Unvalidated1 f a) (f a) (f a)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Unvalidated1 f a -> f a
forall k (f :: k -> *) (a :: k). Unvalidated1 f a -> f a
_unUnvalidate1 (\Unvalidated1 f a
_ f a
a -> f a -> Unvalidated1 f a
forall k (f :: k -> *) (a :: k). f a -> Unvalidated1 f a
Unvalidated1 f a
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 ->
  (api -> m EncJSON) ->
  api ->
  m EncJSON
validateTransforms :: LensLike
  (Either TransformErrorBundle)
  api
  api
  RequestTransform
  RequestTransform
-> (api -> m EncJSON) -> api -> m EncJSON
validateTransforms LensLike
  (Either TransformErrorBundle)
  api
  api
  RequestTransform
  RequestTransform
focus api -> m EncJSON
f api
q =
  case LensLike
  (Either TransformErrorBundle)
  api
  api
  RequestTransform
  RequestTransform
-> LensLike
     (Either TransformErrorBundle)
     api
     api
     RequestTransform
     RequestTransform
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf LensLike
  (Either TransformErrorBundle)
  api
  api
  RequestTransform
  RequestTransform
focus RequestTransform -> Either TransformErrorBundle RequestTransform
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
RequestTransform -> m RequestTransform
validateRequestTransform api
q of
    Left TransformErrorBundle
error' -> EncJSON -> m EncJSON
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> m EncJSON) -> EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$ Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (Value -> EncJSON) -> Value -> EncJSON
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> Value
forall a. ToJSON a => a -> Value
J.toJSON TransformErrorBundle
error'
    Right api
q' -> api -> m EncJSON
f api
q'