{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Validation.Internal.Directive ( shouldIncludeSelection, validateDirectives, ) where import Data.Morpheus.Error.Utils ( validationErrorMessage, ) import Data.Morpheus.Internal.Utils ( Failure (..), selectOr, ) import Data.Morpheus.Types.Internal.AST ( Argument (..), Directive (..), DirectiveDefinition (..), DirectiveLocation (..), Directives, FieldName, Ref (..), ScalarValue (..), Schema (..), VALID, Value (..), msg, ) import Data.Morpheus.Types.Internal.Validation ( Validator, askSchema, selectKnown, selectRequired, withDirective, ) import Data.Morpheus.Validation.Internal.Arguments ( ArgumentsConstraints, validateDirectiveArguments, ) import Relude validateDirectives :: ArgumentsConstraints ctx schemaS s => DirectiveLocation -> Directives s -> Validator schemaS ctx (Directives VALID) validateDirectives :: DirectiveLocation -> Directives s -> Validator schemaS ctx (Directives VALID) validateDirectives DirectiveLocation location = (Directive s -> Validator schemaS ctx (Directive VALID)) -> Directives s -> Validator schemaS ctx (Directives VALID) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (DirectiveLocation -> Directive s -> Validator schemaS ctx (Directive VALID) forall c (schemaS :: Stage) (s :: Stage). ArgumentsConstraints c schemaS s => DirectiveLocation -> Directive s -> Validator schemaS c (Directive VALID) validate DirectiveLocation location) validate :: ArgumentsConstraints c schemaS s => DirectiveLocation -> Directive s -> Validator schemaS c (Directive VALID) validate :: DirectiveLocation -> Directive s -> Validator schemaS c (Directive VALID) validate DirectiveLocation location directive :: Directive s directive@Directive {Position FieldName Arguments s directiveArgs :: forall (s :: Stage). Directive s -> Arguments s directiveName :: forall (s :: Stage). Directive s -> FieldName directivePosition :: forall (s :: Stage). Directive s -> Position directiveArgs :: Arguments s directiveName :: FieldName directivePosition :: Position ..} = Directive s -> Validator schemaS c (Directive VALID) -> Validator schemaS c (Directive VALID) forall (m :: * -> * -> *) (schemaS :: Stage) c (s :: Stage) a. MonadContext m schemaS c => Directive s -> m c a -> m c a withDirective Directive s directive (Validator schemaS c (Directive VALID) -> Validator schemaS c (Directive VALID)) -> Validator schemaS c (Directive VALID) -> Validator schemaS c (Directive VALID) forall a b. (a -> b) -> a -> b $ do Schema {[DirectiveDefinition schemaS] directiveDefinitions :: forall (s :: Stage). Schema s -> [DirectiveDefinition s] directiveDefinitions :: [DirectiveDefinition schemaS] directiveDefinitions} <- Validator schemaS c (Schema schemaS) forall (m :: * -> * -> *) (s :: Stage) c. MonadContext m s c => m c (Schema s) askSchema DirectiveDefinition schemaS directiveDef <- Directive s -> [DirectiveDefinition schemaS] -> Validator schemaS c (DirectiveDefinition schemaS) forall k a c sel ctx (s :: Stage). (Selectable k a c, Unknown c sel ctx, KeyOf k sel) => sel -> c -> Validator s ctx a selectKnown Directive s directive [DirectiveDefinition schemaS] directiveDefinitions Position -> FieldName -> Arguments VALID -> Directive VALID forall (s :: Stage). Position -> FieldName -> Arguments s -> Directive s Directive Position directivePosition FieldName directiveName (Arguments VALID -> Directive VALID) -> Validator schemaS c (Arguments VALID) -> Validator schemaS c (Directive VALID) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ( DirectiveLocation -> Directive s -> DirectiveDefinition schemaS -> Validator schemaS c () forall (s :: Stage) (s' :: Stage) (schemaS :: Stage) ctx. DirectiveLocation -> Directive s -> DirectiveDefinition s' -> Validator schemaS ctx () validateDirectiveLocation DirectiveLocation location Directive s directive DirectiveDefinition schemaS directiveDef Validator schemaS c () -> Validator schemaS c (Arguments VALID) -> Validator schemaS c (Arguments VALID) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> DirectiveDefinition schemaS -> Arguments s -> Validator schemaS c (Arguments VALID) forall ctx (schemaStage :: Stage) (valueStage :: Stage). ArgumentsConstraints ctx schemaStage valueStage => DirectiveDefinition schemaStage -> Arguments valueStage -> Validator schemaStage ctx (Arguments VALID) validateDirectiveArguments DirectiveDefinition schemaS directiveDef Arguments s directiveArgs ) validateDirectiveLocation :: DirectiveLocation -> Directive s -> DirectiveDefinition s' -> Validator schemaS ctx () validateDirectiveLocation :: DirectiveLocation -> Directive s -> DirectiveDefinition s' -> Validator schemaS ctx () validateDirectiveLocation DirectiveLocation loc Directive {FieldName directiveName :: FieldName directiveName :: forall (s :: Stage). Directive s -> FieldName directiveName, Position directivePosition :: Position directivePosition :: forall (s :: Stage). Directive s -> Position directivePosition} DirectiveDefinition {[DirectiveLocation] directiveDefinitionLocations :: forall (s :: Stage). DirectiveDefinition s -> [DirectiveLocation] directiveDefinitionLocations :: [DirectiveLocation] directiveDefinitionLocations} | DirectiveLocation loc DirectiveLocation -> [DirectiveLocation] -> Bool forall (f :: * -> *) a. (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool `elem` [DirectiveLocation] directiveDefinitionLocations = () -> Validator schemaS ctx () forall (f :: * -> *) a. Applicative f => a -> f a pure () | Bool otherwise = ValidationError -> Validator schemaS ctx () forall error (f :: * -> *) v. Failure error f => error -> f v failure (ValidationError -> Validator schemaS ctx ()) -> ValidationError -> Validator schemaS ctx () forall a b. (a -> b) -> a -> b $ Maybe Position -> Message -> ValidationError validationErrorMessage (Position -> Maybe Position forall a. a -> Maybe a Just Position directivePosition) (Message "Directive " Message -> Message -> Message forall a. Semigroup a => a -> a -> a <> FieldName -> Message forall a. Msg a => a -> Message msg FieldName directiveName Message -> Message -> Message forall a. Semigroup a => a -> a -> a <> Message " may not to be used on " Message -> Message -> Message forall a. Semigroup a => a -> a -> a <> DirectiveLocation -> Message forall a. Msg a => a -> Message msg DirectiveLocation loc) directiveFulfilled :: Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled :: Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled Bool target = Validator schemaS ctx Bool -> (Directive s -> Validator schemaS ctx Bool) -> FieldName -> Directives s -> Validator schemaS ctx Bool forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d selectOr (Bool -> Validator schemaS ctx Bool forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True) (Bool -> Directive s -> Validator schemaS ctx Bool forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> Directive s -> Validator schemaS ctx Bool argumentIf Bool target) shouldIncludeSelection :: Directives VALID -> Validator schemaS ctx Bool shouldIncludeSelection :: Directives VALID -> Validator schemaS ctx Bool shouldIncludeSelection Directives VALID directives = do Bool dontSkip <- Bool -> FieldName -> Directives VALID -> Validator schemaS ctx Bool forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled Bool False FieldName "skip" Directives VALID directives Bool include <- Bool -> FieldName -> Directives VALID -> Validator schemaS ctx Bool forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled Bool True FieldName "include" Directives VALID directives Bool -> Validator schemaS ctx Bool forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool dontSkip Bool -> Bool -> Bool && Bool include) argumentIf :: Bool -> Directive s -> Validator schemaS ctx Bool argumentIf :: Bool -> Directive s -> Validator schemaS ctx Bool argumentIf Bool target Directive {Arguments s directiveArgs :: Arguments s directiveArgs :: forall (s :: Stage). Directive s -> Arguments s directiveArgs, Position directivePosition :: Position directivePosition :: forall (s :: Stage). Directive s -> Position directivePosition} = Ref -> Arguments s -> Validator schemaS ctx (Argument s) forall value c ctx (s :: Stage). (Selectable FieldName value c, MissingRequired c ctx) => Ref -> c -> Validator s ctx value selectRequired (FieldName -> Position -> Ref Ref FieldName "if" Position directivePosition) Arguments s directiveArgs Validator schemaS ctx (Argument s) -> (Argument s -> Validator schemaS ctx Bool) -> Validator schemaS ctx Bool forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Bool -> Argument s -> Validator schemaS ctx Bool forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> Argument s -> Validator schemaS ctx Bool assertArgument Bool target assertArgument :: Bool -> Argument s -> Validator schemaS ctx Bool assertArgument :: Bool -> Argument s -> Validator schemaS ctx Bool assertArgument Bool asserted Argument {argumentValue :: forall (valid :: Stage). Argument valid -> Value valid argumentValue = Scalar (Boolean Bool actual)} = Bool -> Validator schemaS ctx Bool forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool asserted Bool -> Bool -> Bool forall a. Eq a => a -> a -> Bool == Bool actual) assertArgument Bool _ Argument {Value s argumentValue :: Value s argumentValue :: forall (valid :: Stage). Argument valid -> Value valid argumentValue, Position argumentPosition :: forall (valid :: Stage). Argument valid -> Position argumentPosition :: Position argumentPosition} = ValidationError -> Validator schemaS ctx Bool forall error (f :: * -> *) v. Failure error f => error -> f v failure (ValidationError -> Validator schemaS ctx Bool) -> ValidationError -> Validator schemaS ctx Bool forall a b. (a -> b) -> a -> b $ Maybe Position -> Message -> ValidationError validationErrorMessage (Position -> Maybe Position forall a. a -> Maybe a Just Position argumentPosition) (Message -> ValidationError) -> Message -> ValidationError forall a b. (a -> b) -> a -> b $ Message "Expected type Boolean!, found " Message -> Message -> Message forall a. Semigroup a => a -> a -> a <> Value s -> Message forall a. Msg a => a -> Message msg Value s argumentValue Message -> Message -> Message forall a. Semigroup a => a -> a -> a <> Message "."