diff --git a/LICENSE.Apache-2.0 b/LICENSE.Apache-2.0 new file mode 100644 --- /dev/null +++ b/LICENSE.Apache-2.0 @@ -0,0 +1,163 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and +distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the +copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other +entities that control, are controlled by, or are under common control with +that entity. For the purposes of this definition, "control" means (i) the +power, direct or indirect, to cause the direction or management of such +entity, whether by contract or otherwise, or (ii) ownership of fifty percent +(50%) or more of the outstanding shares, or (iii) beneficial ownership of such +entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising +permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, +including but not limited to software source code, documentation source, and +configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or +translation of a Source form, including but not limited to compiled object +code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, +made available under the License, as indicated by a copyright notice that is +included in or attached to the work (an example is provided in the Appendix +below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that +is based on (or derived from) the Work and for which the editorial revisions, +annotations, elaborations, or other modifications represent, as a whole, an +original work of authorship. For the purposes of this License, Derivative +Works shall not include works that remain separable from, or merely link (or +bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original +version of the Work and any modifications or additions to that Work or +Derivative Works thereof, that is intentionally submitted to Licensor for +inclusion in the Work by the copyright owner or by an individual or Legal +Entity authorized to submit on behalf of the copyright owner. For the purposes +of this definition, "submitted" means any form of electronic, verbal, or +written communication sent to the Licensor or its representatives, including +but not limited to communication on electronic mailing lists, source code +control systems, and issue tracking systems that are managed by, or on behalf +of, the Licensor for the purpose of discussing and improving the Work, but +excluding communication that is conspicuously marked or otherwise designated +in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf +of whom a Contribution has been received by Licensor and subsequently +incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this +License, each Contributor hereby grants to You a perpetual, worldwide, +non-exclusive, no-charge, royalty-free, irrevocable copyright license to +reproduce, prepare Derivative Works of, publicly display, publicly perform, +sublicense, and distribute the Work and such Derivative Works in Source or +Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this +License, each Contributor hereby grants to You a perpetual, worldwide, +non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this +section) patent license to make, have made, use, offer to sell, sell, import, +and otherwise transfer the Work, where such license applies only to those +patent claims licensable by such Contributor that are necessarily infringed by +their Contribution(s) alone or by combination of their Contribution(s) with +the Work to which such Contribution(s) was submitted. If You institute patent +litigation against any entity (including a cross-claim or counterclaim in a +lawsuit) alleging that the Work or a Contribution incorporated within the Work +constitutes direct or contributory patent infringement, then any patent +licenses granted to You under this License for that Work shall terminate as of +the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or +Derivative Works thereof in any medium, with or without modifications, and in +Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of +this License; and + +You must cause any modified files to carry prominent notices stating that You +changed the files; and + +You must retain, in the Source form of any Derivative Works that You +distribute, all copyright, patent, trademark, and attribution notices from the +Source form of the Work, excluding those notices that do not pertain to any +part of the Derivative Works; and + +If the Work includes a "NOTICE" text file as part of its distribution, then +any Derivative Works that You distribute must include a readable copy of the +attribution notices contained within such NOTICE file, excluding those notices +that do not pertain to any part of the Derivative Works, in at least one of +the following places: within a NOTICE text file distributed as part of the +Derivative Works; within the Source form or documentation, if provided along +with the Derivative Works; or, within a display generated by the Derivative +Works, if and wherever such third-party notices normally appear. The contents +of the NOTICE file are for informational purposes only and do not modify the +License. You may add Your own attribution notices within Derivative Works that +You distribute, alongside or as an addendum to the NOTICE text from the Work, +provided that such additional attribution notices cannot be construed as +modifying the License. + +You may add Your own copyright statement to Your modifications and may provide +additional or different license terms and conditions for use, reproduction, or +distribution of Your modifications, or for any such Derivative Works as a +whole, provided Your use, reproduction, and distribution of the Work otherwise +complies with the conditions stated in this License. + +5. Submission of Contributions. Unless You explicitly state otherwise, any +Contribution intentionally submitted for inclusion in the Work by You to the +Licensor shall be under the terms and conditions of this License, without any +additional terms or conditions. Notwithstanding the above, nothing herein +shall supersede or modify the terms of any separate license agreement you may +have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, +trademarks, service marks, or product names of the Licensor, except as +required for reasonable and customary use in describing the origin of the Work +and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in +writing, Licensor provides the Work (and each Contributor provides its +Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +KIND, either express or implied, including, without limitation, any warranties +or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A +PARTICULAR PURPOSE. You are solely responsible for determining the +appropriateness of using or redistributing the Work and assume any risks +associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in +tort (including negligence), contract, or otherwise, unless required by +applicable law (such as deliberate and grossly negligent acts) or agreed to in +writing, shall any Contributor be liable to You for damages, including any +direct, indirect, special, incidental, or consequential damages of any +character arising as a result of this License or out of the use or inability +to use the Work (including but not limited to damages for loss of goodwill, +work stoppage, computer failure or malfunction, or any and all other +commercial damages or losses), even if such Contributor has been advised of +the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work +or Derivative Works thereof, You may choose to offer, and charge a fee for, +acceptance of support, warranty, indemnity, or other liability obligations +and/or rights consistent with this License. However, in accepting such +obligations, You may act only on Your own behalf and on Your sole +responsibility, not on behalf of any other Contributor, and only if You agree +to indemnify, defend, and hold each Contributor harmless for any liability +incurred by, or claims asserted against, such Contributor by reason of your +accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Protolude + +import Criterion.Main (bgroup, defaultMain) +import qualified Validation + + +main :: IO () +main = do + defaultMain [ bgroup "GraphQL API" Validation.benchmarks + ] diff --git a/benchmarks/Validation.hs b/benchmarks/Validation.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Validation.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeApplications #-} +module Validation (benchmarks) where + +import Protolude + +import Criterion (Benchmark, bench, nf) +import GraphQL.Internal.Validation (findDuplicates) + + +benchmarks :: [Benchmark] +benchmarks = + [ bench "findDuplicates" (nf findDuplicates exampleData) + ] + where + exampleData :: [Int] + exampleData = [2, 8, 9, 8, 1, 7, 5, 0, 1, 3, 5, 4] diff --git a/graphql-api.cabal b/graphql-api.cabal new file mode 100644 --- /dev/null +++ b/graphql-api.cabal @@ -0,0 +1,140 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: graphql-api +version: 0.1.1 +synopsis: Sketch of GraphQL stuff +description: Please see README.md +category: Web +homepage: https://github.com/jml/graphql-api#readme +bug-reports: https://github.com/jml/graphql-api/issues +maintainer: Jonathan M. Lange +license: Apache +license-file: LICENSE.Apache-2.0 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jml/graphql-api + +library + hs-source-dirs: + src + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall -fno-warn-redundant-constraints + build-depends: + base >= 4.9 && < 5 + , protolude + , exceptions + , transformers + , attoparsec + , aeson + , containers + , scientific + , QuickCheck + , text + exposed-modules: + GraphQL + GraphQL.API + GraphQL.API.Enum + GraphQL.Internal.Arbitrary + GraphQL.Internal.Execution + GraphQL.Internal.Name + GraphQL.Internal.OrderedMap + GraphQL.Internal.Output + GraphQL.Internal.Schema + GraphQL.Internal.Syntax.AST + GraphQL.Internal.Syntax.Encoder + GraphQL.Internal.Syntax.Parser + GraphQL.Internal.Syntax.Tokens + GraphQL.Internal.Validation + GraphQL.Resolver + GraphQL.Value + GraphQL.Value.FromValue + GraphQL.Value.ToValue + default-language: Haskell2010 + +test-suite graphql-api-doctests + type: exitcode-stdio-1.0 + main-is: Doctests.hs + hs-source-dirs: + tests + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall -fno-warn-redundant-constraints -threaded + build-depends: + base >= 4.9 && < 5 + , protolude + , exceptions + , transformers + , attoparsec + , doctest + other-modules: + ASTTests + EndToEndTests + Examples.InputObject + Examples.UnionExample + ExampleSchema + OrderedMapTests + ResolverTests + SchemaTests + Spec + ValidationTests + ValueTests + default-language: Haskell2010 + +test-suite graphql-api-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + tests + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall -fno-warn-redundant-constraints + build-depends: + base >= 4.9 && < 5 + , protolude + , exceptions + , transformers + , attoparsec + , aeson + , containers + , graphql-api + , hspec + , QuickCheck + , raw-strings-qq + , tasty + , tasty-hspec + , directory + other-modules: + ASTTests + Doctests + EndToEndTests + Examples.InputObject + Examples.UnionExample + ExampleSchema + OrderedMapTests + ResolverTests + SchemaTests + ValidationTests + ValueTests + default-language: Haskell2010 + +benchmark criterion + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + benchmarks + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall -fno-warn-redundant-constraints + build-depends: + base >= 4.9 && < 5 + , protolude + , exceptions + , transformers + , attoparsec + , criterion + , graphql-api + other-modules: + Validation + default-language: Haskell2010 diff --git a/src/GraphQL.hs b/src/GraphQL.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Interface for GraphQL API. +-- +-- __Note__: This module is highly subject to change. We're still figuring +-- where to draw the lines and what to expose. +module GraphQL + ( + -- * Running queries + interpretQuery + , interpretAnonymousQuery + , Response(..) + -- * Preparing queries then running them + , makeSchema + , compileQuery + , executeQuery + , QueryError + , Schema + , VariableValues + , Value + ) where + +import Protolude + +import Data.Attoparsec.Text (parseOnly, endOfInput) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import GraphQL.API (HasObjectDefinition(..)) +import GraphQL.Internal.Execution + ( VariableValues + , ExecutionError + , substituteVariables + ) +import qualified GraphQL.Internal.Execution as Execution +import qualified GraphQL.Internal.Syntax.AST as AST +import qualified GraphQL.Internal.Syntax.Parser as Parser +import GraphQL.Internal.Validation + ( QueryDocument + , SelectionSetByType + , ValidationErrors + , validate + , getSelectionSet + , VariableValue + ) +import GraphQL.Internal.Output + ( GraphQLError(..) + , Response(..) + , singleError + ) +import GraphQL.Internal.Schema (Schema) +import qualified GraphQL.Internal.Schema as Schema +import GraphQL.Resolver (HasResolver(..), Result(..)) +import GraphQL.Value (Name, NameError, Value, pattern ValueObject) + +-- | Errors that can happen while processing a query document. +data QueryError + -- | Failed to parse. + = ParseError Text + -- | Parsed, but failed validation. + -- + -- See for more + -- details. + | ValidationError ValidationErrors + -- | Validated, but failed during execution. + | ExecutionError ExecutionError + -- | Error in the schema. + | SchemaError NameError + -- | Got a value that wasn't an object. + | NonObjectResult Value + deriving (Eq, Show) + +instance GraphQLError QueryError where + formatError (ParseError e) = + "Couldn't parse query document: " <> e + formatError (ValidationError es) = + "Validation errors:\n" <> mconcat [" " <> formatError e <> "\n" | e <- NonEmpty.toList es] + formatError (ExecutionError e) = + "Execution error: " <> show e + formatError (SchemaError e) = + "Schema error: " <> formatError e + formatError (NonObjectResult v) = + "Query returned a value that is not an object: " <> show v + +-- | Execute a GraphQL query. +executeQuery + :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api) + => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. + -> QueryDocument VariableValue -- ^ A validated query document. Build one with 'compileQuery'. + -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something". + -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. + -> m Response -- ^ The outcome of running the query. +executeQuery handler document name variables = + case getOperation document name variables of + Left e -> pure (ExecutionFailure (singleError e)) + Right operation -> toResult <$> resolve @m @api handler (Just operation) + where + toResult (Result errors result) = + case result of + -- TODO: Prevent this at compile time. Particularly frustrating since + -- we *know* that api has an object definition. + ValueObject object -> + case NonEmpty.nonEmpty errors of + Nothing -> Success object + Just errs -> PartialSuccess object (map toError errs) + v -> ExecutionFailure (singleError (NonObjectResult v)) + +-- | Create a GraphQL schema. +makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema +makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api) + +-- | Interpet a GraphQL query. +-- +-- Compiles then executes a GraphQL query. +interpretQuery + :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. + -> Text -- ^ The text of a query document. Will be parsed and then executed. + -> Maybe Name -- ^ An optional name for the operation within document to run. If 'Nothing', execute the only operation in the document. If @Just "something"@, execute the query or mutation named @"something"@. + -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. + -> m Response -- ^ The outcome of running the query. +interpretQuery handler query name variables = + case makeSchema @api >>= flip compileQuery query of + Left err -> pure (PreExecutionFailure (toError err :| [])) + Right document -> executeQuery @api @m handler document name variables + +-- | Interpret an anonymous GraphQL query. +-- +-- Anonymous queries have no name and take no variables. +interpretAnonymousQuery + :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + => Handler m api -- ^ Handler for the anonymous query. + -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation. + -> m Response -- ^ The result of running the query. +interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty + +-- | Turn some text into a valid query document. +compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue) +compileQuery schema query = do + parsed <- first ParseError (parseQuery query) + first ValidationError (validate schema parsed) + +-- | Parse a query document. +parseQuery :: Text -> Either Text AST.QueryDocument +parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query) + +-- | Get an operation from a query document ready to be processed. +getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value) +getOperation document name vars = first ExecutionError $ do + op <- Execution.getOperation document name + resolved <- substituteVariables op vars + pure (getSelectionSet resolved) diff --git a/src/GraphQL/API.hs b/src/GraphQL/API.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/API.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Type-level definitions for a GraphQL schema. +module GraphQL.API + ( Object + , Field + , Argument + , DefaultArgument + , Union + , List + , Enum + , GraphQLEnum(..) + , Interface + , (:>)(..) + , HasAnnotatedType(..) + , HasAnnotatedInputType + , HasObjectDefinition(..) + , getArgumentDefinition + -- | Exported for testing. Perhaps should be a different module. + , getFieldDefinition + , getInterfaceDefinition + , getAnnotatedInputType + ) where + +import Protolude hiding (Enum, TypeError) + +import GraphQL.Internal.Schema hiding (Type) +import qualified GraphQL.Internal.Schema (Type) +import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..)) +import GraphQL.Internal.Name (NameError, nameFromSymbol) +import GraphQL.API.Enum (GraphQLEnum(..)) +import GHC.Generics ((:*:)(..)) + + +-- $setup +-- >>> :set -XDataKinds -XTypeOperators + +-- | Argument operator. Can only be used with 'Field'. +-- +-- Say we have a @Company@ object that has a field that shows whether +-- someone is an employee, e.g. +-- +-- @ +-- type Company { +-- hasEmployee(employeeName: String!): String! +-- } +-- @ +-- +-- Then we might represent that as: +-- +-- >>> type Company = Object "Company" '[] '[Argument "employeeName" Text :> Field "hasEmployee" Bool] +-- +-- For multiple arguments, simply chain them together with ':>', ending +-- finally with 'Field'. e.g. +-- +-- @ +-- Argument "foo" String :> Argument "bar" Int :> Field "qux" Int +-- @ +data a :> b = a :> b +infixr 8 :> + + +data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type]) +data Enum (name :: Symbol) (values :: Type) +data Union (name :: Symbol) (types :: [Type]) +data List (elemType :: Type) + +-- TODO(tom): AFACIT We can't constrain "fields" to e.g. have at least +-- one field in it - is this a problem? +data Interface (name :: Symbol) (fields :: [Type]) +data Field (name :: Symbol) (fieldType :: Type) +data Argument (name :: Symbol) (argType :: Type) + + +-- Can't set the value for default arguments via types, but can +-- distinguish to force users to provide a default argument somewhere +-- in their function (using Maybe? ore some new type like +-- https://hackage.haskell.org/package/optional-args-1.0.1) +data DefaultArgument (name :: Symbol) (argType :: Type) + +cons :: a -> [a] -> [a] +cons = (:) + +-- Transform into a Schema definition +class HasObjectDefinition a where + -- Todo rename to getObjectTypeDefinition + getDefinition :: Either NameError ObjectTypeDefinition + +class HasFieldDefinition a where + getFieldDefinition :: Either NameError FieldDefinition + + +-- Fields +class HasFieldDefinitions a where + getFieldDefinitions :: Either NameError [FieldDefinition] + +instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where + getFieldDefinitions = cons <$> getFieldDefinition @a <*> getFieldDefinitions @as + +instance HasFieldDefinitions '[] where + getFieldDefinitions = pure [] + + +-- object types from union type lists, e.g. for +-- Union "Horse" '[Leg, Head, Tail] +-- ^^^^^^^^^^^^^^^^^^ this part +class UnionTypeObjectTypeDefinitionList a where + getUnionTypeObjectTypeDefinitions :: Either NameError [ObjectTypeDefinition] + +instance forall a as. (HasObjectDefinition a, UnionTypeObjectTypeDefinitionList as) => UnionTypeObjectTypeDefinitionList (a:as) where + getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as + +instance UnionTypeObjectTypeDefinitionList '[] where + getUnionTypeObjectTypeDefinitions = pure [] + +-- Interfaces +class HasInterfaceDefinitions a where + getInterfaceDefinitions :: Either NameError Interfaces + +instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where + getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as + +instance HasInterfaceDefinitions '[] where + getInterfaceDefinitions = pure [] + +class HasInterfaceDefinition a where + getInterfaceDefinition :: Either NameError InterfaceTypeDefinition + +instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where + getInterfaceDefinition = + let name = nameFromSymbol @ks + fields = NonEmptyList <$> getFieldDefinitions @fields + in InterfaceTypeDefinition <$> name <*> fields + +-- Give users some help if they don't terminate Arguments with a Field: +-- NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 +instance forall ks t. TypeError ('Text ":> Arguments must end with a Field") => + HasFieldDefinition (Argument ks t) where + getFieldDefinition = notImplemented + +instance forall ks is ts. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions ts) => HasAnnotatedType (Object ks is ts) where + getAnnotatedType = + let obj = getDefinition @(Object ks is ts) + in (TypeNamed . DefinedType . TypeDefinitionObject) <$> obj + +instance forall t ks. (KnownSymbol ks, HasAnnotatedType t) => HasFieldDefinition (Field ks t) where + getFieldDefinition = + let name = nameFromSymbol @ks + in FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t + +class HasArgumentDefinition a where + getArgumentDefinition :: Either NameError ArgumentDefinition + +instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where + getArgumentDefinition = ArgumentDefinition <$> argName <*> argType <*> defaultValue + where + argName = nameFromSymbol @ks + argType = getAnnotatedInputType @t + defaultValue = pure Nothing + +instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where + getFieldDefinition = + prependArg <$> argument <*> getFieldDefinition @b + where + prependArg arg (FieldDefinition name argDefs at) = FieldDefinition name (arg:argDefs) at + argument = getArgumentDefinition @a + +instance forall ks is fields. + (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) => + HasObjectDefinition (Object ks is fields) where + getDefinition = + let name = nameFromSymbol @ks + interfaces = getInterfaceDefinitions @is + fields = NonEmptyList <$> getFieldDefinitions @fields + in ObjectTypeDefinition <$> name <*> interfaces <*> fields + +-- Builtin output types (annotated types) +class HasAnnotatedType a where + -- TODO - the fact that we have to return TypeNonNull for normal + -- types will amost certainly lead to bugs because people will + -- forget this. Maybe we can flip the internal encoding to be + -- non-null by default and needing explicit null-encoding (via + -- Maybe). + getAnnotatedType :: Either NameError (AnnotatedType GraphQL.Internal.Schema.Type) + +-- | Turn a non-null type into the optional version of its own type. +dropNonNull :: AnnotatedType t -> AnnotatedType t +dropNonNull (TypeNonNull (NonNullTypeNamed t)) = TypeNamed t +dropNonNull (TypeNonNull (NonNullTypeList t)) = TypeList t +dropNonNull x@(TypeNamed _) = x +dropNonNull x@(TypeList _) = x + +instance forall a. HasAnnotatedType a => HasAnnotatedType (Maybe a) where + -- see TODO in HasAnnotatedType class + getAnnotatedType = dropNonNull <$> getAnnotatedType @a + +builtinType :: Builtin -> Either NameError (AnnotatedType GraphQL.Internal.Schema.Type) +builtinType = pure . TypeNonNull . NonNullTypeNamed . BuiltinType + +-- TODO(jml): Given that AnnotatedType is parametrised, we can probably reduce +-- a great deal of duplication by making HasAnnotatedType a parametrised type +-- class. + +-- TODO(jml): Be smarter and figure out how to say "all integral types" rather +-- than listing each individually. + +instance HasAnnotatedType Int where + getAnnotatedType = builtinType GInt + +instance HasAnnotatedType Int32 where + getAnnotatedType = builtinType GInt + +instance HasAnnotatedType Bool where + getAnnotatedType = builtinType GBool + +instance HasAnnotatedType Text where + getAnnotatedType = builtinType GString + +instance HasAnnotatedType Double where + getAnnotatedType = builtinType GFloat + +instance HasAnnotatedType Float where + getAnnotatedType = builtinType GFloat + +instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where + getAnnotatedType = TypeList . ListType <$> getAnnotatedType @t + +instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedType (Enum ks enum) where + getAnnotatedType = do + let name = nameFromSymbol @ks + let enums = sequenceA (enumValues @enum) :: Either NameError [Name] + let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums + TypeNonNull . NonNullTypeNamed . DefinedType . TypeDefinitionEnum <$> et + +instance forall ks as. (KnownSymbol ks, UnionTypeObjectTypeDefinitionList as) => HasAnnotatedType (Union ks as) where + getAnnotatedType = + let name = nameFromSymbol @ks + types = NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as + in (TypeNamed . DefinedType . TypeDefinitionUnion) <$> (UnionTypeDefinition <$> name <*> types) + +-- Help users with better type errors +instance TypeError ('Text "Cannot encode Integer because it has arbitrary size but the JSON encoding is a number") => + HasAnnotatedType Integer where + getAnnotatedType = undefined + + +-- Builtin input types +class HasAnnotatedInputType a where + -- See TODO comment in "HasAnnotatedType" class for nullability. + getAnnotatedInputType :: Either NameError (AnnotatedType InputType) + default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either NameError (AnnotatedType InputType) + getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a) + +instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where + getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a + +builtinInputType :: Builtin -> Either NameError (AnnotatedType InputType) +builtinInputType = pure . TypeNonNull . NonNullTypeNamed . BuiltinInputType + +instance HasAnnotatedInputType Int where + getAnnotatedInputType = builtinInputType GInt + +instance HasAnnotatedInputType Int32 where + getAnnotatedInputType = builtinInputType GInt + +instance HasAnnotatedInputType Bool where + getAnnotatedInputType = builtinInputType GBool + +instance HasAnnotatedInputType Text where + getAnnotatedInputType = builtinInputType GString + +instance HasAnnotatedInputType Double where + getAnnotatedInputType = builtinInputType GFloat + +instance HasAnnotatedInputType Float where + getAnnotatedInputType = builtinInputType GFloat + +instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where + getAnnotatedInputType = TypeList . ListType <$> getAnnotatedInputType @t + +instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedInputType (Enum ks enum) where + getAnnotatedInputType = do + let name = nameFromSymbol @ks + enums = sequenceA (enumValues @enum) :: Either NameError [Name] + let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums + TypeNonNull . NonNullTypeNamed . DefinedInputType . InputTypeDefinitionEnum <$> et + + +-- Generic getAnnotatedInputType function +class GenericAnnotatedInputType (f :: Type -> Type) where + genericGetAnnotatedInputType :: Either NameError (AnnotatedType InputType) + +class GenericInputObjectFieldDefinitions (f :: Type -> Type) where + genericGetInputObjectFieldDefinitions :: Either NameError [InputObjectFieldDefinition] + +instance forall dataName consName records s l p. + ( KnownSymbol dataName + , KnownSymbol consName + , GenericInputObjectFieldDefinitions records + ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False) + (C1 ('MetaCons consName p 'True) records + )) where + genericGetAnnotatedInputType = do + name <- nameFromSymbol @dataName + map ( TypeNonNull + . NonNullTypeNamed + . DefinedInputType + . InputTypeDefinitionObject + . (InputObjectTypeDefinition name) + . NonEmptyList + ) (genericGetInputObjectFieldDefinitions @records) + +instance forall wrappedType fieldName rest u s l. + ( KnownSymbol fieldName + , HasAnnotatedInputType wrappedType + , GenericInputObjectFieldDefinitions rest + ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType) :*: rest) where + genericGetInputObjectFieldDefinitions = do + name <- nameFromSymbol @fieldName + annotatedInputType <- getAnnotatedInputType @wrappedType + let l = InputObjectFieldDefinition name annotatedInputType Nothing + r <- genericGetInputObjectFieldDefinitions @rest + pure (l:r) + +instance forall wrappedType fieldName u s l. + ( KnownSymbol fieldName + , HasAnnotatedInputType wrappedType + ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where + genericGetInputObjectFieldDefinitions = do + name <- nameFromSymbol @fieldName + annotatedInputType <- getAnnotatedInputType @wrappedType + let l = InputObjectFieldDefinition name annotatedInputType Nothing + pure [l] diff --git a/src/GraphQL/API/Enum.hs b/src/GraphQL/API/Enum.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/API/Enum.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module GraphQL.API.Enum + ( GraphQLEnum(..) + ) where + +import Protolude hiding (Enum, TypeError) +import GraphQL.Internal.Name (Name, nameFromSymbol, NameError) +import GraphQL.Internal.Output (GraphQLError(..)) +import GHC.Generics (D, (:+:)(..)) +import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) + +invalidEnumName :: forall t. NameError -> Either Text t +invalidEnumName x = Left ("In Enum: " <> formatError x) + +-- TODO: Enums have a slightly more restricted set of names than 'Name' +-- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser +-- /probably/ guarantees this, so it should export this guarantee by providing +-- an 'Enum' type. + +class GenericEnumValues (f :: Type -> Type) where + genericEnumValues :: [Either NameError Name] + -- XXX: Why is this 'Text' and not 'NameError'? + genericEnumFromValue :: Name -> Either Text (f p) + genericEnumToValue :: f p -> Name + +instance forall conName m p f nt. + ( KnownSymbol conName + , KnownSymbol m + , KnownSymbol p + , GenericEnumValues f + ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where + genericEnumValues = genericEnumValues @f + genericEnumFromValue name = M1 <$> genericEnumFromValue name + genericEnumToValue (M1 gv) = genericEnumToValue gv + +instance forall conName f p b. + ( KnownSymbol conName + , GenericEnumValues f + ) => GenericEnumValues (C1 ('MetaCons conName p b) U1 :+: f) where + genericEnumValues = let name = nameFromSymbol @conName in name:genericEnumValues @f + genericEnumFromValue vname = + case nameFromSymbol @conName of + Right name -> if name == vname + then L1 <$> Right (M1 U1) + else R1 <$> genericEnumFromValue vname + Left x -> invalidEnumName x + genericEnumToValue (L1 _) = + case nameFromSymbol @conName of + Right name -> name + -- XXX: This is impossible to catch during validation, because we cannot + -- validate type-level symbols, we can only validate values. We could + -- show that the schema is invalid at the type-level and still decide to + -- call this anyway. The error should rather say that the schema is + -- invalid. + -- + -- Further, we don't actually have any schema-level validation, so + -- "should have been caught during validation" is misleading. + Left err -> panic ("Invalid name: " <> show err <> ". This should have been caught during validation. Please file a bug.") + genericEnumToValue (R1 gv) = genericEnumToValue gv + +instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where + genericEnumValues = let name = nameFromSymbol @conName in [name] + genericEnumFromValue vname = + case nameFromSymbol @conName of + Right name -> if name == vname + then Right (M1 U1) + else Left ("Not a valid choice for enum: " <> show vname) + Left x -> invalidEnumName x + genericEnumToValue (M1 _) = + let Right name = nameFromSymbol @conName + in name + +-- TODO(tom): better type errors using `n`. Also type errors for other +-- invalid constructors. +instance forall conName p b sa sb. + ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) + , KnownSymbol conName + ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where + genericEnumValues = undefined + genericEnumFromValue = undefined + genericEnumToValue = undefined + +instance forall conName p b sa sb f. + ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) + , KnownSymbol conName + ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where + genericEnumValues = undefined + genericEnumFromValue = undefined + genericEnumToValue = undefined + + +-- | For each enum type we need 1) a list of all possible values 2) a +-- way to serialise and 3) deserialise. +-- +-- TODO: Update this comment to explain what a GraphQLEnum is, why you might +-- want an instance, and any laws that apply to method relations. +class GraphQLEnum a where + -- TODO: Document each of these methods. + enumValues :: [Either NameError Name] + default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name] + enumValues = genericEnumValues @(Rep a) + + enumFromValue :: Name -> Either Text a + default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a + enumFromValue v = to <$> genericEnumFromValue v + + enumToValue :: a -> Name + default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name + enumToValue = genericEnumToValue . from diff --git a/src/GraphQL/Internal/Arbitrary.hs b/src/GraphQL/Internal/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Arbitrary.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RankNTypes #-} + +module GraphQL.Internal.Arbitrary + ( arbitraryText + , arbitraryNonEmpty + ) where + +import Protolude + +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty) +import qualified Data.String +import Test.QuickCheck (Gen, Arbitrary(..), arbitrary, listOf1) + +-- | Generate arbitrary 'Text'. +arbitraryText :: Gen Text +arbitraryText = toS <$> arbitrary @Data.String.String + +-- | Generate an arbitrary 'NonEmpty' list. +arbitraryNonEmpty :: forall a. Arbitrary a => Gen (NonEmpty a) +arbitraryNonEmpty = + -- NonEmpty.fromList panics, but that's OK, because listOf1 is guaranteed to + -- return a non-empty list, and because a panic in a test is highly + -- informative and indicative of a bug. + NonEmpty.fromList <$> listOf1 arbitrary + diff --git a/src/GraphQL/Internal/Execution.hs b/src/GraphQL/Internal/Execution.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Execution.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +-- | Implement the \"Execution\" part of the GraphQL spec. +-- +-- Actually, most of the execution work takes place in 'GraphQL.Resolver', but +-- there's still a fair bit required to glue together the results of +-- 'GraphQL.Internal.Validation' and the processing in 'GraphQL.Resolver'. +-- This module provides that glue. +module GraphQL.Internal.Execution + ( VariableValues + , ExecutionError(..) + , formatError + , getOperation + , substituteVariables + ) where + +import Protolude hiding (Type) + +import qualified Data.Map as Map +import GraphQL.Value + ( Name + , Value + , pattern ValueNull + , Value'(..) + , List'(..) + , Object'(..) + ) +import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Validation + ( Operation + , QueryDocument(..) + , VariableDefinition(..) + , VariableValue + , Variable + , Type(..) + ) + +-- | Get an operation from a GraphQL document +-- +-- +-- +-- GetOperation(document, operationName): +-- +-- * If {operationName} is {null}: +-- * If {document} contains exactly one operation. +-- * Return the Operation contained in the {document}. +-- * Otherwise produce a query error requiring {operationName}. +-- * Otherwise: +-- * Let {operation} be the Operation named {operationName} in {document}. +-- * If {operation} was not found, produce a query error. +-- * Return {operation}. +getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value) +getOperation (LoneAnonymousOperation op) Nothing = pure op +getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup name ops) +getOperation (MultipleOperations ops) Nothing = + case toList ops of + [op] -> pure op + _ -> throwError NoAnonymousOperation +getOperation _ (Just name) = throwError (NoSuchOperation name) + + +-- | Substitute variables in a GraphQL document. +-- +-- Once this is done, there will be no variables in the document whatsoever. +substituteVariables :: Operation VariableValue -> VariableValues -> Either ExecutionError (Operation Value) +substituteVariables op vars = traverse (replaceVariable vars) op + +replaceVariable :: VariableValues -> VariableValue -> Either ExecutionError Value +replaceVariable vars value = + case value of + ValueScalar' (Left defn) -> getValue defn + ValueScalar' (Right v) -> pure (ValueScalar' v) + ValueList' (List' xs) -> ValueList' . List' <$> traverse (replaceVariable vars) xs + ValueObject' (Object' xs) -> ValueObject' . Object' <$> traverse (replaceVariable vars) xs + where + + getValue :: VariableDefinition -> Either ExecutionError Value + getValue (VariableDefinition variableName variableType defaultValue) = + note (MissingValue variableName) $ + Map.lookup variableName vars <|> defaultValue <|> allowNull variableType + + allowNull (TypeNonNull _) = empty + allowNull _ = pure ValueNull + +-- | An error that occurs while executing a query. Technically, +-- 'ResolverError' also falls into the same category, but is separate to help +-- our code be a bit better organized. +data ExecutionError + = MissingValue Variable + | NoSuchOperation Name + | NoAnonymousOperation + deriving (Eq, Show) + +instance GraphQLError ExecutionError where + formatError (MissingValue name) = "Missing value for " <> show name <> " and must be non-null." + formatError (NoSuchOperation name) = "Requested operation " <> show name <> " but couldn't find it." + formatError NoAnonymousOperation = "No name supplied for opertaion, but no anonymous operation." + +-- | A map of variables to their values. +-- +-- In GraphQL the variable values are not part of the query itself, they are +-- instead passed in through a separate channel. Create a 'VariableValues' +-- from this other channel and pass it to 'substituteVariables'. +-- +-- GraphQL allows the values of variables to be specified, but doesn't provide +-- a way for doing so in the language. +type VariableValues = Map Variable Value diff --git a/src/GraphQL/Internal/Name.hs b/src/GraphQL/Internal/Name.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Name.hs @@ -0,0 +1,69 @@ +-- | Representation of GraphQL names. +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GraphQL.Internal.Name + ( Name(unName) + , NameError(..) + , makeName + , nameFromSymbol + -- * Named things + , HasName(..) + -- * Unsafe functions + , unsafeMakeName + ) where + +import Protolude + +import qualified Data.Attoparsec.Text as A +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import GraphQL.Internal.Syntax.AST + ( Name(..) + , nameParser + ) + +-- | An invalid name. +newtype NameError = NameError Text deriving (Eq, Show) + +-- | Create a 'Name'. +-- +-- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does +-- not match, return Nothing. +-- +-- >>> makeName "foo" +-- Right (Name {unName = "foo"}) +-- >>> makeName "9-bar" +-- Left (NameError "9-bar") +makeName :: Text -> Either NameError Name +makeName name = first (const (NameError name)) (A.parseOnly nameParser name) + +-- | Convert a type-level 'Symbol' into a GraphQL 'Name'. +nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name +nameFromSymbol = makeName (toS (symbolVal @n Proxy)) + +-- | Create a 'Name', panicking if the given text is invalid. +-- +-- Prefer 'makeName' to this in all cases. +-- +-- >>> unsafeMakeName "foo" +-- Name {unName = "foo"} +unsafeMakeName :: HasCallStack => Text -> Name +unsafeMakeName name = + case makeName name of + Left e -> panic (show e) + Right n -> n + +-- | Types that implement this have values with a single canonical name in a +-- GraphQL schema. +-- +-- e.g. a field @foo(bar: Int32)@ would have the name @\"foo\"@. +-- +-- If a thing *might* have a name, or has a name that might not be valid, +-- don't use this. +-- +-- If a thing is aliased, then return the *original* name. +class HasName a where + -- | Get the name of the object. + getName :: a -> Name diff --git a/src/GraphQL/Internal/OrderedMap.hs b/src/GraphQL/Internal/OrderedMap.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/OrderedMap.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE RankNTypes #-} +-- | Data structure for mapping keys to values while preserving order of appearance. +-- +-- There are many cases in GraphQL where we want to have a map from names to +-- values, where values can easily be lookup up by name and name is unique. +-- This would normally be modelled as a 'Map'. However, in many of these +-- cases, the order in which the entries appear matters. +-- +-- That is, +-- +-- @ +-- { +-- 'foo': 1, +-- 'bar': 2 +-- } +-- @ +-- +-- Is different to, +-- +-- @ +-- { +-- 'bar': 2, +-- 'foo': 1, +-- } +-- +-- Even though they have exactly the same keys, and the keys have exactly the +-- same values. +-- +-- Goal for this module is to provide data structures that are "complete +-- enough" for implementing the rest of GraphQL. +module GraphQL.Internal.OrderedMap + ( OrderedMap + -- * Construction + , empty + , singleton + , orderedMap + -- * Querying + , lookup + -- * Filtering + , GraphQL.Internal.OrderedMap.catMaybes + -- * Combine + -- ** Union + , unions + , unionWith + , unionsWith + , unionWithM + , unionsWithM + -- * Conversion + , toList + , toMap + , keys + , values + -- * Properties + , genOrderedMap + ) where + +import Protolude hiding (empty, toList) + +import qualified Data.Map as Map +import Test.QuickCheck (Arbitrary(..), Gen, listOf) + +data OrderedMap key value + = OrderedMap + { -- | Get the list of keys from an ordered map, in order of appearance. + -- + -- This list is guaranteed to have no duplicates. + keys :: [key] + -- | Convert an ordered map to a regular map, losing insertion order. + , toMap :: Map key value + } + deriving (Eq, Ord, Show) + +-- | Convert an ordered map to a list of keys and values. The list is +-- guaranteed to be the same order as the order of insertion into the map. +-- +-- /O(n log n)/ +toList :: forall key value. Ord key => OrderedMap key value -> [(key, value)] +toList (OrderedMap keys entries) = Protolude.catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries) + +instance Foldable (OrderedMap key) where + foldr f z (OrderedMap _ entries) = foldr f z entries + +instance Traversable (OrderedMap key) where + traverse f (OrderedMap keys entries) = OrderedMap keys <$> traverse f entries + +instance Functor (OrderedMap key) where + fmap f (OrderedMap keys entries) = OrderedMap keys (map f entries) + +instance (Arbitrary key, Arbitrary value, Ord key) => Arbitrary (OrderedMap key value) where + arbitrary = genOrderedMap arbitrary arbitrary + +-- | Generate an ordered map with the given key & value generators. +genOrderedMap :: forall key value. Ord key => Gen key -> Gen value -> Gen (OrderedMap key value) +genOrderedMap genKey genValue = do + entries <- Map.fromList <$> (zip <$> listOf genKey <*> listOf genValue) + pure (OrderedMap (Map.keys entries) entries) + +-- | The empty OrderedMap. /O(1)/ +empty :: forall key value. OrderedMap key value +empty = OrderedMap [] Map.empty + +-- | Create an ordered map containing a single entry. /O(1)/ +singleton :: forall key value. key -> value -> OrderedMap key value +singleton key value = OrderedMap [key] (Map.singleton key value) + +-- | Find a value in an ordered map. +-- +-- /O(log n)/ +lookup :: forall key value. Ord key => key -> OrderedMap key value -> Maybe value +lookup key (OrderedMap _ entries) = Map.lookup key entries + +-- | Get the values from an ordered map, in order of appearance. /O(n log n)/ +values :: forall key value. Ord key => OrderedMap key value -> [value] +values = map snd . toList + +-- | The union of a list of ordered maps. +-- +-- If any map shares a key with any other map, return 'Nothing'. +-- +-- Otherwise, return a new map containing all of the keys from all of the +-- maps. The keys from the first map will appear first, followed by the +-- second, and so forth. +-- +-- /O(m * n log (m * n))/ where /m/ is the number of maps, and /n/ is the size of +-- the largest map. +unions :: forall key value. Ord key => [OrderedMap key value] -> Maybe (OrderedMap key value) +unions orderedMaps = orderedMap (orderedMaps >>= toList) + +-- | Append the second ordered map to the first, combining any shared elements +-- with the given function. +unionWith :: Ord key + => (value -> value -> value) + -> OrderedMap key value + -> OrderedMap key value + -> OrderedMap key value +unionWith f x y = + OrderedMap + { toMap = Map.unionWith f (toMap x) (toMap y) + , keys = keys x <> [k | k <- keys y, k `Map.notMember` toMap x] + } + +-- | Append together a list of ordered maps, preserving ordering of keys. +-- Combine any shared elements with the given function. +unionsWith :: Ord key + => (value -> value -> value) + -> [OrderedMap key value] + -> OrderedMap key value +unionsWith f = foldl' (unionWith f) empty + +-- | Take two ordered maps, append the second one to the first. If the second +-- contains any keys that also appear in the first, combine the two values +-- with the given function. +unionWithM :: (Monad m, Ord key) + => (value -> value -> m value) + -> OrderedMap key value + -> OrderedMap key value + -> m (OrderedMap key value) +unionWithM f x y = sequenceA (unionWith (liftMM f) (map pure x) (map pure y)) + +-- | Take a list of ordered maps and append them together. Any shared elements +-- are combined using the given function. +unionsWithM :: (Monad m, Ord key) + => (value -> value -> m value) + -> [OrderedMap key value] + -> m (OrderedMap key value) +unionsWithM f xs = sequenceA (unionsWith (liftMM f) (map (map pure) xs)) + +liftMM :: Monad m => (a -> b -> m c) -> m a -> m b -> m c +liftMM f a' b' = do + (a, b) <- (,) <$> a' <*> b' + f a b + +-- | Take an ordered map with 'Maybe' values and return the same map with all +-- the 'Nothing' values removed. +catMaybes :: Ord key => OrderedMap key (Maybe value) -> OrderedMap key value +catMaybes xs = + OrderedMap + { keys = [ k | k <- keys xs, k `Map.member` newMap ] + , toMap = newMap + } + where + newMap = Map.mapMaybe identity (toMap xs) + +-- | Construct an ordered map from a list. +-- +-- /O(n log n)/. +-- +-- If the list contains duplicate keys, then return 'Nothing'. Otherwise, +-- return an 'OrderedMap', preserving the order. +orderedMap :: forall key value. Ord key => [(key, value)] -> Maybe (OrderedMap key value) +orderedMap entries + | ks == ordNub ks = Just (OrderedMap ks (Map.fromList entries)) + | otherwise = Nothing + where + ks = map fst entries diff --git a/src/GraphQL/Internal/Output.hs b/src/GraphQL/Internal/Output.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Output.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE PatternSynonyms #-} +-- | GraphQL output. +-- +-- How we encode GraphQL responses. +module GraphQL.Internal.Output + ( Response(..) + , Errors + , Error(..) + , GraphQLError(..) + , singleError + ) where + +import Protolude hiding (Location, Map) +import Data.Aeson (ToJSON(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import GraphQL.Value + ( Object + , objectFromList + , Value + , pattern ValueObject + , pattern ValueNull + , NameError(..) + ) +import GraphQL.Internal.Name (unsafeMakeName) +import GraphQL.Value.ToValue (ToValue(..)) + +-- | GraphQL response. +-- +-- A GraphQL response must: +-- +-- * be a map +-- * have a "data" key iff the operation executed +-- * have an "errors" key iff the operation encountered errors +-- * not include "data" if operation failed before execution (e.g. syntax errors, +-- validation errors, missing info) +-- * not have keys other than "data", "errors", and "extensions" +-- +-- Other interesting things: +-- +-- * Doesn't have to be JSON, but does have to have maps, strings, lists, +-- and null +-- * Can also support bool, int, enum, and float +-- * Value of "extensions" must be a map +-- +-- "data" must be null if an error was encountered during execution that +-- prevented a valid response. +-- +-- "errors" +-- +-- * must be a non-empty list +-- * each error is a map with "message", optionally "locations" key +-- with list of locations +-- * locations are maps with 1-indexed "line" and "column" keys. +data Response + = Success Object + | PreExecutionFailure Errors + | ExecutionFailure Errors + | PartialSuccess Object Errors + deriving (Eq, Ord, Show) + +-- | Construct an object from a list of names and values. +-- +-- Panic if there are duplicate names. +unsafeMakeObject :: HasCallStack => [(Text, Value)] -> Value +unsafeMakeObject fields = + case objectFromList (map (first unsafeMakeName) fields) of + Nothing -> panic $ "Object has duplicate keys: " <> show fields + Just object -> ValueObject object + +instance ToValue Response where + toValue (Success x) = unsafeMakeObject [("data", toValue x)] + toValue (PreExecutionFailure e) = unsafeMakeObject [("errors", toValue e)] + toValue (ExecutionFailure e) = unsafeMakeObject [("data", ValueNull) + ,("errors", toValue e)] + toValue (PartialSuccess x e) = unsafeMakeObject [("data", toValue x) + ,("errors", toValue e) + ] + +instance ToJSON Response where + toJSON = toJSON . toValue + +type Errors = NonEmpty Error + +data Error = Error Text [Location] deriving (Eq, Ord, Show) + +instance ToValue Error where + toValue (Error message []) = unsafeMakeObject [("message", toValue message)] + toValue (Error message locations) = unsafeMakeObject [("message", toValue message) + ,("locations", toValue locations) + ] + +-- | Make a list of errors containing a single error. +singleError :: GraphQLError e => e -> Errors +singleError e = toError e :| [] + +data Location = Location Line Column deriving (Eq, Ord, Show) +type Line = Int32 -- XXX: 1-indexed natural number +type Column = Int32 -- XXX: 1-indexed natural number + +instance ToValue Location where + toValue (Location line column) = unsafeMakeObject [("line" , toValue line) + ,("column", toValue column) + ] + +-- | An error that arises while processing a GraphQL query. +class GraphQLError e where + -- | Represent an error as human-readable text, primarily intended for + -- developers of GraphQL clients, and secondarily for developers of GraphQL + -- servers. + formatError :: e -> Text + + -- | Represent an error as human-readable text, together with reference to a + -- series of locations within a GraphQL query document. Default + -- implementation calls 'formatError' and provides no locations. + toError :: e -> Error + toError e = Error (formatError e) [] + +-- Defined here to avoid circular dependency. +instance GraphQLError NameError where + formatError (NameError name) = "Not a valid GraphQL name: " <> show name diff --git a/src/GraphQL/Internal/Schema.hs b/src/GraphQL/Internal/Schema.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Schema.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Fully realized GraphQL schema type system at the value level. +-- +-- Differs from "Data.GraphQL.AST" in the +-- [graphql](http://hackage.haskell.org/package/graphql) package in that there +-- are no type references. Instead, everything is inlined. +-- +-- Equivalent representation of GraphQL /values/ is in "GraphQL.Value". +module GraphQL.Internal.Schema + ( Type(..) + -- * Builtin types + , Builtin(..) + -- * Defining new types + , TypeDefinition(..) + , Name + , ArgumentDefinition(..) + , EnumValueDefinition(..) + , EnumTypeDefinition(..) + , FieldDefinition(..) + , Interfaces + , InterfaceTypeDefinition(..) + , NonEmptyList(..) + , ObjectTypeDefinition(..) + , UnionTypeDefinition(..) + -- ** Input types + , InputType(..) + , InputTypeDefinition(..) + , InputObjectTypeDefinition(..) + , InputObjectFieldDefinition(..) + -- * Using existing types + , AnnotatedType(..) + , ListType(..) + , NonNullType(..) + , DefinesTypes(..) + , doesFragmentTypeApply + -- * The schema + , Schema + , makeSchema + , lookupType + ) where + +import Protolude hiding (Type) + +import qualified Data.Map as Map +import GraphQL.Value (Value) +import GraphQL.Internal.Name (HasName(..), Name, unsafeMakeName) + +-- | An entire GraphQL schema. +-- +-- This is very much a work in progress. Currently, the only thing we provide +-- is a dictionary mapping type names to their definitions. +newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show) + +-- | Create a schema from the root object. +-- +-- This is technically an insufficient API, since not all types in a schema +-- need to be reachable from a single root object. However, it's a start. +makeSchema :: ObjectTypeDefinition -> Schema +makeSchema = Schema . getDefinedTypes + +-- | Find the type with the given name in the schema. +lookupType :: Schema -> Name -> Maybe TypeDefinition +lookupType (Schema schema) name = Map.lookup name schema + +-- XXX: Use the built-in NonEmptyList in Haskell +newtype NonEmptyList a = NonEmptyList [a] deriving (Eq, Ord, Show, Functor, Foldable) + +-- | A thing that defines types. Excludes definitions of input types. +class DefinesTypes t where + -- | Get the types defined by @t@ + -- + -- TODO: This ignores whether a value can define multiple types with the + -- same name, and further admits the possibility that the name embedded in + -- the type definition does not match the name in the returned dictionary. + -- jml would like to have a schema validation phase that eliminates one or + -- both of these possibilities. + -- + -- Also pretty much works because we've inlined all our type definitions. + getDefinedTypes :: t -> Map Name TypeDefinition + +data AnnotatedType t = TypeNamed t + | TypeList (ListType t) + | TypeNonNull (NonNullType t) + deriving (Eq, Ord, Show) + +-- | Get the type that is being annotated. +getAnnotatedType :: AnnotatedType t -> t +getAnnotatedType (TypeNamed t) = t +getAnnotatedType (TypeList (ListType t)) = getAnnotatedType t +getAnnotatedType (TypeNonNull (NonNullTypeNamed t)) = t +getAnnotatedType (TypeNonNull (NonNullTypeList (ListType t))) = getAnnotatedType t + +instance HasName t => HasName (AnnotatedType t) where + getName = getName . getAnnotatedType + +newtype ListType t = ListType (AnnotatedType t) deriving (Eq, Ord, Show) + +data NonNullType t = NonNullTypeNamed t + | NonNullTypeList (ListType t) + deriving (Eq, Ord, Show) + +data Type = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show) + +instance DefinesTypes Type where + getDefinedTypes (BuiltinType _) = mempty + getDefinedTypes (DefinedType t) = getDefinedTypes t + +instance HasName Type where + getName (DefinedType x) = getName x + getName (BuiltinType x) = getName x + +data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition + | TypeDefinitionInterface InterfaceTypeDefinition + | TypeDefinitionUnion UnionTypeDefinition + | TypeDefinitionScalar ScalarTypeDefinition + | TypeDefinitionEnum EnumTypeDefinition + | TypeDefinitionInputObject InputObjectTypeDefinition + | TypeDefinitionTypeExtension TypeExtensionDefinition + deriving (Eq, Ord, Show) + +instance HasName TypeDefinition where + getName (TypeDefinitionObject x) = getName x + getName (TypeDefinitionInterface x) = getName x + getName (TypeDefinitionUnion x) = getName x + getName (TypeDefinitionScalar x) = getName x + getName (TypeDefinitionEnum x) = getName x + getName (TypeDefinitionInputObject x) = getName x + getName (TypeDefinitionTypeExtension x) = getName x + +instance DefinesTypes TypeDefinition where + getDefinedTypes defn = + case defn of + TypeDefinitionObject x -> getDefinedTypes x + TypeDefinitionInterface x -> getDefinedTypes x + TypeDefinitionUnion x -> getDefinedTypes x + TypeDefinitionScalar x -> getDefinedTypes x + TypeDefinitionEnum x -> getDefinedTypes x + TypeDefinitionInputObject _ -> mempty + TypeDefinitionTypeExtension _ -> + panic "TODO: we should remove the 'extend' behaviour entirely" + +data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmptyList FieldDefinition) + deriving (Eq, Ord, Show) + +instance HasName ObjectTypeDefinition where + getName (ObjectTypeDefinition name _ _) = name + +instance DefinesTypes ObjectTypeDefinition where + getDefinedTypes obj@(ObjectTypeDefinition name interfaces fields) = + Map.singleton name (TypeDefinitionObject obj) <> + foldMap getDefinedTypes interfaces <> + foldMap getDefinedTypes fields + +type Interfaces = [InterfaceTypeDefinition] + +data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType Type) + deriving (Eq, Ord, Show) + +instance HasName FieldDefinition where + getName (FieldDefinition name _ _) = name + +instance DefinesTypes FieldDefinition where + getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal) + +data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) + deriving (Eq, Ord, Show) + +instance HasName ArgumentDefinition where + getName (ArgumentDefinition name _ _) = name + +data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmptyList FieldDefinition) + deriving (Eq, Ord, Show) + +instance HasName InterfaceTypeDefinition where + getName (InterfaceTypeDefinition name _) = name + +instance DefinesTypes InterfaceTypeDefinition where + getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields + +data UnionTypeDefinition = UnionTypeDefinition Name (NonEmptyList ObjectTypeDefinition) + deriving (Eq, Ord, Show) + +instance HasName UnionTypeDefinition where + getName (UnionTypeDefinition name _) = name + +instance DefinesTypes UnionTypeDefinition where + getDefinedTypes defn@(UnionTypeDefinition name objs) = + Map.singleton name (TypeDefinitionUnion defn) <> + foldMap getDefinedTypes objs + +newtype ScalarTypeDefinition = ScalarTypeDefinition Name + deriving (Eq, Ord, Show) + +instance HasName ScalarTypeDefinition where + getName (ScalarTypeDefinition name) = name + +instance DefinesTypes ScalarTypeDefinition where + getDefinedTypes defn = Map.singleton (getName defn) (TypeDefinitionScalar defn) + +-- | Types that are built into GraphQL. +-- +-- The GraphQL spec refers to these as +-- \"[scalars](https://facebook.github.io/graphql/#sec-Scalars)\". +data Builtin + -- | A signed 32‐bit numeric non‐fractional value + = GInt + -- | True or false + | GBool + -- | Textual data represented as UTF-8 character sequences + | GString + -- | Signed double‐precision fractional values as specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point) + | GFloat + -- | A unique identifier, often used to refetch an object or as the key for a cache + | GID deriving (Eq, Ord, Show) + +instance HasName Builtin where + getName = unsafeMakeName . getBuiltinName + where + getBuiltinName GInt = "Int" + getBuiltinName GBool = "Boolean" + getBuiltinName GString = "String" + getBuiltinName GFloat = "Float" + getBuiltinName GID = "ID" + +data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] + deriving (Eq, Ord, Show) + +instance HasName EnumTypeDefinition where + getName (EnumTypeDefinition name _) = name + +instance DefinesTypes EnumTypeDefinition where + getDefinedTypes enum = Map.singleton (getName enum) (TypeDefinitionEnum enum) + +newtype EnumValueDefinition = EnumValueDefinition Name + deriving (Eq, Ord, Show) + +instance HasName EnumValueDefinition where + getName (EnumValueDefinition name) = name + +data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmptyList InputObjectFieldDefinition) + deriving (Eq, Ord, Show) + +instance HasName InputObjectTypeDefinition where + getName (InputObjectTypeDefinition name _) = name + +data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) + deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions + +instance HasName InputObjectFieldDefinition where + getName (InputObjectFieldDefinition name _ _) = name + +newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition + deriving (Eq, Ord, Show) + +instance HasName TypeExtensionDefinition where + getName (TypeExtensionDefinition obj) = getName obj + +data InputType = DefinedInputType InputTypeDefinition | BuiltinInputType Builtin deriving (Eq, Ord, Show) + +instance HasName InputType where + getName (DefinedInputType x) = getName x + getName (BuiltinInputType x) = getName x + +data InputTypeDefinition + = InputTypeDefinitionObject InputObjectTypeDefinition + | InputTypeDefinitionScalar ScalarTypeDefinition + | InputTypeDefinitionEnum EnumTypeDefinition + deriving (Eq, Ord, Show) + +instance HasName InputTypeDefinition where + getName (InputTypeDefinitionObject x) = getName x + getName (InputTypeDefinitionScalar x) = getName x + getName (InputTypeDefinitionEnum x) = getName x + +-- | A literal value specified as a default as part of a type definition. +-- +-- Use this type alias when you want to be clear that a definition may include +-- some sort of default value. +-- +-- Arguments (see 'ArgumentDefinition') and fields within input objects (see +-- 'InputObjectFieldDefinition') can have default values. These are allowed to +-- be any kind of literal. +type DefaultValue = Value + + +-- | Does the given object type match the given type condition. +-- +-- See +-- +-- @ +-- DoesFragmentTypeApply(objectType, fragmentType) +-- If fragmentType is an Object Type: +-- if objectType and fragmentType are the same type, return true, otherwise return false. +-- If fragmentType is an Interface Type: +-- if objectType is an implementation of fragmentType, return true otherwise return false. +-- If fragmentType is a Union: +-- if objectType is a possible type of fragmentType, return true otherwise return false. +-- @ +doesFragmentTypeApply :: ObjectTypeDefinition -> TypeDefinition -> Bool +doesFragmentTypeApply objectType fragmentType = + case fragmentType of + TypeDefinitionObject obj -> obj == objectType + TypeDefinitionInterface interface -> objectType `implements` interface + TypeDefinitionUnion union -> objectType `branchOf` union + _ -> False + where + implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces + branchOf obj (UnionTypeDefinition _ (NonEmptyList branches)) = obj `elem` branches diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GraphQL.Internal.Syntax.AST + ( Name(unName) + , nameParser + , QueryDocument(..) + , SchemaDocument(..) + , Definition(..) + , OperationDefinition(..) + , Node(..) + , getNodeName + , VariableDefinition(..) + , Variable(..) + , SelectionSet + , Selection(..) + , Field(..) + , Alias + , Argument(..) + , FragmentSpread(..) + , InlineFragment(..) + , FragmentDefinition(..) + , TypeCondition + , Value(..) + , StringValue(..) + , ListValue(..) + , ObjectValue(..) + , ObjectField(..) + , DefaultValue + , Directive(..) + , Type(..) + , NamedType(..) + , ListType(..) + , NonNullType(..) + , TypeDefinition(..) + , ObjectTypeDefinition(..) + , Interfaces + , FieldDefinition(..) + , ArgumentsDefinition + , InputValueDefinition(..) + , InterfaceTypeDefinition(..) + , UnionTypeDefinition(..) + , ScalarTypeDefinition(..) + , EnumTypeDefinition(..) + , EnumValueDefinition(..) + , InputObjectTypeDefinition(..) + , TypeExtensionDefinition(..) + ) where + +import Protolude hiding (Type) + +import qualified Data.Aeson as Aeson +import qualified Data.Attoparsec.Text as A +import Data.Char (isDigit) +import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof) + +import GraphQL.Internal.Arbitrary (arbitraryText) +import GraphQL.Internal.Syntax.Tokens (tok) + +-- * Name + +-- | A name in GraphQL. +-- +-- https://facebook.github.io/graphql/#sec-Names +newtype Name = Name { unName :: Text } deriving (Eq, Ord, Show) + +instance Aeson.ToJSON Name where + toJSON = Aeson.toJSON . unName + +instance Arbitrary Name where + arbitrary = do + initial <- elements alpha + rest <- listOf (elements (alpha <> numeric)) + pure (Name (toS (initial:rest))) + where + alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_'] + numeric = ['0'..'9'] + +-- | Parser for 'Name'. +nameParser :: A.Parser Name +nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z + <*> A.takeWhile ((||) <$> isDigit <*> isA_z)) + where + -- `isAlpha` handles many more Unicode Chars + isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z'] + +-- * Documents + +-- | A 'QueryDocument' is something a user might send us. +-- +-- https://facebook.github.io/graphql/#sec-Language.Query-Document +newtype QueryDocument = QueryDocument { getDefinitions :: [Definition] } deriving (Eq,Show) + +data Definition = DefinitionOperation OperationDefinition + | DefinitionFragment FragmentDefinition + deriving (Eq,Show) + +-- | A 'SchemaDocument' is a document that defines a GraphQL schema. +-- +-- https://facebook.github.io/graphql/#sec-Type-System +newtype SchemaDocument = SchemaDocument [TypeDefinition] deriving (Eq, Show) + +data OperationDefinition + = Query Node + | Mutation Node + | AnonymousQuery SelectionSet + deriving (Eq,Show) + +data Node = Node Name [VariableDefinition] [Directive] SelectionSet + deriving (Eq,Show) + +-- TODO: Just make Node implement HasName. +getNodeName :: Node -> Name +getNodeName (Node name _ _ _) = name + +data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) + deriving (Eq,Show) + +newtype Variable = Variable Name deriving (Eq, Ord, Show) + +instance Arbitrary Variable where + arbitrary = Variable <$> arbitrary + +type SelectionSet = [Selection] + +data Selection = SelectionField Field + | SelectionFragmentSpread FragmentSpread + | SelectionInlineFragment InlineFragment + deriving (Eq,Show) + +data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSet + deriving (Eq,Show) + +type Alias = Name + +data Argument = Argument Name Value deriving (Eq,Show) + +-- * Fragments + +data FragmentSpread = FragmentSpread Name [Directive] + deriving (Eq,Show) + +data InlineFragment = + InlineFragment (Maybe TypeCondition) [Directive] SelectionSet + deriving (Eq,Show) + +data FragmentDefinition = + FragmentDefinition Name TypeCondition [Directive] SelectionSet + deriving (Eq,Show) + +type TypeCondition = NamedType + +-- * Values + +data Value = ValueVariable Variable + | ValueInt Int32 + -- GraphQL Float is double precison + | ValueFloat Double + | ValueBoolean Bool + | ValueString StringValue + | ValueEnum Name + | ValueList ListValue + | ValueObject ObjectValue + | ValueNull + deriving (Eq, Show) + +instance Arbitrary Value where + arbitrary = oneof [ ValueVariable <$> arbitrary + , ValueInt <$> arbitrary + , ValueFloat <$> arbitrary + , ValueBoolean <$> arbitrary + , ValueString <$> arbitrary + , ValueEnum <$> arbitrary + , ValueList <$> arbitrary + , ValueObject <$> arbitrary + , pure ValueNull + ] + +newtype StringValue = StringValue Text deriving (Eq,Show) + +instance Arbitrary StringValue where + arbitrary = StringValue <$> arbitraryText + +newtype ListValue = ListValue [Value] deriving (Eq,Show) + +instance Arbitrary ListValue where + arbitrary = ListValue <$> listOf arbitrary + +newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show) + +instance Arbitrary ObjectValue where + arbitrary = ObjectValue <$> listOf arbitrary + +data ObjectField = ObjectField Name Value deriving (Eq,Show) + +instance Arbitrary ObjectField where + arbitrary = ObjectField <$> arbitrary <*> arbitrary + +type DefaultValue = Value + +-- * Directives + +data Directive = Directive Name [Argument] deriving (Eq,Show) + +-- * Type Reference + +data Type = TypeNamed NamedType + | TypeList ListType + | TypeNonNull NonNullType + deriving (Eq, Ord, Show) + +newtype NamedType = NamedType Name deriving (Eq, Ord, Show) + +newtype ListType = ListType Type deriving (Eq, Ord, Show) + +data NonNullType = NonNullTypeNamed NamedType + | NonNullTypeList ListType + deriving (Eq, Ord, Show) + +-- * Type definition + +data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition + | TypeDefinitionInterface InterfaceTypeDefinition + | TypeDefinitionUnion UnionTypeDefinition + | TypeDefinitionScalar ScalarTypeDefinition + | TypeDefinitionEnum EnumTypeDefinition + | TypeDefinitionInputObject InputObjectTypeDefinition + | TypeDefinitionTypeExtension TypeExtensionDefinition + deriving (Eq,Show) + +data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition] + deriving (Eq,Show) + +type Interfaces = [NamedType] + +data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type + deriving (Eq,Show) + +type ArgumentsDefinition = [InputValueDefinition] + +data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue) + deriving (Eq,Show) + +data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition] + deriving (Eq,Show) + +data UnionTypeDefinition = UnionTypeDefinition Name [NamedType] + deriving (Eq,Show) + +newtype ScalarTypeDefinition = ScalarTypeDefinition Name + deriving (Eq,Show) + +data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] + deriving (Eq,Show) + +newtype EnumValueDefinition = EnumValueDefinition Name + deriving (Eq,Show) + +data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition] + deriving (Eq,Show) + +newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition + deriving (Eq,Show) diff --git a/src/GraphQL/Internal/Syntax/Encoder.hs b/src/GraphQL/Internal/Syntax/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Syntax/Encoder.hs @@ -0,0 +1,248 @@ +module GraphQL.Internal.Syntax.Encoder + ( queryDocument + , schemaDocument + , value + ) where + +import Protolude hiding (Type, intercalate) + +import qualified Data.Aeson as Aeson +import Data.Text (Text, cons, intercalate, pack, snoc) + +import qualified GraphQL.Internal.Syntax.AST as AST + +-- * Document + +queryDocument :: AST.QueryDocument -> Text +queryDocument (AST.QueryDocument defs) = (`snoc` '\n') . mconcat $ definition <$> defs + +definition :: AST.Definition -> Text +definition (AST.DefinitionOperation x) = operationDefinition x +definition (AST.DefinitionFragment x) = fragmentDefinition x + +schemaDocument :: AST.SchemaDocument -> Text +schemaDocument (AST.SchemaDocument defs) = (`snoc` '\n') . mconcat $ typeDefinition <$> defs + +operationDefinition :: AST.OperationDefinition -> Text +operationDefinition (AST.Query n) = "query " <> node n +operationDefinition (AST.Mutation n) = "mutation " <> node n +operationDefinition (AST.AnonymousQuery ss) = selectionSet ss + +node :: AST.Node -> Text +node (AST.Node name vds ds ss) = + AST.unName name + <> optempty variableDefinitions vds + <> optempty directives ds + <> selectionSet ss + +variableDefinitions :: [AST.VariableDefinition] -> Text +variableDefinitions = parensCommas variableDefinition + +variableDefinition :: AST.VariableDefinition -> Text +variableDefinition (AST.VariableDefinition var ty dv) = + variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv + +defaultValue :: AST.DefaultValue -> Text +defaultValue val = "=" <> value val + +variable :: AST.Variable -> Text +variable (AST.Variable name) = "$" <> AST.unName name + +selectionSet :: AST.SelectionSet -> Text +selectionSet = bracesCommas selection + +selection :: AST.Selection -> Text +selection (AST.SelectionField x) = field x +selection (AST.SelectionInlineFragment x) = inlineFragment x +selection (AST.SelectionFragmentSpread x) = fragmentSpread x + +field :: AST.Field -> Text +field (AST.Field alias name args ds ss) = + optempty (`snoc` ':') (maybe mempty AST.unName alias) + <> AST.unName name + <> optempty arguments args + <> optempty directives ds + <> optempty selectionSet ss + +arguments :: [AST.Argument] -> Text +arguments = parensCommas argument + +argument :: AST.Argument -> Text +argument (AST.Argument name v) = AST.unName name <> ":" <> value v + +-- * Fragments + +fragmentSpread :: AST.FragmentSpread -> Text +fragmentSpread (AST.FragmentSpread name ds) = + "..." <> AST.unName name <> optempty directives ds + +inlineFragment :: AST.InlineFragment -> Text +inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) = + "... on " <> AST.unName tc + <> optempty directives ds + <> optempty selectionSet ss +inlineFragment (AST.InlineFragment Nothing ds ss) = + "... " <> optempty directives ds + <> optempty selectionSet ss + +fragmentDefinition :: AST.FragmentDefinition -> Text +fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) = + "fragment " <> AST.unName name <> " on " <> AST.unName tc + <> optempty directives ds + <> selectionSet ss + +-- * Values + +value :: AST.Value -> Text +value (AST.ValueVariable x) = variable x +-- TODO: This will be replaced with `decimal` Buidler +value (AST.ValueInt x) = pack $ show x +-- TODO: This will be replaced with `decimal` Buidler +value (AST.ValueFloat x) = pack $ show x +value (AST.ValueBoolean x) = booleanValue x +value (AST.ValueString x) = stringValue x +value (AST.ValueEnum x) = AST.unName x +value (AST.ValueList x) = listValue x +value (AST.ValueObject x) = objectValue x +value AST.ValueNull = "null" + +booleanValue :: Bool -> Text +booleanValue True = "true" +booleanValue False = "false" + +-- TODO: Escape characters +stringValue :: AST.StringValue -> Text +stringValue (AST.StringValue v) = toS $ Aeson.encode v + +listValue :: AST.ListValue -> Text +listValue (AST.ListValue vs) = bracketsCommas value vs + +objectValue :: AST.ObjectValue -> Text +objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs + +objectField :: AST.ObjectField -> Text +objectField (AST.ObjectField name v) = AST.unName name <> ":" <> value v + +-- * Directives + +directives :: [AST.Directive] -> Text +directives = spaces directive + +directive :: AST.Directive -> Text +directive (AST.Directive name args) = "@" <> AST.unName name <> optempty arguments args + +-- * Type Reference + +type_ :: AST.Type -> Text +type_ (AST.TypeNamed (AST.NamedType x)) = AST.unName x +type_ (AST.TypeList x) = listType x +type_ (AST.TypeNonNull x) = nonNullType x + +namedType :: AST.NamedType -> Text +namedType (AST.NamedType name) = AST.unName name + +listType :: AST.ListType -> Text +listType (AST.ListType ty) = brackets (type_ ty) + +nonNullType :: AST.NonNullType -> Text +nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = AST.unName x <> "!" +nonNullType (AST.NonNullTypeList x) = listType x <> "!" + +typeDefinition :: AST.TypeDefinition -> Text +typeDefinition (AST.TypeDefinitionObject x) = objectTypeDefinition x +typeDefinition (AST.TypeDefinitionInterface x) = interfaceTypeDefinition x +typeDefinition (AST.TypeDefinitionUnion x) = unionTypeDefinition x +typeDefinition (AST.TypeDefinitionScalar x) = scalarTypeDefinition x +typeDefinition (AST.TypeDefinitionEnum x) = enumTypeDefinition x +typeDefinition (AST.TypeDefinitionInputObject x) = inputObjectTypeDefinition x +typeDefinition (AST.TypeDefinitionTypeExtension x) = typeExtensionDefinition x + +objectTypeDefinition :: AST.ObjectTypeDefinition -> Text +objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) = + "type " <> AST.unName name + <> optempty (spaced . interfaces) ifaces + <> optempty fieldDefinitions fds + +interfaces :: AST.Interfaces -> Text +interfaces = ("implements " <>) . spaces namedType + +fieldDefinitions :: [AST.FieldDefinition] -> Text +fieldDefinitions = bracesCommas fieldDefinition + +fieldDefinition :: AST.FieldDefinition -> Text +fieldDefinition (AST.FieldDefinition name args ty) = + AST.unName name <> optempty argumentsDefinition args + <> ":" + <> type_ ty + +argumentsDefinition :: AST.ArgumentsDefinition -> Text +argumentsDefinition = parensCommas inputValueDefinition + +interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text +interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) = + "interface " <> AST.unName name <> fieldDefinitions fds + +unionTypeDefinition :: AST.UnionTypeDefinition -> Text +unionTypeDefinition (AST.UnionTypeDefinition name ums) = + "union " <> AST.unName name <> "=" <> unionMembers ums + +unionMembers :: [AST.NamedType] -> Text +unionMembers = intercalate "|" . fmap namedType + +scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text +scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> AST.unName name + +enumTypeDefinition :: AST.EnumTypeDefinition -> Text +enumTypeDefinition (AST.EnumTypeDefinition name evds) = + "enum " <> AST.unName name + <> bracesCommas enumValueDefinition evds + +enumValueDefinition :: AST.EnumValueDefinition -> Text +enumValueDefinition (AST.EnumValueDefinition name) = AST.unName name + +inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text +inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) = + "input " <> AST.unName name <> inputValueDefinitions ivds + +inputValueDefinitions :: [AST.InputValueDefinition] -> Text +inputValueDefinitions = bracesCommas inputValueDefinition + +inputValueDefinition :: AST.InputValueDefinition -> Text +inputValueDefinition (AST.InputValueDefinition name ty dv) = + AST.unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv + +typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text +typeExtensionDefinition (AST.TypeExtensionDefinition otd) = + "extend " <> objectTypeDefinition otd + +-- * Internal + +spaced :: Text -> Text +spaced = cons '\SP' + +between :: Char -> Char -> Text -> Text +between open close = cons open . (`snoc` close) + +parens :: Text -> Text +parens = between '(' ')' + +brackets :: Text -> Text +brackets = between '[' ']' + +braces :: Text -> Text +braces = between '{' '}' + +spaces :: (a -> Text) -> [a] -> Text +spaces f = intercalate "\SP" . fmap f + +parensCommas :: (a -> Text) -> [a] -> Text +parensCommas f = parens . intercalate "," . fmap f + +bracketsCommas :: (a -> Text) -> [a] -> Text +bracketsCommas f = brackets . intercalate "," . fmap f + +bracesCommas :: (a -> Text) -> [a] -> Text +bracesCommas f = braces . intercalate "," . fmap f + +optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b +optempty f xs = if xs == mempty then mempty else f xs diff --git a/src/GraphQL/Internal/Syntax/Parser.hs b/src/GraphQL/Internal/Syntax/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Syntax/Parser.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE FlexibleContexts #-} +module GraphQL.Internal.Syntax.Parser + ( queryDocument + , schemaDocument + , value + ) where + +import Protolude hiding (Type, takeWhile) + +import Control.Applicative ((<|>), empty, many, optional) +import Control.Monad (fail) +import Data.Aeson.Parser (jstring) +import Data.Scientific (floatingOrInteger) +import Data.Text (find) +import qualified Data.Attoparsec.ByteString as A +import Data.Attoparsec.Text + ( Parser + , () + , anyChar + , char + , match + , many1 + , option + , scan + , scientific + , sepBy1 + ) + +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Syntax.Tokens (tok, whiteSpace) + +-- * Document + +queryDocument :: Parser AST.QueryDocument +queryDocument = whiteSpace *> (AST.QueryDocument <$> many1 definition) "query document error!" + +-- | Parser for a schema document. +schemaDocument :: Parser AST.SchemaDocument +schemaDocument = whiteSpace *> (AST.SchemaDocument <$> many1 typeDefinition) "type document error" + +definition :: Parser AST.Definition +definition = AST.DefinitionOperation <$> operationDefinition + <|> AST.DefinitionFragment <$> fragmentDefinition + "definition error!" + +operationDefinition :: Parser AST.OperationDefinition +operationDefinition = + AST.Query <$ tok "query" <*> node + <|> AST.Mutation <$ tok "mutation" <*> node + <|> (AST.AnonymousQuery <$> selectionSet) + "operationDefinition error!" + +node :: Parser AST.Node +node = AST.Node <$> AST.nameParser + <*> optempty variableDefinitions + <*> optempty directives + <*> selectionSet + +variableDefinitions :: Parser [AST.VariableDefinition] +variableDefinitions = parens (many1 variableDefinition) + +variableDefinition :: Parser AST.VariableDefinition +variableDefinition = + AST.VariableDefinition <$> variable + <* tok ":" + <*> type_ + <*> optional defaultValue + +defaultValue :: Parser AST.DefaultValue +defaultValue = tok "=" *> value + +variable :: Parser AST.Variable +variable = AST.Variable <$ tok "$" <*> AST.nameParser + +selectionSet :: Parser AST.SelectionSet +selectionSet = braces $ many1 selection + +selection :: Parser AST.Selection +selection = AST.SelectionField <$> field + -- Inline first to catch `on` case + <|> AST.SelectionInlineFragment <$> inlineFragment + <|> AST.SelectionFragmentSpread <$> fragmentSpread + "selection error!" + +field :: Parser AST.Field +field = AST.Field <$> option empty (pure <$> alias) + <*> AST.nameParser + <*> optempty arguments + <*> optempty directives + <*> optempty selectionSet + +alias :: Parser AST.Alias +alias = AST.nameParser <* tok ":" + +arguments :: Parser [AST.Argument] +arguments = parens $ many1 argument + +argument :: Parser AST.Argument +argument = AST.Argument <$> AST.nameParser <* tok ":" <*> value + +-- * Fragments + +fragmentSpread :: Parser AST.FragmentSpread +-- TODO: Make sure it fails when `... on`. +-- See https://facebook.github.io/graphql/#FragmentSpread +fragmentSpread = AST.FragmentSpread + <$ tok "..." + <*> AST.nameParser + <*> optempty directives + +-- InlineFragment tried first in order to guard against 'on' keyword +inlineFragment :: Parser AST.InlineFragment +inlineFragment = AST.InlineFragment + <$ tok "..." + <*> optional (tok "on" *> typeCondition) + <*> optempty directives + <*> selectionSet + +fragmentDefinition :: Parser AST.FragmentDefinition +fragmentDefinition = AST.FragmentDefinition + <$ tok "fragment" + <*> AST.nameParser + <* tok "on" + <*> typeCondition + <*> optempty directives + <*> selectionSet + +typeCondition :: Parser AST.TypeCondition +typeCondition = namedType + +-- * Values + +-- This will try to pick the first type it can parse. If you are working with +-- explicit types use the `typedValue` parser. +value :: Parser AST.Value +value = tok (AST.ValueVariable <$> (variable "variable") + <|> (number "number") + <|> AST.ValueNull <$ tok "null" + <|> AST.ValueBoolean <$> (booleanValue "booleanValue") + <|> AST.ValueString <$> (stringValue "stringValue") + -- `true` and `false` have been tried before + <|> AST.ValueEnum <$> (AST.nameParser "name") + <|> AST.ValueList <$> (listValue "listValue") + <|> AST.ValueObject <$> (objectValue "objectValue") + "value error!") + where + number = do + (numText, num) <- match (tok scientific) + case (Data.Text.find (== '.') numText, floatingOrInteger num) of + (Just _, Left r) -> pure (AST.ValueFloat r) + (Just _, Right i) -> pure (AST.ValueFloat (fromIntegral i)) + -- TODO: Handle maxBound, Int32 in spec. + (Nothing, Left r) -> pure (AST.ValueInt (floor r)) + (Nothing, Right i) -> pure (AST.ValueInt i) + +booleanValue :: Parser Bool +booleanValue = True <$ tok "true" + <|> False <$ tok "false" + +stringValue :: Parser AST.StringValue +stringValue = do + parsed <- char '"' *> jstring_ + case unescapeText parsed of + Left err -> fail err + Right escaped -> pure (AST.StringValue escaped) + where + -- | Parse a string without a leading quote, ignoring any escaped characters. + jstring_ :: Parser Text + jstring_ = scan startState go <* anyChar + + startState = False + go a c + | a = Just False + | c == '"' = Nothing + | otherwise = let a' = c == backslash + in Just a' + where backslash = '\\' + + -- | Unescape a string. + -- + -- Turns out this is really tricky, so we're going to cheat by + -- reconstructing a literal string (by putting quotes around it) and + -- delegating all the hard work to Aeson. + unescapeText str = A.parseOnly jstring ("\"" <> toS str <> "\"") + +-- Notice it can be empty +listValue :: Parser AST.ListValue +listValue = AST.ListValue <$> brackets (many value) + +-- Notice it can be empty +objectValue :: Parser AST.ObjectValue +objectValue = AST.ObjectValue <$> braces (many (objectField "objectField")) + +objectField :: Parser AST.ObjectField +objectField = AST.ObjectField <$> AST.nameParser <* tok ":" <*> value + +-- * Directives + +directives :: Parser [AST.Directive] +directives = many1 directive + +directive :: Parser AST.Directive +directive = AST.Directive + <$ tok "@" + <*> AST.nameParser + <*> optempty arguments + +-- * Type Reference + +type_ :: Parser AST.Type +type_ = AST.TypeList <$> listType + <|> AST.TypeNonNull <$> nonNullType + <|> AST.TypeNamed <$> namedType + "type_ error!" + +namedType :: Parser AST.NamedType +namedType = AST.NamedType <$> AST.nameParser + +listType :: Parser AST.ListType +listType = AST.ListType <$> brackets type_ + +nonNullType :: Parser AST.NonNullType +nonNullType = AST.NonNullTypeNamed <$> namedType <* tok "!" + <|> AST.NonNullTypeList <$> listType <* tok "!" + "nonNullType error!" + +-- * Type Definition + +typeDefinition :: Parser AST.TypeDefinition +typeDefinition = + AST.TypeDefinitionObject <$> objectTypeDefinition + <|> AST.TypeDefinitionInterface <$> interfaceTypeDefinition + <|> AST.TypeDefinitionUnion <$> unionTypeDefinition + <|> AST.TypeDefinitionScalar <$> scalarTypeDefinition + <|> AST.TypeDefinitionEnum <$> enumTypeDefinition + <|> AST.TypeDefinitionInputObject <$> inputObjectTypeDefinition + <|> AST.TypeDefinitionTypeExtension <$> typeExtensionDefinition + "typeDefinition error!" + +objectTypeDefinition :: Parser AST.ObjectTypeDefinition +objectTypeDefinition = AST.ObjectTypeDefinition + <$ tok "type" + <*> AST.nameParser + <*> optempty interfaces + <*> fieldDefinitions + +interfaces :: Parser AST.Interfaces +interfaces = tok "implements" *> many1 namedType + +fieldDefinitions :: Parser [AST.FieldDefinition] +fieldDefinitions = braces $ many1 fieldDefinition + +fieldDefinition :: Parser AST.FieldDefinition +fieldDefinition = AST.FieldDefinition + <$> AST.nameParser + <*> optempty argumentsDefinition + <* tok ":" + <*> type_ + +argumentsDefinition :: Parser AST.ArgumentsDefinition +argumentsDefinition = parens $ many1 inputValueDefinition + +interfaceTypeDefinition :: Parser AST.InterfaceTypeDefinition +interfaceTypeDefinition = AST.InterfaceTypeDefinition + <$ tok "interface" + <*> AST.nameParser + <*> fieldDefinitions + +unionTypeDefinition :: Parser AST.UnionTypeDefinition +unionTypeDefinition = AST.UnionTypeDefinition + <$ tok "union" + <*> AST.nameParser + <* tok "=" + <*> unionMembers + +unionMembers :: Parser [AST.NamedType] +unionMembers = namedType `sepBy1` tok "|" + +scalarTypeDefinition :: Parser AST.ScalarTypeDefinition +scalarTypeDefinition = AST.ScalarTypeDefinition + <$ tok "scalar" + <*> AST.nameParser + +enumTypeDefinition :: Parser AST.EnumTypeDefinition +enumTypeDefinition = AST.EnumTypeDefinition + <$ tok "enum" + <*> AST.nameParser + <*> enumValueDefinitions + +enumValueDefinitions :: Parser [AST.EnumValueDefinition] +enumValueDefinitions = braces $ many1 enumValueDefinition + +enumValueDefinition :: Parser AST.EnumValueDefinition +enumValueDefinition = AST.EnumValueDefinition <$> AST.nameParser + +inputObjectTypeDefinition :: Parser AST.InputObjectTypeDefinition +inputObjectTypeDefinition = AST.InputObjectTypeDefinition + <$ tok "input" + <*> AST.nameParser + <*> inputValueDefinitions + +inputValueDefinitions :: Parser [AST.InputValueDefinition] +inputValueDefinitions = braces $ many1 inputValueDefinition + +inputValueDefinition :: Parser AST.InputValueDefinition +inputValueDefinition = AST.InputValueDefinition + <$> AST.nameParser + <* tok ":" + <*> type_ + <*> optional defaultValue + +typeExtensionDefinition :: Parser AST.TypeExtensionDefinition +typeExtensionDefinition = AST.TypeExtensionDefinition + <$ tok "extend" + <*> objectTypeDefinition + +-- * Internal + +parens :: Parser a -> Parser a +parens = between "(" ")" + +braces :: Parser a -> Parser a +braces = between "{" "}" + +brackets :: Parser a -> Parser a +brackets = between "[" "]" + +between :: Parser Text -> Parser Text -> Parser a -> Parser a +between open close p = tok open *> p <* tok close + +-- `empty` /= `pure mempty` for `Parser`. +optempty :: Monoid a => Parser a -> Parser a +optempty = option mempty diff --git a/src/GraphQL/Internal/Syntax/Tokens.hs b/src/GraphQL/Internal/Syntax/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Syntax/Tokens.hs @@ -0,0 +1,24 @@ +-- | Basic tokenising used by parser. +module GraphQL.Internal.Syntax.Tokens + ( tok + , whiteSpace + ) where + +import Protolude +import Data.Attoparsec.Text + ( Parser + , anyChar + , endOfLine + , peekChar + , manyTill + ) +import Data.Char (isSpace) + +tok :: Parser a -> Parser a +tok p = p <* whiteSpace + +whiteSpace :: Parser () +whiteSpace = peekChar >>= traverse_ (\c -> + if isSpace c || c == ',' + then anyChar *> whiteSpace + else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace) diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Validation.hs @@ -0,0 +1,879 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE KindSignatures #-} +-- | Transform GraphQL query documents from AST into valid structures +-- +-- This corresponds roughly to the +-- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of +-- the specification, except where noted. +-- +-- One core difference is that this module doesn't attempt to do any +-- type-level validation, as we attempt to defer all of that to the Haskell +-- type checker. +-- +-- Deliberately not going to do: +-- +-- * field selections on compound types +-- * leaf field selections +-- * argument names +-- * argument value type correctness +-- * fragment spread type existence +-- * fragments on compound types +-- * fragment spread is possible +-- * directives are defined +-- * directives are in valid locations +-- * variable default values are correctly typed +-- * variables are input types +-- * all variable usages are allowed +-- +-- Because all of the above rely on type checking. +module GraphQL.Internal.Validation + ( ValidationError(..) + , ValidationErrors + , QueryDocument(..) + , validate + , getErrors + -- * Operating on validated documents + , Operation + , getSelectionSet + -- * Executing validated documents + , VariableDefinition(..) + , VariableValue + , Variable + , AST.Type(..) + -- * Resolving queries + , SelectionSetByType + , SelectionSet(..) + , getSelectionSetForType + , Field + , lookupArgument + , getSubSelectionSet + , ResponseKey + , getResponseKey + -- * Exported for testing + , findDuplicates + ) where + +import Protolude + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Set as Set +import GraphQL.Internal.Name (HasName(..), Name) +import qualified GraphQL.Internal.Syntax.AST as AST +-- Directly import things from the AST that do not need validation, so that +-- @AST.Foo@ in a type signature implies that something hasn't been validated. +import GraphQL.Internal.Syntax.AST (Alias, Variable, NamedType(..)) +import GraphQL.Internal.OrderedMap (OrderedMap) +import qualified GraphQL.Internal.OrderedMap as OrderedMap +import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Schema + ( TypeDefinition + , ObjectTypeDefinition + , Schema + , doesFragmentTypeApply + , lookupType + ) +import GraphQL.Value + ( Value + , Value' + , ConstScalar + , UnresolvedVariableValue + , astToVariableValue + ) + +-- | A valid query document. +-- +-- Construct this using 'validate' on an 'AST.QueryDocument'. +data QueryDocument value + -- | The query document contains a single anonymous operation. + = LoneAnonymousOperation (Operation value) + -- | The query document contains multiple uniquely-named operations. + | MultipleOperations (Operations value) + deriving (Eq, Show) + +data Operation value + = Query VariableDefinitions (Directives value) (SelectionSetByType value) + | Mutation VariableDefinitions (Directives value) (SelectionSetByType value) + deriving (Eq, Show) + +instance Functor Operation where + fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (fmap f selectionSet) + fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (fmap f selectionSet) + +instance Foldable Operation where + foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet + foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet + +instance Traversable Operation where + traverse f (Query vars directives selectionSet) = Query vars <$> traverse f directives <*> traverse f selectionSet + traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse f selectionSet + +-- | Get the selection set for an operation. +getSelectionSet :: Operation value -> SelectionSetByType value +getSelectionSet (Query _ _ ss) = ss +getSelectionSet (Mutation _ _ ss) = ss + +-- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. +type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value + +type Operations value = Map Name (Operation value) + +-- | Turn a parsed document into a known valid one. +-- +-- The document is known to be syntactically valid, as we've got its AST. +-- Here, we confirm that it's semantically valid (modulo types). +validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) +validate schema (AST.QueryDocument defns) = runValidator $ do + let (operations, fragments) = splitBy splitDefns defns + let (anonymous, named) = splitBy splitOps operations + (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments + case (anonymous, named) of + ([], ops) -> do + (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty + assertAllFragmentsUsed frags (visitedFrags <> usedFrags) + resolvedOps <- traverse validateOperation validOps + pure (MultipleOperations resolvedOps) + ([x], []) -> do + (ss, usedFrags) <- runStateT (validateSelectionSet schema frags x) mempty + assertAllFragmentsUsed frags (visitedFrags <> usedFrags) + validValuesSS <- validateValues ss + resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS + pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) + _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named)) + + where + splitBy :: (a -> Either b c) -> [a] -> ([b], [c]) + splitBy f xs = partitionEithers (map f xs) + + splitDefns (AST.DefinitionOperation op) = Left op + splitDefns (AST.DefinitionFragment frag) = Right frag + + splitOps (AST.AnonymousQuery ss) = Left ss + splitOps (AST.Query node@(AST.Node name _ _ _)) = Right (name, (Query, node)) + splitOps (AST.Mutation node@(AST.Node name _ _ _)) = Right (name, (Mutation, node)) + + assertAllFragmentsUsed :: Fragments value -> Set Name -> Validation () + assertAllFragmentsUsed fragments used = + let unused = Map.keysSet fragments `Set.difference` used + in unless (Set.null unused) (throwE (UnusedFragments unused)) + +-- * Operations + +validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value) +validateOperations schema fragments ops = do + deduped <- lift (mapErrors DuplicateOperation (makeMap ops)) + traverse validateNode deduped + where + validateNode (operationType, AST.Node _ vars directives ss) = + operationType <$> lift (validateVariableDefinitions vars) + <*> lift (validateDirectives directives) + <*> validateSelectionSet schema fragments ss + +-- TODO: Either make operation type (Query, Mutation) a parameter of an +-- Operation constructor or give all the fields accessors. This duplication is +-- driving me batty. +validateOperation :: Operation AST.Value -> Validation (Operation VariableValue) +validateOperation (Query vars directives selectionSet) = do + validValues <- Query vars <$> validateValues directives <*> validateValues selectionSet + -- Instead of doing this, we could build up a list of used variables as we + -- resolve them. + let usedVariables = getVariables validValues + let definedVariables = getDefinedVariables vars + let unusedVariables = definedVariables `Set.difference` usedVariables + unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables) + resolveVariables vars validValues +validateOperation (Mutation vars directives selectionSet) = do + validValues <- Mutation vars <$> validateValues directives <*> validateValues selectionSet + -- Instead of doing this, we could build up a list of used variables as we + -- resolve them. + let usedVariables = getVariables validValues + let definedVariables = getDefinedVariables vars + let unusedVariables = definedVariables `Set.difference` usedVariables + unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables) + resolveVariables vars validValues + + +-- * Selection sets + +-- https://facebook.github.io/graphql/#sec-Field-Selection-Merging +-- https://facebook.github.io/graphql/#sec-Executing-Selection-Sets +-- 1. the selection set is turned into a grouped field set; +-- 2. each represented field in the grouped field set produces an entry into +-- a response map. +-- https://facebook.github.io/graphql/#sec-Field-Collection + + +-- | Resolve all the fragments in a selection set and make sure the names, +-- arguments, and directives are all valid. +-- +-- Runs in 'StateT', collecting a set of names of 'FragmentDefinition' that +-- have been used by this selection set. +-- +-- We do this /before/ validating the values (since that's much easier once +-- everything is in a nice structure and away from the AST), which means we +-- can't yet evaluate directives. +validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value) +validateSelectionSet schema fragments selections = do + unresolved <- lift $ traverse (validateSelection schema) selections + resolved <- traverse (resolveSelection fragments) unresolved + lift $ groupByResponseKey resolved + +-- | A selection set, almost fully validated. +-- +-- Sub-selection sets might not be validated. +newtype SelectionSet value = SelectionSet (OrderedMap ResponseKey (Field value)) deriving (Eq, Ord, Show) + +newtype SelectionSetByType value + = SelectionSetByType (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | A 'ResponseKey' is the key under which a field appears in a response. If +-- there's an alias, it's the alias, if not, it's the field name. +type ResponseKey = Name + +-- | A field ready to be resolved. +data Field value + = Field + { name :: Name + , arguments :: Arguments value + , subSelectionSet :: Maybe (SelectionSetByType value) + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance HasName (Field value) where + getName = name + +-- | Get the value of an argument in a field. +lookupArgument :: Field value -> Name -> Maybe value +lookupArgument (Field _ (Arguments args) _) name = Map.lookup name args + +-- | Get the selection set within a field. +getSubSelectionSet :: Field value -> Maybe (SelectionSetByType value) +getSubSelectionSet = subSelectionSet + +-- | Merge two execution fields. Assumes that they are fields for the same +-- response key on the same type (i.e. that they are fields we would actually +-- rationally want to merge). +mergeFields :: Eq value => Field value -> Field value -> Validation (Field value) +mergeFields field1 field2 = do + unless (name field1 == name field2) $ throwE (MismatchedNames (name field1) (name field2)) + unless (arguments field1 == arguments field2) $ throwE (MismatchedArguments (name field1)) + case (subSelectionSet field1, subSelectionSet field2) of + (Nothing, Nothing) -> + pure Field { name = name field1 + , arguments = arguments field1 + , subSelectionSet = Nothing + } + (Just ss1, Just ss2) -> do + mergedSet <- mergeSelectionSets ss1 ss2 + pure Field { name = name field1 + , arguments = arguments field1 + , subSelectionSet = Just mergedSet + } + _ -> throwE (IncompatibleFields (name field1)) + + where + mergeSelectionSets :: Eq value + => SelectionSetByType value + -> SelectionSetByType value + -> Validation (SelectionSetByType value) + mergeSelectionSets (SelectionSetByType ss1) (SelectionSetByType ss2) = + SelectionSetByType <$> OrderedMap.unionWithM (OrderedMap.unionWithM mergeFields) ss1 ss2 + +-- | Once we know the GraphQL type of the object that a selection set (i.e. a +-- 'SelectionSetByType') is for, we can eliminate all the irrelevant types and +-- present a single, flattened map of 'ResponseKey' to 'Field'. +getSelectionSetForType + :: Eq value + => ObjectTypeDefinition -- ^ The type of the object that the selection set is for + -> SelectionSetByType value -- ^ A selection set with type conditions, obtained from the validation process + -> Either ValidationErrors (SelectionSet value) -- ^ A flattened + -- selection set without type conditions. It's possible that some of the + -- fields in various types are not mergeable, in which case, we'll return a + -- validation error. +getSelectionSetForType objectType (SelectionSetByType ss) = runValidator $ + SelectionSet . OrderedMap.catMaybes <$> traverse mergeFieldsForType ss + where + mergeFieldsForType fieldMap = do + let matching = filter (satisfiesType . fst) (OrderedMap.toList fieldMap) + case map snd matching of + [] -> pure Nothing + x:xs -> Just <$> foldlM mergeFields x xs + + satisfiesType = all (doesFragmentTypeApply objectType) . Set.toList + + +-- | Flatten the selection and group it by response key and then type +-- conditions. +-- +-- Doesn't do any validation at all. Just provides a list of "execution +-- values" which are the possible things that might be executed, depending on +-- the type. +-- +-- XXX: This is so incredibly complex. No doubt there's a way to simplify, but +-- jml can't see it right now. +groupByResponseKey :: Eq value => [Selection' FragmentSpread value] -> Validation (SelectionSetByType value) +groupByResponseKey selectionSet = SelectionSetByType <$> + flattenSelectionSet mempty selectionSet + where + -- | Given a currently "active" type condition, and a single selection, + -- return a map of response keys to validated fields, grouped by types: + -- essentially a SelectionSetByType without the wrapping + -- constructor. + -- + -- The "active" type condition is the type condition of the selection set + -- that contains the selection. + byKey :: Eq value + => Set TypeDefinition + -> Selection' FragmentSpread value + -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) + byKey typeConds (SelectionField field@(Field' _ name arguments _ ss)) + = case ss of + [] -> pure $ OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments $ Nothing + _ -> OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments . Just <$> groupByResponseKey ss + byKey typeConds (SelectionFragmentSpread (FragmentSpread _ _ (FragmentDefinition _ typeCond _ ss))) + = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss + byKey typeConds (SelectionInlineFragment (InlineFragment (Just typeCond) _ ss)) + = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss + byKey typeConds (SelectionInlineFragment (InlineFragment Nothing _ ss)) + = flattenSelectionSet typeConds ss + + flattenSelectionSet :: Eq value + => Set TypeDefinition + -> [Selection' FragmentSpread value] + -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) + flattenSelectionSet typeConds ss = do + groupedByKey <- traverse (byKey typeConds) ss + OrderedMap.unionsWithM (OrderedMap.unionWithM mergeFields) groupedByKey + +-- * Selections + +-- $fragmentSpread +-- +-- The @spread@ type variable is for the type used to "fragment spreads", i.e. +-- references to fragments. It's a variable because we do multiple traversals +-- of the selection graph. +-- +-- The first pass (see 'validateSelection') ensures all the arguments and +-- directives are valid. This is applied to all selections, including those +-- that make up fragment definitions (see 'validateFragmentDefinitions'). At +-- this stage, @spread@ will be 'UnresolvedFragmentSpread'. +-- +-- Once we have a known-good map of fragment definitions, we can do the next +-- phase of validation, which checks that references to fragments exist, that +-- all fragments are used, and that we don't have circular references. +-- +-- This is encoded as a type variable because we want to provide evidence that +-- references in fragment spreads can be resolved, and what better way to do +-- so than including the resolved fragment in the type. Thus, @spread@ will be +-- 'FragmentSpread', following this module's convention that unadorned names +-- imply that everything is valid. + +-- | A GraphQL selection. +data Selection' (spread :: * -> *) value + = SelectionField (Field' spread value) + | SelectionFragmentSpread (spread value) + | SelectionInlineFragment (InlineFragment spread value) + deriving (Eq, Show, Functor, Foldable, Traversable) + +-- | A field in a selection set, which itself might have children which might +-- have fragment spreads. +data Field' spread value + = Field' (Maybe Alias) Name (Arguments value) (Directives value) [Selection' spread value] + deriving (Eq, Show) + +-- | Get the response key of a field. +-- +-- \"A field’s response key is its alias if an alias is provided, and it is +-- otherwise the field’s name.\" +-- +-- +getResponseKey :: Field' spread value -> ResponseKey +getResponseKey (Field' alias name _ _ _) = fromMaybe name alias + +instance HasName (Field' spread value) where + getName (Field' _ name _ _ _) = name + +instance Functor spread => Functor (Field' spread) where + fmap f (Field' alias name arguments directives selectionSet) = + Field' alias name (fmap f arguments) (fmap f directives) (map (fmap f) selectionSet) + +instance Foldable spread => Foldable (Field' spread) where + foldMap f (Field' _ _ arguments directives selectionSet) = + mconcat [ foldMap f arguments + , foldMap f directives + , mconcat (map (foldMap f) selectionSet) + ] + +instance Traversable spread => Traversable (Field' spread) where + traverse f (Field' alias name arguments directives selectionSet) = + Field' alias name <$> traverse f arguments + <*> traverse f directives + <*> traverse (traverse f) selectionSet + +-- | A fragment spread that has a valid set of directives, but may or may not +-- refer to a fragment that actually exists. +data UnresolvedFragmentSpread value + = UnresolvedFragmentSpread Name (Directives value) + deriving (Eq, Show, Functor) + +instance Foldable UnresolvedFragmentSpread where + foldMap f (UnresolvedFragmentSpread _ directives) = foldMap f directives + +instance Traversable UnresolvedFragmentSpread where + traverse f (UnresolvedFragmentSpread name directives) = UnresolvedFragmentSpread name <$> traverse f directives + +-- | A fragment spread that refers to fragments which are known to exist. +data FragmentSpread value + = FragmentSpread Name (Directives value) (FragmentDefinition FragmentSpread value) + deriving (Eq, Show) + +instance Functor FragmentSpread where + fmap f (FragmentSpread name directives definition) = FragmentSpread name (fmap f directives) (fmap f definition) + +instance Foldable FragmentSpread where + foldMap f (FragmentSpread _ directives fragment) = foldMap f directives `mappend` foldMap f fragment + +instance Traversable FragmentSpread where + traverse f (FragmentSpread name directives definition) = + FragmentSpread name <$> traverse f directives <*> traverse f definition + +-- | An inline fragment, which itself can contain fragment spreads. +data InlineFragment spread value + = InlineFragment (Maybe TypeDefinition) (Directives value) [Selection' spread value] + deriving (Eq, Show) + +instance Functor spread => Functor (InlineFragment spread) where + fmap f (InlineFragment typeDefn directives selectionSet) = + InlineFragment typeDefn (fmap f directives) (map (fmap f) selectionSet) + +instance Foldable spread => Foldable (InlineFragment spread) where + foldMap f (InlineFragment _ directives selectionSet) = + foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) + +instance Traversable spread => Traversable (InlineFragment spread) where + traverse f (InlineFragment typeDefn directives selectionSet) = + InlineFragment typeDefn <$> traverse f directives + <*> traverse (traverse f) selectionSet + +-- | Traverse through every fragment spread in a selection. +-- +-- The given function @f@ is applied to each fragment spread. The rest of the +-- selection remains unchanged. +-- +-- Note that this is essentially a definition of 'Traversable' for +-- 'Selection'. However, we probably also want to have other kinds of +-- traversals (e.g. for transforming values), so best not to bless one kind +-- with a type class. +traverseFragmentSpreads :: Applicative f => (a value -> f (b value)) -> Selection' a value -> f (Selection' b value) +traverseFragmentSpreads f selection = + case selection of + SelectionField (Field' alias name args directives ss) -> + SelectionField <$> (Field' alias name args directives <$> childSegments ss) + SelectionFragmentSpread x -> + SelectionFragmentSpread <$> f x + SelectionInlineFragment (InlineFragment typeCond directives ss) -> + SelectionInlineFragment <$> (InlineFragment typeCond directives <$> childSegments ss) + where + childSegments = traverse (traverseFragmentSpreads f) + +-- | Ensure a selection has valid arguments and directives. +validateSelection :: Schema -> AST.Selection -> Validation (Selection' UnresolvedFragmentSpread AST.Value) +validateSelection schema selection = + case selection of + AST.SelectionField (AST.Field alias name args directives ss) -> + SelectionField <$> (Field' alias name + <$> validateArguments args + <*> validateDirectives directives + <*> childSegments ss) + AST.SelectionFragmentSpread (AST.FragmentSpread name directives) -> + SelectionFragmentSpread <$> (UnresolvedFragmentSpread name <$> validateDirectives directives) + AST.SelectionInlineFragment (AST.InlineFragment typeCond directives ss) -> + SelectionInlineFragment <$> (InlineFragment + <$> traverse (validateTypeCondition schema) typeCond + <*> validateDirectives directives + <*> childSegments ss) + where + childSegments = traverse (validateSelection schema) + +-- | Resolve the fragment references in a selection, accumulating a set of +-- the fragment names that we have resolved. +-- +-- We're doing a standard depth-first traversal of fragment references, where +-- references are by name, so the set of names can be thought of as a record +-- of visited references. +resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set Name) Validation (Selection' FragmentSpread a) +resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread + where + resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do + case Map.lookup name fragments of + Nothing -> lift (throwE (NoSuchFragment name)) + Just fragment -> do + modify (Set.insert name) + pure (FragmentSpread name directive fragment) + +-- * Fragment definitions + +-- | A validated fragment definition. +-- +-- @spread@ indicates whether references to other fragment definitions have +-- been resolved. +data FragmentDefinition spread value + = FragmentDefinition Name TypeDefinition (Directives value) [Selection' spread value] + deriving (Eq, Show) + +type Fragments value = Map Name (FragmentDefinition FragmentSpread value) + +instance Functor spread => Functor (FragmentDefinition spread) where + fmap f (FragmentDefinition name typeDefn directives selectionSet) = + FragmentDefinition name typeDefn (fmap f directives) (map (fmap f) selectionSet) + +instance Foldable spread => Foldable (FragmentDefinition spread) where + foldMap f (FragmentDefinition _ _ directives selectionSet) = + foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) + +instance Traversable spread => Traversable (FragmentDefinition spread) where + traverse f (FragmentDefinition name typeDefn directives selectionSet) = + FragmentDefinition name typeDefn <$> traverse f directives + <*> traverse (traverse f) selectionSet + +-- | Ensure fragment definitions are uniquely named, and that their arguments +-- and directives are sane. +-- +-- +validateFragmentDefinitions :: Schema -> [AST.FragmentDefinition] -> Validation (Map Name (FragmentDefinition UnresolvedFragmentSpread AST.Value)) +validateFragmentDefinitions schema frags = do + defns <- traverse validateFragmentDefinition frags + mapErrors DuplicateFragmentDefinition (makeMap [(name, value) | value@(FragmentDefinition name _ _ _) <- defns]) + where + validateFragmentDefinition (AST.FragmentDefinition name typeCond directives ss) = do + FragmentDefinition name + <$> validateTypeCondition schema typeCond + <*> validateDirectives directives + <*> traverse (validateSelection schema) ss + +-- | Validate a type condition that appears in a query. +validateTypeCondition :: Schema -> AST.TypeCondition -> Validation TypeDefinition +validateTypeCondition schema (NamedType typeCond) = + case lookupType schema typeCond of + Nothing -> throwE (TypeConditionNotFound typeCond) + Just typeDefn -> pure typeDefn + +-- | Resolve all references to fragments inside fragment definitions. +-- +-- Guarantees that fragment spreads refer to fragments that have been defined, +-- and that there are no circular references. +-- +-- Returns the resolved fragment definitions and a set of the names of all +-- defined fragments that were referred to by other fragments. This is to be +-- used to guarantee that all defined fragments are used (c.f. +-- ). +-- +-- +-- +resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set Name) +resolveFragmentDefinitions allFragments = + splitResult <$> traverse resolveFragment allFragments + where + -- The result of our computation is a map from names of fragment + -- definitions to the resolved fragment and visited names. We want to + -- split out the visited names and combine them so that later we can + -- report on the _un_visited names. + splitResult mapWithVisited = (map fst mapWithVisited, foldMap snd mapWithVisited) + + -- | Resolves all references to fragments in a fragment definition, + -- returning the resolved fragment and a set of visited names. + resolveFragment frag = runStateT (resolveFragment' frag) mempty + + resolveFragment' (FragmentDefinition name cond directives ss) = + FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss + + resolveSpread (UnresolvedFragmentSpread name directives) = do + visited <- Set.member name <$> get + when visited (lift (throwE (CircularFragmentSpread name))) + case Map.lookup name allFragments of + Nothing -> lift (throwE (NoSuchFragment name)) + Just definition -> do + modify (Set.insert name) + FragmentSpread name directives <$> resolveFragment' definition + +-- * Arguments + +-- | The set of arguments for a given field, directive, etc. +-- +-- Note that the 'value' can be a variable. +newtype Arguments value = Arguments (Map Name value) deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | Turn a set of arguments from the AST into a guaranteed unique set of arguments. +-- +-- +validateArguments :: [AST.Argument] -> Validation (Arguments AST.Value) +validateArguments args = Arguments <$> mapErrors DuplicateArgument (makeMap [(name, value) | AST.Argument name value <- args]) + +-- * Variables + +-- | Defines a variable within the context of an operation. +-- +-- See +data VariableDefinition + = VariableDefinition + { variable :: Variable -- ^ The name of the variable + , variableType :: AST.Type -- ^ The type of the variable + , defaultValue :: Maybe Value -- ^ An optional default value for the variable + } deriving (Eq, Ord, Show) + +type VariableDefinitions = Map Variable VariableDefinition + +getDefinedVariables :: VariableDefinitions -> Set Variable +getDefinedVariables = Map.keysSet + +-- | A GraphQL value which might contain some defined variables. +type VariableValue = Value' (Either VariableDefinition ConstScalar) + +emptyVariableDefinitions :: VariableDefinitions +emptyVariableDefinitions = mempty + +-- | Ensure that a set of variable definitions is valid. +validateVariableDefinitions :: [AST.VariableDefinition] -> Validation VariableDefinitions +validateVariableDefinitions vars = do + validatedDefns <- traverse validateVariableDefinition vars + let items = [ (variable defn, defn) | defn <- validatedDefns] + mapErrors DuplicateVariableDefinition (makeMap items) + +-- | Ensure that a variable definition is a valid one. +validateVariableDefinition :: AST.VariableDefinition -> Validation VariableDefinition +validateVariableDefinition (AST.VariableDefinition name varType value) = + VariableDefinition name varType <$> traverse validateDefaultValue value + +-- | Ensure that a default value contains no variables. +validateDefaultValue :: AST.DefaultValue -> Validation Value +validateDefaultValue defaultValue = + case astToVariableValue defaultValue of + Nothing -> throwE $ InvalidValue defaultValue + Just value -> + for value $ + \case + Left _ -> throwE $ InvalidDefaultValue defaultValue + Right constant -> pure constant + + +-- | Get all the variables referred to in a thing what contains variables. +getVariables :: Foldable f => f UnresolvedVariableValue -> Set Variable +getVariables = foldMap valueToVariable + where + valueToVariable = foldMap (either Set.singleton (const Set.empty)) + +-- | Make sure all the values are valid. +validateValues :: Traversable f => f AST.Value -> Validation (f UnresolvedVariableValue) +validateValues = traverse toVariableValue + where + toVariableValue astValue = + case astToVariableValue astValue of + Just value -> pure value + Nothing -> throwE (InvalidValue astValue) + +-- | Make sure each variable has a definition, and each definition a variable. +resolveVariables :: Traversable f => VariableDefinitions -> f UnresolvedVariableValue -> Validation (f VariableValue) +resolveVariables definitions = traverse resolveVariableValue + where + resolveVariableValue = traverse resolveVariable + resolveVariable (Left variable) = + case Map.lookup variable definitions of + Nothing -> throwE (UndefinedVariable variable) + Just defn -> pure (Left defn) + resolveVariable (Right constant) = pure (Right constant) + + +-- * Directives + +-- | A directive is a way of changing the run-time behaviour +newtype Directives value = Directives (Map Name (Arguments value)) deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +emptyDirectives :: Directives value +emptyDirectives = Directives Map.empty + +-- | Ensure that the directives in a given place are valid. +-- +-- Doesn't check to see if directives are defined & doesn't check to see if +-- they are in valid locations, because we don't have access to the schema at +-- this point. +-- +-- +validateDirectives :: [AST.Directive] -> Validation (Directives AST.Value) +validateDirectives directives = do + items <- traverse validateDirective directives + Directives <$> mapErrors DuplicateDirective (makeMap items) + where + validateDirective (AST.Directive name args) = (,) name <$> validateArguments args + +-- TODO: There's a chunk of duplication around "this collection of things has +-- unique names". Fix that. + +-- TODO: Might be nice to have something that goes from a validated document +-- back to the AST. This would be especially useful for encoding, so we could +-- debug by looking at GraphQL rather than data types. + +-- * Validation errors + +-- | Errors arising from validating a document. +data ValidationError + -- | 'DuplicateOperation' means there was more than one operation defined + -- with the given name. + -- + -- + = DuplicateOperation Name + -- | 'MixedAnonymousOperations' means there was more than one operation + -- defined in a document with an anonymous operation. + -- + -- + | MixedAnonymousOperations Int [Name] + -- | 'DuplicateArgument' means that multiple copies of the same argument was + -- given to the same field, directive, etc. + | DuplicateArgument Name + -- | 'DuplicateFragmentDefinition' means that there were more than one + -- fragment defined with the same name. + | DuplicateFragmentDefinition Name + -- | 'NoSuchFragment' means there was a reference to a fragment in a + -- fragment spread but we couldn't find any fragment with that name. + | NoSuchFragment Name + -- | 'DuplicateDirective' means there were two copies of the same directive + -- given in the same place. + -- + -- + | DuplicateDirective Name + -- | There were multiple variables defined with the same name. + | DuplicateVariableDefinition Variable + -- | 'CircularFragmentSpread' means that a fragment definition contains a + -- fragment spread that itself is a fragment definition that contains a + -- fragment spread referring to the /first/ fragment spread. + | CircularFragmentSpread Name + -- | 'UnusedFragments' means that fragments were defined that weren't used. + -- + | UnusedFragments (Set Name) + -- | Variables were defined without being used. + -- + | UnusedVariables (Set Variable) + -- | A variable was used without being defined. + -- + | UndefinedVariable Variable + -- | Value in AST wasn't valid. + | InvalidValue AST.Value + -- | Default value in AST contained variables. + | InvalidDefaultValue AST.Value + -- | Two different names given for the same response key. + | MismatchedNames Name Name + -- | Two different sets of arguments given for the same response key. + | MismatchedArguments Name + -- | Two fields had the same response key, one was a leaf, the other was not. + | IncompatibleFields Name + -- | There's a type condition that's not present in the schema. + | TypeConditionNotFound Name + deriving (Eq, Show) + +instance GraphQLError ValidationError where + formatError (DuplicateOperation name) = "More than one operation named '" <> show name <> "'" + formatError (MixedAnonymousOperations n names) + | n > 1 && null names = "Multiple anonymous operations defined. Found " <> show n + | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show names <> ")" + formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'" + formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'" + formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'" + formatError (DuplicateDirective name) = "More than one directive named '" <> show name <> "'" + formatError (DuplicateVariableDefinition name) = "More than one variable defined with name '" <> show name <> "'" + formatError (CircularFragmentSpread name) = "Fragment '" <> show name <> "' contains a fragment spread that refers back to itself." + formatError (UnusedFragments names) = "Fragments defined but not used: " <> show names + formatError (UnusedVariables names) = "Variables defined but not used: " <> show names + formatError (UndefinedVariable variable) = "No definition for variable: " <> show variable + formatError (InvalidValue value) = "Invalid value (maybe an object has duplicate field names?): " <> show value + formatError (InvalidDefaultValue value) = "Invalid default value, contains variables: " <> show value + formatError (MismatchedNames name1 name2) = "Two different names given for same response key: " <> show name1 <> ", " <> show name2 + formatError (MismatchedArguments name) = "Two different sets of arguments given for same response key: " <> show name + formatError (IncompatibleFields name) = "Field " <> show name <> " has a leaf in one place and a non-leaf in another." + formatError (TypeConditionNotFound name) = "Type condition " <> show name <> " not found in schema." + +type ValidationErrors = NonEmpty ValidationError + +-- | Type alias for our most common kind of validator. +type Validation = Validator ValidationError + +-- | Identify all of the validation errors in @doc@. +-- +-- An empty list means no errors. +-- +-- +getErrors :: Schema -> AST.QueryDocument -> [ValidationError] +getErrors schema doc = + case validate schema doc of + Left errors -> NonEmpty.toList errors + Right _ -> [] + +-- * Helper functions + +-- | Return a list of all the elements with duplicates. The list of duplicates +-- itself will not contain duplicates. +-- +-- prop> \xs -> findDuplicates @Int xs == ordNub (findDuplicates @Int xs) +findDuplicates :: Ord a => [a] -> [a] +findDuplicates xs = findDups (sort xs) + where + findDups [] = [] + findDups [_] = [] + findDups (x:ys@(y:zs)) + | x == y = x:findDups (dropWhile (== x) zs) + | otherwise = findDups ys + +-- | Create a map from a list of key-value pairs. +-- +-- Returns a list of duplicates on 'Left' if there are duplicates. +makeMap :: Ord key => [(key, value)] -> Validator key (Map key value) +makeMap entries = + case NonEmpty.nonEmpty (findDuplicates (map fst entries)) of + Nothing -> pure (Map.fromList entries) + Just dups -> throwErrors dups + +-- * Error handling + +-- | A 'Validator' is a value that can either be valid or have a non-empty +-- list of errors. +newtype Validator e a = Validator { runValidator :: Either (NonEmpty e) a } deriving (Eq, Show, Functor, Monad) + +-- | Throw a single validation error. +throwE :: e -> Validator e a +throwE e = throwErrors (e :| []) + +-- | Throw multiple validation errors. There must be at least one. +throwErrors :: NonEmpty e -> Validator e a +throwErrors = Validator . Left + +-- | Map over each individual error on a validation. Useful for composing +-- validations. +-- +-- This is /somewhat/ like 'first', but 'Validator' is not, and cannot be, a +-- 'Bifunctor', because the left-hand side is specialized to @NonEmpty e@, +-- rather than plain @e@. Also, whatever function were passed to 'first' would +-- get the whole non-empty list, whereas 'mapErrors' works on one element at a +-- time. +-- +-- >>> mapErrors (+1) (pure "hello") +-- Validator {runValidator = Right "hello"} +-- >>> mapErrors (+1) (throwE 2) +-- Validator {runValidator = Left (3 :| [])} +-- >>> mapErrors (+1) (throwErrors (NonEmpty.fromList [3, 5])) +-- Validator {runValidator = Left (4 :| [6])} +mapErrors :: (e1 -> e2) -> Validator e1 a -> Validator e2 a +mapErrors f (Validator (Left es)) = Validator (Left (map f es)) +mapErrors _ (Validator (Right x)) = Validator (Right x) + +-- | The applicative on Validator allows multiple potentially-valid values to +-- be composed, and ensures that *all* validation errors bubble up. +instance Applicative (Validator e) where + pure x = Validator (Right x) + Validator (Left e1) <*> (Validator (Left e2)) = Validator (Left (e1 <> e2)) + Validator (Left e) <*> _ = Validator (Left e) + Validator _ <*> (Validator (Left e)) = Validator (Left e) + Validator (Right f) <*> Validator (Right x) = Validator (Right (f x)) diff --git a/src/GraphQL/Resolver.hs b/src/GraphQL/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Resolver.hs @@ -0,0 +1,535 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} -- nicer type errors in some cases +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- for TypeError + +module GraphQL.Resolver + ( ResolverError(..) + , HasResolver(..) + , (:<>)(..) + , Defaultable(..) + , Result(..) + , unionValue + ) where + +-- TODO (probably incomplete, the spec is large) +-- - input objects - I'm not super clear from the spec on how +-- they differ from normal objects. +-- - "extend type X" is used in examples in the spec but it's not +-- explained anywhere? +-- - Directives (https://facebook.github.io/graphql/#sec-Type-System.Directives) +-- - Enforce non-empty lists (might only be doable via value-level validation) + +import Protolude hiding (Enum, TypeError) + +import qualified Data.Text as Text +import qualified Data.List.NonEmpty as NonEmpty +import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal) +import qualified GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + +import GraphQL.API + ( (:>) + , HasAnnotatedType(..) + , HasAnnotatedInputType(..) + ) +import qualified GraphQL.API as API +import qualified GraphQL.Value as GValue +import GraphQL.Value + ( Value + , pattern ValueEnum + ) +import GraphQL.Value.FromValue (FromValue(..)) +import GraphQL.Value.ToValue (ToValue(..)) +import GraphQL.Internal.Name (Name, NameError(..), HasName(..), nameFromSymbol) +import qualified GraphQL.Internal.OrderedMap as OrderedMap +import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Validation + ( SelectionSetByType + , SelectionSet(..) + , Field + , ValidationErrors + , getSubSelectionSet + , getSelectionSetForType + , lookupArgument + ) + +data ResolverError + -- | There was a problem in the schema. Server-side problem. + = SchemaError NameError + -- | Couldn't find the requested field in the object. A client-side problem. + | FieldNotFoundError Name + -- | No value provided for name, and no default specified. Client-side problem. + | ValueMissing Name + -- | Could not translate value into Haskell. Probably a client-side problem. + | InvalidValue Name Text + -- | Found validation errors when we tried to merge fields. + | ValidationError ValidationErrors + -- | Tried to get subselection of leaf field. + | SubSelectionOnLeaf (SelectionSetByType Value) + -- | Tried to treat an object as a leaf. + | MissingSelectionSet + deriving (Show, Eq) + +instance GraphQLError ResolverError where + formatError (SchemaError e) = + "Schema error: " <> formatError e + formatError (FieldNotFoundError field) = + "Field not supported by the API: " <> show field + formatError (ValueMissing name) = + "No value provided for " <> show name <> ", and no default specified." + formatError (InvalidValue name text) = + "Could not coerce " <> show name <> " to valid value: " <> text + formatError (ValidationError errs) = + "Validation errors: " <> Text.intercalate ", " (map formatError (NonEmpty.toList errs)) + formatError (SubSelectionOnLeaf ss) = + "Tried to get values within leaf field: " <> show ss + formatError MissingSelectionSet = + "Triet to treat object as if it were leaf field." + +-- | Object field separation operator. +-- +-- Use this to provide handlers for fields of an object. +-- +-- Say you had the following GraphQL type with \"foo\" and \"bar\" fields, +-- e.g. +-- +-- @ +-- type MyObject { +-- foo: Int! +-- bar: String! +-- } +-- @ +-- +-- You could provide handlers for it like this: +-- +-- >>> :m +System.Environment +-- >>> let fooHandler = pure 42 +-- >>> let barHandler = System.Environment.getProgName +-- >>> let myObjectHandler = pure $ fooHandler :<> barHandler :<> () +data a :<> b = a :<> b +infixr 8 :<> + + +-- Result collects errors and values at the same time unless a handler +-- tells us to bail out in which case we stop the processing +-- immediately. +data Result a = Result [ResolverError] a deriving (Show, Functor, Eq) + +-- Aggregating results keeps all errors and creates a ValueList +-- containing the individual values. +aggregateResults :: [Result Value] -> Result Value +aggregateResults r = toValue <$> sequenceA r + +throwE :: Applicative f => ResolverError -> f (Result Value) +throwE err = pure (Result [err] GValue.ValueNull) + +instance Applicative Result where + pure v = Result [] v + (Result e1 f) <*> (Result e2 x) = Result (e1 <> e2) (f x) + +ok :: Value -> Result Value +ok = pure + +class HasResolver m a where + type Handler m a + resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) + +-- | Specify a default value for a type in a GraphQL schema. +-- +-- GraphQL schema can have default values in certain places. For example, +-- arguments to fields can have default values. Because we cannot lift +-- arbitrary values to the type level, we need some way of getting at those +-- values. This typeclass provides the means. +-- +-- To specify a default, implement this typeclass. +-- +-- The default implementation is to say that there *is* no default for this +-- type. +class Defaultable a where + -- | defaultFor returns the value to be used when no value has been given. + defaultFor :: Name -> Maybe a + defaultFor _ = empty + +-- | Called when the schema expects an input argument @name@ of type @a@ but +-- @name@ has not been provided. +valueMissing :: Defaultable a => Name -> Either ResolverError a +valueMissing name = maybe (Left (ValueMissing name)) Right (defaultFor name) + +instance Defaultable Int32 + +instance Defaultable Double + +instance Defaultable Bool + +instance Defaultable Text + +instance Defaultable (Maybe a) where + -- | The default for @Maybe a@ is @Nothing@. + defaultFor _ = pure Nothing + +instance forall m. (Applicative m) => HasResolver m Int32 where + type Handler m Int32 = m Int32 + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m. (Applicative m) => HasResolver m Double where + type Handler m Double = m Double + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m. (Applicative m) => HasResolver m Text where + type Handler m Text = m Text + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m. (Applicative m) => HasResolver m Bool where + type Handler m Bool = m Bool + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where + type Handler m (API.List hg) = m [Handler m hg] + resolve handler selectionSet = do + h <- handler + let a = traverse (flip (resolve @m @hg) selectionSet) h + map aggregateResults a + +instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where + type Handler m (API.Enum ksN enum) = enum + resolve handler Nothing = (pure . ok . GValue.ValueEnum . API.enumToValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +-- TODO: This is our handler for `Maybe a`, which is currently used to +-- implement nullable types. It's *probably* broken, in that it's discarding +-- the selection set. +instance forall m hg. (HasResolver m hg, Functor m, ToValue (Maybe hg)) => HasResolver m (Maybe hg) where + type Handler m (Maybe hg) = m (Maybe hg) + resolve handler _ = map (ok . toValue) handler + +-- TODO: A parametrized `Result` is really not a good way to handle the +-- "result" for resolveField, but not sure what to use either. Tom liked the +-- tuple we had before more because it didn't imply any other structure or +-- meaning. Maybe we can just create a new datatype. jml thinks we should +-- extract some helpful generic monad, ala `Validator`. +-- +type ResolveFieldResult = Result (Maybe GValue.Value) + +-- Extract field name from an argument type. TODO: ideally we'd run +-- this directly on the "a :> b" argument structure, but that requires +-- passing in the plain argument structure type into resolveField or +-- resolving "name" in the buildFieldResolver. Both options duplicate +-- code somwehere else. +type family FieldName (a :: Type) = (r :: Symbol) where + FieldName (JustHandler (API.Field name t)) = name + FieldName (PlainArgument a f) = FieldName f + FieldName (EnumArgument a f) = FieldName f + FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x) + +resolveField :: forall dispatchType (m :: Type -> Type). + (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType)) + => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult +resolveField handler nextHandler field = + -- check name before + case nameFromSymbol @(FieldName dispatchType) of + Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull)) + Right name' + | getName field == name' -> + case buildFieldResolver @m @dispatchType handler field of + Left err -> pure (Result [err] (Just GValue.ValueNull)) + Right resolver -> do + Result errs value <- resolver + pure (Result errs (Just value)) + | otherwise -> nextHandler + +-- We're using our usual trick of rewriting a type in a closed type +-- family to emulate a closed typeclass. The following are the +-- universe of "allowed" class instances for field types: +data JustHandler a +data EnumArgument a b +data PlainArgument a b + +-- injective helps with errors sometimes +type family FieldResolverDispatchType (a :: Type) = (r :: Type) | r -> a where + FieldResolverDispatchType (API.Field ksA t) = JustHandler (API.Field ksA t) + FieldResolverDispatchType (API.Argument ksB (API.Enum name t) :> f) = EnumArgument (API.Argument ksB (API.Enum name t)) (FieldResolverDispatchType f) + FieldResolverDispatchType (API.Argument ksC t :> f) = PlainArgument (API.Argument ksC t) (FieldResolverDispatchType f) + +-- | Derive the handler type from the Field/Argument type in a closed +-- type family: We don't want anyone else to extend this ever. +type family FieldHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where + FieldHandler m (JustHandler (API.Field ksD t)) = Handler m t + FieldHandler m (PlainArgument (API.Argument ksE t) f) = t -> FieldHandler m f + FieldHandler m (EnumArgument (API.Argument ksF (API.Enum name t)) f) = t -> FieldHandler m f + +class BuildFieldResolver m fieldResolverType where + buildFieldResolver :: FieldHandler m fieldResolverType -> Field Value -> Either ResolverError (m (Result Value)) + +instance forall ksG t m. + ( KnownSymbol ksG, HasResolver m t, HasAnnotatedType t, Monad m + ) => BuildFieldResolver m (JustHandler (API.Field ksG t)) where + buildFieldResolver handler field = do + pure (resolve @m @t handler (getSubSelectionSet field)) + +instance forall ksH t f m. + ( KnownSymbol ksH + , BuildFieldResolver m f + , FromValue t + , Defaultable t + , HasAnnotatedInputType t + , Monad m + ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where + buildFieldResolver handler field = do + argument <- first SchemaError (API.getArgumentDefinition @(API.Argument ksH t)) + let argName = getName argument + value <- case lookupArgument field argName of + Nothing -> valueMissing @t argName + Just v -> first (InvalidValue argName) (fromValue @t v) + buildFieldResolver @m @f (handler value) field + +instance forall ksK t f m name. + ( KnownSymbol ksK + , BuildFieldResolver m f + , KnownSymbol name + , Defaultable t + , API.GraphQLEnum t + , Monad m + ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where + buildFieldResolver handler field = do + argName <- first SchemaError (nameFromSymbol @ksK) + value <- case lookupArgument field argName of + Nothing -> valueMissing @t argName + Just (ValueEnum enum) -> first (InvalidValue argName) (API.enumFromValue @t enum) + Just value -> Left (InvalidValue argName (show value <> " not an enum: " <> show (API.enumValues @t))) + buildFieldResolver @m @f (handler value) field + +-- Note that we enumerate all ks variables with capital letters so we +-- can figure out error messages like the following that don't come +-- with line numbers: +-- +-- • No instance for (GHC.TypeLits.KnownSymbol ks0) +-- arising from a use of ‘interpretAnonymousQuery’ + +-- We only allow Field and Argument :> Field combinations: +type family RunFieldsType (m :: Type -> Type) (a :: [Type]) = (r :: Type) where + RunFieldsType m '[API.Field ksI t] = API.Field ksI t + RunFieldsType m '[a :> b] = a :> b + RunFieldsType m ((API.Field ksJ t) ': rest) = API.Field ksJ t :<> RunFieldsType m rest + RunFieldsType m ((a :> b) ': rest) = (a :> b) :<> RunFieldsType m rest + RunFieldsType m a = TypeError ( + 'Text "All field entries in an Object must be Field or Argument :> Field. Got: " ':<>: 'ShowType a) + +-- Match the three possible cases for Fields (see also RunFieldsType) +type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where + RunFieldsHandler m (f :<> fs) = FieldHandler m (FieldResolverDispatchType f) :<> RunFieldsHandler m fs + RunFieldsHandler m (API.Field ksL t) = FieldHandler m (FieldResolverDispatchType (API.Field ksL t)) + RunFieldsHandler m (a :> b) = FieldHandler m (FieldResolverDispatchType (a :> b)) + RunFieldsHandler m a = TypeError ( + 'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a) + + +class RunFields m a where + -- | Run a single 'Selection' over all possible fields (as specified by the + -- type @a@), returning exactly one 'GValue.ObjectField' when a field + -- matches, or an error otherwise. + -- + -- Individual implementations are responsible for calling 'runFields' if + -- they haven't matched the field and there are still candidate fields + -- within the handler. + runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult + +instance forall f fs m dispatchType. + ( BuildFieldResolver m dispatchType + , dispatchType ~ FieldResolverDispatchType f + , RunFields m fs + , KnownSymbol (FieldName dispatchType) + , Monad m + ) => RunFields m (f :<> fs) where + runFields (handler :<> nextHandlers) field = + resolveField @dispatchType @m handler nextHandler field + where + nextHandler = runFields @m @fs nextHandlers field + +instance forall ksM t m dispatchType. + ( BuildFieldResolver m dispatchType + , KnownSymbol ksM + , dispatchType ~ FieldResolverDispatchType (API.Field ksM t) + , Monad m + ) => RunFields m (API.Field ksM t) where + runFields handler field = + resolveField @dispatchType @m handler nextHandler field + where + nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) + +instance forall m a b dispatchType. + ( BuildFieldResolver m dispatchType + , dispatchType ~ FieldResolverDispatchType (a :> b) + , KnownSymbol (FieldName dispatchType) + , Monad m + ) => RunFields m (a :> b) where + runFields handler field = + resolveField @dispatchType @m handler nextHandler field + where + nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) + +instance forall typeName interfaces fields m. + ( RunFields m (RunFieldsType m fields) + , API.HasObjectDefinition (API.Object typeName interfaces fields) + , Monad m + ) => HasResolver m (API.Object typeName interfaces fields) where + type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields)) + + resolve _ Nothing = throwE MissingSelectionSet + resolve mHandler (Just selectionSet) = + case getSelectionSet of + Left err -> throwE err + Right ss -> do + -- Run the handler so the field resolvers have access to the object. + -- This (and other places, including field resolvers) is where user + -- code can do things like look up something in a database. + handler <- mHandler + r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss + let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r + pure (Result errs (GValue.ValueObject obj)) + + where + getSelectionSet = do + defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields) + -- Fields of a selection set may be behind "type conditions", due to + -- inline fragments or the use of fragment spreads. These type + -- conditions are represented in the schema by the name of a type + -- (e.g. "Dog"). To determine which type conditions (and thus which + -- fields) are relevant for this 1selection set, we need to look up the + -- actual types they refer to, as interfaces (say) match objects + -- differently than unions. + -- + -- See for + -- more details. + (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet + pure ss' + +-- TODO(tom): we're getting to a point where it might make sense to +-- split resolver into submodules (GraphQL.Resolver.Union etc.) + + +-- | For unions we need a way to have type-safe, open sum types based +-- on the possible 'API.Object's of a union. The following closed type +-- family selects one Object from the union and returns the matching +-- 'HasResolver' 'Handler' type. If the object @o@ is not a member of +-- 'API.Union' then the user code won't compile. +-- +-- This type family is an implementation detail but its TypeError +-- messages are visible at compile time. +type family TypeIndex (m :: Type -> Type) (object :: Type) (union :: Type) = (result :: Type) where + TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name interfaces fields:_)) = + Handler m (API.Object name interfaces fields) + TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name' i' f':objects)) = + TypeIndex m (API.Object name interfaces fields) (API.Union uName objects) + -- Slightly nicer type errors: + TypeIndex _ (API.Object name interfaces fields) (API.Union uName '[]) = + TypeError ('Text "Type not found in union definition: " ':<>: 'ShowType (API.Object name interfaces fields)) + TypeIndex _ (API.Object name interfaces fields) x = + TypeError ('Text "3rd type must be a union but it is: " ':<>: 'ShowType x) + TypeIndex _ o _ = + TypeError ('Text "Invalid TypeIndex. Must be Object but got: " ':<>: 'ShowType o) + + +-- | The 'Handler' type of a 'API.Union' must be the same for all +-- possible Objects, but each Object has a different type. We +-- unsafeCoerce the return type into an Any, tagging it with the union +-- and the underlying monad for type safety, but we elide the Object +-- type itself. This way we can represent all 'Handler' types of the +-- Union with a single type and still stay type-safe. +type role DynamicUnionValue representational representational +data DynamicUnionValue (union :: Type) (m :: Type -> Type) = DynamicUnionValue { _label :: Text, _value :: GHC.Exts.Any } + +class RunUnion m union objects where + runUnion :: DynamicUnionValue union m -> SelectionSetByType Value -> m (Result Value) + +instance forall m union objects name interfaces fields. + ( Monad m + , KnownSymbol name + , TypeIndex m (API.Object name interfaces fields) union ~ Handler m (API.Object name interfaces fields) + , RunFields m (RunFieldsType m fields) + , API.HasObjectDefinition (API.Object name interfaces fields) + , RunUnion m union objects + ) => RunUnion m union (API.Object name interfaces fields:objects) where + runUnion duv selectionSet = + case extractUnionValue @(API.Object name interfaces fields) @union @m duv of + Just handler -> resolve @m @(API.Object name interfaces fields) handler (Just selectionSet) + Nothing -> runUnion @m @union @objects duv selectionSet + +-- AFAICT it should not be possible to ever hit the empty case because +-- the compiler doesn't allow constructing a unionValue that's not in +-- the Union. If the following code ever gets executed it's almost +-- certainly a bug in the union code. +-- +-- We still need to implement this instance for the compiler because +-- it exhaustively checks all cases when deconstructs the Union. +instance forall m union. RunUnion m union '[] where + runUnion (DynamicUnionValue label _) selection = + panic ("Unexpected branch in runUnion, got " <> show selection <> " for label " <> label <> ". Please file a bug.") + +instance forall m unionName objects. + ( Monad m + , KnownSymbol unionName + , RunUnion m (API.Union unionName objects) objects + ) => HasResolver m (API.Union unionName objects) where + type Handler m (API.Union unionName objects) = m (DynamicUnionValue (API.Union unionName objects) m) + resolve _ Nothing = throwE MissingSelectionSet + resolve mHandler (Just selectionSet) = do + duv <- mHandler + runUnion @m @(API.Union unionName objects) @objects duv selectionSet + +symbolText :: forall ks. KnownSymbol ks => Text +symbolText = toS (symbolVal @ks Proxy) + +-- | Translate a 'Handler' into a DynamicUnionValue type required by +-- 'Union' handlers. This is dynamic, but nevertheless type-safe +-- because we can only tag with types that are part of the union. +-- +-- Use e.g. like "unionValue @Cat" if you have an object like this: +-- +-- >>> type Cat = API.Object "Cat" '[] '[API.Field "name" Text] +-- +-- and then use `unionValue @Cat (pure (pure "Felix"))`. See +-- `examples/UnionExample.hs` for more code. +unionValue :: + forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. + (Monad m, API.Object name interfaces fields ~ object, KnownSymbol name) + => TypeIndex m object union -> m (DynamicUnionValue union m) +unionValue x = + -- TODO(tom) - we might want to move to Typeable `cast` for uValue + -- instead of doing our own unsafeCoerce because it comes with + -- additional safety guarantees: Typerep is unforgeable, while we + -- can still into a bad place by matching on name only. We can't + -- actually segfault this because right now we walk the list of + -- objects in a union left-to-right so in case of duplicate names we + -- only every see one type. That doesn't seen like a great thing to + -- rely on though! + + -- Note that unsafeCoerce is safe because we index the type from the + -- union with an 'API.Object' whose name we're storing in label. On + -- the way out we check that the name is the same, and we know the + -- type universe is the same because we annotated DynamicUnionValue + -- with the type universe. + pure (DynamicUnionValue (symbolText @name) (unsafeCoerce x)) + +extractUnionValue :: + forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. + (API.Object name interfaces fields ~ object, KnownSymbol name) + => DynamicUnionValue union m -> Maybe (TypeIndex m object union) +extractUnionValue (DynamicUnionValue uName uValue) = + if uName == symbolText @name + then Just (unsafeCoerce uValue) + else Nothing diff --git a/src/GraphQL/Value.hs b/src/GraphQL/Value.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Value.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Literal GraphQL values. +module GraphQL.Value + ( Value + , Value'(..) + , ConstScalar + , UnresolvedVariableValue + , pattern ValueInt + , pattern ValueFloat + , pattern ValueBoolean + , pattern ValueString + , pattern ValueEnum + , pattern ValueList + , pattern ValueObject + , pattern ValueNull + , toObject + , valueToAST + , astToVariableValue + , variableValueToAST + , List + , List'(..) + , String(..) + -- * Names + , Name(..) + , NameError(..) + , makeName + -- * Objects + , Object + , Object'(..) + , ObjectField + , ObjectField'(ObjectField) + -- ** Constructing + , makeObject + , objectFromList + , objectFromOrderedMap + -- ** Combining + , unionObjects + -- ** Querying + , objectFields + ) where + +import Protolude + +import qualified Data.Aeson as Aeson +import Data.Aeson (ToJSON(..), (.=), pairs) +import qualified Data.Map as Map +import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized) + +import GraphQL.Internal.Arbitrary (arbitraryText) +import GraphQL.Internal.Name (Name(..), NameError(..), makeName) +import GraphQL.Internal.Syntax.AST (Variable) +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.OrderedMap (OrderedMap) +import qualified GraphQL.Internal.OrderedMap as OrderedMap + +-- * Values + +-- | A GraphQL value. @scalar@ represents the type of scalar that's contained +-- within this value. +-- +-- Normally, it is one of either 'ConstScalar' (to indicate that there are no +-- variables whatsoever) or 'VariableScalar' (to indicate that there might be +-- some variables). +data Value' scalar + = ValueScalar' scalar + | ValueList' (List' scalar) + | ValueObject' (Object' scalar) + deriving (Eq, Ord, Show, Functor) + +instance Foldable Value' where + foldMap f (ValueScalar' scalar) = f scalar + foldMap f (ValueList' values) = foldMap f values + foldMap f (ValueObject' obj) = foldMap f obj + +instance Traversable Value' where + traverse f (ValueScalar' x) = ValueScalar' <$> f x + traverse f (ValueList' xs) = ValueList' <$> traverse f xs + traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs + +instance ToJSON scalar => ToJSON (Value' scalar) where + toJSON (ValueScalar' x) = toJSON x + toJSON (ValueList' x) = toJSON x + toJSON (ValueObject' x) = toJSON x + +instance Arbitrary scalar => Arbitrary (Value' scalar) where + -- | Generate an arbitrary value. Uses the generator's \"size\" property to + -- determine maximum object depth. + arbitrary = sized genValue + +-- | Generate an arbitrary value, with objects at most @n@ levels deep. +genValue :: Arbitrary scalar => Int -> Gen (Value' scalar) +genValue n + | n <= 0 = arbitrary + | otherwise = oneof [ ValueScalar' <$> arbitrary + , ValueObject' <$> genObject (n - 1) + , ValueList' . List' <$> listOf (genValue (n - 1)) + ] + +-- | A GraphQL value which contains no variables. +type Value = Value' ConstScalar + +-- TODO: These next two definitions are quite internal. We should move this +-- module to Internal and then re-export the bits that end-users will use. +-- + +-- | A GraphQL value which might contain some variables. These variables are +-- not yet associated with +-- (see also 'GraphQL.Internal.Validation.VariableDefinition'), +-- which are provided in a different context. +type UnresolvedVariableValue = Value' UnresolvedVariableScalar + +pattern ValueInt :: Int32 -> Value +pattern ValueInt x = ValueScalar' (ConstInt x) + +pattern ValueFloat :: Double -> Value +pattern ValueFloat x = ValueScalar' (ConstFloat x) + +pattern ValueBoolean :: Bool -> Value +pattern ValueBoolean x = ValueScalar' (ConstBoolean x) + +pattern ValueString :: String -> Value +pattern ValueString x = ValueScalar' (ConstString x) + +pattern ValueEnum :: Name -> Value +pattern ValueEnum x = ValueScalar' (ConstEnum x) + +pattern ValueList :: forall t. List' t -> Value' t +pattern ValueList x = ValueList' x + +pattern ValueObject :: forall t. Object' t -> Value' t +pattern ValueObject x = ValueObject' x + +pattern ValueNull :: Value +pattern ValueNull = ValueScalar' ConstNull + +-- | If a value is an object, return just that. Otherwise @Nothing@. +toObject :: Value' scalar -> Maybe (Object' scalar) +toObject (ValueObject' o) = pure o +toObject _ = empty + +-- * Scalars + +-- | A non-variable value which contains no other values. +data ConstScalar + = ConstInt Int32 + | ConstFloat Double + | ConstBoolean Bool + | ConstString String + | ConstEnum Name + | ConstNull + deriving (Eq, Ord, Show) + +instance ToJSON ConstScalar where + toJSON (ConstInt x) = toJSON x + toJSON (ConstFloat x) = toJSON x + toJSON (ConstBoolean x) = toJSON x + toJSON (ConstString x) = toJSON x + toJSON (ConstEnum x) = toJSON x + toJSON ConstNull = Aeson.Null + +-- | A value which contains no other values, and might be a variable that +-- might lack a definition. +type UnresolvedVariableScalar = Either Variable ConstScalar + +-- | Generate an arbitrary scalar value. +instance Arbitrary ConstScalar where + arbitrary = oneof [ ConstInt <$> arbitrary + , ConstFloat <$> arbitrary + , ConstBoolean <$> arbitrary + , ConstString <$> arbitrary + , ConstEnum <$> arbitrary + , pure ConstNull + ] + +-- | Convert a constant scalar to an AST.Value +constScalarToAST :: ConstScalar -> AST.Value +constScalarToAST scalar = + case scalar of + ConstInt x -> AST.ValueInt x + ConstFloat x -> AST.ValueFloat x + ConstBoolean x -> AST.ValueBoolean x + ConstString (String x) -> AST.ValueString (AST.StringValue x) + ConstEnum x -> AST.ValueEnum x + ConstNull -> AST.ValueNull + +-- | Convert a variable scalar to an AST.Value +variableToAST :: UnresolvedVariableScalar -> AST.Value +variableToAST (Left variable) = AST.ValueVariable variable +variableToAST (Right constant) = constScalarToAST constant + +-- | Convert a value from the AST into a variable scalar, presuming it /is/ a +-- scalar. +astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar +astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x +astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x +astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x +astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x) +astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x +astToScalar AST.ValueNull = pure $ Right ConstNull +astToScalar (AST.ValueVariable x) = pure $ Left x +astToScalar _ = empty + + +-- * Strings + +newtype String = String Text deriving (Eq, Ord, Show) + +instance Arbitrary String where + arbitrary = String <$> arbitraryText + +instance ToJSON String where + toJSON (String x) = toJSON x + +-- * Lists + +newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor) + +instance Foldable List' where + foldMap f (List' values) = mconcat (map (foldMap f) values) + +instance Traversable List' where + traverse f (List' xs) = List' <$> traverse (traverse f) xs + + +-- | A list of values that are known to be constants. +-- +-- Note that this list might not be valid GraphQL, because GraphQL only allows +-- homogeneous lists (i.e. all elements of the same type), and we do no type +-- checking at this point. +type List = List' ConstScalar + +instance Arbitrary scalar => Arbitrary (List' scalar) where + -- TODO: GraphQL does not allow heterogeneous lists: + -- https://facebook.github.io/graphql/#sec-Lists, so this will generate + -- invalid lists. + arbitrary = List' <$> listOf arbitrary + + +instance ToJSON scalar => ToJSON (List' scalar) where + toJSON (List' x) = toJSON x + +-- * Objects + +-- | A GraphQL object. +-- +-- Note that https://facebook.github.io/graphql/#sec-Response calls these +-- \"Maps\", but everywhere else in the spec refers to them as objects. +newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor) + +instance Foldable Object' where + foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap + +instance Traversable Object' where + traverse f (Object' xs) = Object' <$> traverse (traverse f) xs + +-- | A GraphQL object that contains only non-variable values. +type Object = Object' ConstScalar + +objectFields :: Object' scalar -> [ObjectField' scalar] +objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object) + +instance Arbitrary scalar => Arbitrary (Object' scalar) where + arbitrary = sized genObject + +-- | Generate an arbitrary object to the given maximum depth. +genObject :: Arbitrary scalar => Int -> Gen (Object' scalar) +genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n) + +data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor) + +-- | A field of an object that has a non-variable value. +type ObjectField = ObjectField' ConstScalar + +pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t +pattern ObjectField name value = ObjectField' name value + +instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where + arbitrary = ObjectField' <$> arbitrary <*> arbitrary + +-- | Make an object from a list of object fields. +makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar) +makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields] + +-- | Make an object from an ordered map. +objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar +objectFromOrderedMap = Object' + +-- | Create an object from a list of (name, value) pairs. +objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar) +objectFromList xs = Object' <$> OrderedMap.orderedMap xs + +unionObjects :: [Object' scalar] -> Maybe (Object' scalar) +unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects] + +instance ToJSON scalar => ToJSON (Object' scalar) where + -- Direct encoding to preserve order of keys / values + toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs]) + toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs)) + + + + +-- * Conversion to and from AST. + +-- | Convert an AST value into a literal value. +-- +-- This is a stop-gap until we have proper conversion of user queries into +-- canonical forms. +astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar) +astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x)) +astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull)) +astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x)) +astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs +astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do + fields' <- traverse toObjectField fields + object <- makeObject fields' + pure (ValueObject' object) + where + toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value + +-- | Convert an AST value to a variable value. +-- +-- Will fail if the AST value contains duplicate object fields, or is +-- otherwise invalid. +astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue +astToVariableValue ast = astToValue' convertScalar ast + where + convertScalar x = + case astToScalar x of + Just scalar -> scalar + Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x) + +-- | Convert a value to an AST value. +valueToAST :: Value -> AST.Value +valueToAST = valueToAST' constScalarToAST + +-- | Convert a variable value to an AST value. +variableValueToAST :: UnresolvedVariableValue -> AST.Value +variableValueToAST = valueToAST' variableToAST + +-- | Convert a literal value into an AST value. +-- +-- Nulls are converted into Nothing. +-- +-- This function probably isn't particularly useful, but it functions as a +-- stop-gap until we have QuickCheck generators for the AST. +valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value +valueToAST' f (ValueScalar' x) = f x +valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs)) +valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields))) + where + toObjectField (name, value) = AST.ObjectField name (valueToAST' f value) diff --git a/src/GraphQL/Value/FromValue.hs b/src/GraphQL/Value/FromValue.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Value/FromValue.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Literal GraphQL values. +module GraphQL.Value.FromValue + ( FromValue(..) + , prop_roundtripValue + , wrongType + ) where + +import Protolude hiding (TypeError) +import GraphQL.Internal.Name (nameFromSymbol) +import qualified GraphQL.Internal.OrderedMap as OM +import GraphQL.Value +import GraphQL.Value.ToValue (ToValue(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics ((:*:)(..)) +import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) + +-- * FromValue + +-- | @a@ can be converted from a GraphQL 'Value' to a Haskell value. +-- +-- The @FromValue@ instance converts 'AST.Value' to the type expected by the +-- handler function. It is the boundary between incoming data and your custom +-- application Haskell types. +-- +-- @FromValue@ has a generic instance for converting input objects to +-- records. +class FromValue a where + -- | Convert an already-parsed value into a Haskell value, generally to be + -- passed to a handler. + fromValue :: Value' ConstScalar -> Either Text a + default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a + fromValue (ValueObject v) = to <$> genericFromValue v + fromValue v = wrongType "genericFromValue only works with objects." v + +instance FromValue Int32 where + fromValue (ValueInt v) = pure v + fromValue v = wrongType "Int" v + +instance FromValue Double where + fromValue (ValueFloat v) = pure v + fromValue v = wrongType "Double" v + +instance FromValue Bool where + fromValue (ValueBoolean v) = pure v + fromValue v = wrongType "Bool" v + +instance FromValue Text where + fromValue (ValueString (String v)) = pure v + fromValue v = wrongType "String" v + +instance forall v. FromValue v => FromValue [v] where + fromValue (ValueList' (List' values)) = traverse (fromValue @v) values + fromValue v = wrongType "List" v + +instance forall v. FromValue v => FromValue (NonEmpty v) where + fromValue (ValueList' (List' values)) = + case NonEmpty.nonEmpty values of + Nothing -> Left "Cannot construct NonEmpty from empty list" + Just values' -> traverse (fromValue @v) values' + fromValue v = wrongType "List" v + +instance forall v. FromValue v => FromValue (Maybe v) where + fromValue ValueNull = pure Nothing + fromValue x = Just <$> fromValue @v x + +-- | Anything that can be converted to a value and from a value should roundtrip. +prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool +prop_roundtripValue x = fromValue (toValue x) == Right x + +-- | Throw an error saying that @value@ does not have the @expected@ type. +wrongType :: (MonadError Text m, Show a) => Text -> a -> m b +wrongType expected value = throwError ("Wrong type, should be " <> expected <> show value) + + +-- We only allow generic record reading for now because I am not sure +-- how we should interpret any other generic things (e.g. tuples). +class GenericFromValue (f :: Type -> Type) where + genericFromValue :: Object' ConstScalar -> Either Text (f p) + +instance forall dataName consName records s l p. + ( KnownSymbol dataName + , KnownSymbol consName + , GenericFromValue records + ) => GenericFromValue (D1 ('MetaData dataName s l 'False) + (C1 ('MetaCons consName p 'True) records + )) where + genericFromValue o = M1 . M1 <$> genericFromValue @records o + +instance forall wrappedType fieldName rest u s l. + ( KnownSymbol fieldName + , FromValue wrappedType + , GenericFromValue rest + ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType) :*: rest) where + genericFromValue object = do + l <- getValue @wrappedType @fieldName object + r <- genericFromValue @rest object + pure (l :*: r) + +-- | Look up a single record field element in the Object. +getValue :: forall wrappedType fieldName u s l p. (FromValue wrappedType, KnownSymbol fieldName) + => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p) +getValue (Object' fieldMap) = do + fieldName <- case nameFromSymbol @fieldName of + Left err -> throwError ("invalid field name" <> show err) + Right name' -> pure name' + -- TODO(tom): How do we deal with optional fields? Maybe sounds + -- like the correct type, but how would Maybe be different from + -- `null`? Delegating to FromValue not good enough here because of + -- the dictionary lookup. + case OM.lookup fieldName fieldMap of + Nothing -> throwError ("Key not found: " <> show fieldName) + Just v -> M1 . K1 <$> fromValue @wrappedType v + +instance forall wrappedType fieldName u s l. + ( KnownSymbol fieldName + , FromValue wrappedType + ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where + genericFromValue = getValue @wrappedType @fieldName + +instance forall l r m. + ( TypeError ('Text "Generic fromValue only works for records with exactly one data constructor.") + ) => GenericFromValue (D1 m (l :+: r)) where + genericFromValue = undefined diff --git a/src/GraphQL/Value/ToValue.hs b/src/GraphQL/Value/ToValue.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Value/ToValue.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances #-} + +module GraphQL.Value.ToValue + ( ToValue(..) + ) where + +import Protolude +import GraphQL.Value +import Data.List.NonEmpty (NonEmpty) + +-- * ToValue + +-- | Turn a Haskell value into a GraphQL value. +class ToValue a where + toValue :: a -> Value' ConstScalar + +instance ToValue (Value' ConstScalar) where + toValue = identity + +-- XXX: Should this just be for Foldable? +instance ToValue a => ToValue [a] where + toValue = toValue . List' . map toValue + +-- TODO - tom still thinks that using Maybe for nullable is maybe not +-- the best idea. +instance ToValue a => ToValue (Maybe a) where + toValue Nothing = ValueNull + toValue (Just v) = toValue v + +instance ToValue a => ToValue (NonEmpty a) where + toValue = toValue . makeList + +instance ToValue Bool where + toValue = ValueBoolean + +instance ToValue Int32 where + toValue = ValueInt + +instance ToValue Double where + toValue = ValueFloat + +instance ToValue String where + toValue = ValueString + +-- XXX: Make more generic: any string-like thing rather than just Text. +instance ToValue Text where + toValue = toValue . String + +instance ToValue List where + toValue = ValueList' + +instance ToValue (Object' ConstScalar) where + toValue = ValueObject' + + +makeList :: (Functor f, Foldable f, ToValue a) => f a -> List +makeList = List' . Protolude.toList . map toValue diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs new file mode 100644 --- /dev/null +++ b/tests/ASTTests.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Tests for AST, including parser and encoder. +module ASTTests (tests) where + +import Protolude + +import Data.Attoparsec.Text (parseOnly) +import Text.RawString.QQ (r) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (arbitrary, forAll, resize) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) + +import GraphQL.Value (String(..)) +import GraphQL.Internal.Name (Name, unsafeMakeName) +import qualified GraphQL.Internal.Syntax.AST as AST +import qualified GraphQL.Internal.Syntax.Parser as Parser +import qualified GraphQL.Internal.Syntax.Encoder as Encoder + +kitchenSink :: Text +kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n" + +dog :: Name +dog = unsafeMakeName "dog" + +someName :: Name +someName = unsafeMakeName "name" + +tests :: IO TestTree +tests = testSpec "AST" $ do + describe "Parser and encoder" $ do + it "roundtrips on minified documents" $ do + let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink + actual `shouldBe` Right kitchenSink + describe "parsing numbers" $ do + it "works for some integers" $ do + parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1) + prop "works for all integers" $ do + \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x) + it "works for some floats" $ do + parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5) + it "treats floats as floats even if they end with .0" $ do + parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0) + prop "works for floats" $ do + \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x) + describe "strings" $ do + prop "works for all strings" $ do + \(String x) -> + let input = AST.ValueString (AST.StringValue x) + output = Encoder.value input in + parseOnly Parser.value output == Right input + it "handles unusual strings" $ do + let input = AST.ValueString (AST.StringValue "\fh\244") + let output = Encoder.value input + -- \f is \u000c + output `shouldBe` "\"\\u000ch\244\"" + parseOnly Parser.value output `shouldBe` Right input + describe "parsing values" $ do + prop "works for all literal values" $ do + forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x + it "parses ununusual objects" $ do + let input = AST.ValueObject + (AST.ObjectValue + [ AST.ObjectField (unsafeMakeName "s") + (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")), + AST.ObjectField (unsafeMakeName "Hsr") (AST.ValueInt 0) + ]) + let output = Encoder.value input + parseOnly Parser.value output `shouldBe` Right input + it "parses lists of floats" $ do + let input = AST.ValueList + (AST.ListValue + [ AST.ValueFloat 1.5 + , AST.ValueFloat 1.5 + ]) + let output = Encoder.value input + output `shouldBe` "[1.5,1.5]" + parseOnly Parser.value output `shouldBe` Right input + describe "Parser" $ do + it "parses anonymous query documents" $ do + let query = [r|{ + dog { + name + } + }|] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.AnonymousQuery + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ]) + ] + parsed `shouldBe` expected + + it "parses invalid documents" $ do + let query = [r|{ + dog { + name + } + } + + query getName { + dog { + owner { + name + } + } + }|] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.AnonymousQuery + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ]) + , AST.DefinitionOperation + (AST.Query + (AST.Node (unsafeMakeName "getName") [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing (unsafeMakeName "owner") [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ]) + ])) + ] + parsed `shouldBe` expected + + it "includes variable definitions" $ do + let query = [r| + query houseTrainedQuery($atOtherHomes: Boolean = true) { + dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node (unsafeMakeName "houseTrainedQuery") + [ AST.VariableDefinition + (AST.Variable (unsafeMakeName "atOtherHomes")) + (AST.TypeNamed (AST.NamedType (unsafeMakeName "Boolean"))) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing (unsafeMakeName "isHousetrained") + [ AST.Argument (unsafeMakeName "atOtherHomes") + (AST.ValueVariable (AST.Variable (unsafeMakeName "atOtherHomes"))) + ] [] []) + ]) + ])) + ] + parsed `shouldBe` expected diff --git a/tests/Doctests.hs b/tests/Doctests.hs new file mode 100644 --- /dev/null +++ b/tests/Doctests.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import Protolude + +import Test.DocTest + +main :: IO () +main = doctest $ ["-isrc"] <> options <> files + where + options = map ("-X" <>) extensions + -- These must match the extensions in package.yaml. + extensions = [ "NoImplicitPrelude" + , "OverloadedStrings" + , "RecordWildCards" + , "TypeApplications" + , "DataKinds" + ] + -- library code and examples + files = [ "src/" + , "examples/" + ] diff --git a/tests/EndToEndTests.hs b/tests/EndToEndTests.hs new file mode 100644 --- /dev/null +++ b/tests/EndToEndTests.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +-- | Tests that span the entire system. +-- +-- These tests function both as examples of how to use the API, as well as +-- sanity checks on our reasoning. +module EndToEndTests (tests) where + +import Protolude + +import Data.Aeson (Value(Null), toJSON, object, (.=)) +import qualified Data.Map as Map +import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) +import GraphQL.API (Object, Field) +import GraphQL.Internal.Syntax.AST (Variable(..)) +import GraphQL.Resolver ((:<>)(..), Handler) +import GraphQL.Value (makeName) +import GraphQL.Value.ToValue (ToValue(..)) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) +import Text.RawString.QQ (r) + +import ExampleSchema + +-- | Example query root. +-- +-- @ +-- type QueryRoot { +-- dog: Dog +-- } +-- @ +-- +-- Drawn from . +type QueryRoot = Object "QueryRoot" '[] + '[ Field "dog" Dog + ] + +-- | Our server's internal representation of a 'Dog'. +data ServerDog + = ServerDog + { name :: Text + , nickname :: Maybe Text + , barkVolume :: Int32 + , knownCommands :: Set DogCommand + , houseTrainedAtHome :: Bool + , houseTrainedElsewhere :: Bool + , owner :: ServerHuman + } + +-- | Whether 'ServerDog' knows the given command. +doesKnowCommand :: ServerDog -> DogCommand -> Bool +doesKnowCommand dog command = command `elem` knownCommands dog + +-- | Whether 'ServerDog' is house-trained. +isHouseTrained :: ServerDog -> Maybe Bool -> Bool +isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog +isHouseTrained dog (Just False) = houseTrainedAtHome dog +isHouseTrained dog (Just True) = houseTrainedElsewhere dog + +-- | Present 'ServerDog' for GraphQL. +viewServerDog :: ServerDog -> Handler IO Dog +viewServerDog dog@(ServerDog{..}) = pure $ + pure name :<> + pure nickname :<> + pure barkVolume :<> + pure . doesKnowCommand dog :<> + pure . isHouseTrained dog :<> + viewServerHuman owner + +-- | jml has a stuffed black dog called "Mortgage". +mortgage :: ServerDog +mortgage = ServerDog + { name = "Mortgage" + , nickname = Just "Mort" + , barkVolume = 0 -- He's stuffed + , knownCommands = mempty -- He's stuffed + , houseTrainedAtHome = True -- Never been a problem + , houseTrainedElsewhere = True -- Untested in the field + , owner = jml + } + +-- | Our server's internal representation of a 'Human'. +data ServerHuman = ServerHuman Text deriving (Eq, Ord, Show) + +-- | Present a 'ServerHuman' as a GraphQL 'Human'. +viewServerHuman :: ServerHuman -> Handler IO Human +viewServerHuman (ServerHuman name) = pure (pure name) + +-- | It me. +jml :: ServerHuman +jml = ServerHuman "jml" + +tests :: IO TestTree +tests = testSpec "End-to-end tests" $ do + describe "interpretAnonymousQuery" $ do + it "Handles the simplest possible valid query" $ do + let root = pure (viewServerDog mortgage) + let query = [r|{ + dog { + name + } + } + |] + response <- interpretAnonymousQuery @QueryRoot root query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Handles more than one field" $ do + let root = pure (viewServerDog mortgage) + let query = [r|{ + dog { + name + barkVolume + } + } + |] + response <- interpretAnonymousQuery @QueryRoot root query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "barkVolume" .= (0 :: Int32) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Handles nested queries" $ do + let root = pure (viewServerDog mortgage) + let query = [r|{ + dog { + name + owner { + name + } + } + } + |] + response <- interpretAnonymousQuery @QueryRoot root query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "owner" .= object + [ "name" .= ("jml" :: Text) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "It aliases fields" $ do + let root = pure (viewServerDog mortgage) + let query = [r|{ + dog { + name + boss: owner { + name + } + } + } + |] + response <- interpretAnonymousQuery @QueryRoot root query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "boss" .= object + [ "name" .= ("jml" :: Text) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Passes arguments to functions" $ do + let root = pure (viewServerDog mortgage) + let query = [r|{ + dog { + name + doesKnowCommand(dogCommand: Sit) + } + } + |] + response <- interpretAnonymousQuery @QueryRoot root query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= False + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Handles fairly complex queries" $ do + let root = pure (viewServerDog mortgage) + -- TODO: jml would like to put some union checks in here, but we don't + -- have any unions reachable from Dog! + let query = [r|{ + dog { + callsign: name + ... on Dog { + callsign: name + me: owner { + ... on Sentient { + name + } + ... on Human { + name + } + name + } + } + } + } + |] + response <- interpretAnonymousQuery @QueryRoot root query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "callsign" .= ("Mortgage" :: Text) + , "me" .= object + [ "name" .= ("jml" :: Text) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + describe "interpretQuery" $ do + it "Handles the simplest named query" $ do + let root = pure (viewServerDog mortgage) + let query = [r|query myQuery { + dog { + name + } + } + |] + response <- interpretQuery @QueryRoot root query Nothing mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Allows calling query by name" $ do + let root = pure (viewServerDog mortgage) + let query = [r|query myQuery { + dog { + name + } + } + |] + let Right name = makeName "myQuery" + response <- interpretQuery @QueryRoot root query (Just name) mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + describe "Handles variables" $ do + let root = pure (viewServerDog mortgage) + let Right schema = makeSchema @Dog + let Right query = + compileQuery schema + [r|query myQuery($whichCommand: DogCommand) { + dog { + name + doesKnowCommand(dogCommand: $whichCommand) + } + } + |] + it "Errors when no variables provided" $ do + response <- executeQuery @QueryRoot root query Nothing mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= Null + ] + ] + , "errors" .= + [ + object + -- TODO: This error message is pretty bad. We should define + -- a typeclass for client-friendly "Show" (separate from + -- actual Show which remains extremely useful for debugging) + -- and use that when including values in error messages. + [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Substitutes variables when they are provided" $ do + -- TODO: This is a crummy way to make a variable map. jml doesn't want + -- to come up with a new API in this PR, but probably we should have a + -- very simple function to turn a JSON value / object into the + -- variable map that we desire. Alternatively, we should have APIs + -- like Aeson does. + -- + let Right varName = makeName "whichCommand" + let vars = Map.singleton (Variable varName) (toValue Sit) + response <- executeQuery @QueryRoot root query Nothing vars + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= False + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + diff --git a/tests/ExampleSchema.hs b/tests/ExampleSchema.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleSchema.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | An example GraphQL schema, used in our end-to-end tests. +-- +-- Based on the example schema given in the GraphQL spec. See +-- . +-- +-- Here's the full schema: +-- +-- @ +-- enum DogCommand { SIT, DOWN, HEEL } +-- +-- type Dog implements Pet { +-- name: String! +-- nickname: String +-- barkVolume: Int +-- doesKnowCommand(dogCommand: DogCommand!): Boolean! +-- isHousetrained(atOtherHomes: Boolean): Boolean! +-- owner: Human +-- } +-- +-- interface Sentient { +-- name: String! +-- } +-- +-- interface Pet { +-- name: String! +-- } +-- +-- type Alien implements Sentient { +-- name: String! +-- homePlanet: String +-- } +-- +-- type Human implements Sentient { +-- name: String! +-- } +-- +-- enum CatCommand { JUMP } +-- +-- type Cat implements Pet { +-- name: String! +-- nickname: String +-- doesKnowCommand(catCommand: CatCommand!): Boolean! +-- meowVolume: Int +-- } +-- +-- union CatOrDog = Cat | Dog +-- union DogOrHuman = Dog | Human +-- union HumanOrAlien = Human | Alien +-- @ +-- +-- Unlike the spec, we don't define a @QueryRoot@ type here, instead +-- encouraging test modules to define their own as appropriate to their needs. +-- +-- We'll repeat bits of the schema below, explaining how they translate into +-- Haskell as we go. + +module ExampleSchema + ( DogCommand(..) + , Dog + , Sentient + , Pet + , Alien + , Human + , CatCommand(..) + , Cat + , CatOrDog + , DogOrHuman + , HumanOrAlien + ) where + +import Protolude hiding (Enum) + +import GraphQL.API + ( GraphQLEnum(..) + , Enum + , Object + , Field + , Argument + , Interface + , Union + , (:>) + ) +-- XXX: This really shouldn't be part of Resolver, since whether or not a +-- thing has a default is part of the API / Schema definition. +import GraphQL.Resolver (Defaultable(..)) +import GraphQL.Value (pattern ValueEnum, unName) +import GraphQL.Value.ToValue (ToValue(..)) + +-- | A command that can be given to a 'Dog'. +-- +-- @ +-- enum DogCommand { SIT, DOWN, HEEL } +-- @ +-- +-- To define this in Haskell we need to do three things: +-- +-- 1. Define a sum type with nullary constructors to represent the enum +-- (here, 'DogCommandEnum') +-- 2. Make it an instance of 'GraphQLEnum' +-- 3. Wrap the sum type in 'Enum', e.g. @Enum "DogCommand" DogCommandEnum@ +-- so it can be placed in a schema. +data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic) + +instance GraphQLEnum DogCommand + +-- TODO: Probably shouldn't have to do this for enums. +instance ToValue DogCommand where + toValue = ValueEnum . enumToValue + +-- | A dog. +-- +-- This is an example of a GraphQL \"object\". +-- +-- @ +-- type Dog implements Pet { +-- name: String! +-- nickname: String +-- barkVolume: Int +-- doesKnowCommand(dogCommand: DogCommand!): Boolean! +-- isHousetrained(atOtherHomes: Boolean): Boolean! +-- owner: Human +-- } +-- @ +-- +-- To define it in Haskell, we use 'Object'. The first argument is the name of +-- the object (here, @"Dog"@). The second is a list of interfaces implemented +-- by the object (here, only 'Pet'). +-- +-- The third, final, and most interesting argument is the list of fields the +-- object has. Fields can look one of two ways: +-- +-- @ +-- Field "name" Text +-- @ +-- +-- for a field that takes no arguments. This field would be called @name@ and +-- is guaranteed to return some text if queried. +-- +-- A field that takes arguments looks like this: +-- +-- @ +-- Argument "dogCommand" DogCommand :> Field "doesKnowCommand" Bool +-- @ +-- +-- Here, the field is named @doesKnowCommand@ and it takes a single +-- argument--a 'DogCommand'--and returns a 'Bool'. Note that this is in +-- reverse order to the GraphQL schema, which represents this field as: +-- +-- @ +-- doesKnowCommand(dogCommand: DogCommand!): Boolean! +-- @ +-- +-- Also note that all fields and arguments are "non-null" by default. If you +-- want a field to be nullable, give it a 'Maybe' type, e.g. +-- +-- @ +-- nickname: String +-- @ +-- +-- @nickname@ is nullable, so we represent the field in Haskell as: +-- +-- @ +-- Field "nickname" (Maybe Text) +-- @ +type Dog = Object "Dog" '[Pet] + '[ Field "name" Text + , Field "nickname" (Maybe Text) + , Field "barkVolume" Int32 + , Argument "dogCommand" (Enum "DogCommand" DogCommand) :> Field "doesKnowCommand" Bool + , Argument "atOtherHomes" (Maybe Bool) :> Field "isHouseTrained" Bool + , Field "owner" Human + ] + +instance Defaultable DogCommand where + -- Explicitly want no default for dogCommand + defaultFor (unName -> "dogCommand") = Nothing + -- DogCommand shouldn't be used elsewhere in schema, but who can say? + defaultFor _ = Nothing + +-- | Sentient beings have names. +-- +-- This defines an interface, 'Sentient', that objects can implement. +-- +-- @ +-- interface Sentient { +-- name: String! +-- } +-- @ +type Sentient = Interface "Sentient" '[Field "name" Text] + +-- | Pets have names too. +-- +-- This defines an interface, 'Pet', that objects can implement. +-- +-- @ +-- interface Pet { +-- name: String! +-- } +-- @ +type Pet = Interface "Pet" '[Field "name" Text] + +-- | An alien. +-- +-- See 'Dog' for more details on how to define an object type for GraphQL. +-- +-- @ +-- type Alien implements Sentient { +-- name: String! +-- homePlanet: String +-- } +-- @ +type Alien = Object "Alien" '[Sentient] + '[ Field "name" Text + , Field "homePlanet" (Maybe Text) + ] + +-- | Humans are sentient. +-- +-- See 'Dog' for more details on how to define an object type for GraphQL. +-- +-- @ +-- type Human implements Sentient { +-- name: String! +-- } +-- @ +type Human = Object "Human" '[Sentient] + '[ Field "name" Text + ] + +-- TODO: Extend example to cover unions, interfaces and lists by giving humans +-- a list of pets and a list of cats & dogs. + +-- | Cats can jump. +-- +-- See 'DogCommandEnum' for more details on defining an enum for GraphQL. +-- +-- The interesting thing about 'CatCommandEnum' is that it's an enum that has +-- only one possible value. +-- +-- @ +-- enum CatCommand { JUMP } +-- @ +data CatCommand = Jump deriving Generic + +instance GraphQLEnum CatCommand + +-- | A cat. +-- +-- See 'Dog' for more details on how to define an object type for GraphQL. +-- +-- @ +-- type Cat implements Pet { +-- name: String! +-- nickname: String +-- doesKnowCommand(catCommand: CatCommand!): Boolean! +-- meowVolume: Int +-- } +-- @ +type Cat = Object "Cat" '[Pet] + '[ Field "name" Text + , Field "nickName" (Maybe Text) + , Argument "catCommand" (Enum "CatCommand" CatCommand) :> Field "doesKnowCommand" Bool + , Field "meowVolume" Int32 + ] + +-- | Either a cat or a dog. (Pick dog, dogs are awesome). +-- +-- A 'Union' is used when you want to return one of short list of known +-- types. +-- +-- You define them in GraphQL like so: +-- +-- @ +-- union CatOrDog = Cat | Dog +-- @ +-- +-- To translate this to Haskell, define a new type using 'Union'. The first +-- argument is the name of the union, here @"CatOrDog"@, and the second +-- argument is the list of possible types of the union. These must be objects, +-- defined with 'Object'. +type CatOrDog = Union "CatOrDog" '[Cat, Dog] + +-- | Either a dog or a human. (Pick dog, dogs are awesome). +-- +-- See 'CatOrDog' for more details on defining a union. +-- +-- @ +-- union DogOrHuman = Dog | Human +-- @ +type DogOrHuman = Union "DogOrHuman" '[Dog, Human] + +-- | Either a human or an alien. (Pick dog, dogs are awesome). +-- +-- See 'CatOrDog' for more details on defining a union. +-- +-- @ +-- union HumanOrAlien = Human | Alien +-- @ +type HumanOrAlien = Union "HumanOrAlien" '[Human, Alien] diff --git a/tests/Examples/InputObject.hs b/tests/Examples/InputObject.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/InputObject.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +module Examples.InputObject where +import Protolude hiding (Enum) + +import GraphQL +import GraphQL.API +import GraphQL.Resolver (Handler, Defaultable(..)) +import GraphQL.Value.FromValue (FromValue) + +data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic) +instance FromValue DogStuff +instance HasAnnotatedInputType DogStuff +instance Defaultable DogStuff where + -- TODO defaultFor takes a Name which makes sense, but what's the + -- name for an input object? + defaultFor _ = Just (DogStuff "shoe" False) + +type Query = Object "Query" '[] + '[ Argument "dogStuff" DogStuff :> Field "description" Text ] + +root :: Handler IO Query +root = pure description + +description :: DogStuff -> Handler IO Text +description (DogStuff toy likesTreats) + | likesTreats = pure $ "likes treats and their favorite toy is a " <> toy + | otherwise = pure $ "their favorite toy is a " <> toy + +-- $setup +-- >>> import Data.Aeson (encode) +-- >>> import GraphQL.Value.ToValue (ToValue(..)) + +-- | Show input object usage +-- +-- >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }" +-- >>> putStrLn $ encode $ toValue response +-- {"data":{"description":"likes treats and their favorite toy is a bone"}} +-- +-- >>> response <- example "{ description }" +-- >>> putStrLn $ encode $ toValue response +-- {"data":{"description":"their favorite toy is a shoe"}} +example :: Text -> IO Response +example = interpretAnonymousQuery @Query root diff --git a/tests/Examples/UnionExample.hs b/tests/Examples/UnionExample.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/UnionExample.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds #-} +module Examples.UnionExample where + +import Protolude +import GraphQL.API (Field, List, Object, Union) +import GraphQL (Response, interpretAnonymousQuery) +import GraphQL.Resolver (Handler, (:<>)(..), unionValue) + +-- Slightly reduced example from the spec +type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32] +type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32] + +type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])] +type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))] + +miniCat :: Text -> Handler IO MiniCat +miniCat name = pure (pure name :<> pure 32) + +miniDog :: Handler IO MiniDog +miniDog = pure (pure 100) + +catOrDog :: Handler IO CatOrDog +catOrDog = pure $ do + name <- pure "MonadicFelix" -- we can do monadic actions + unionValue @MiniCat (miniCat name) + +catOrDogList :: Handler IO CatOrDogList +catOrDogList = pure $ + pure [ unionValue @MiniCat (miniCat "Felix") + , unionValue @MiniCat (miniCat "Mini") + , unionValue @MiniDog miniDog + ] + +-- $setup +-- >>> import Data.Aeson (encode) +-- >>> import GraphQL.Value.ToValue (ToValue(..)) + +-- | Show usage of a single unionValue +-- +-- >>> response <- exampleQuery +-- >>> putStrLn $ encode $ toValue response +-- {"data":{"myPet":{"meowVolume":32,"name":"MonadicFelix"}}} +exampleQuery :: IO Response +exampleQuery = interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" + +-- | 'unionValue' can be used in a list context +-- +-- >>> response <- exampleListQuery +-- >>> putStrLn $ encode $ toValue response +-- {"data":{"pets":[{"meowVolume":32,"name":"Felix"},{"meowVolume":32,"name":"Mini"},{"barkVolume":100}]}} +exampleListQuery :: IO Response +exampleListQuery = interpretAnonymousQuery @CatOrDogList catOrDogList "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" diff --git a/tests/OrderedMapTests.hs b/tests/OrderedMapTests.hs new file mode 100644 --- /dev/null +++ b/tests/OrderedMapTests.hs @@ -0,0 +1,43 @@ +module OrderedMapTests (tests) where + +import Protolude + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Gen, arbitrary, forAll) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) + +import qualified Data.Map as Map +import GraphQL.Internal.OrderedMap (OrderedMap) +import qualified GraphQL.Internal.OrderedMap as OrderedMap + + +orderedMaps :: Gen (OrderedMap Int Int) +orderedMaps = arbitrary + +tests :: IO TestTree +tests = testSpec "OrderedMap" $ do + describe "Integrity" $ do + prop "fromList . toList == id" $ do + forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x) + prop "keys == Map.keys . toMap" $ do + forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x))) + prop "keys == map fst . Map.toList" $ do + forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x)) + prop "has unique keys" $ do + forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks) + prop "all keys can be looked up" $ do + forAll orderedMaps (\x -> let keys = OrderedMap.keys x + values = OrderedMap.values x + in mapMaybe (flip OrderedMap.lookup x) keys == values) + it "empty is orderedMap []" $ do + Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap [] + prop "singleton x is orderedMap [x]" $ do + \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)] + it "preserves insertion order" $ do + let items1 = [("foo", 2), ("bar", 1)] + let Just x = OrderedMap.orderedMap items1 + OrderedMap.toList @Text @Int x `shouldBe` items1 + let items2 = [("bar", 1), ("foo", 2)] + let Just y = OrderedMap.orderedMap items2 + OrderedMap.toList @Text @Int y `shouldBe` items2 diff --git a/tests/ResolverTests.hs b/tests/ResolverTests.hs new file mode 100644 --- /dev/null +++ b/tests/ResolverTests.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module ResolverTests (tests) where + +import Protolude hiding (Enum) + +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) + +import Data.Aeson (encode) +import GraphQL + ( Response(..) + , interpretAnonymousQuery + ) +import GraphQL.API + ( Object + , Field + , Argument + , (:>) + ) +import GraphQL.Resolver + ( Handler + , ResolverError(..) + , (:<>)(..) + ) +import GraphQL.Internal.Name (unsafeMakeName) +import GraphQL.Internal.Output (singleError) + +-- Test a custom error monad +type TMonad = ExceptT Text IO +type T = Object "T" '[] '[ Field "z" Int32 + , Argument "x" Int32 :> Field "t" Int32 + , Argument "y" Int32 :> Field "q" Int32 + ] + +tHandler :: Handler TMonad T +tHandler = + pure $ (pure 10) :<> (\tArg -> pure tArg) :<> (pure . (*2)) + +tests :: IO TestTree +tests = testSpec "TypeAPI" $ do + describe "tTest" $ do + it "works in a simple case" $ do + Right (Success object) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") + encode object `shouldBe` "{\"t\":12}" + it "complains about missing field" $ do + Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") + errs `shouldBe` singleError (FieldNotFoundError (unsafeMakeName "not_a_field")) + it "complains about missing argument" $ do + Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") + errs `shouldBe` singleError (ValueMissing (unsafeMakeName "x")) diff --git a/tests/SchemaTests.hs b/tests/SchemaTests.hs new file mode 100644 --- /dev/null +++ b/tests/SchemaTests.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +module SchemaTests (tests) where + +import Protolude hiding (Down, Enum) + +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) + +import GraphQL.API + ( Field + , Enum + , List + , getAnnotatedType + , getAnnotatedInputType + , getDefinition + , getFieldDefinition + , getInterfaceDefinition + ) +import GraphQL.Internal.Name (unsafeMakeName) +import GraphQL.Internal.Schema + ( EnumTypeDefinition(..) + , EnumValueDefinition(..) + , FieldDefinition(..) + , ObjectTypeDefinition(..) + , NonEmptyList(..) + , InterfaceTypeDefinition(..) + , AnnotatedType(..) + , ListType(..) + , UnionTypeDefinition(..) + , Type(..) + , TypeDefinition(..) + , NonNullType(..) + , Builtin(..) + , InputType(..) + ) +import ExampleSchema + +tests :: IO TestTree +tests = testSpec "Type" $ do + describe "Field" $ + it "encodes correctly" $ do + getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition (unsafeMakeName "hello") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) + describe "Interface" $ + it "encodes correctly" $ do + getInterfaceDefinition @Sentient `shouldBe` + Right (InterfaceTypeDefinition + (unsafeMakeName "Sentient") + (NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) + describe "full example" $ + it "encodes correctly" $ do + getDefinition @Human `shouldBe` + Right (ObjectTypeDefinition (unsafeMakeName "Human") + [ InterfaceTypeDefinition (unsafeMakeName "Sentient") ( + NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]) + ] + (NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) + describe "output Enum" $ + it "encodes correctly" $ do + getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe` + Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition (unsafeMakeName "DogCommand") + [ EnumValueDefinition (unsafeMakeName "Sit") + , EnumValueDefinition (unsafeMakeName "Down") + , EnumValueDefinition (unsafeMakeName "Heel") + ]))))) + describe "Union type" $ + it "encodes correctly" $ do + getAnnotatedType @CatOrDog `shouldBe` + TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition (unsafeMakeName "CatOrDog") + . NonEmptyList <$> sequence [ getDefinition @Cat + , getDefinition @Dog + ] + describe "List" $ + it "encodes correctly" $ do + getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))) + getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt))))) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,34 @@ +module Main + ( main + ) where + +import Protolude + +import Test.Tasty (defaultMain, testGroup) + +import qualified ASTTests +import qualified EndToEndTests +import qualified OrderedMapTests +import qualified ResolverTests +import qualified SchemaTests +import qualified ValidationTests +import qualified ValueTests + +-- import examples to ensure they compile +import Examples.InputObject () +import Examples.UnionExample () + +main :: IO () +main = do + t <- sequence tests + defaultMain . testGroup "GraphQL API" $ t + where + tests = + [ ASTTests.tests + , EndToEndTests.tests + , OrderedMapTests.tests + , ResolverTests.tests + , SchemaTests.tests + , ValidationTests.tests + , ValueTests.tests + ] diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs new file mode 100644 --- /dev/null +++ b/tests/ValidationTests.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TypeApplications #-} + +-- | Tests for query validation. +module ValidationTests (tests) where + +import Protolude + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) + +import GraphQL.Internal.Name (Name, unsafeMakeName) +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Schema (Schema) +import GraphQL.Internal.Validation + ( ValidationError(..) + , findDuplicates + , getErrors + ) + +me :: Name +me = unsafeMakeName "me" + +someName :: Name +someName = unsafeMakeName "name" + +-- | Schema used for these tests. Since none of them do type-level stuff, we +-- don't need to define it. +schema :: Schema +schema = undefined + +tests :: IO TestTree +tests = testSpec "Validation" $ do + describe "getErrors" $ do + it "Treats simple queries as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.Query + ( AST.Node me [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ) + ] + getErrors schema doc `shouldBe` [] + + it "Detects duplicate operation names" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.Query + ( AST.Node me [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ) + , AST.DefinitionOperation + ( AST.Query + ( AST.Node me [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ) + ] + getErrors schema doc `shouldBe` [DuplicateOperation me] + + it "Detects duplicate anonymous operations" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.AnonymousQuery + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + , AST.DefinitionOperation + ( AST.AnonymousQuery + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ] + getErrors schema doc `shouldBe` [MixedAnonymousOperations 2 []] + + describe "findDuplicates" $ do + prop "returns empty on unique lists" $ do + \xs -> findDuplicates @Int (ordNub xs) === [] + prop "finds only duplicates" $ \xs -> do + all (>1) (count xs <$> findDuplicates @Int xs) + prop "finds all duplicates" $ \xs -> do + (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs + + +-- | Count the number of times 'x' occurs in 'xs'. +count :: Eq a => [a] -> a -> Int +count xs x = (length . filter (== x)) xs diff --git a/tests/ValueTests.hs b/tests/ValueTests.hs new file mode 100644 --- /dev/null +++ b/tests/ValueTests.hs @@ -0,0 +1,71 @@ +module ValueTests (tests) where + +import Protolude + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe, shouldSatisfy) + +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty) +import GraphQL.Internal.Name (unsafeMakeName) +import GraphQL.Value + ( Object + , ObjectField'(..) + , astToVariableValue + , unionObjects + , objectFields + , objectFromList + ) +import GraphQL.Value.FromValue (prop_roundtripValue) +import GraphQL.Value.ToValue (toValue) + + +tests :: IO TestTree +tests = testSpec "Value" $ do + describe "unionObject" $ do + it "returns empty on empty list" $ do + unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) + it "merges objects" $ do + let (Just foo) = objectFromList [ (unsafeMakeName "foo", toValue @Int32 1) + , (unsafeMakeName "bar",toValue @Int32 2)] + let (Just bar) = objectFromList [ (unsafeMakeName "bar", toValue @Text "cow") + , (unsafeMakeName "baz",toValue @Int32 3)] + let observed = unionObjects [foo, bar] + observed `shouldBe` Nothing + it "merges objects with unique keys" $ do + let (Just foo) = objectFromList [(unsafeMakeName "foo", toValue @Int32 1)] + let (Just bar) = objectFromList [ (unsafeMakeName "bar", toValue @Text "cow") + , (unsafeMakeName "baz",toValue @Int32 3)] + let (Just expected) = objectFromList [ (unsafeMakeName "foo", toValue @Int32 1) + , (unsafeMakeName "bar", toValue @Text "cow") + , (unsafeMakeName "baz", toValue @Int32 3) + ] + let (Just observed) = unionObjects [foo, bar] + observed `shouldBe` expected + expected `shouldSatisfy` prop_fieldsUnique + describe "Objects" $ do + prop "have unique fields" $ do + prop_fieldsUnique + describe "ToValue / FromValue instances" $ do + prop "Bool" $ prop_roundtripValue @Bool + prop "Int32" $ prop_roundtripValue @Int32 + prop "Double" $ prop_roundtripValue @Double + prop "Text" $ forAll arbitraryText prop_roundtripValue + prop "Lists" $ prop_roundtripValue @[Int32] + prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue + describe "AST" $ do + it "Objects converted from AST have unique fields" $ do + let input = AST.ObjectValue [ AST.ObjectField (unsafeMakeName "foo") (AST.ValueString (AST.StringValue "bar")) + , AST.ObjectField (unsafeMakeName "foo") (AST.ValueString (AST.StringValue "qux")) + ] + astToVariableValue (AST.ValueObject input) `shouldBe` Nothing + + +-- | All of the fields in an object should have unique names. +prop_fieldsUnique :: Object -> Bool +prop_fieldsUnique object = + fieldNames == ordNub fieldNames + where + fieldNames = [name | ObjectField name _ <- objectFields object]