graphql 1.1.0.0 → 1.2.0.0
raw patch · 11 files changed
+416/−272 lines, 11 filesdep −aesondep −scientificdep ~hspecdep ~hspec-expectationsdep ~transformersPVP ok
version bump matches the API change (PVP)
Dependencies removed: aeson, scientific
Dependency ranges changed: hspec, hspec-expectations, transformers, vector
API changes (from Hackage documentation)
+ Language.GraphQL.AST.Document: instance GHC.Base.Monoid Language.GraphQL.AST.Document.Description
+ Language.GraphQL.AST.Document: instance GHC.Base.Semigroup Language.GraphQL.AST.Document.Description
+ Language.GraphQL.AST.Encoder: typeSystemDefinition :: Formatter -> TypeSystemDefinition -> Text
Files
- CHANGELOG.md +16/−0
- graphql.cabal +6/−19
- src/Language/GraphQL.hs +0/−101
- src/Language/GraphQL/AST/Document.hs +8/−0
- src/Language/GraphQL/AST/Encoder.hs +264/−15
- src/Language/GraphQL/Execute.hs +6/−5
- src/Language/GraphQL/Execute/Coerce.hs +0/−76
- src/Test/Hspec/GraphQL.hs +0/−49
- tests/Language/GraphQL/AST/DocumentSpec.hs +6/−0
- tests/Language/GraphQL/AST/EncoderSpec.hs +89/−0
- tests/Language/GraphQL/ExecuteSpec.hs +21/−7
CHANGELOG.md view
@@ -6,6 +6,21 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.2.0.0] - 2023-02-28+### Added+- Schema printing.+- `Semigroup` and `Monoid` instances for `AST.Document.Description`.+- Support for vector 0.13.0.0 and transformers 0.6.1.0.++### Fixed+- Fix resolvers returning a list in the reverse order.++### Removed+- GHC 8 support.+- Cabal -json flag.+- `Test.Hspec.GraphQL`: moved to `graphql-spice` package.+- CPP `ifdef WITH_JSON` blocks.+ ## [1.1.0.0] - 2022-12-24 ### Changed - Removed deprecated `Language.GraphQL.Error` functions: `addErr`, `addErrMsg`,@@ -490,6 +505,7 @@ ### Added - Data types for the GraphQL language. +[1.2.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.2.0.0&rev_to=v1.1.0.0 [1.1.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.1.0.0&rev_to=v1.0.3.0 [1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.3.0&rev_to=v1.0.2.0 [1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.2.0&rev_to=v1.0.1.0
graphql.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: graphql-version: 1.1.0.0+version: 1.2.0.0 synopsis: Haskell GraphQL implementation description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. category: Language@@ -11,7 +11,7 @@ Matthías Páll Gissurarson <mpg@mpg.is>, Sólrún Halla Einarsdóttir <she@mpg.is> maintainer: belka@caraus.de-copyright: (c) 2019-2022 Eugen Wissner,+copyright: (c) 2019-2023 Eugen Wissner, (c) 2015-2017 J. Daniel Navarro license: MPL-2.0 AND BSD-3-Clause license-files: LICENSE,@@ -21,18 +21,12 @@ CHANGELOG.md README.md tested-with:- GHC == 8.10.7,- GHC == 9.2.4+ GHC == 9.2.5 source-repository head type: git location: git://caraus.tech/pub/graphql.git -flag Json- description: Whether to build against @aeson 1.x@- default: False- manual: True- library exposed-modules: Language.GraphQL@@ -53,7 +47,6 @@ Language.GraphQL.Type.Schema Language.GraphQL.Validate Language.GraphQL.Validate.Validation- Test.Hspec.GraphQL other-modules: Language.GraphQL.Execute.Transform Language.GraphQL.Type.Definition@@ -72,15 +65,9 @@ parser-combinators >= 1.3 && < 2, template-haskell >= 2.16 && < 3, text >= 1.2 && < 3,- transformers ^>= 0.5.6,+ transformers >= 0.5.6 && < 0.7, unordered-containers ^>= 0.2.14,- vector ^>= 0.12.3- if flag(Json)- build-depends:- aeson >= 1.5.6 && < 1.6,- hspec-expectations >= 0.8.2 && < 0.9,- scientific >= 0.3.7 && < 0.4- cpp-options: -DWITH_JSON+ vector >= 0.12 && < 0.14 default-language: Haskell2010 @@ -110,7 +97,7 @@ conduit, exceptions, graphql,- hspec ^>= 2.9.1,+ hspec ^>= 2.10.9, hspec-expectations ^>= 0.8.2, hspec-megaparsec ^>= 2.2.0, megaparsec,
src/Language/GraphQL.hs view
@@ -1,111 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -#ifdef WITH_JSON -- | This module provides the functions to parse and execute @GraphQL@ queries.------ The content of this module depends on the value of the __json__ flag, which--- is currently on by default. This behavior will change in the future, the flag--- will be switched off by default and then removed.------ This documentation is generated with the enabled __json__ flag and functions--- described here support JSON and are deprecated. JSON instances are provided--- now by an additional package, __graphql-spice__. To start using the new--- package create __cabal.project__ in the root directory of your project with--- the following contents:------ @--- packages: .--- constraints: graphql -json--- @------ Then add __graphql-spice__ as dependency.------ The new version of this module defines only one function, @graphql@, which--- works with the internal GraphQL value representation used by this lbirary.--- Refer to @Language.GraphQL.JSON.graphql@ in __graphql-spice__ for the--- function that accepts and returns JSON. module Language.GraphQL ( graphql- , graphqlSubs ) where import Control.Monad.Catch (MonadCatch)-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Types as Aeson-import qualified Data.HashMap.Strict as HashMap-import Data.Maybe (catMaybes)-import qualified Data.Sequence as Seq-import Data.Text (Text)-import Language.GraphQL.AST-import Language.GraphQL.Error-import Language.GraphQL.Execute-import qualified Language.GraphQL.Validate as Validate-import Language.GraphQL.Type.Schema (Schema)-import Text.Megaparsec (parse)--{-# DEPRECATED graphql "Use graphql-spice package instead" #-}--- | If the text parses correctly as a @GraphQL@ query the query is--- executed using the given 'Schema'.-graphql :: MonadCatch m- => Schema m -- ^ Resolvers.- -> Text -- ^ Text representing a @GraphQL@ request document.- -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.-graphql schema = graphqlSubs schema mempty mempty--{-# DEPRECATED graphqlSubs "Use graphql-spice package instead" #-}--- | If the text parses correctly as a @GraphQL@ query the substitution is--- applied to the query and the query is then executed using to the given--- 'Schema'.-graphqlSubs :: MonadCatch m- => Schema m -- ^ Resolvers.- -> Maybe Text -- ^ Operation name.- -> Aeson.Object -- ^ Variable substitution function.- -> Text -- ^ Text representing a @GraphQL@ request document.- -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.-graphqlSubs schema operationName variableValues document' =- case parse document "" document' of- Left errorBundle -> pure . formatResponse <$> parseError errorBundle- Right parsed ->- case validate parsed of- Seq.Empty -> fmap formatResponse- <$> execute schema operationName variableValues parsed- errors -> pure $ pure- $ HashMap.singleton "errors"- $ Aeson.toJSON- $ fromValidationError <$> errors- where- validate = Validate.document schema Validate.specifiedRules- formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''- formatResponse (Response data'' errors') = HashMap.fromList- [ ("data", data'')- , ("errors", Aeson.toJSON $ fromError <$> errors')- ]- fromError Error{..} = Aeson.object $ catMaybes- [ Just ("message", Aeson.toJSON message)- , toMaybe fromLocation "locations" locations- , toMaybe fromPath "path" path- ]- fromValidationError Validate.Error{..} = Aeson.object- [ ("message", Aeson.toJSON message)- , ("locations", Aeson.listValue fromLocation locations)- ]- toMaybe _ _ [] = Nothing- toMaybe f key xs = Just (key, Aeson.listValue f xs)- fromPath (Segment segment) = Aeson.String segment- fromPath (Index index) = Aeson.toJSON index- fromLocation Location{..} = Aeson.object- [ ("line", Aeson.toJSON line)- , ("column", Aeson.toJSON column)- ]-#else--- | This module provides the functions to parse and execute @GraphQL@ queries.-module Language.GraphQL- ( graphql- ) where--import Control.Monad.Catch (MonadCatch) import Data.HashMap.Strict (HashMap) import qualified Data.Sequence as Seq import Data.Text (Text)@@ -144,4 +44,3 @@ , locations = locations , path = [] }-#endif
src/Language/GraphQL/AST/Document.hs view
@@ -464,6 +464,14 @@ newtype Description = Description (Maybe Text) deriving (Eq, Show) +instance Semigroup Description+ where+ Description lhs <> Description rhs = Description $ lhs <> rhs++instance Monoid Description+ where+ mempty = Description mempty+ -- ** Types -- | Type definitions describe various user-defined types.
src/Language/GraphQL/AST/Encoder.hs view
@@ -14,10 +14,11 @@ , operationType , pretty , type'+ , typeSystemDefinition , value ) where -import Data.Foldable (fold)+import Data.Foldable (fold, Foldable (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text@@ -28,6 +29,7 @@ import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) import qualified Language.GraphQL.AST.Document as Full+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation -- | Instructs the encoder whether the GraphQL document should be minified or -- pretty printed.@@ -54,8 +56,247 @@ encodeDocument = foldr executableDefinition [] defs executableDefinition (Full.ExecutableDefinition executableDefinition') acc = definition formatter executableDefinition' : acc- executableDefinition _ acc = acc+ executableDefinition (Full.TypeSystemDefinition typeSystemDefinition' _location) acc =+ typeSystemDefinition formatter typeSystemDefinition' : acc+ executableDefinition (Full.TypeSystemExtension typeSystemExtension' _location) acc =+ typeSystemExtension formatter typeSystemExtension' : acc +directiveLocation :: DirectiveLocation.DirectiveLocation -> Lazy.Text+directiveLocation = Lazy.Text.pack . show++withLineBreak :: Formatter -> Lazy.Text.Text -> Lazy.Text.Text+withLineBreak formatter encodeDefinition+ | Pretty _ <- formatter = Lazy.Text.snoc encodeDefinition '\n'+ | Minified <- formatter = encodeDefinition++typeSystemExtension :: Formatter -> Full.TypeSystemExtension -> Lazy.Text+typeSystemExtension formatter = \case+ Full.SchemaExtension schemaExtension' ->+ schemaExtension formatter schemaExtension'+ Full.TypeExtension typeExtension' -> typeExtension formatter typeExtension'++schemaExtension :: Formatter -> Full.SchemaExtension -> Lazy.Text+schemaExtension formatter = \case+ Full.SchemaOperationExtension operationDirectives operationTypeDefinitions' ->+ withLineBreak formatter+ $ "extend schema "+ <> optempty (directives formatter) operationDirectives+ <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')+ Full.SchemaDirectivesExtension operationDirectives -> "extend schema "+ <> optempty (directives formatter) (NonEmpty.toList operationDirectives)++typeExtension :: Formatter -> Full.TypeExtension -> Lazy.Text+typeExtension formatter = \case+ Full.ScalarTypeExtension name' directives'+ -> "extend scalar "+ <> Lazy.Text.fromStrict name'+ <> directives formatter (NonEmpty.toList directives')+ Full.ObjectTypeFieldsDefinitionExtension name' ifaces' directives' fields'+ -> "extend type "+ <> Lazy.Text.fromStrict name'+ <> optempty (" " <>) (implementsInterfaces ifaces')+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')+ Full.ObjectTypeDirectivesExtension name' ifaces' directives'+ -> "extend type "+ <> Lazy.Text.fromStrict name'+ <> optempty (" " <>) (implementsInterfaces ifaces')+ <> optempty (directives formatter) (NonEmpty.toList directives')+ Full.ObjectTypeImplementsInterfacesExtension name' ifaces'+ -> "extend type "+ <> Lazy.Text.fromStrict name'+ <> optempty (" " <>) (implementsInterfaces ifaces')+ Full.InterfaceTypeFieldsDefinitionExtension name' directives' fields'+ -> "extend interface "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')+ Full.InterfaceTypeDirectivesExtension name' directives'+ -> "extend interface "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) (NonEmpty.toList directives')+ Full.UnionTypeUnionMemberTypesExtension name' directives' members'+ -> "extend union "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> unionMemberTypes formatter members'+ Full.UnionTypeDirectivesExtension name' directives'+ -> "extend union "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) (NonEmpty.toList directives')+ Full.EnumTypeEnumValuesDefinitionExtension name' directives' members'+ -> "extend enum "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (enumValueDefinition formatter) (NonEmpty.toList members')+ Full.EnumTypeDirectivesExtension name' directives'+ -> "extend enum "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) (NonEmpty.toList directives')+ Full.InputObjectTypeInputFieldsDefinitionExtension name' directives' fields'+ -> "extend input "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (inputValueDefinition nextFormatter) (NonEmpty.toList fields')+ Full.InputObjectTypeDirectivesExtension name' directives'+ -> "extend input "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) (NonEmpty.toList directives')+ where+ nextFormatter = incrementIndent formatter++-- | Converts a t'Full.TypeSystemDefinition' into a string.+typeSystemDefinition :: Formatter -> Full.TypeSystemDefinition -> Lazy.Text+typeSystemDefinition formatter = \case+ Full.SchemaDefinition operationDirectives operationTypeDefinitions' ->+ withLineBreak formatter+ $ "schema "+ <> optempty (directives formatter) operationDirectives+ <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')+ Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'+ Full.DirectiveDefinition description' name' arguments' locations+ -> description formatter description'+ <> "@"+ <> Lazy.Text.fromStrict name'+ <> argumentsDefinition formatter arguments'+ <> " on"+ <> pipeList formatter (directiveLocation <$> locations)++operationTypeDefinition :: Formatter -> Full.OperationTypeDefinition -> Lazy.Text.Text+operationTypeDefinition formatter (Full.OperationTypeDefinition operationType' namedType')+ = indentLine (incrementIndent formatter)+ <> operationType formatter operationType'+ <> colon formatter+ <> Lazy.Text.fromStrict namedType'++fieldDefinition :: Formatter -> Full.FieldDefinition -> Lazy.Text.Text+fieldDefinition formatter fieldDefinition' =+ let Full.FieldDefinition description' name' arguments' type'' directives' = fieldDefinition'+ in optempty (description formatter) description'+ <> indentLine formatter+ <> Lazy.Text.fromStrict name'+ <> argumentsDefinition formatter arguments'+ <> colon formatter+ <> type' type''+ <> optempty (directives formatter) directives'++argumentsDefinition :: Formatter -> Full.ArgumentsDefinition -> Lazy.Text.Text+argumentsDefinition formatter (Full.ArgumentsDefinition arguments') =+ parensCommas formatter (argumentDefinition formatter) arguments'++argumentDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text+argumentDefinition formatter definition' =+ let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'+ in optempty (description formatter) description'+ <> Lazy.Text.fromStrict name'+ <> colon formatter+ <> type' type''+ <> maybe mempty (defaultValue formatter . Full.node) defaultValue'+ <> directives formatter directives'++inputValueDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text+inputValueDefinition formatter definition' =+ let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'+ in optempty (description formatter) description'+ <> indentLine formatter+ <> Lazy.Text.fromStrict name'+ <> colon formatter+ <> type' type''+ <> maybe mempty (defaultValue formatter . Full.node) defaultValue'+ <> directives formatter directives'++typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text+typeDefinition formatter = \case+ Full.ScalarTypeDefinition description' name' directives'+ -> optempty (description formatter) description'+ <> "scalar "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ Full.ObjectTypeDefinition description' name' ifaces' directives' fields'+ -> optempty (description formatter) description'+ <> "type "+ <> Lazy.Text.fromStrict name'+ <> optempty (" " <>) (implementsInterfaces ifaces')+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (fieldDefinition nextFormatter) fields'+ Full.InterfaceTypeDefinition description' name' directives' fields'+ -> optempty (description formatter) description'+ <> "interface "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (fieldDefinition nextFormatter) fields'+ Full.UnionTypeDefinition description' name' directives' members'+ -> optempty (description formatter) description'+ <> "union "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> unionMemberTypes formatter members'+ Full.EnumTypeDefinition description' name' directives' members'+ -> optempty (description formatter) description'+ <> "enum "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (enumValueDefinition formatter) members'+ Full.InputObjectTypeDefinition description' name' directives' fields'+ -> optempty (description formatter) description'+ <> "input "+ <> Lazy.Text.fromStrict name'+ <> optempty (directives formatter) directives'+ <> eitherFormat formatter " " ""+ <> bracesList formatter (inputValueDefinition nextFormatter) fields'+ where+ nextFormatter = incrementIndent formatter++implementsInterfaces :: Foldable t => Full.ImplementsInterfaces t -> Lazy.Text+implementsInterfaces (Full.ImplementsInterfaces interfaces)+ | null interfaces = mempty+ | otherwise = Lazy.Text.fromStrict+ $ Text.append "implements "+ $ Text.intercalate " & "+ $ toList interfaces++unionMemberTypes :: Foldable t => Formatter -> Full.UnionMemberTypes t -> Lazy.Text+unionMemberTypes formatter (Full.UnionMemberTypes memberTypes)+ | null memberTypes = mempty+ | otherwise = Lazy.Text.append "="+ $ pipeList formatter+ $ Lazy.Text.fromStrict+ <$> toList memberTypes++pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text+pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList+pipeList (Pretty _) = Lazy.Text.concat+ . fmap (("\n" <> indentSymbol <> "| ") <>)+ . toList ++enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text+enumValueDefinition (Pretty _) enumValue =+ let Full.EnumValueDefinition description' name' directives' = enumValue+ formatter = Pretty 1+ in description formatter description'+ <> indentLine formatter+ <> Lazy.Text.fromStrict name'+ <> directives formatter directives'+enumValueDefinition Minified enumValue =+ let Full.EnumValueDefinition description' name' directives' = enumValue+ in description Minified description'+ <> Lazy.Text.fromStrict name'+ <> directives Minified directives'++description :: Formatter -> Full.Description -> Lazy.Text.Text+description _formatter (Full.Description Nothing) = ""+description formatter (Full.Description (Just description')) =+ stringValue formatter description'+ -- | Converts a t'Full.ExecutableDefinition' into a string. definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text definition formatter x@@ -100,7 +341,7 @@ let Full.VariableDefinition variableName variableType defaultValue' _ = variableDefinition' in variable variableName- <> eitherFormat formatter ": " ":"+ <> colon formatter <> type' variableType <> maybe mempty (defaultValue formatter . Full.node) defaultValue' @@ -127,21 +368,27 @@ indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol selection :: Formatter -> Full.Selection -> Lazy.Text-selection formatter = Lazy.Text.append indent' . encodeSelection+selection formatter = Lazy.Text.append (indentLine formatter')+ . encodeSelection where encodeSelection (Full.FieldSelection fieldSelection) =- field incrementIndent fieldSelection+ field formatter' fieldSelection encodeSelection (Full.InlineFragmentSelection fragmentSelection) =- inlineFragment incrementIndent fragmentSelection+ inlineFragment formatter' fragmentSelection encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =- fragmentSpread incrementIndent fragmentSelection- incrementIndent- | Pretty indentation <- formatter = Pretty $ indentation + 1- | otherwise = Minified- indent'- | Pretty indentation <- formatter = indent $ indentation + 1- | otherwise = ""+ fragmentSpread formatter' fragmentSelection+ formatter' = incrementIndent formatter +indentLine :: Formatter -> Lazy.Text+indentLine formatter+ | Pretty indentation <- formatter = indent indentation+ | otherwise = ""++incrementIndent :: Formatter -> Formatter+incrementIndent formatter+ | Pretty indentation <- formatter = Pretty $ indentation + 1+ | otherwise = Minified+ colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" @@ -198,8 +445,10 @@ = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args directives :: Formatter -> [Full.Directive] -> Lazy.Text-directives Minified = spaces (directive Minified)-directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)+directives Minified values = spaces (directive Minified) values+directives formatter values+ | null values = ""+ | otherwise = Lazy.Text.cons ' ' $ spaces (directive formatter) values -- | Converts a 'Full.Value' into a string. value :: Formatter -> Full.Value -> Lazy.Text
src/Language/GraphQL/Execute.hs view
@@ -39,6 +39,7 @@ import Data.Maybe (fromMaybe) import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import qualified Data.Vector as Vector import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (cast)@@ -466,12 +467,12 @@ completeValue (Out.isNonNullType -> False) _ _ Type.Null = pure null completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)- = foldM go (0, []) list >>= coerceResult outputType . List . snd+ = foldM go Vector.empty list >>= coerceResult outputType . List . Vector.toList where- go (index, accumulator) listItem = do- let updatedPath = Index index : errorPath- completedValue <- completeValue listType fields updatedPath listItem- pure (index + 1, completedValue : accumulator)+ go accumulator listItem =+ let updatedPath = Index (Vector.length accumulator) : errorPath+ in Vector.snoc accumulator+ <$> completeValue listType fields updatedPath listItem completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) = coerceResult outputType $ Int int completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
src/Language/GraphQL/Execute/Coerce.hs view
@@ -5,14 +5,8 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-} -- | Types and functions used for input and result coercion.------ JSON instances in this module are only available with the __json__--- flag that is currently on by default, but will be disabled in the future.--- Refer to the documentation in the 'Language.GraphQL' module and to--- the __graphql-spice__ package. module Language.GraphQL.Execute.Coerce ( Output(..) , Serialize(..)@@ -21,10 +15,6 @@ , matchFieldValues ) where -#ifdef WITH_JSON-import qualified Data.Aeson as Aeson-import Data.Scientific (toBoundedInteger, toRealFloat)-#endif import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap@@ -232,69 +222,3 @@ $ HashMap.fromList $ OrderedMap.toList object serialize _ _ = Nothing--#ifdef WITH_JSON-instance Serialize Aeson.Value where- serialize (Out.ScalarBaseType scalarType) value- | Type.ScalarType "Int" _ <- scalarType- , Int int <- value = Just $ Aeson.toJSON int- | Type.ScalarType "Float" _ <- scalarType- , Float float <- value = Just $ Aeson.toJSON float- | Type.ScalarType "String" _ <- scalarType- , String string <- value = Just $ Aeson.String string- | Type.ScalarType "ID" _ <- scalarType- , String string <- value = Just $ Aeson.String string- | Type.ScalarType "Boolean" _ <- scalarType- , Boolean boolean <- value = Just $ Aeson.Bool boolean- serialize _ (Enum enum) = Just $ Aeson.String enum- serialize _ (List list) = Just $ Aeson.toJSON list- serialize _ (Object object) = Just- $ Aeson.object- $ OrderedMap.toList- $ Aeson.toJSON <$> object- serialize _ _ = Nothing- null = Aeson.Null--instance VariableValue Aeson.Value where- coerceVariableValue _ Aeson.Null = Just Type.Null- coerceVariableValue (In.ScalarBaseType scalarType) value- | (Aeson.String stringValue) <- value = Just $ Type.String stringValue- | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue- | (Aeson.Number numberValue) <- value- , (Type.ScalarType "Float" _) <- scalarType =- Just $ Type.Float $ toRealFloat numberValue- | (Aeson.Number numberValue) <- value = -- ID or Int- Type.Int <$> toBoundedInteger numberValue- coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =- Just $ Type.Enum stringValue- coerceVariableValue (In.InputObjectBaseType objectType) value- | (Aeson.Object objectValue) <- value = do- let (In.InputObjectType _ _ inputFields) = objectType- (newObjectValue, resultMap) <- foldWithKey objectValue inputFields- if HashMap.null newObjectValue- then Just $ Type.Object resultMap- else Nothing- where- foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'- $ Just (objectValue, HashMap.empty)- matchFieldValues' _ _ Nothing = Nothing- matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =- let (In.InputField _ fieldType _) = inputField- insert = flip (HashMap.insert fieldName) resultMap- newObjectValue = HashMap.delete fieldName objectValue- in case HashMap.lookup fieldName objectValue of- Just variableValue -> do- coerced <- coerceVariableValue fieldType variableValue- pure (newObjectValue, insert coerced)- Nothing -> Just (objectValue, resultMap)- coerceVariableValue (In.ListBaseType listType) value- | (Aeson.Array arrayValue) <- value =- Type.List <$> foldr foldVector (Just []) arrayValue- | otherwise = coerceVariableValue listType value- where- foldVector _ Nothing = Nothing- foldVector variableValue (Just list) = do- coerced <- coerceVariableValue listType variableValue- pure $ coerced : list - coerceVariableValue _ _ = Nothing-#endif
− src/Test/Hspec/GraphQL.hs
@@ -1,49 +0,0 @@-{- This Source Code Form is subject to the terms of the Mozilla Public License,- v. 2.0. If a copy of the MPL was not distributed with this file, You can- obtain one at https://mozilla.org/MPL/2.0/. -}--{-# LANGUAGE CPP #-}--#ifdef WITH_JSON-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE OverloadedStrings #-}---- | Test helpers.-module Test.Hspec.GraphQL {-# DEPRECATED "Use graphql-spice package instead" #-}- ( shouldResolve- , shouldResolveTo- ) where--import Control.Monad.Catch (MonadCatch)-import qualified Data.Aeson as Aeson-import qualified Data.HashMap.Strict as HashMap-import Data.Text (Text)-import Language.GraphQL.Error-import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)---- | Asserts that a query resolves to some value.-shouldResolveTo :: MonadCatch m- => Either (ResponseEventStream m Aeson.Value) Aeson.Object- -> Aeson.Object- -> Expectation-shouldResolveTo (Right actual) expected = actual `shouldBe` expected-shouldResolveTo _ _ = expectationFailure- "the query is expected to resolve to a value, but it resolved to an event stream"---- | Asserts that the response doesn't contain any errors.-shouldResolve :: MonadCatch m- => (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object))- -> Text- -> Expectation-shouldResolve executor query = do- actual <- executor query- case actual of- Right response ->- response `shouldNotSatisfy` HashMap.member "errors"- _ -> expectationFailure- "the query is expected to resolve to a value, but it resolved to an event stream"-#else-module Test.Hspec.GraphQL {-# DEPRECATED "Use graphql-spice package instead" #-}- (- ) where-#endif
tests/Language/GraphQL/AST/DocumentSpec.hs view
@@ -18,3 +18,9 @@ ] expected = "{ field1: 1.2, field2: null }" in show object `shouldBe` expected++ describe "Description" $+ it "keeps content when merging with no description" $+ let expected = Description $ Just "Left description"+ actual = expected <> Description Nothing+ in actual `shouldBe` expected
tests/Language/GraphQL/AST/EncoderSpec.hs view
@@ -4,6 +4,7 @@ ( spec ) where +import Data.List.NonEmpty (NonEmpty(..)) import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Encoder import Language.GraphQL.TH@@ -178,3 +179,91 @@ it "produces lowercase mutation operation type" $ let actual = operationType pretty Full.Mutation in actual `shouldBe` "mutation"++ describe "typeSystemDefinition" $ do+ it "produces a schema with an indented operation type definition" $+ let queryType = Full.OperationTypeDefinition Full.Query "QueryRootType"+ mutationType = Full.OperationTypeDefinition Full.Mutation "MutationType"+ operations = queryType :| pure mutationType+ definition' = Full.SchemaDefinition [] operations+ expected = Text.Lazy.snoc [gql|+ schema {+ query: QueryRootType+ mutation: MutationType+ }+ |] '\n'+ actual = typeSystemDefinition pretty definition'+ in actual `shouldBe` expected++ it "encodes a scalar type definition" $+ let uuidType = Full.ScalarTypeDefinition mempty "UUID" mempty+ definition' = Full.TypeDefinition uuidType+ expected = "scalar UUID"+ actual = typeSystemDefinition pretty definition'+ in actual `shouldBe` expected++ it "encodes an interface definition" $+ let someType = Full.TypeNamed "String"+ argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty+ arguments = Full.ArgumentsDefinition [argument]+ definition' = Full.TypeDefinition+ $ Full.InterfaceTypeDefinition mempty "UUID" mempty+ $ pure+ $ Full.FieldDefinition mempty "value" arguments someType mempty+ expected = [gql|+ interface UUID {+ value(arg: String): String+ }+ |]+ actual = typeSystemDefinition pretty definition'+ in actual `shouldBe` expected++ it "encodes an union definition" $+ let definition' = Full.TypeDefinition+ $ Full.UnionTypeDefinition mempty "SearchResult" mempty+ $ Full.UnionMemberTypes ["Photo", "Person"]+ expected = [gql|+ union SearchResult =+ | Photo+ | Person+ |]+ actual = typeSystemDefinition pretty definition'+ in actual `shouldBe` expected++ it "encodes an enum definition" $+ let values =+ [ Full.EnumValueDefinition mempty "NORTH" mempty+ , Full.EnumValueDefinition mempty "EAST" mempty+ , Full.EnumValueDefinition mempty "SOUTH" mempty+ , Full.EnumValueDefinition mempty "WEST" mempty+ ]+ definition' = Full.TypeDefinition+ $ Full.EnumTypeDefinition mempty "Direction" mempty values+ expected = [gql|+ enum Direction {+ NORTH+ EAST+ SOUTH+ WEST+ }+ |]+ actual = typeSystemDefinition pretty definition'+ in actual `shouldBe` expected++ it "encodes an input type" $+ let intType = Full.TypeNonNull $ Full.NonNullTypeNamed "Int"+ stringType = Full.TypeNamed "String"+ fields =+ [ Full.InputValueDefinition mempty "a" stringType Nothing mempty+ , Full.InputValueDefinition mempty "b" intType Nothing mempty+ ]+ definition' = Full.TypeDefinition+ $ Full.InputObjectTypeDefinition mempty "ExampleInputObject" mempty fields+ expected = [gql|+ input ExampleInputObject {+ a: String+ b: Int!+ }+ |]+ actual = typeSystemDefinition pretty definition'+ in actual `shouldBe` expected
tests/Language/GraphQL/ExecuteSpec.hs view
@@ -66,8 +66,9 @@ queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList [ ("philosopher", ValueResolver philosopherField philosopherResolver)- , ("genres", ValueResolver genresField genresResolver)+ , ("throwing", ValueResolver throwingField throwingResolver) , ("count", ValueResolver countField countResolver)+ , ("sequence", ValueResolver sequenceField sequenceResolver) ] where philosopherField =@@ -75,16 +76,23 @@ $ HashMap.singleton "id" $ In.Argument Nothing (In.NamedScalarType id) Nothing philosopherResolver = pure $ Object mempty- genresField =+ throwingField = let fieldType = Out.ListType $ Out.NonNullScalarType string in Out.Field Nothing fieldType HashMap.empty- genresResolver :: Resolve IO- genresResolver = throwM PhilosopherException+ throwingResolver :: Resolve IO+ throwingResolver = throwM PhilosopherException countField = let fieldType = Out.NonNullScalarType int in Out.Field Nothing fieldType HashMap.empty countResolver = pure ""+ sequenceField =+ let fieldType = Out.ListType $ Out.NonNullScalarType int+ in Out.Field Nothing fieldType HashMap.empty+ sequenceResolver = pure intSequence +intSequence :: Value+intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3]+ musicType :: Out.ObjectType IO musicType = Out.ObjectType "Music" Nothing [] $ HashMap.fromList resolvers@@ -344,14 +352,14 @@ in sourceQuery `shouldResolveTo` expected it "gives location information for failed result coercion" $- let data'' = Object $ HashMap.singleton "genres" Null+ let data'' = Object $ HashMap.singleton "throwing" Null executionErrors = pure $ Error { message = "PhilosopherException" , locations = [Location 1 3]- , path = [Segment "genres"]+ , path = [Segment "throwing"] } expected = Response data'' executionErrors- sourceQuery = "{ genres }"+ sourceQuery = "{ throwing }" in sourceQuery `shouldResolveTo` expected it "sets data to null if a root field isn't nullable" $@@ -373,6 +381,12 @@ } expected = Response data'' executionErrors sourceQuery = "{ philosopher(id: \"1\") { firstLanguage } }"+ in sourceQuery `shouldResolveTo` expected++ it "returns list elements in the original order" $+ let data'' = Object $ HashMap.singleton "sequence" intSequence+ expected = Response data'' mempty+ sourceQuery = "{ sequence }" in sourceQuery `shouldResolveTo` expected context "queryError" $ do