{-# 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 Control.Monad.Except (throwError) import Data.Morpheus.Internal.Utils ( selectOr, ) import Data.Morpheus.Types.Internal.AST ( Argument (..), Directive (..), DirectiveDefinition (..), DirectiveLocation (..), Directives, FieldName, Ref (..), ScalarValue (..), Schema (..), VALID, Value (..), at, msg, ) import Data.Morpheus.Types.Internal.Validation ( Validator, ValidatorContext (schema), selectKnown, selectRequired, setDirective, withScope, ) import Data.Morpheus.Validation.Internal.Arguments ( ArgumentsConstraints, validateDirectiveArguments, ) import Relude validateDirectives :: ArgumentsConstraints ctx schemaS s => DirectiveLocation -> Directives s -> Validator schemaS ctx (Directives VALID) validateDirectives :: forall ctx (schemaS :: Stage) (s :: Stage). ArgumentsConstraints ctx schemaS s => DirectiveLocation -> Directives s -> Validator schemaS ctx (Directives VALID) validateDirectives DirectiveLocation location = forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (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 :: forall c (schemaS :: Stage) (s :: Stage). ArgumentsConstraints c schemaS s => DirectiveLocation -> Directive s -> Validator schemaS c (Directive VALID) validate DirectiveLocation location directive :: Directive s directive@Directive {Arguments s Position FieldName 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 ..} = forall (s :: Stage) c (m :: * -> *) b. MonadReader (ValidatorContext s c) m => (Scope -> Scope) -> m b -> m b withScope (forall (s :: Stage). Directive s -> Scope -> Scope setDirective Directive s directive) forall a b. (a -> b) -> a -> b $ do DirectivesDefinition schemaS directiveDefinitions <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks (forall (s :: Stage). Schema s -> DirectivesDefinition s directiveDefinitions forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema) DirectiveDefinition schemaS directiveDef <- forall k (c :: * -> *) sel ctx a (s :: Stage). (IsMap k c, Unknown sel ctx, KeyOf k sel) => sel -> c a -> Validator s ctx a selectKnown Directive s directive DirectivesDefinition schemaS directiveDefinitions forall (s :: Stage). Position -> FieldName -> Arguments s -> Directive s Directive Position directivePosition FieldName directiveName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ( 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> 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 :: forall (s :: Stage) (s' :: Stage) (schemaS :: Stage) ctx. 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 forall (f :: * -> *) a. (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool `elem` [DirectiveLocation] directiveDefinitionLocations = forall (f :: * -> *) a. Applicative f => a -> f a pure () | Bool otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ (GQLError "Directive " forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg FieldName directiveName forall a. Semigroup a => a -> a -> a <> GQLError " may not to be used on " forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg DirectiveLocation loc) GQLError -> Position -> GQLError `at` Position directivePosition directiveFulfilled :: Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled :: forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled Bool target = forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True) (forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> Directive s -> Validator schemaS ctx Bool argumentIf Bool target) shouldIncludeSelection :: Directives VALID -> Validator schemaS ctx Bool shouldIncludeSelection :: forall (schemaS :: Stage) ctx. Directives VALID -> Validator schemaS ctx Bool shouldIncludeSelection Directives VALID directives = do Bool doNotSkip <- forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled Bool False FieldName "skip" Directives VALID directives Bool include <- forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> FieldName -> Directives s -> Validator schemaS ctx Bool directiveFulfilled Bool True FieldName "include" Directives VALID directives forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool doNotSkip Bool -> Bool -> Bool && Bool include) argumentIf :: Bool -> Directive s -> Validator schemaS ctx Bool argumentIf :: forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> Directive s -> Validator schemaS ctx Bool argumentIf Bool target Directive {OrdMap FieldName (Argument s) directiveArgs :: OrdMap FieldName (Argument s) directiveArgs :: forall (s :: Stage). Directive s -> Arguments s directiveArgs, Position directivePosition :: Position directivePosition :: forall (s :: Stage). Directive s -> Position directivePosition} = forall (c :: * -> *) a ctx (s :: Stage). (IsMap FieldName c, MissingRequired (c a) ctx) => Ref FieldName -> c a -> Validator s ctx a selectRequired (forall name. name -> Position -> Ref name Ref FieldName "if" Position directivePosition) OrdMap FieldName (Argument s) directiveArgs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= 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 :: forall (s :: Stage) (schemaS :: Stage) ctx. Bool -> Argument s -> Validator schemaS ctx Bool assertArgument Bool asserted Argument {argumentValue :: forall (valid :: Stage). Argument valid -> Value valid argumentValue = Scalar (Boolean Bool actual)} = forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool asserted 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} = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ ( GQLError "Expected type Boolean!, found " forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg Value s argumentValue forall a. Semigroup a => a -> a -> a <> GQLError "." ) GQLError -> Position -> GQLError `at` Position argumentPosition