{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.Validation.SchemaValidator ( SchemaValidator, TypeSystemContext (..), constraintInterface, renderField, withLocalContext, runSchemaValidator, inInterface, inType, inField, inArgument, ON_INTERFACE, ON_TYPE, TypeEntity (..), Field (..), InterfaceName (..), PLACE, ) where import Control.Monad.Except (throwError) import Data.Morpheus.Ext.Result (GQLResult) import Data.Morpheus.Types.Internal.AST ( ANY, CONST, FieldName, FieldsDefinition, Name, OUT, PropName (PropName), TypeContent (..), TypeDefinition (..), TypeName, mkBaseType, msg, unpackName, ) import Data.Morpheus.Types.Internal.AST.Type (TypeKind (KindObject)) import Data.Morpheus.Types.Internal.AST.TypeSystem (Schema) import Data.Morpheus.Types.Internal.Config (Config) import Data.Morpheus.Types.Internal.Validation (Scope (..), ScopeKind (TYPE), runValidator) import Data.Morpheus.Types.Internal.Validation.Validator ( Validator (..), renderField, withContext, withScope, ) import Relude hiding (local) inInterface :: TypeName -> SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v inInterface :: TypeName -> SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v inInterface TypeName name = TypeName -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath TypeName name (SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v) -> (SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v) -> SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v forall b c a. (b -> c) -> (a -> b) -> a -> c . (TypeEntity 'ON_TYPE -> TypeEntity 'ON_INTERFACE) -> SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (\TypeEntity 'ON_TYPE t -> TypeEntity 'ON_TYPE t {$sel:interfaceName:TypeEntity :: InterfaceName 'ON_INTERFACE interfaceName = TypeName -> InterfaceName 'ON_INTERFACE OnInterface TypeName name}) inType :: TypeName -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v inType :: TypeName -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v inType TypeName name = TypeName -> SchemaValidator () v -> SchemaValidator () v forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath TypeName name (SchemaValidator () v -> SchemaValidator () v) -> (SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v) -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v forall b c a. (b -> c) -> (a -> b) -> a -> c . (() -> TypeEntity 'ON_TYPE) -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (TypeEntity 'ON_TYPE -> () -> TypeEntity 'ON_TYPE forall a b. a -> b -> a const (InterfaceName 'ON_TYPE -> TypeName -> TypeEntity 'ON_TYPE forall (p :: PLACE). InterfaceName p -> TypeName -> TypeEntity p TypeEntity InterfaceName 'ON_TYPE OnType TypeName name)) inField :: FieldName -> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v inField :: FieldName -> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v inField FieldName fieldName = FieldName -> SchemaValidator (TypeEntity p) v -> SchemaValidator (TypeEntity p) v forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath FieldName fieldName (SchemaValidator (TypeEntity p) v -> SchemaValidator (TypeEntity p) v) -> (SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v) -> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v forall b c a. (b -> c) -> (a -> b) -> a -> c . (TypeEntity p -> Field p) -> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (FieldName -> Maybe FieldName -> TypeEntity p -> Field p forall (p :: PLACE). FieldName -> Maybe FieldName -> TypeEntity p -> Field p Field FieldName fieldName Maybe FieldName forall a. Maybe a Nothing) inArgument :: FieldName -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v inArgument :: FieldName -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v inArgument FieldName name = FieldName -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath FieldName name (SchemaValidator (Field p) v -> SchemaValidator (Field p) v) -> (SchemaValidator (Field p) v -> SchemaValidator (Field p) v) -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v forall b c a. (b -> c) -> (a -> b) -> a -> c . (Field p -> Field p) -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (\Field p field -> Field p field {$sel:fieldArgument:Field :: Maybe FieldName fieldArgument = FieldName -> Maybe FieldName forall a. a -> Maybe a Just FieldName name}) data PLACE = ON_INTERFACE | ON_TYPE type ON_INTERFACE = 'ON_INTERFACE type ON_TYPE = 'ON_TYPE data InterfaceName (p :: PLACE) where OnInterface :: TypeName -> InterfaceName 'ON_INTERFACE OnType :: InterfaceName 'ON_TYPE data TypeEntity (p :: PLACE) = TypeEntity { TypeEntity p -> InterfaceName p interfaceName :: InterfaceName p, TypeEntity p -> TypeName typeName :: TypeName } data Field p = Field { Field p -> FieldName fieldName :: FieldName, Field p -> Maybe FieldName fieldArgument :: Maybe FieldName, Field p -> TypeEntity p fieldOf :: TypeEntity p } initialScope :: Scope initialScope :: Scope initialScope = Scope :: Maybe Position -> TypeName -> TypeKind -> TypeWrapper -> FieldName -> ScopeKind -> [PropName] -> Scope Scope { position :: Maybe Position position = Maybe Position forall a. Maybe a Nothing, currentTypeName :: TypeName currentTypeName = TypeName "Root", currentTypeKind :: TypeKind currentTypeKind = Maybe OperationType -> TypeKind KindObject Maybe OperationType forall a. Maybe a Nothing, currentTypeWrappers :: TypeWrapper currentTypeWrappers = TypeWrapper mkBaseType, kind :: ScopeKind kind = ScopeKind TYPE, fieldName :: FieldName fieldName = FieldName "Root", path :: [PropName] path = [] } newtype TypeSystemContext c = TypeSystemContext {TypeSystemContext c -> c local :: c} deriving (Int -> TypeSystemContext c -> ShowS [TypeSystemContext c] -> ShowS TypeSystemContext c -> String (Int -> TypeSystemContext c -> ShowS) -> (TypeSystemContext c -> String) -> ([TypeSystemContext c] -> ShowS) -> Show (TypeSystemContext c) forall c. Show c => Int -> TypeSystemContext c -> ShowS forall c. Show c => [TypeSystemContext c] -> ShowS forall c. Show c => TypeSystemContext c -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TypeSystemContext c] -> ShowS $cshowList :: forall c. Show c => [TypeSystemContext c] -> ShowS show :: TypeSystemContext c -> String $cshow :: forall c. Show c => TypeSystemContext c -> String showsPrec :: Int -> TypeSystemContext c -> ShowS $cshowsPrec :: forall c. Show c => Int -> TypeSystemContext c -> ShowS Show) pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v pushPath Name t name = (Scope -> Scope) -> SchemaValidator a v -> SchemaValidator a v forall (s :: Stage) c (m :: * -> *) b. MonadReader (ValidatorContext s c) m => (Scope -> Scope) -> m b -> m b withScope (\Scope x -> Scope x {path :: [PropName] path = Scope -> [PropName] path Scope x [PropName] -> [PropName] -> [PropName] forall a. Semigroup a => a -> a -> a <> [Text -> PropName PropName (Name t -> Text forall a (t :: NAME). NamePacking a => Name t -> a unpackName Name t name)]}) withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext = (TypeSystemContext a -> TypeSystemContext b) -> SchemaValidator b v -> SchemaValidator a v forall c' c (s :: Stage) a. (c' -> c) -> Validator s c a -> Validator s c' a withContext ((TypeSystemContext a -> TypeSystemContext b) -> SchemaValidator b v -> SchemaValidator a v) -> ((a -> b) -> TypeSystemContext a -> TypeSystemContext b) -> (a -> b) -> SchemaValidator b v -> SchemaValidator a v forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> b) -> TypeSystemContext a -> TypeSystemContext b forall a b. (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal a -> b f TypeSystemContext a ctx = TypeSystemContext a ctx {$sel:local:TypeSystemContext :: b local = a -> b f (TypeSystemContext a -> a forall c. TypeSystemContext c -> c local TypeSystemContext a ctx)} type SchemaValidator c = Validator CONST (TypeSystemContext c) runSchemaValidator :: Validator s (TypeSystemContext ()) a -> Config -> Schema s -> GQLResult a runSchemaValidator :: Validator s (TypeSystemContext ()) a -> Config -> Schema s -> GQLResult a runSchemaValidator Validator s (TypeSystemContext ()) a value Config config Schema s sysSchema = Validator s (TypeSystemContext ()) a -> Config -> Schema s -> Scope -> TypeSystemContext () -> GQLResult a forall (s :: Stage) ctx a. Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a runValidator Validator s (TypeSystemContext ()) a value Config config Schema s sysSchema Scope initialScope TypeSystemContext :: forall c. c -> TypeSystemContext c TypeSystemContext { $sel:local:TypeSystemContext :: () local = () } constraintInterface :: TypeDefinition ANY CONST -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) constraintInterface :: TypeDefinition ANY CONST -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) constraintInterface TypeDefinition { TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName :: TypeName typeName, typeContent :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent = DataInterface FieldsDefinition OUT CONST fields } = (TypeName, FieldsDefinition OUT CONST) -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeName typeName, FieldsDefinition OUT CONST fields) constraintInterface TypeDefinition {TypeName typeName :: TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName} = GQLError -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)) -> GQLError -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) forall a b. (a -> b) -> a -> b $ GQLError "type " GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> TypeName -> GQLError forall a. Msg a => a -> GQLError msg TypeName typeName GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> GQLError " must be an interface"