{-# 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