{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.Validation
  ( Validator,
    SelectionValidator,
    InputValidator,
    BaseValidator,
    InputSource (..),
    OperationContext (..),
    runValidator,
    askType,
    askTypeMember,
    selectRequired,
    selectKnown,
    Constraint (..),
    constraint,
    asksScope,
    selectWithDefaultValue,
    startInput,
    inField,
    inputMessagePrefix,
    checkUnused,
    Prop (..),
    constraintInputUnion,
    ScopeKind (..),
    setDirective,
    inputValueSource,
    askVariables,
    Scope (..),
    MissingRequired (..),
    InputContext,
    Unknown,
    askFragments,
    getOperationType,
    selectType,
    FragmentValidator,
    askInterfaceTypes,
    askTypeDefinitions,
    withScope,
    setPosition,
    setSelection,
    ValidatorContext (..),
  )
where

-- Resolution,

import Control.Monad.Except (throwError)
import Data.Morpheus.Internal.Utils
  ( IsMap,
    KeyOf (..),
    member,
    selectBy,
    selectOr,
    throwErrors,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    FieldContent (..),
    FieldDefinition (..),
    FieldName,
    IN,
    Position (..),
    Ref (..),
    TRUE,
    TypeName,
    Value (..),
    constraintInputUnion,
    fromAny,
    isNullable,
    msg,
    withPath,
  )
import Data.Morpheus.Types.Internal.AST.TypeSystem
import Data.Morpheus.Types.Internal.Validation.Error
  ( KindViolation (..),
    MissingRequired (..),
    Unknown (..),
    Unused (..),
  )
import Data.Morpheus.Types.Internal.Validation.Internal
  ( askInterfaceTypes,
    askType,
    askTypeMember,
    getOperationType,
  )
import Data.Morpheus.Types.Internal.Validation.Validator
import Relude hiding (Constraint)

getUnused :: (KeyOf k b, IsMap k c, Foldable t) => c a -> t b -> [b]
getUnused :: c a -> t b -> [b]
getUnused c a
uses = (b -> Bool) -> [b] -> [b]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (b -> Bool) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> c a -> Bool
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Bool
`member` c a
uses) (k -> Bool) -> (b -> k) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> k
forall k a. KeyOf k a => a -> k
keyOf) ([b] -> [b]) -> (t b -> [b]) -> t b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

failOnUnused :: Unused a => [a] -> Validator s (OperationContext s1 s2) ()
failOnUnused :: [a] -> Validator s (OperationContext s1 s2) ()
failOnUnused [] = () -> Validator s (OperationContext s1 s2) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
failOnUnused (a
x : [a]
xs) = do
  ValidatorContext s (OperationContext s1 s2)
ctx <- ReaderT
  (ValidatorContext s (OperationContext s1 s2))
  GQLResult
  (ValidatorContext s (OperationContext s1 s2))
-> Validator
     s
     (OperationContext s1 s2)
     (ValidatorContext s (OperationContext s1 s2))
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator ReaderT
  (ValidatorContext s (OperationContext s1 s2))
  GQLResult
  (ValidatorContext s (OperationContext s1 s2))
forall r (m :: * -> *). MonadReader r m => m r
ask
  NonEmpty GQLError -> Validator s (OperationContext s1 s2) ()
forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors (NonEmpty GQLError -> Validator s (OperationContext s1 s2) ())
-> NonEmpty GQLError -> Validator s (OperationContext s1 s2) ()
forall a b. (a -> b) -> a -> b
$ (GQLError -> [PropName] -> GQLError
`withPath` Scope -> [PropName]
path (ValidatorContext s (OperationContext s1 s2) -> Scope
forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope ValidatorContext s (OperationContext s1 s2)
ctx)) (GQLError -> GQLError) -> (a -> GQLError) -> a -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OperationContext s1 s2 -> a -> GQLError
forall c (s1 :: Stage) (s2 :: Stage).
Unused c =>
OperationContext s1 s2 -> c -> GQLError
unused (ValidatorContext s (OperationContext s1 s2)
-> OperationContext s1 s2
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext ValidatorContext s (OperationContext s1 s2)
ctx) (a -> GQLError) -> NonEmpty a -> NonEmpty GQLError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

checkUnused ::
  ( KeyOf k b,
    IsMap k c,
    Unused b,
    Foldable t
  ) =>
  c a ->
  t b ->
  Validator s (OperationContext s1 s2) ()
checkUnused :: c a -> t b -> Validator s (OperationContext s1 s2) ()
checkUnused c a
uses = [b] -> Validator s (OperationContext s1 s2) ()
forall a (s :: Stage) (s1 :: Stage) (s2 :: Stage).
Unused a =>
[a] -> Validator s (OperationContext s1 s2) ()
failOnUnused ([b] -> Validator s (OperationContext s1 s2) ())
-> (t b -> [b]) -> t b -> Validator s (OperationContext s1 s2) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c a -> t b -> [b]
forall k b (c :: * -> *) (t :: * -> *) a.
(KeyOf k b, IsMap k c, Foldable t) =>
c a -> t b -> [b]
getUnused c a
uses

constraint ::
  KindViolation k inp =>
  Constraint (k :: TypeCategory) ->
  inp ->
  TypeDefinition ANY s ->
  Validator s ctx (TypeDefinition k s)
constraint :: Constraint k
-> inp
-> TypeDefinition ANY s
-> Validator s ctx (TypeDefinition k s)
constraint Constraint k
IMPLEMENTABLE inp
_ TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields, [TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> [TypeName]
objectImplements :: [TypeName]
..}, Maybe Description
Directives s
TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..} =
  TypeDefinition k s -> Validator s ctx (TypeDefinition k s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE k s
typeContent = DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName] -> FieldsDefinition OUT s -> CondTypeContent OBJECT a s
DataObject {FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields, [TypeName]
objectImplements :: [TypeName]
objectImplements :: [TypeName]
..}, Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..}
constraint Constraint k
IMPLEMENTABLE inp
_ TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface FieldsDefinition OUT s
fields, Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
..} =
  TypeDefinition k s -> Validator s ctx (TypeDefinition k s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE k s
typeContent = FieldsDefinition OUT s -> CondTypeContent IMPLEMENTABLE k s
forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> CondTypeContent IMPLEMENTABLE a s
DataInterface FieldsDefinition OUT s
fields, Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..}
constraint Constraint k
INPUT inp
ctx TypeDefinition ANY s
x = Validator s ctx (TypeDefinition k s)
-> (TypeDefinition k s -> Validator s ctx (TypeDefinition k s))
-> Maybe (TypeDefinition k s)
-> Validator s ctx (TypeDefinition k s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> Validator s ctx (TypeDefinition k s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Constraint IN -> inp -> GQLError
forall (t :: TypeCategory) ctx (c :: TypeCategory -> *).
KindViolation t ctx =>
c t -> ctx -> GQLError
kindViolation Constraint IN
INPUT inp
ctx)) TypeDefinition k s -> Validator s ctx (TypeDefinition k s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition ANY s -> Maybe (TypeDefinition k s)
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
FromCategory a ANY k =>
a ANY s -> Maybe (a k s)
fromAny TypeDefinition ANY s
x)
constraint Constraint k
target inp
ctx TypeDefinition ANY s
_ = GQLError -> Validator s ctx (TypeDefinition k s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Constraint k -> inp -> GQLError
forall (t :: TypeCategory) ctx (c :: TypeCategory -> *).
KindViolation t ctx =>
c t -> ctx -> GQLError
kindViolation Constraint k
target inp
ctx)

selectRequired ::
  ( IsMap FieldName c,
    MissingRequired (c a) ctx
  ) =>
  Ref FieldName ->
  c a ->
  Validator s ctx a
selectRequired :: Ref FieldName -> c a -> Validator s ctx a
selectRequired Ref FieldName
selector c a
container =
  do
    ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
localContext :: ctx
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext} <- ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
-> Validator s ctx (ValidatorContext s ctx)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
    GQLError -> FieldName -> c a -> Validator s ctx a
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy
      (Scope -> ctx -> Ref FieldName -> c a -> GQLError
forall c ctx.
MissingRequired c ctx =>
Scope -> ctx -> Ref FieldName -> c -> GQLError
missingRequired Scope
scope ctx
localContext Ref FieldName
selector c a
container)
      (Ref FieldName -> FieldName
forall k a. KeyOf k a => a -> k
keyOf Ref FieldName
selector)
      c a
container

selectWithDefaultValue ::
  forall ctx c s validValue a.
  ( IsMap FieldName c,
    MissingRequired (c a) ctx
  ) =>
  (Value s -> Validator s ctx validValue) ->
  (a -> Validator s ctx validValue) ->
  FieldDefinition IN s ->
  c a ->
  Validator s ctx validValue
selectWithDefaultValue :: (Value s -> Validator s ctx validValue)
-> (a -> Validator s ctx validValue)
-> FieldDefinition IN s
-> c a
-> Validator s ctx validValue
selectWithDefaultValue
  Value s -> Validator s ctx validValue
f
  a -> Validator s ctx validValue
validateF
  field :: FieldDefinition IN s
field@FieldDefinition
    { FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName,
      Maybe (FieldContent TRUE IN s)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE IN s)
fieldContent
    }
  c a
values =
    Validator s ctx validValue
-> (a -> Validator s ctx validValue)
-> FieldName
-> c a
-> Validator s ctx validValue
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
      (Maybe (FieldContent TRUE IN s) -> Validator s ctx validValue
handleNull Maybe (FieldContent TRUE IN s)
fieldContent)
      a -> Validator s ctx validValue
validateF
      FieldName
fieldName
      c a
values
    where
      ------------------
      handleNull ::
        Maybe (FieldContent TRUE IN s) ->
        Validator s ctx validValue
      handleNull :: Maybe (FieldContent TRUE IN s) -> Validator s ctx validValue
handleNull (Just (DefaultInputValue Value s
value)) = Value s -> Validator s ctx validValue
f Value s
value
      handleNull Maybe (FieldContent TRUE IN s)
Nothing
        | FieldDefinition IN s -> Bool
forall a. Nullable a => a -> Bool
isNullable FieldDefinition IN s
field = Value s -> Validator s ctx validValue
f Value s
forall (stage :: Stage). Value stage
Null
        | Bool
otherwise = Validator s ctx validValue
failSelection
      -----------------
      failSelection :: Validator s ctx validValue
failSelection = do
        ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
localContext :: ctx
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext} <- ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
-> Validator s ctx (ValidatorContext s ctx)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
        Maybe Position
position <- (Scope -> Maybe Position) -> Validator s ctx (Maybe Position)
forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> Maybe Position
position
        GQLError -> Validator s ctx validValue
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Validator s ctx validValue)
-> GQLError -> Validator s ctx validValue
forall a b. (a -> b) -> a -> b
$ Scope -> ctx -> Ref FieldName -> c a -> GQLError
forall c ctx.
MissingRequired c ctx =>
Scope -> ctx -> Ref FieldName -> c -> GQLError
missingRequired Scope
scope ctx
localContext (FieldName -> Position -> Ref FieldName
forall name. name -> Position -> Ref name
Ref FieldName
fieldName (Position -> Maybe Position -> Position
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Position
Position Int
0 Int
0) Maybe Position
position)) c a
values

selectType ::
  TypeName ->
  Validator s ctx (TypeDefinition ANY s)
selectType :: TypeName -> Validator s ctx (TypeDefinition ANY s)
selectType TypeName
name =
  (ValidatorContext s ctx -> Schema s) -> Validator s ctx (Schema s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidatorContext s ctx -> Schema s
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema Validator s ctx (Schema s)
-> (Schema s -> Validator s ctx (TypeDefinition ANY s))
-> Validator s ctx (TypeDefinition ANY s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Validator s ctx (TypeDefinition ANY s)
-> (TypeDefinition ANY s -> Validator s ctx (TypeDefinition ANY s))
-> Maybe (TypeDefinition ANY s)
-> Validator s ctx (TypeDefinition ANY s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> Validator s ctx (TypeDefinition ANY s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err) TypeDefinition ANY s -> Validator s ctx (TypeDefinition ANY s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeDefinition ANY s)
 -> Validator s ctx (TypeDefinition ANY s))
-> (Schema s -> Maybe (TypeDefinition ANY s))
-> Schema s
-> Validator s ctx (TypeDefinition ANY s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name
  where
    err :: GQLError
err = GQLError
"Unknown Type " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"."

selectKnown ::
  ( IsMap k c,
    Unknown sel ctx,
    KeyOf k sel
  ) =>
  sel ->
  c a ->
  Validator s ctx a
selectKnown :: sel -> c a -> Validator s ctx a
selectKnown sel
selector c a
lib =
  do
    ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
localContext :: ctx
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext} <- ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
-> Validator s ctx (ValidatorContext s ctx)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
    GQLError -> k -> c a -> Validator s ctx a
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy
      (Scope -> ctx -> sel -> GQLError
forall ref ctx. Unknown ref ctx => Scope -> ctx -> ref -> GQLError
unknown Scope
scope ctx
localContext sel
selector)
      (sel -> k
forall k a. KeyOf k a => a -> k
keyOf sel
selector)
      c a
lib