diff options
Diffstat (limited to 'src/Language')
| -rw-r--r-- | src/Language/GraphQL.hs | 12 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 5 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 126 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 84 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 75 | ||||
| -rw-r--r-- | src/Language/GraphQL/Schema.hs | 33 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Definition.hs | 250 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Schema.hs | 59 |
8 files changed, 554 insertions, 90 deletions
diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index fff378d..aef23f0 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -5,11 +5,13 @@ module Language.GraphQL ) where import qualified Data.Aeson as Aeson +import Data.HashMap.Strict (HashMap) import Data.Text (Text) +import Language.GraphQL.AST.Document +import Language.GraphQL.AST.Parser import Language.GraphQL.Error import Language.GraphQL.Execute -import Language.GraphQL.AST.Parser -import qualified Language.GraphQL.Schema as Schema +import Language.GraphQL.Execute.Coerce import Language.GraphQL.Type.Schema import Text.Megaparsec (parse) @@ -19,14 +21,14 @@ graphql :: Monad m => Schema m -- ^ Resolvers. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. -graphql = flip graphqlSubs mempty +graphql = flip graphqlSubs (mempty :: Aeson.Object) -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given -- 'Schema.Resolver's. -graphqlSubs :: Monad m +graphqlSubs :: (Monad m, VariableValue a) => Schema m -- ^ Resolvers. - -> Schema.Subs -- ^ Variable substitution function. + -> HashMap Name a -- ^ Variable substitution function. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. graphqlSubs schema f diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 084ae21..d719912 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -3,7 +3,6 @@ module Language.GraphQL.AST.Core ( Alias , Arguments(..) , Directive(..) - , Document , Field(..) , Fragment(..) , Name @@ -15,15 +14,11 @@ module Language.GraphQL.AST.Core import Data.Int (Int32) import Data.HashMap.Strict (HashMap) -import Data.List.NonEmpty (NonEmpty) import Data.Sequence (Seq) import Data.String (IsString(..)) import Data.Text (Text) import Language.GraphQL.AST (Alias, Name, TypeCondition) --- | GraphQL document is a non-empty list of operations. -type Document = NonEmpty Operation - -- | GraphQL has 3 operation types: queries, mutations and subscribtions. -- -- Currently only queries and mutations are supported. diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index e1bacbc..e21d5de 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -9,42 +9,42 @@ module Language.GraphQL.Execute import qualified Data.Aeson as Aeson import Data.Foldable (find) +import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.Core as AST.Core +import Language.GraphQL.Execute.Coerce import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error import qualified Language.GraphQL.Schema as Schema -import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Definition as Definition import Language.GraphQL.Type.Schema -- | Query error types. data QueryError = OperationNotFound Text | OperationNameRequired + | CoercionError queryError :: QueryError -> Text queryError (OperationNotFound operationName) = Text.unwords ["Operation", operationName, "couldn't be found in the document."] queryError OperationNameRequired = "Missing operation name." +queryError CoercionError = "Coercion error." -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -execute :: Monad m +execute :: (Monad m, VariableValue a) => Schema m -- ^ Resolvers. - -> Schema.Subs -- ^ Variable substitution function. + -> HashMap.HashMap Name a -- ^ Variable substitution function. -> Document -- @GraphQL@ document. -> m Aeson.Value -execute schema subs doc = - maybe transformError (document schema Nothing) - $ Transform.document subs doc - where - transformError = return $ singleError "Schema transformation error." +execute schema = document schema Nothing -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document @@ -52,41 +52,105 @@ execute schema subs doc = -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -executeWithName :: Monad m +executeWithName :: (Monad m, VariableValue a) => Schema m -- ^ Resolvers -> Text -- ^ Operation name. - -> Schema.Subs -- ^ Variable substitution function. + -> HashMap.HashMap Name a -- ^ Variable substitution function. -> Document -- ^ @GraphQL@ Document. -> m Aeson.Value -executeWithName schema operationName subs doc = - maybe transformError (document schema $ Just operationName) - $ Transform.document subs doc - where - transformError = return $ singleError "Schema transformation error." +executeWithName schema operationName = document schema (Just operationName) getOperation :: Maybe Text - -> AST.Core.Document - -> Either QueryError AST.Core.Operation -getOperation Nothing (operation' :| []) = pure operation' + -> Transform.Document + -> Either QueryError Transform.OperationDefinition +getOperation Nothing (Transform.Document (operation' :| []) _) = pure operation' getOperation Nothing _ = Left OperationNameRequired -getOperation (Just operationName) document' - | Just operation' <- find matchingName document' = pure operation' +getOperation (Just operationName) (Transform.Document operations _) + | Just operation' <- find matchingName operations = pure operation' | otherwise = Left $ OperationNotFound operationName where - matchingName (AST.Core.Query (Just name') _) = operationName == name' - matchingName (AST.Core.Mutation (Just name') _) = operationName == name' - matchingName _ = False + matchingName (Transform.OperationDefinition _ name _ _ _) = + name == Just operationName + +lookupInputType + :: Type + -> HashMap.HashMap Name (Definition.TypeDefinition m) + -> Maybe Definition.InputType +lookupInputType (TypeNamed name) types = + case HashMap.lookup name types of + Just (Definition.ScalarTypeDefinition scalarType) -> + Just $ Definition.ScalarInputType scalarType + Just (Definition.EnumTypeDefinition enumType) -> + Just $ Definition.EnumInputType enumType + Just (Definition.InputObjectTypeDefinition objectType) -> + Just $ Definition.ObjectInputType objectType + _ -> Nothing +lookupInputType (TypeList list) types + = Definition.ListInputType + <$> lookupInputType list types +lookupInputType (TypeNonNull (NonNullTypeNamed nonNull)) types = + case HashMap.lookup nonNull types of + Just (Definition.ScalarTypeDefinition scalarType) -> + Just $ Definition.NonNullScalarInputType scalarType + Just (Definition.EnumTypeDefinition enumType) -> + Just $ Definition.NonNullEnumInputType enumType + Just (Definition.InputObjectTypeDefinition objectType) -> + Just $ Definition.NonNullObjectInputType objectType + _ -> Nothing +lookupInputType (TypeNonNull (NonNullTypeList nonNull)) types + = Definition.NonNullListInputType + <$> lookupInputType nonNull types + +coerceVariableValues :: (Monad m, VariableValue a) + => Schema m + -> Transform.OperationDefinition + -> HashMap.HashMap Name a + -> Either QueryError Schema.Subs +coerceVariableValues schema (Transform.OperationDefinition _ _ variables _ _) values = + let referencedTypes = collectReferencedTypes schema + in maybe (Left CoercionError) Right + $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables + where + coerceValue referencedTypes variableDefinition coercedValues = do + let VariableDefinition variableName variableTypeName _defaultValue = + variableDefinition + variableType <- lookupInputType variableTypeName referencedTypes + value <- HashMap.lookup variableName values + coercedValue <- coerceVariableValue variableType value + HashMap.insert variableName coercedValue <$> coercedValues -document :: Monad m +executeRequest :: (Monad m, VariableValue a) => Schema m -> Maybe Text - -> AST.Core.Document + -> HashMap.HashMap Name a + -> Transform.Document + -> Either QueryError (Transform.OperationDefinition, Schema.Subs) +executeRequest schema operationName subs document' = do + operation' <- getOperation operationName document' + coercedValues <- coerceVariableValues schema operation' subs + pure (operation', coercedValues) + +document :: (Monad m, VariableValue a) + => Schema m + -> Maybe Text + -> HashMap.HashMap Name a + -> Document -> m Aeson.Value -document schema operationName document' = - case getOperation operationName document' of - Left error' -> pure $ singleError $ queryError error' - Right operation' -> operation schema operation' +document schema operationName subs document' = + case Transform.document document' of + Just transformed -> executeRequest' transformed + Nothing -> pure $ singleError + "The document doesn't contain any executable operations." + where + transformOperation fragmentTable operation' subs' = + case Transform.operation fragmentTable subs' operation' of + Just operationResult -> operation schema operationResult + Nothing -> pure $ singleError "Schema transformation error." + executeRequest' transformed@(Transform.Document _ fragmentTable) = + case executeRequest schema operationName subs transformed of + Right (operation', subs') -> transformOperation fragmentTable operation' subs' + Left error' -> pure $ singleError $ queryError error' operation :: Monad m => Schema m @@ -96,7 +160,8 @@ operation = schemaOperation where resolve queryFields = runCollectErrs . flip Schema.resolve queryFields - . fields + . fmap getResolver + . Definition.fields lookupError = pure $ singleError "Root operation type couldn't be found in the schema." schemaOperation Schema {query} (AST.Core.Query _ fields') = @@ -105,3 +170,4 @@ operation = schemaOperation resolve fields' mutation schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) = lookupError + getResolver (Definition.Field _ _ _ resolver) = resolver diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs new file mode 100644 index 0000000..5b26faa --- /dev/null +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Types and functions used for input and result coercion. +module Language.GraphQL.Execute.Coerce + ( VariableValue(..) + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import Data.Scientific (toBoundedInteger, toRealFloat) +import Language.GraphQL.AST.Core +import Language.GraphQL.Type.Definition + +-- | Since variables are passed separately from the query, in an independent +-- format, they should be first coerced to the internal representation used by +-- this implementation. +class VariableValue a where + -- | Only a basic, format-specific, coercion must be done here. Type + -- correctness or nullability shouldn't be validated here, they will be + -- validated later. The type information is provided only as a hint. + -- + -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an + -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be + -- coerced to 't:Int` when receiving variables as a JSON object. The same + -- holds for 't:Enum'. There are formats that support enumerations, @JSON@ + -- doesn't, so the type information is given and 'coerceVariableValue' can + -- check that an 't:Enum' is expected and treat the given value + -- appropriately. Even checking whether this value is a proper member of the + -- corresponding 't:Enum' type isn't required here, since this can be + -- checked independently. + -- + -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce + -- integers and strings to @ID@s, so if an @ID@ is received as an integer, + -- it can be left as is and will be coerced later. + -- + -- If a value cannot be coerced without losing information, 'Nothing' should + -- be returned, the coercion will fail then and the query won't be executed. + coerceVariableValue + :: InputType -- ^ Expected type (variable type given in the query). + -> a -- ^ Variable value being coerced. + -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise. + +instance VariableValue Aeson.Value where + coerceVariableValue _ Aeson.Null = Just Null + coerceVariableValue (ScalarInputTypeDefinition scalarType) value + | (Aeson.String stringValue) <- value = Just $ String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue + | (Aeson.Number numberValue) <- value + , (ScalarType "Float" _) <- scalarType = + Just $ Float $ toRealFloat numberValue + | (Aeson.Number numberValue) <- value = -- ID or Int + Int <$> toBoundedInteger numberValue + coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) = + Just $ Enum stringValue + coerceVariableValue (ObjectInputTypeDefinition objectType) value + | (Aeson.Object objectValue) <- value = do + let (InputObjectType _ _ inputFields) = objectType + (newObjectValue, resultMap) <- foldWithKey objectValue inputFields + if HashMap.null newObjectValue + then Just $ Object resultMap + else Nothing + where + foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues + $ Just (objectValue, HashMap.empty) + matchFieldValues _ _ Nothing = Nothing + matchFieldValues fieldName inputField (Just (objectValue, resultMap)) = + let (InputField _ fieldType _) = inputField + insert = flip (HashMap.insert fieldName) resultMap + newObjectValue = HashMap.delete fieldName objectValue + in case HashMap.lookup fieldName objectValue of + Just variableValue -> do + coerced <- coerceVariableValue fieldType variableValue + pure (newObjectValue, insert coerced) + Nothing -> Just (objectValue, resultMap) + coerceVariableValue (ListInputTypeDefinition listType) value + | (Aeson.Array arrayValue) <- value = List + <$> foldr foldVector (Just []) arrayValue + | otherwise = coerceVariableValue listType value + where + foldVector _ Nothing = Nothing + foldVector variableValue (Just list) = do + coerced <- coerceVariableValue listType variableValue + pure $ coerced : list + coerceVariableValue _ _ = Nothing diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 5a9eef8..56b2a22 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -1,25 +1,28 @@ {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} -- | After the document is parsed, before getting executed the AST is -- transformed into a similar, simpler AST. This module is responsible for -- this transformation. module Language.GraphQL.Execute.Transform - ( document + ( Document(..) + , OperationDefinition(..) + , document + , operation ) where -import Control.Arrow (first) import Control.Monad (foldM, unless) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Sequence (Seq, (<|), (><)) import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST.Core as Core -import Language.GraphQL.AST.Document (Definition(..), Document) import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Type.Directive as Directive @@ -34,36 +37,56 @@ type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a liftJust :: forall a. a -> TransformT a liftJust = lift . lift . Just +-- | GraphQL document is a non-empty list of operations. +data Document = Document + (NonEmpty OperationDefinition) + (HashMap Full.Name Full.FragmentDefinition) + +data OperationDefinition = OperationDefinition + Full.OperationType + (Maybe Full.Name) + [Full.VariableDefinition] + [Full.Directive] + Full.SelectionSet + -- | Rewrites the original syntax tree into an intermediate representation used -- for query execution. -document :: Schema.Subs -> Document -> Maybe Core.Document -document subs document' = - flip runReaderT subs - $ evalStateT (collectFragments >> operations operationDefinitions) - $ Replacement HashMap.empty fragmentTable +document :: Full.Document -> Maybe Document +document ast = + let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast + in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable where - (fragmentTable, operationDefinitions) = foldr defragment mempty document' - defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc = - (definition :) <$> acc - defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc = - let (Full.FragmentDefinition name _ _ _) = definition - in first (HashMap.insert name definition) acc + defragment definition (operations, fragments') + | (Full.ExecutableDefinition executable) <- definition + , (Full.DefinitionOperation operation') <- executable = + (transform operation' : operations, fragments') + | (Full.ExecutableDefinition executable) <- definition + , (Full.DefinitionFragment fragment) <- executable + , (Full.FragmentDefinition name _ _ _) <- fragment = + (operations, HashMap.insert name fragment fragments') defragment _ acc = acc + transform = \case + Full.OperationDefinition type' name variables directives' selections -> + OperationDefinition type' name variables directives' selections + Full.SelectionSet selectionSet -> + OperationDefinition Full.Query Nothing mempty mempty selectionSet -- * Operation -operations :: [Full.OperationDefinition] -> TransformT Core.Document -operations operations' = do - coreOperations <- traverse operation operations' - lift . lift $ NonEmpty.nonEmpty coreOperations - -operation :: Full.OperationDefinition -> TransformT Core.Operation -operation (Full.SelectionSet sels) - = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels -operation (Full.OperationDefinition Full.Query name _vars _dirs sels) - = Core.Query name <$> appendSelection sels -operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) - = Core.Mutation name <$> appendSelection sels +operation + :: HashMap Full.Name Full.FragmentDefinition + -> Schema.Subs + -> OperationDefinition + -> Maybe Core.Operation +operation fragmentTable subs operationDefinition = flip runReaderT subs + $ evalStateT (collectFragments >> transform operationDefinition) + $ Replacement HashMap.empty fragmentTable + where + transform :: OperationDefinition -> TransformT Core.Operation + transform (OperationDefinition Full.Query name _ _ sels) = + Core.Query name <$> appendSelection sels + transform (OperationDefinition Full.Mutation name _ _ sels) = + Core.Mutation name <$> appendSelection sels -- * Selection diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index e76b42e..752ce29 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -3,8 +3,7 @@ -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Schema - ( FieldResolver(..) - , Resolver(..) + ( Resolver(..) , Subs , object , resolve @@ -31,21 +30,18 @@ import qualified Data.Text as T import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Trans +import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error -- information (if an error has occurred). @m@ is an arbitrary monad, usually -- 'IO'. -data Resolver m = Resolver Name (FieldResolver m) - -data FieldResolver m - = ValueResolver (ActionT m Aeson.Value) - | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m)))) +data Resolver m = Resolver Name (Definition.FieldResolver m) -- | Converts resolvers to a map. resolversToMap :: (Foldable f, Functor f) => f (Resolver m) - -> HashMap Text (FieldResolver m) + -> HashMap Text (Definition.FieldResolver m) resolversToMap = HashMap.fromList . toList . fmap toKV where toKV (Resolver name r) = (name, r) @@ -57,7 +53,7 @@ type Subs = HashMap Name Value -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m object name = Resolver name - . NestingResolver + . Definition.NestingResolver . fmap (Type.Named . resolversToMap) -- | Like 'object' but can be null or a list of objects. @@ -66,19 +62,19 @@ wrappedObject :: Monad m -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m wrappedObject name = Resolver name - . NestingResolver + . Definition.NestingResolver . (fmap . fmap) resolversToMap -- | A scalar represents a primitive value, like a string or an integer. scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m -scalar name = Resolver name . ValueResolver . fmap Aeson.toJSON +scalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON -- | Like 'scalar' but can be null or a list of scalars. wrappedScalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m (Type.Wrapping a) -> Resolver m -wrappedScalar name = Resolver name . ValueResolver . fmap Aeson.toJSON +wrappedScalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a) resolveFieldValue field@(Field _ _ args _) = @@ -91,11 +87,14 @@ convert Type.Null = Aeson.Null convert (Type.Named value) = value convert (Type.List value) = Aeson.toJSON value -withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object -withField field (ValueResolver resolver) = do +withField :: Monad m + => Field + -> Definition.FieldResolver m + -> CollectErrsT m Aeson.Object +withField field (Definition.ValueResolver resolver) = do answer <- lift $ resolveFieldValue field resolver either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer -withField field@(Field _ _ _ seqSelection) (NestingResolver resolver) = do +withField field@(Field _ _ _ seqSelection) (Definition.NestingResolver resolver) = do answer <- lift $ resolveFieldValue field resolver case answer of Right result -> do @@ -112,7 +111,7 @@ errmsg field errorMessage = do -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. resolve :: Monad m - => HashMap Text (FieldResolver m) + => HashMap Text (Definition.FieldResolver m) -> Seq Selection -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers @@ -122,7 +121,7 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers | (Just resolver) <- lookupResolver name = withField fld resolver | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] tryResolvers (SelectionFragment (Fragment typeCondition selections')) - | Just (ValueResolver resolver) <- lookupResolver "__typename" = do + | Just (Definition.ValueResolver resolver) <- lookupResolver "__typename" = do let fakeField = Field Nothing "__typename" mempty mempty that <- lift $ resolveFieldValue fakeField resolver if Right (Aeson.String typeCondition) == that diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 016eeb8..5891f71 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -1,18 +1,256 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Types representing GraphQL type system. module Language.GraphQL.Type.Definition - ( ObjectType(..) + ( Argument(..) + , EnumType(..) + , Field(..) + , FieldResolver(..) + , InputField(..) + , InputObjectType(..) + , InputType(..) + , ObjectType(..) + , OutputType(..) + , ScalarType(..) + , TypeDefinition(..) + , pattern EnumInputTypeDefinition + , pattern ListInputTypeDefinition + , pattern ObjectInputTypeDefinition + , pattern ScalarInputTypeDefinition + , pattern EnumOutputTypeDefinition + , pattern ListOutputTypeDefinition + , pattern ObjectOutputTypeDefinition + , pattern ScalarOutputTypeDefinition + , boolean + , float + , id + , int + , string ) where +import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) +import Data.Set (Set) import Data.Text (Text) -import Language.GraphQL.Schema - -type Fields m = HashMap Text (FieldResolver m) +import Language.GraphQL.AST.Core (Name, Value) +import Language.GraphQL.Trans +import qualified Language.GraphQL.Type as Type +import Prelude hiding (id) --- | Object Type Definition. +-- | Object type definition. -- -- Almost all of the GraphQL types you define will be object types. Object -- types have a name, but most importantly describe their fields. data ObjectType m = ObjectType { name :: Text - , fields :: Fields m + , fields :: HashMap Name (Field m) } + +-- | Output object field definition. +data Field m = Field + (Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m) + +-- | Resolving a field can result in a leaf value or an object, which is +-- represented as a list of nested resolvers, used to resolve the fields of that +-- object. +data FieldResolver m + = ValueResolver (ActionT m Aeson.Value) + | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m)))) + +-- | Field argument definition. +data Argument = Argument (Maybe Text) InputType (Maybe Value) + +-- | Scalar type definition. +-- +-- The leaf values of any request and input values to arguments are Scalars (or +-- Enums) . +data ScalarType = ScalarType Name (Maybe Text) + +-- | Enum type definition. +-- +-- Some leaf values of requests and input values are Enums. GraphQL serializes +-- Enum values as strings, however internally Enums can be represented by any +-- kind of type, often integers. +data EnumType = EnumType Name (Maybe Text) (Set Text) + +-- | Single field of an 'InputObjectType'. +data InputField = InputField (Maybe Text) InputType (Maybe Value) + +-- | Input object type definition. +-- +-- An input object defines a structured collection of fields which may be +-- supplied to a field argument. +data InputObjectType = InputObjectType + Name (Maybe Text) (HashMap Name InputField) + +-- | These types may be used as input types for arguments and directives. +data InputType + = ScalarInputType ScalarType + | EnumInputType EnumType + | ObjectInputType InputObjectType + | ListInputType InputType + | NonNullScalarInputType ScalarType + | NonNullEnumInputType EnumType + | NonNullObjectInputType InputObjectType + | NonNullListInputType InputType + +-- | These types may be used as output types as the result of fields. +data OutputType m + = ScalarOutputType ScalarType + | EnumOutputType EnumType + | ObjectOutputType (ObjectType m) + | ListOutputType (OutputType m) + | NonNullScalarOutputType ScalarType + | NonNullEnumOutputType EnumType + | NonNullObjectOutputType (ObjectType m) + | NonNullListOutputType (OutputType m) + +-- | These are all of the possible kinds of types. +data TypeDefinition m + = ScalarTypeDefinition ScalarType + | EnumTypeDefinition EnumType + | ObjectTypeDefinition (ObjectType m) + | InputObjectTypeDefinition InputObjectType + +-- | The @String@ scalar type represents textual data, represented as UTF-8 +-- character sequences. The String type is most often used by GraphQL to +-- represent free-form human-readable text. +string :: ScalarType +string = ScalarType "String" (Just description) + where + description = + "The `String` scalar type represents textual data, represented as \ + \UTF-8 character sequences. The String type is most often used by \ + \GraphQL to represent free-form human-readable text." + +-- | The @Boolean@ scalar type represents @true@ or @false@. +boolean :: ScalarType +boolean = ScalarType "Boolean" (Just description) + where + description = "The `Boolean` scalar type represents `true` or `false`." + +-- | The @Int@ scalar type represents non-fractional signed whole numeric +-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\). +int :: ScalarType +int = ScalarType "Int" (Just description) + where + description = + "The `Int` scalar type represents non-fractional signed whole numeric \ + \values. Int can represent values between -(2^31) and 2^31 - 1." + +-- | The @Float@ scalar type represents signed double-precision fractional +-- values as specified by +-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point). +float :: ScalarType +float = ScalarType "Float" (Just description) + where + description = + "The `Float` scalar type represents signed double-precision fractional \ + \values as specified by \ + \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)." + +-- | The @ID@ scalar type represents a unique identifier, often used to refetch +-- an object or as key for a cache. The ID type appears in a JSON response as a +-- String; however, it is not intended to be human-readable. When expected as an +-- input type, any string (such as @"4"@) or integer (such as @4@) input value +-- will be accepted as an ID. +id :: ScalarType +id = ScalarType "ID" (Just description) + where + description = + "The `ID` scalar type represents a unique identifier, often used to \ + \refetch an object or as key for a cache. The ID type appears in a \ + \JSON response as a String; however, it is not intended to be \ + \human-readable. When expected as an input type, any string (such as \ + \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID." + +-- | Matches either 'ScalarInputType' or 'NonNullScalarInputType'. +pattern ScalarInputTypeDefinition :: ScalarType -> InputType +pattern ScalarInputTypeDefinition scalarType <- + (isScalarInputType -> Just scalarType) + +-- | Matches either 'EnumInputType' or 'NonNullEnumInputType'. +pattern EnumInputTypeDefinition :: EnumType -> InputType +pattern EnumInputTypeDefinition enumType <- + (isEnumInputType -> Just enumType) + +-- | Matches either 'ObjectInputType' or 'NonNullObjectInputType'. +pattern ObjectInputTypeDefinition :: InputObjectType -> InputType +pattern ObjectInputTypeDefinition objectType <- + (isObjectInputType -> Just objectType) + +-- | Matches either 'ListInputType' or 'NonNullListInputType'. +pattern ListInputTypeDefinition :: InputType -> InputType +pattern ListInputTypeDefinition listType <- + (isListInputType -> Just listType) + +{-# COMPLETE EnumInputTypeDefinition + , ListInputTypeDefinition + , ObjectInputTypeDefinition + , ScalarInputTypeDefinition + #-} + +pattern ScalarOutputTypeDefinition :: forall m. ScalarType -> OutputType m +pattern ScalarOutputTypeDefinition scalarType <- + (isScalarOutputType -> Just scalarType) + +pattern EnumOutputTypeDefinition :: forall m. EnumType -> OutputType m +pattern EnumOutputTypeDefinition enumType <- + (isEnumOutputType -> Just enumType) + +pattern ObjectOutputTypeDefinition :: forall m. ObjectType m -> OutputType m +pattern ObjectOutputTypeDefinition objectType <- + (isObjectOutputType -> Just objectType) + +pattern ListOutputTypeDefinition :: forall m. OutputType m -> OutputType m +pattern ListOutputTypeDefinition listType <- + (isListOutputType -> Just listType) + +{-# COMPLETE ScalarOutputTypeDefinition + , EnumOutputTypeDefinition + , ObjectOutputTypeDefinition + , ListOutputTypeDefinition + #-} + +isScalarInputType :: InputType -> Maybe ScalarType +isScalarInputType (ScalarInputType inputType) = Just inputType +isScalarInputType (NonNullScalarInputType inputType) = Just inputType +isScalarInputType _ = Nothing + +isObjectInputType :: InputType -> Maybe InputObjectType +isObjectInputType (ObjectInputType inputType) = Just inputType +isObjectInputType (NonNullObjectInputType inputType) = Just inputType +isObjectInputType _ = Nothing + +isEnumInputType :: InputType -> Maybe EnumType +isEnumInputType (EnumInputType inputType) = Just inputType +isEnumInputType (NonNullEnumInputType inputType) = Just inputType +isEnumInputType _ = Nothing + +isListInputType :: InputType -> Maybe InputType +isListInputType (ListInputType inputType) = Just inputType +isListInputType (NonNullListInputType inputType) = Just inputType +isListInputType _ = Nothing + +isScalarOutputType :: forall m. OutputType m -> Maybe ScalarType +isScalarOutputType (ScalarOutputType outputType) = Just outputType +isScalarOutputType (NonNullScalarOutputType outputType) = Just outputType +isScalarOutputType _ = Nothing + +isObjectOutputType :: forall m. OutputType m -> Maybe (ObjectType m) +isObjectOutputType (ObjectOutputType outputType) = Just outputType +isObjectOutputType (NonNullObjectOutputType outputType) = Just outputType +isObjectOutputType _ = Nothing + +isEnumOutputType :: forall m. OutputType m -> Maybe EnumType +isEnumOutputType (EnumOutputType outputType) = Just outputType +isEnumOutputType (NonNullEnumOutputType outputType) = Just outputType +isEnumOutputType _ = Nothing + +isListOutputType :: forall m. OutputType m -> Maybe (OutputType m) +isListOutputType (ListOutputType outputType) = Just outputType +isListOutputType (NonNullListOutputType outputType) = Just outputType +isListOutputType _ = Nothing diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index f830c26..fa44694 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -1,11 +1,68 @@ +{-# LANGUAGE ExplicitForAll #-} + +-- | Schema Definition. module Language.GraphQL.Type.Schema ( Schema(..) + , collectReferencedTypes ) where +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST.Core (Name) import Language.GraphQL.Type.Definition --- | Schema Definition +-- | A Schema is created by supplying the root types of each type of operation, +-- query and mutation (optional). A schema definition is then supplied to the +-- validator and executor. +-- +-- __Note:__ When the schema is constructed, by default only the types that +-- are reachable by traversing the root types are included, other types must +-- be explicitly referenced. data Schema m = Schema { query :: ObjectType m , mutation :: Maybe (ObjectType m) } + +-- | Traverses the schema and finds all referenced types. +collectReferencedTypes :: forall m. Schema m -> HashMap Name (TypeDefinition m) +collectReferencedTypes schema = + let queryTypes = traverseObjectType (query schema) HashMap.empty + in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema + where + collect traverser typeName element foundTypes = + let newMap = HashMap.insert typeName element foundTypes + in maybe (traverser newMap) (const foundTypes) + $ HashMap.lookup typeName foundTypes + visitFields (Field _ outputType arguments _) foundTypes + = traverseOutputType outputType + $ foldr visitArguments foundTypes arguments + visitArguments (Argument _ inputType _) = traverseInputType inputType + visitInputFields (InputField _ inputType _) = traverseInputType inputType + traverseInputType (ObjectInputTypeDefinition objectType) = + let (InputObjectType typeName _ inputFields) = objectType + element = InputObjectTypeDefinition objectType + traverser = flip (foldr visitInputFields) inputFields + in collect traverser typeName element + traverseInputType (ListInputTypeDefinition listType) = + traverseInputType listType + traverseInputType (ScalarInputTypeDefinition scalarType) = + let (ScalarType typeName _) = scalarType + in collect Prelude.id typeName (ScalarTypeDefinition scalarType) + traverseInputType (EnumInputTypeDefinition enumType) = + let (EnumType typeName _ _) = enumType + in collect Prelude.id typeName (EnumTypeDefinition enumType) + traverseOutputType (ObjectOutputTypeDefinition objectType) = + traverseObjectType objectType + traverseOutputType (ListOutputTypeDefinition listType) = + traverseOutputType listType + traverseOutputType (ScalarOutputTypeDefinition scalarType) = + let (ScalarType typeName _) = scalarType + in collect Prelude.id typeName (ScalarTypeDefinition scalarType) + traverseOutputType (EnumOutputTypeDefinition enumType) = + let (EnumType typeName _ _) = enumType + in collect Prelude.id typeName (EnumTypeDefinition enumType) + traverseObjectType objectType foundTypes = + let (ObjectType typeName objectFields) = objectType + element = ObjectTypeDefinition objectType + traverser = flip (foldr visitFields) objectFields + in collect traverser typeName element foundTypes |