{-# 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 :: 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 {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
..} =
  (Scope -> Scope)
-> Validator schemaS c (Directive VALID)
-> Validator schemaS c (Directive VALID)
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (Directive s -> Scope -> Scope
forall (s :: Stage). Directive s -> Scope -> Scope
setDirective 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
    DirectivesDefinition schemaS
directiveDefinitions <- (ValidatorContext schemaS c -> DirectivesDefinition schemaS)
-> Validator schemaS c (DirectivesDefinition schemaS)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Schema schemaS -> DirectivesDefinition schemaS
forall (s :: Stage). Schema s -> DirectivesDefinition s
directiveDefinitions (Schema schemaS -> DirectivesDefinition schemaS)
-> (ValidatorContext schemaS c -> Schema schemaS)
-> ValidatorContext schemaS c
-> DirectivesDefinition schemaS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext schemaS c -> Schema schemaS
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema)
    DirectiveDefinition schemaS
directiveDef <- Directive s
-> DirectivesDefinition schemaS
-> Validator schemaS c (DirectiveDefinition schemaS)
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
    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 =
      GQLError -> Validator schemaS ctx ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Validator schemaS ctx ())
-> GQLError -> Validator schemaS ctx ()
forall a b. (a -> b) -> a -> b
$
        (GQLError
"Directive " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg FieldName
directiveName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" may not to be used on " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> DirectiveLocation -> GQLError
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 :: 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 (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> 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
doNotSkip <- 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
doNotSkip 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 FieldName -> Arguments s -> Validator schemaS ctx (Argument s)
forall (c :: * -> *) a ctx (s :: Stage).
(IsMap FieldName c, MissingRequired (c a) ctx) =>
Ref FieldName -> c a -> Validator s ctx a
selectRequired (FieldName -> Position -> Ref FieldName
forall name. name -> Position -> Ref name
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} =
  GQLError -> Validator schemaS ctx Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Validator schemaS ctx Bool)
-> GQLError -> Validator schemaS ctx Bool
forall a b. (a -> b) -> a -> b
$
    ( GQLError
"Expected type Boolean!, found "
        GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Value s -> GQLError
forall a. Msg a => a -> GQLError
msg Value s
argumentValue
        GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"."
    )
      GQLError -> Position -> GQLError
`at` Position
argumentPosition