prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Merge branch 'core'

Browse Source 
This introduces a distinction between a Full and a Core AST. Fragments and
variables are replaced when transforming from Full to Core.
This commit is contained in:
Danny Navarro 2017-02-26 16:07:00 -03:00
commit 1b8fca3658
No known key found for this signature in database
GPG Key ID: 81E5F99780FA6A32
13 changed files with 487 additions and 348 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@ -4,3 +4,7 @@ cabal.sandbox.config
dist/ dist/
TAGS TAGS
.#* .#*
.DS_Store
cabal.project.local
dist-newstyle/
dist-newstyle/

4
Data/GraphQL.hs
View File

@ -19,7 +19,7 @@ import Data.GraphQL.Error
-- executed according to the given 'Schema'. -- executed according to the given 'Schema'.
-- --
-- Returns the response as an @Aeson.@'Aeson.Value'. -- Returns the response as an @Aeson.@'Aeson.Value'.
graphql :: Alternative m => Schema m -> Text -> m Aeson.Value graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
graphql = flip graphqlSubs $ const Nothing graphql = flip graphqlSubs $ const Nothing
-- | Takes a 'Schema', a variable substitution function and text -- | Takes a 'Schema', a variable substitution function and text
@ -28,7 +28,7 @@ graphql = flip graphqlSubs $ const Nothing
-- query and the query is then executed according to the given 'Schema'. -- query and the query is then executed according to the given 'Schema'.
-- --
-- Returns the response as an @Aeson.@'Aeson.Value'. -- Returns the response as an @Aeson.@'Aeson.Value'.
graphqlSubs :: Alternative m => Schema m -> Subs -> Text -> m Aeson.Value graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
graphqlSubs schema f = graphqlSubs schema f =
either parseError (execute schema f) either parseError (execute schema f)
. Attoparsec.parseOnly document . Attoparsec.parseOnly document

143
Data/GraphQL/AST.hs
View File

@ -1,11 +1,13 @@
-- | This module defines an abstract syntax tree for the @GraphQL@ language based on -- | This module defines an abstract syntax tree for the @GraphQL@ language based on
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>. -- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
--
-- Target AST for Parser.
module Data.GraphQL.AST where module Data.GraphQL.AST where
import Data.Int (Int32) import Data.Int (Int32)
import Data.String (IsString(fromString)) import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text, pack) import Data.Text (Text)
-- * Name -- * Name
@ -13,116 +15,117 @@ type Name = Text
-- * Document -- * Document
newtype Document = Document [Definition] deriving (Eq,Show) type Document = NonEmpty Definition
-- * Operations
data Definition = DefinitionOperation OperationDefinition data Definition = DefinitionOperation OperationDefinition
| DefinitionFragment FragmentDefinition | DefinitionFragment FragmentDefinition
deriving (Eq,Show) deriving (Eq,Show)
data OperationDefinition = Query Node data OperationDefinition = OperationSelectionSet SelectionSet
| Mutation Node | OperationDefinition OperationType
(Maybe Name)
VariableDefinitions
Directives
SelectionSet
deriving (Eq,Show) deriving (Eq,Show)
data Node = Node Name [VariableDefinition] [Directive] SelectionSet data OperationType = Query | Mutation deriving (Eq,Show)
deriving (Eq,Show)
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) -- * SelectionSet
deriving (Eq,Show)
newtype Variable = Variable Name deriving (Eq,Show) type SelectionSet = NonEmpty Selection
instance IsString Variable where type SelectionSetOpt = [Selection]
fromString = Variable . pack
type SelectionSet = [Selection] data Selection = SelectionField Field
data Selection = SelectionField Field
| SelectionFragmentSpread FragmentSpread | SelectionFragmentSpread FragmentSpread
| SelectionInlineFragment InlineFragment | SelectionInlineFragment InlineFragment
deriving (Eq,Show) deriving (Eq,Show)
-- | A 'SelectionSet' is primarily composed of 'Field's. A 'Field' describes one -- * Field
-- discrete piece of information available to request within a 'SelectionSet'.
-- data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
-- Some 'Field's describe complex data or relationships to other data. In
-- order to further explore this data, a 'Field' may itself contain a
-- 'SelectionSet', allowing for deeply nested requests. All @GraphQL@ operations
-- must specify their 'Selection's down to 'Field's which return scalar values to
-- ensure an unambiguously shaped response.
--
-- <https://facebook.github.io/graphql/#sec-Language.Query-Document.Fields Field Specification>
data Field = Field Alias Name [Argument] [Directive] SelectionSet
deriving (Eq,Show) deriving (Eq,Show)
type Alias = Name type Alias = Name
-- | 'Field's are conceptually functions which return values, and occasionally accept -- * Arguments
-- 'Argument's which alter their behavior. These 'Argument's often map directly to
-- function arguments within a @GraphQL@ server’s implementation. type Arguments = [Argument]
--
-- <https://facebook.github.io/graphql/#sec-Language.Query-Document.Arguments Argument Specification>
data Argument = Argument Name Value deriving (Eq,Show) data Argument = Argument Name Value deriving (Eq,Show)
-- * Fragments -- * Fragments
data FragmentSpread = FragmentSpread Name [Directive] data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
deriving (Eq,Show) deriving (Eq,Show)
data InlineFragment =
InlineFragment TypeCondition [Directive] SelectionSet
deriving (Eq,Show)
data FragmentDefinition = data FragmentDefinition =
FragmentDefinition Name TypeCondition [Directive] SelectionSet FragmentDefinition FragmentName TypeCondition Directives SelectionSet
deriving (Eq,Show) deriving (Eq,Show)
type TypeCondition = NamedType type FragmentName = Name
-- * Values type TypeCondition = Name
-- Input Values
-- | 'Field' and 'Directive' 'Arguments' accept input values of various literal
-- primitives; input values can be scalars, enumeration values, lists, or input
-- objects.
--
-- If not defined as constant (for example, in 'DefaultValue'), input values
-- can be specified as a 'Variable'. List and inputs objects may also contain
-- 'Variable's (unless defined to be constant).
--
-- <https://facebook.github.io/graphql/#sec-Input-Values Input Value Specification>
data Value = ValueVariable Variable data Value = ValueVariable Variable
| ValueInt Int32 | ValueInt IntValue
-- GraphQL Float is double precison | ValueFloat FloatValue
| ValueFloat Double | ValueString StringValue
| ValueBoolean Bool | ValueBoolean BooleanValue
| ValueString Text | ValueNull
| ValueEnum Name | ValueEnum EnumValue
| ValueList ListValue | ValueList ListValue
| ValueObject ObjectValue | ValueObject ObjectValue
deriving (Eq,Show) deriving (Eq,Show)
newtype ListValue = ListValue [Value] deriving (Eq,Show) type IntValue = Int32
newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show) -- GraphQL Float is double precison
type FloatValue = Double
type StringValue = Text
type BooleanValue = Bool
type EnumValue = Name
type ListValue = [Value]
type ObjectValue = [ObjectField]
data ObjectField = ObjectField Name Value deriving (Eq,Show) data ObjectField = ObjectField Name Value deriving (Eq,Show)
-- * Variables
type VariableDefinitions = [VariableDefinition]
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
deriving (Eq,Show)
type Variable = Name
type DefaultValue = Value type DefaultValue = Value
-- * Directives -- * Input Types
data Directive = Directive Name [Argument] deriving (Eq,Show) data Type = TypeNamed Name
| TypeList Type
-- * Type Reference
data Type = TypeNamed NamedType
| TypeList ListType
| TypeNonNull NonNullType | TypeNonNull NonNullType
deriving (Eq,Show) deriving (Eq,Show)
newtype NamedType = NamedType Name deriving (Eq,Show) data NonNullType = NonNullTypeNamed Name
| NonNullTypeList Type
newtype ListType = ListType Type deriving (Eq,Show)
data NonNullType = NonNullTypeNamed NamedType
| NonNullTypeList ListType
deriving (Eq,Show) deriving (Eq,Show)
-- * Directives
type Directives = [Directive]
data Directive = Directive Name [Argument] deriving (Eq,Show)

17
Data/GraphQL/AST/Core.hs
View File

@ -3,29 +3,36 @@ module Data.GraphQL.AST.Core where
import Data.Int (Int32) import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.String
import Data.Text (Text) import Data.Text (Text)
newtype Name = Name Text deriving (Eq,Show) type Name = Text
newtype Document = Document (NonEmpty Operation) deriving (Eq,Show) type Document = NonEmpty Operation
data Operation = Query (NonEmpty Field) data Operation = Query (NonEmpty Field)
| Mutation (NonEmpty Field) | Mutation (NonEmpty Field)
deriving (Eq,Show) deriving (Eq,Show)
data Field = Field Name [Argument] [Field] deriving (Eq,Show) data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
type Alias = Name
data Argument = Argument Name Value deriving (Eq,Show) data Argument = Argument Name Value deriving (Eq,Show)
data Value = ValueInt Int32 data Value = ValueInt Int32
-- GraphQL Float is double precision -- GraphQL Float is double precision
| ValueFloat Double | ValueFloat Double
| ValueBoolean Bool
| ValueString Text | ValueString Text
| ValueBoolean Bool
| ValueNull
| ValueEnum Name | ValueEnum Name
| ValueList [Value] | ValueList [Value]
| ValueObject [ObjectField] | ValueObject [ObjectField]
deriving (Eq,Show) deriving (Eq,Show)
instance IsString Value where
fromString = ValueString . fromString
data ObjectField = ObjectField Name Value deriving (Eq,Show) data ObjectField = ObjectField Name Value deriving (Eq,Show)

123
Data/GraphQL/AST/Transform.hs Normal file
View File

@ -0,0 +1,123 @@
{-# LANGUAGE OverloadedStrings #-}
module Data.GraphQL.AST.Transform where
import Control.Applicative (empty)
import Control.Monad ((<=<))
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import Data.Foldable (fold, foldMap)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Monoid (Alt(Alt,getAlt), (<>))
import Data.Text (Text)
import qualified Data.GraphQL.AST as Full
import qualified Data.GraphQL.AST.Core as Core
import qualified Data.GraphQL.Schema as Schema
type Name = Text
-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
-- empty list is returned.
type Fragmenter = Name -> [Core.Field]
-- TODO: Replace Maybe by MonadThrow with CustomError
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
document subs doc = operations subs fr ops
where
(fr, ops) = first foldFrags
. partitionEithers
. NonEmpty.toList
$ defrag subs
<$> doc
foldFrags :: [Fragmenter] -> Fragmenter
foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
-- * Operation
-- TODO: Replace Maybe by MonadThrow CustomError
operations
:: Schema.Subs
-> Fragmenter
-> [Full.OperationDefinition]
-> Maybe Core.Document
operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
-- TODO: Replace Maybe by MonadThrow CustomError
operation
:: Schema.Subs
-> Fragmenter
-> Full.OperationDefinition
-> Maybe Core.Operation
operation subs fr (Full.OperationSelectionSet sels) =
operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
-- TODO: Validate Variable definitions with substituter
operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
case ot of
Full.Query -> Core.Query <$> node
Full.Mutation -> Core.Mutation <$> node
where
node = traverse (hush . selection subs fr) sels
selection
:: Schema.Subs
-> Fragmenter
-> Full.Selection
-> Either [Core.Field] Core.Field
selection subs fr (Full.SelectionField fld) =
Right $ field subs fr fld
selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
Left $ fr n
selection _ _ (Full.SelectionInlineFragment _) =
error "Inline fragments not supported yet"
-- * Fragment replacement
-- | Extract Fragments into a single Fragmenter function and a Operation
-- Definition.
defrag
:: Schema.Subs
-> Full.Definition
-> Either Fragmenter Full.OperationDefinition
defrag _ (Full.DefinitionOperation op) =
Right op
defrag subs (Full.DefinitionFragment fragDef) =
Left $ fragmentDefinition subs fragDef
fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
-- TODO: Support fragments within fragments. Fold instead of map.
if name == name'
then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
else empty
field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
field subs fr (Full.Field a n args _dirs sels) =
Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
where
go :: Full.Selection -> [Core.Field] -> [Core.Field]
go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
go sel = (either id pure (selection subs fr sel) <>)
argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
value :: Schema.Subs -> Full.Value -> Maybe Core.Value
value subs (Full.ValueVariable n) = subs n
value _ (Full.ValueInt i) = pure $ Core.ValueInt i
value _ (Full.ValueFloat f) = pure $ Core.ValueFloat f
value _ (Full.ValueString x) = pure $ Core.ValueString x
value _ (Full.ValueBoolean b) = pure $ Core.ValueBoolean b
value _ Full.ValueNull = pure Core.ValueNull
value _ (Full.ValueEnum e) = pure $ Core.ValueEnum e
value subs (Full.ValueList l) =
Core.ValueList <$> traverse (value subs) l
value subs (Full.ValueObject o) =
Core.ValueObject <$> traverse (objectField subs) o
objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
hush :: Either a b -> Maybe b
hush = either (const Nothing) Just

73
Data/GraphQL/Encoder.hs
View File

@ -2,7 +2,9 @@
-- | This module defines a printer for the @GraphQL@ language. -- | This module defines a printer for the @GraphQL@ language.
module Data.GraphQL.Encoder where module Data.GraphQL.Encoder where
import Data.Foldable (fold)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import qualified Data.List.NonEmpty as NonEmpty (toList)
import Data.Text (Text, cons, intercalate, pack, snoc) import Data.Text (Text, cons, intercalate, pack, snoc)
@ -10,24 +12,26 @@ import Data.GraphQL.AST
-- * Document -- * Document
-- TODO: Use query shorthand
document :: Document -> Text document :: Document -> Text
document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs
definition :: Definition -> Text definition :: Definition -> Text
definition (DefinitionOperation x) = operationDefinition x definition (DefinitionOperation x) = operationDefinition x
definition (DefinitionFragment x) = fragmentDefinition x definition (DefinitionFragment x) = fragmentDefinition x
operationDefinition :: OperationDefinition -> Text operationDefinition :: OperationDefinition -> Text
operationDefinition (Query n) = "query " <> node n operationDefinition (OperationSelectionSet sels) = selectionSet sels
operationDefinition (Mutation n) = "mutation " <> node n operationDefinition (OperationDefinition Query name vars dirs sels) =
"query " <> node (fold name) vars dirs sels
operationDefinition (OperationDefinition Mutation name vars dirs sels) =
"mutation " <> node (fold name) vars dirs sels
node :: Node -> Text node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
node (Node name vds ds ss) = node name vars dirs sels =
name name
<> optempty variableDefinitions vds <> optempty variableDefinitions vars
<> optempty directives ds <> optempty directives dirs
<> selectionSet ss <> selectionSet sels
variableDefinitions :: [VariableDefinition] -> Text variableDefinitions :: [VariableDefinition] -> Text
variableDefinitions = parensCommas variableDefinition variableDefinitions = parensCommas variableDefinition
@ -40,10 +44,13 @@ defaultValue :: DefaultValue -> Text
defaultValue val = "=" <> value val defaultValue val = "=" <> value val
variable :: Variable -> Text variable :: Variable -> Text
variable (Variable name) = "$" <> name variable var = "$" <> var
selectionSet :: SelectionSet -> Text selectionSet :: SelectionSet -> Text
selectionSet = bracesCommas selection selectionSet = bracesCommas selection . NonEmpty.toList
selectionSetOpt :: SelectionSetOpt -> Text
selectionSetOpt = bracesCommas selection
selection :: Selection -> Text selection :: Selection -> Text
selection (SelectionField x) = field x selection (SelectionField x) = field x
@ -51,12 +58,12 @@ selection (SelectionInlineFragment x) = inlineFragment x
selection (SelectionFragmentSpread x) = fragmentSpread x selection (SelectionFragmentSpread x) = fragmentSpread x
field :: Field -> Text field :: Field -> Text
field (Field alias name args ds ss) = field (Field alias name args dirs selso) =
optempty (`snoc` ':') alias optempty (`snoc` ':') (fold alias)
<> name <> name
<> optempty arguments args <> optempty arguments args
<> optempty directives ds <> optempty directives dirs
<> optempty selectionSet ss <> optempty selectionSetOpt selso
arguments :: [Argument] -> Text arguments :: [Argument] -> Text
arguments = parensCommas argument arguments = parensCommas argument
@ -71,26 +78,27 @@ fragmentSpread (FragmentSpread name ds) =
"..." <> name <> optempty directives ds "..." <> name <> optempty directives ds
inlineFragment :: InlineFragment -> Text inlineFragment :: InlineFragment -> Text
inlineFragment (InlineFragment (NamedType tc) ds ss) = inlineFragment (InlineFragment tc dirs sels) =
"... on " <> tc "... on " <> fold tc
<> optempty directives ds <> directives dirs
<> optempty selectionSet ss <> selectionSet sels
fragmentDefinition :: FragmentDefinition -> Text fragmentDefinition :: FragmentDefinition -> Text
fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) = fragmentDefinition (FragmentDefinition name tc dirs sels) =
"fragment " <> name <> " on " <> tc "fragment " <> name <> " on " <> tc
<> optempty directives ds <> optempty directives dirs
<> selectionSet ss <> selectionSet sels
-- * Values -- * Values
value :: Value -> Text value :: Value -> Text
value (ValueVariable x) = variable x value (ValueVariable x) = variable x
-- TODO: This will be replaced with `decimal` Buidler -- TODO: This will be replaced with `decimal` Builder
value (ValueInt x) = pack $ show x value (ValueInt x) = pack $ show x
-- TODO: This will be replaced with `decimal` Buidler -- TODO: This will be replaced with `decimal` Builder
value (ValueFloat x) = pack $ show x value (ValueFloat x) = pack $ show x
value (ValueBoolean x) = booleanValue x value (ValueBoolean x) = booleanValue x
value ValueNull = mempty
value (ValueString x) = stringValue x value (ValueString x) = stringValue x
value (ValueEnum x) = x value (ValueEnum x) = x
value (ValueList x) = listValue x value (ValueList x) = listValue x
@ -105,10 +113,10 @@ stringValue :: Text -> Text
stringValue = quotes stringValue = quotes
listValue :: ListValue -> Text listValue :: ListValue -> Text
listValue (ListValue vs) = bracketsCommas value vs listValue = bracketsCommas value
objectValue :: ObjectValue -> Text objectValue :: ObjectValue -> Text
objectValue (ObjectValue ofs) = bracesCommas objectField ofs objectValue = bracesCommas objectField
objectField :: ObjectField -> Text objectField :: ObjectField -> Text
objectField (ObjectField name v) = name <> ":" <> value v objectField (ObjectField name v) = name <> ":" <> value v
@ -124,18 +132,15 @@ directive (Directive name args) = "@" <> name <> optempty arguments args
-- * Type Reference -- * Type Reference
type_ :: Type -> Text type_ :: Type -> Text
type_ (TypeNamed (NamedType x)) = x type_ (TypeNamed x) = x
type_ (TypeList x) = listType x type_ (TypeList x) = listType x
type_ (TypeNonNull x) = nonNullType x type_ (TypeNonNull x) = nonNullType x
namedType :: NamedType -> Text listType :: Type -> Text
namedType (NamedType name) = name listType x = brackets (type_ x)
listType :: ListType -> Text
listType (ListType ty) = brackets (type_ ty)
nonNullType :: NonNullType -> Text nonNullType :: NonNullType -> Text
nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!" nonNullType (NonNullTypeNamed x) = x <> "!"
nonNullType (NonNullTypeList x) = listType x <> "!" nonNullType (NonNullTypeList x) = listType x <> "!"
-- * Internal -- * Internal

69
Data/GraphQL/Execute.hs
View File

@ -1,58 +1,71 @@
{-# LANGUAGE OverloadedStrings #-}
-- | This module provides the function to execute a @GraphQL@ request -- -- | This module provides the function to execute a @GraphQL@ request --
-- according to a 'Schema'. -- according to a 'Schema'.
module Data.GraphQL.Execute (execute) where module Data.GraphQL.Execute (execute) where
import Control.Applicative (Alternative) import Control.Applicative (Alternative, empty)
import Data.Maybe (catMaybes) import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.GraphQL.AST import qualified Data.GraphQL.AST as AST
import Data.GraphQL.Schema (Schema(..)) import qualified Data.GraphQL.AST.Core as AST.Core
import qualified Data.GraphQL.AST.Transform as Transform
import Data.GraphQL.Schema (Schema)
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
import Data.GraphQL.Error
-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a -- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
-- @GraphQL@ 'document'. The substitution is applied to the document using -- @GraphQL@ 'document'. The substitution is applied to the document using
-- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields. -- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
-- --
-- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or -- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
-- errors wrapped in an /errors/ field. -- errors wrapped in an /errors/ field.
execute :: Alternative f execute
=> Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value :: (Alternative f, Monad f)
execute (Schema resolvs) subs doc = runCollectErrs res => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
where res = Schema.resolvers resolvs $ rootFields subs doc execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc)
document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
document schema (op :| []) = operation schema op
document _ _ = error "Multiple operations not supported yet"
operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
operation schema (AST.Core.Query flds) =
Aeson.Object . HashMap.singleton "data"
<$> Schema.resolve (NE.toList schema) (NE.toList flds)
operation _ _ = error "Mutations not supported yet"
-- | Takes a variable substitution function and a @GraphQL@ document. -- | Takes a variable substitution function and a @GraphQL@ document.
-- If the document contains one query (and no other definitions) -- If the document contains one query (and no other definitions)
-- it applies the substitution to the query's set of selections -- it applies the substitution to the query's set of selections
-- and then returns their fields. -- and then returns their fields.
rootFields :: Schema.Subs -> Document -> [Field] -- rootFields :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = -- rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
Schema.fields $ substitute subs <$> sels -- Schema.fields $ substitute subs <$> sels
rootFields _ _ = [] -- rootFields _ _ = []
-- | Takes a variable substitution function and a selection. If the -- | Takes a variable substitution function and a selection. If the
-- selection is a field it applies the substitution to the field's -- selection is a field it applies the substitution to the field's
-- arguments using 'subsArg', and recursively applies the substitution to -- arguments using 'subsArg', and recursively applies the substitution to
-- the arguments of fields nested in the primary field. -- the arguments of fields nested in the primary field.
substitute :: Schema.Subs -> Selection -> Selection -- substitute :: Schema.Subs -> Selection -> Selection
substitute subs (SelectionField (Field alias name args directives sels)) = -- substitute subs (SelectionField (Field alias name args directives sels)) =
SelectionField $ Field -- SelectionField $ Field
alias -- alias
name -- name
-- TODO: Get rid of `catMaybes`, invalid arguments should raise an error -- -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
(catMaybes $ subsArg subs <$> args) -- (catMaybes $ subsArg subs <$> args)
directives -- directives
(substitute subs <$> sels) -- (substitute subs <$> sels)
substitute _ sel = sel -- substitute _ sel = sel
-- TODO: Support different value types -- TODO: Support different value types
-- | Takes a variable substitution function and an argument. If the -- | Takes a variable substitution function and an argument. If the
-- argument's value is a variable the substitution is applied to the -- argument's value is a variable the substitution is applied to the
-- variable's name. -- variable's name.
subsArg :: Schema.Subs -> Argument -> Maybe Argument -- subsArg :: Schema.Subs -> Argument -> Maybe Argument
subsArg subs (Argument n (ValueVariable (Variable v))) = -- subsArg subs (Argument n (ValueVariable (Variable v))) =
Argument n . ValueString <$> subs v -- Argument n . ValueString <$> subs v
subsArg _ arg = Just arg -- subsArg _ arg = Just arg

241
Data/GraphQL/Parser.hs
View File

@ -1,28 +1,32 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module defines a parser for @GraphQL@ request documents. -- | This module defines a parser for @GraphQL@ request documents.
module Data.GraphQL.Parser where module Data.GraphQL.Parser where
import Prelude hiding (takeWhile) import Prelude hiding (takeWhile)
import Control.Applicative ((<|>), empty, many, optional) import Control.Applicative ((<|>), Alternative, empty, many, optional)
import Control.Monad (when) import Control.Monad (when)
import Data.Char (isDigit, isSpace) import Data.Char (isDigit, isSpace)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import Data.Int (Int32) import Data.Int (Int32)
import Data.Monoid ((<>))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Scientific (floatingOrInteger) import Data.Scientific (floatingOrInteger)
import Data.Text (Text, append) import Data.Text (Text, append)
import Data.Attoparsec.Combinator (lookAhead)
import Data.Attoparsec.Text import Data.Attoparsec.Text
( Parser ( Parser
, (<?>) , (<?>)
, anyChar , anyChar
, scientific
, endOfLine , endOfLine
, inClass , inClass
, many1 , many1
, manyTill , manyTill
, option , option
, peekChar , peekChar
, scientific
, takeWhile , takeWhile
, takeWhile1 , takeWhile1
) )
@ -36,20 +40,12 @@ name = tok $ append <$> takeWhile1 isA_z
<*> takeWhile ((||) <$> isDigit <*> isA_z) <*> takeWhile ((||) <$> isDigit <*> isA_z)
where where
-- `isAlpha` handles many more Unicode Chars -- `isAlpha` handles many more Unicode Chars
isA_z = inClass $ '_' : ['A'..'Z'] ++ ['a'..'z'] isA_z = inClass $ '_' : ['A'..'Z'] <> ['a'..'z']
-- * Document -- * Document
document :: Parser Document document :: Parser Document
document = whiteSpace document = whiteSpace *> manyNE definition
*> (Document <$> many1 definition)
-- Try SelectionSet when no definition
<|> (Document . pure
. DefinitionOperation
. Query
. Node mempty empty empty
<$> selectionSet)
<?> "document error!"
definition :: Parser Definition definition :: Parser Definition
definition = DefinitionOperation <$> operationDefinition definition = DefinitionOperation <$> operationDefinition
@ -57,54 +53,48 @@ definition = DefinitionOperation <$> operationDefinition
<?> "definition error!" <?> "definition error!"
operationDefinition :: Parser OperationDefinition operationDefinition :: Parser OperationDefinition
operationDefinition = operationDefinition = OperationSelectionSet <$> selectionSet
Query <$ tok "query" <*> node <|> OperationDefinition <$> operationType
<|> Mutation <$ tok "mutation" <*> node <*> optional name
<?> "operationDefinition error!" <*> opt variableDefinitions
<*> opt directives
<*> selectionSet
<?> "operationDefinition error"
node :: Parser Node operationType :: Parser OperationType
node = Node <$> name operationType = Query <$ tok "query"
<*> optempty variableDefinitions <|> Mutation <$ tok "mutation"
<*> optempty directives <?> "operationType error"
<*> selectionSet
variableDefinitions :: Parser [VariableDefinition] -- * SelectionSet
variableDefinitions = parens (many1 variableDefinition)
variableDefinition :: Parser VariableDefinition
variableDefinition =
VariableDefinition <$> variable
<* tok ":"
<*> type_
<*> optional defaultValue
defaultValue :: Parser DefaultValue
defaultValue = tok "=" *> value
variable :: Parser Variable
variable = Variable <$ tok "$" <*> name
selectionSet :: Parser SelectionSet selectionSet :: Parser SelectionSet
selectionSet = braces $ many1 selection selectionSet = braces $ manyNE selection
selectionSetOpt :: Parser SelectionSetOpt
selectionSetOpt = braces $ many1 selection
selection :: Parser Selection selection :: Parser Selection
selection = SelectionField <$> field selection = SelectionField <$> field
-- Inline first to catch `on` case
<|> SelectionInlineFragment <$> inlineFragment
<|> SelectionFragmentSpread <$> fragmentSpread <|> SelectionFragmentSpread <$> fragmentSpread
<|> SelectionInlineFragment <$> inlineFragment
<?> "selection error!" <?> "selection error!"
-- * Field
field :: Parser Field field :: Parser Field
field = Field <$> optempty alias field = Field <$> optional alias
<*> name <*> name
<*> optempty arguments <*> opt arguments
<*> optempty directives <*> opt directives
<*> optempty selectionSet <*> opt selectionSetOpt
alias :: Parser Alias alias :: Parser Alias
alias = name <* tok ":" alias = name <* tok ":"
arguments :: Parser [Argument] -- * Arguments
arguments :: Parser Arguments
arguments = parens $ many1 argument arguments = parens $ many1 argument
argument :: Parser Argument argument :: Parser Argument
@ -113,108 +103,113 @@ argument = Argument <$> name <* tok ":" <*> value
-- * Fragments -- * Fragments
fragmentSpread :: Parser FragmentSpread fragmentSpread :: Parser FragmentSpread
-- TODO: Make sure it fails when `... on`. fragmentSpread = FragmentSpread <$ tok "..."
-- See https://facebook.github.io/graphql/#FragmentSpread <*> fragmentName
fragmentSpread = FragmentSpread <*> opt directives
<$ tok "..."
<*> name
<*> optempty directives
-- InlineFragment tried first in order to guard against 'on' keyword
inlineFragment :: Parser InlineFragment inlineFragment :: Parser InlineFragment
inlineFragment = InlineFragment inlineFragment = InlineFragment <$ tok "..."
<$ tok "..." <*> optional typeCondition
<* tok "on" <*> opt directives
<*> typeCondition <*> selectionSet
<*> optempty directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition fragmentDefinition = FragmentDefinition
<$ tok "fragment" <$ tok "fragment"
<*> name <*> name
<* tok "on" <*> typeCondition
<*> typeCondition <*> opt directives
<*> optempty directives <*> selectionSet
<*> selectionSet
fragmentName :: Parser FragmentName
fragmentName = but (tok "on") *> name
typeCondition :: Parser TypeCondition typeCondition :: Parser TypeCondition
typeCondition = namedType typeCondition = tok "on" *> name
-- * Values -- * Input 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 Value value :: Parser Value
value = ValueVariable <$> variable value = ValueVariable <$> variable
-- TODO: Handle maxBound, Int32 in spec.
<|> tok floatOrInt32Value <|> tok floatOrInt32Value
<|> ValueBoolean <$> booleanValue <|> ValueBoolean <$> booleanValue
<|> ValueNull <$ tok "null"
<|> ValueString <$> stringValue <|> ValueString <$> stringValue
-- `true` and `false` have been tried before <|> ValueEnum <$> enumValue
<|> ValueEnum <$> name
<|> ValueList <$> listValue <|> ValueList <$> listValue
<|> ValueObject <$> objectValue <|> ValueObject <$> objectValue
<?> "value error!" <?> "value error!"
where
booleanValue :: Parser Bool
booleanValue = True <$ tok "true"
<|> False <$ tok "false"
floatOrInt32Value :: Parser Value floatOrInt32Value :: Parser Value
floatOrInt32Value = do floatOrInt32Value = do
n <- scientific n <- scientific
case (floatingOrInteger n :: Either Double Integer) of case (floatingOrInteger n :: Either Double Integer) of
Left dbl -> return $ ValueFloat dbl Left dbl -> return $ ValueFloat dbl
Right i -> Right i ->
if i < (-2147483648) || i >= 2147483648 if i < (-2147483648) || i >= 2147483648
then fail "Integer value is out of range." then fail "Integer value is out of range."
else return $ ValueInt (fromIntegral i :: Int32) else return $ ValueInt (fromIntegral i :: Int32)
booleanValue :: Parser Bool -- TODO: Escape characters. Look at `jsstring_` in aeson package.
booleanValue = True <$ tok "true" stringValue :: Parser Text
<|> False <$ tok "false" stringValue = quotes (takeWhile (/= '"'))
-- TODO: Escape characters. Look at `jsstring_` in aeson package. enumValue :: Parser Name
stringValue :: Parser Text enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name
stringValue = quotes (takeWhile (/= '"'))
-- Notice it can be empty listValue :: Parser [Value]
listValue :: Parser ListValue listValue = brackets $ many1 value
listValue = ListValue <$> brackets (many value)
-- Notice it can be empty objectValue :: Parser [ObjectField]
objectValue :: Parser ObjectValue objectValue = braces $ many1 objectField
objectValue = ObjectValue <$> braces (many objectField)
objectField :: Parser ObjectField objectField :: Parser ObjectField
objectField = ObjectField <$> name <* tok ":" <*> value objectField = ObjectField <$> name <* tok ":" <*> value
-- * Variables
variableDefinitions :: Parser VariableDefinitions
variableDefinitions = parens $ many1 variableDefinition
variableDefinition :: Parser VariableDefinition
variableDefinition = VariableDefinition <$> variable
<* tok ":"
<*> type_
<*> optional defaultValue
variable :: Parser Variable
variable = tok "$" *> name
defaultValue :: Parser DefaultValue
defaultValue = tok "=" *> value
-- * Input Types
type_ :: Parser Type
type_ = TypeNamed <$> name <* but "!"
<|> TypeList <$> brackets type_
<|> TypeNonNull <$> nonNullType
<?> "type_ error!"
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> name <* tok "!"
<|> NonNullTypeList <$> brackets type_ <* tok "!"
<?> "nonNullType error!"
-- * Directives -- * Directives
directives :: Parser [Directive] directives :: Parser Directives
directives = many1 directive directives = many1 directive
directive :: Parser Directive directive :: Parser Directive
directive = Directive directive = Directive
<$ tok "@" <$ tok "@"
<*> name <*> name
<*> optempty arguments <*> opt arguments
-- * Type Reference
type_ :: Parser Type
type_ = TypeList <$> listType
<|> TypeNonNull <$> nonNullType
<|> TypeNamed <$> namedType
<?> "type_ error!"
namedType :: Parser NamedType
namedType = NamedType <$> name
listType :: Parser ListType
listType = ListType <$> brackets type_
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
<|> NonNullTypeList <$> listType <* tok "!"
<?> "nonNullType error!"
-- * Internal -- * Internal
@ -236,12 +231,18 @@ brackets = between "[" "]"
between :: Parser Text -> Parser Text -> Parser a -> Parser a between :: Parser Text -> Parser Text -> Parser a -> Parser a
between open close p = tok open *> p <* tok close between open close p = tok open *> p <* tok close
-- `empty` /= `pure mempty` for `Parser`. opt :: Monoid a => Parser a -> Parser a
optempty :: Monoid a => Parser a -> Parser a opt = option mempty
optempty = option mempty
-- Hack to reverse parser success
but :: Parser a -> Parser ()
but pn = False <$ lookAhead pn <|> pure True >>= \case
False -> empty
True -> pure ()
manyNE :: Alternative f => f a -> f (NonEmpty a)
manyNE p = (:|) <$> p <*> many p
-- ** WhiteSpace
--
whiteSpace :: Parser () whiteSpace :: Parser ()
whiteSpace = peekChar >>= traverse_ (\c -> whiteSpace = peekChar >>= traverse_ (\c ->
if isSpace c || c == ',' if isSpace c || c == ','

104
Data/GraphQL/Schema.hs
View File

@ -1,9 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas. -- functions for defining and manipulating Schemas.
module Data.GraphQL.Schema module Data.GraphQL.Schema
( Schema(..) ( Schema
, Resolver , Resolver
, Subs , Subs
, object , object
@ -14,55 +13,57 @@ module Data.GraphQL.Schema
, arrayA , arrayA
, enum , enum
, enumA , enumA
, resolvers , resolve
, fields
-- * AST Reexports -- * AST Reexports
, Field , Field
, Argument(..) , Argument(..)
, Value(..) , Value(..)
) where ) where
import Data.Bifunctor (first) import Control.Applicative (Alternative(empty))
import Data.Monoid (Alt(Alt,getAlt))
import Control.Applicative (Alternative((<|>), empty))
import Data.Maybe (catMaybes)
import Data.Foldable (fold) import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
import Data.Monoid (Alt(Alt,getAlt))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T (null, unwords)
import Data.GraphQL.AST import Data.GraphQL.AST.Core
import Data.GraphQL.Error
-- | A GraphQL schema. -- | A GraphQL schema.
-- @f@ is usually expected to be an instance of 'Alternative'. -- @f@ is usually expected to be an instance of 'Alternative'.
data Schema f = Schema [Resolver f] type Schema f = NonEmpty (Resolver f)
-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
-- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'. -- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
type Resolver f = Field -> CollectErrsT f Aeson.Object type Resolver f = Field -> f Aeson.Object
type Resolvers f = [Resolver f]
type Fields = [Field]
type Arguments = [Argument]
-- | Variable substitution function. -- | Variable substitution function.
type Subs = Text -> Maybe Text type Subs = Name -> Maybe Value
-- | Create a named 'Resolver' from a list of 'Resolver's. -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Alternative f => Text -> [Resolver f] -> Resolver f object :: Alternative f => Name -> Resolvers f -> Resolver f
object name resolvs = objectA name $ \case object name resolvers = objectA name $ \case
[] -> resolvs [] -> resolvers
_ -> empty _ -> empty
-- | Like 'object' but also taking 'Argument's. -- | Like 'object' but also taking 'Argument's.
objectA objectA
:: Alternative f :: Alternative f
=> Text -> ([Argument] -> [Resolver f]) -> Resolver f => Name -> (Arguments -> Resolvers f) -> Resolver f
objectA name f fld@(Field _ _ args _ sels) = objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
withField name (resolvers (f args) $ fields sels) fld
-- | A scalar represents a primitive value, like a string or an integer. -- | A scalar represents a primitive value, like a string or an integer.
scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f scalar :: (Alternative f, Aeson.ToJSON a) => Name -> a -> Resolver f
scalar name s = scalarA name $ \case scalar name s = scalarA name $ \case
[] -> pure s [] -> pure s
_ -> empty _ -> empty
@ -70,22 +71,21 @@ scalar name s = scalarA name $ \case
-- | Like 'scalar' but also taking 'Argument's. -- | Like 'scalar' but also taking 'Argument's.
scalarA scalarA
:: (Alternative f, Aeson.ToJSON a) :: (Alternative f, Aeson.ToJSON a)
=> Text -> ([Argument] -> f a) -> Resolver f => Name -> (Arguments -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld scalarA name f fld@(Field _ _ args []) = withField name (f args) fld
scalarA _ _ _ = empty scalarA _ _ _ = empty
-- | Like 'object' but taking lists of 'Resolver's instead of a single list. array :: Alternative f => Name -> [Resolvers f] -> Resolver f
array :: Alternative f => Text -> [[Resolver f]] -> Resolver f array name resolvers = arrayA name $ \case
array name resolvs = arrayA name $ \case [] -> resolvers
[] -> resolvs
_ -> empty _ -> empty
-- | Like 'array' but also taking 'Argument's. -- | Like 'array' but also taking 'Argument's.
arrayA arrayA
:: Alternative f :: Alternative f
=> Text -> ([Argument] -> [[Resolver f]]) -> Resolver f => Text -> (Arguments -> [Resolvers f]) -> Resolver f
arrayA name f fld@(Field _ _ args _ sels) = arrayA name f fld@(Field _ _ args sels) =
withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld withField name (traverse (`resolve` sels) $ f args) fld
-- | Represents one of a finite set of possible values. -- | Represents one of a finite set of possible values.
-- Used in place of a 'scalar' when the possible responses are easily enumerable. -- Used in place of a 'scalar' when the possible responses are easily enumerable.
@ -96,40 +96,24 @@ enum name enums = enumA name $ \case
-- | Like 'enum' but also taking 'Argument's. -- | Like 'enum' but also taking 'Argument's.
enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
enumA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld enumA name f fld@(Field _ _ args []) = withField name (f args) fld
enumA _ _ _ = empty enumA _ _ _ = empty
-- | Helper function to facilitate 'Argument' handling. -- | Helper function to facilitate 'Argument' handling.
withField withField
:: (Alternative f, Aeson.ToJSON a) :: (Alternative f, Aeson.ToJSON a)
=> Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value) => Name -> f a -> Field -> f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _ _) = withField name f (Field alias name' _ _) =
if name == name' if name == name'
then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty else empty
where where
aliasOrName = if T.null alias then name' else alias aliasOrName = fromMaybe name alias
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the -- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information. -- resolved 'Field', or a null value and error information.
resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value
resolvers resolvs = resolve resolvers =
fmap (first Aeson.toJSON . fold) fmap (Aeson.toJSON . fold)
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld) . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers))
where
errmsg (Field alias name _ _ _) = addErrMsg msg $ (errWrap . pure) val
where
val = HashMap.singleton aliasOrName Aeson.Null
msg = T.unwords ["field", name, "not resolved."]
aliasOrName = if T.null alias then name else alias
-- | Checks whether the given 'Selection' contains a 'Field' and
-- returns the 'Field' if so, else returns 'Nothing'.
field :: Selection -> Maybe Field
field (SelectionField x) = Just x
field _ = Nothing
-- | Returns a list of the 'Field's contained in the given 'SelectionSet'.
fields :: SelectionSet -> [Field]
fields = catMaybes . fmap field

6
graphql.cabal
View File

@ -25,11 +25,13 @@ library
ghc-options: -Wall ghc-options: -Wall
exposed-modules: Data.GraphQL exposed-modules: Data.GraphQL
Data.GraphQL.AST Data.GraphQL.AST
Data.GraphQL.Encoder Data.GraphQL.AST.Core
Data.GraphQL.AST.Transform
Data.GraphQL.Execute Data.GraphQL.Execute
Data.GraphQL.Encoder
Data.GraphQL.Error
Data.GraphQL.Schema Data.GraphQL.Schema
Data.GraphQL.Parser Data.GraphQL.Parser
Data.GraphQL.Error
build-depends: aeson >= 0.7.0.3, build-depends: aeson >= 0.7.0.3,
attoparsec >= 0.10.4.0, attoparsec >= 0.10.4.0,
base >= 4.7 && < 5, base >= 4.7 && < 5,

23
tests/Test/StarWars/QueryTests.hs
View File

@ -140,17 +140,18 @@ test = testGroup "Star Wars Query Tests"
$ object [ "data" .= object [ $ object [ "data" .= object [
"human" .= object [hanName] "human" .= object [hanName]
]] ]]
, testCase "Invalid ID" . testQueryParams -- TODO: Enable after Error handling restoration
(\v -> if v == "id" -- , testCase "Invalid ID" . testQueryParams
then Just "Not a valid ID" -- (\v -> if v == "id"
else Nothing) -- then Just "Not a valid ID"
[r| query humanQuery($id: String!) { -- else Nothing)
human(id: $id) { -- [r| query humanQuery($id: String!) {
name -- human(id: $id) {
} -- name
} -- }
|] $ object ["data" .= object ["human" .= object ["name" .= Aeson.Null]], -- }
"errors" .= Aeson.toJSON [object ["message" .= ("field name not resolved." :: Text)]]] -- |] $ object ["data" .= object ["human" .= object ["name" .= Aeson.Null]],
-- "errors" .= Aeson.toJSON [object ["message" .= ("field name not resolved." :: Text)]]]
-- TODO: This test is directly ported from `graphql-js`, however do we want -- TODO: This test is directly ported from `graphql-js`, however do we want
-- to mimic the same behavior? Is this part of the spec? Once proper -- to mimic the same behavior? Is this part of the spec? Once proper
-- exceptions are implemented this test might no longer be meaningful. -- exceptions are implemented this test might no longer be meaningful.

22
tests/Test/StarWars/Schema.hs
View File

@ -1,15 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where module Test.StarWars.Schema where
import Control.Applicative (Alternative, empty) import Control.Applicative (Alternative, empty)
import Data.List.NonEmpty (NonEmpty((:|)))
#if !MIN_VERSION_base(4,8,0) import Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..))
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif
import Data.GraphQL.Schema
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
import Test.StarWars.Data import Test.StarWars.Data
@ -18,12 +14,12 @@ import Test.StarWars.Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
schema :: Alternative f => Schema f schema :: Alternative f => Schema f
schema = Schema [hero, human, droid] schema = hero :| [human, droid]
hero :: Alternative f => Resolver f hero :: Alternative f => Resolver f
hero = Schema.objectA "hero" $ \case hero = Schema.objectA "hero" $ \case
[] -> character artoo [] -> character artoo
[Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n) [Argument "episode" (ValueInt n)] -> character . getHero $ fromIntegral n
_ -> empty _ -> empty
human :: Alternative f => Resolver f human :: Alternative f => Resolver f
@ -38,10 +34,10 @@ droid = Schema.objectA "droid" $ \case
character :: Alternative f => Character -> [Resolver f] character :: Alternative f => Character -> [Resolver f]
character char = character char =
[ Schema.scalar "id" $ id_ char [ Schema.scalar "id" $ id_ char
, Schema.scalar "name" $ name char , Schema.scalar "name" $ name char
, Schema.array "friends" $ character <$> getFriends char , Schema.array "friends" $ character <$> getFriends char
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char , Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char
, Schema.scalar "secretBackstory" $ secretBackstory char , Schema.scalar "secretBackstory" $ secretBackstory char
, Schema.scalar "homePlanet" $ either mempty homePlanet char , Schema.scalar "homePlanet" $ either mempty homePlanet char
] ]

6
tests/tasty.hs
View File

@ -18,10 +18,10 @@ import qualified Test.StarWars.QueryTests as SW
import Paths_graphql (getDataFileName) import Paths_graphql (getDataFileName)
main :: IO () main :: IO ()
main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< ksTest main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< kitchenTest
ksTest :: IO TestTree kitchenTest :: IO TestTree
ksTest = testCase "Kitchen Sink" kitchenTest = testCase "Kitchen Sink"
<$> (assertEqual "Encode" <$> expected <*> actual) <$> (assertEqual "Encode" <$> expected <*> actual)
where where
expected = Text.readFile expected = Text.readFile