Merge branch 'core'

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

4
.gitignore vendored
View File

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

View File

@ -19,7 +19,7 @@ import Data.GraphQL.Error
-- executed according to the given 'Schema'.
--
-- 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
-- | 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'.
--
-- 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 =
either parseError (execute schema f)
. Attoparsec.parseOnly document

View File

@ -1,11 +1,13 @@
-- | This module defines an abstract syntax tree for the @GraphQL@ language based on
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
--
-- Target AST for Parser.
module Data.GraphQL.AST where
import Data.Int (Int32)
import Data.String (IsString(fromString))
import Data.Text (Text, pack)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
-- * Name
@ -13,116 +15,117 @@ type Name = Text
-- * Document
newtype Document = Document [Definition] deriving (Eq,Show)
type Document = NonEmpty Definition
-- * Operations
data Definition = DefinitionOperation OperationDefinition
| DefinitionFragment FragmentDefinition
deriving (Eq,Show)
data OperationDefinition = Query Node
| Mutation Node
data OperationDefinition = OperationSelectionSet SelectionSet
| OperationDefinition OperationType
(Maybe Name)
VariableDefinitions
Directives
SelectionSet
deriving (Eq,Show)
data Node = Node Name [VariableDefinition] [Directive] SelectionSet
deriving (Eq,Show)
data OperationType = Query | Mutation deriving (Eq,Show)
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
deriving (Eq,Show)
-- * SelectionSet
newtype Variable = Variable Name deriving (Eq,Show)
type SelectionSet = NonEmpty Selection
instance IsString Variable where
fromString = Variable . pack
type SelectionSet = [Selection]
type SelectionSetOpt = [Selection]
data Selection = SelectionField Field
| SelectionFragmentSpread FragmentSpread
| SelectionInlineFragment InlineFragment
deriving (Eq,Show)
-- | A 'SelectionSet' is primarily composed of 'Field's. A 'Field' describes one
-- discrete piece of information available to request within a 'SelectionSet'.
--
-- 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
-- * Field
data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
deriving (Eq,Show)
type Alias = Name
-- | 'Field's are conceptually functions which return values, and occasionally accept
-- 'Argument's which alter their behavior. These 'Argument's often map directly to
-- function arguments within a @GraphQL@ servers implementation.
--
-- <https://facebook.github.io/graphql/#sec-Language.Query-Document.Arguments Argument Specification>
-- * Arguments
type Arguments = [Argument]
data Argument = Argument Name Value deriving (Eq,Show)
-- * Fragments
data FragmentSpread = FragmentSpread Name [Directive]
deriving (Eq,Show)
data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
data InlineFragment =
InlineFragment TypeCondition [Directive] SelectionSet
data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
deriving (Eq,Show)
data FragmentDefinition =
FragmentDefinition Name TypeCondition [Directive] SelectionSet
FragmentDefinition FragmentName TypeCondition Directives SelectionSet
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
| ValueInt Int32
-- GraphQL Float is double precison
| ValueFloat Double
| ValueBoolean Bool
| ValueString Text
| ValueEnum Name
| ValueInt IntValue
| ValueFloat FloatValue
| ValueString StringValue
| ValueBoolean BooleanValue
| ValueNull
| ValueEnum EnumValue
| ValueList ListValue
| ValueObject ObjectValue
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)
-- * Variables
type VariableDefinitions = [VariableDefinition]
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
deriving (Eq,Show)
type Variable = Name
type DefaultValue = Value
-- * Directives
-- * Input Types
data Directive = Directive Name [Argument] deriving (Eq,Show)
-- * Type Reference
data Type = TypeNamed NamedType
| TypeList ListType
data Type = TypeNamed Name
| TypeList Type
| TypeNonNull NonNullType
deriving (Eq,Show)
newtype NamedType = NamedType Name deriving (Eq,Show)
newtype ListType = ListType Type deriving (Eq,Show)
data NonNullType = NonNullTypeNamed NamedType
| NonNullTypeList ListType
data NonNullType = NonNullTypeNamed Name
| NonNullTypeList Type
deriving (Eq,Show)
-- * Directives
type Directives = [Directive]
data Directive = Directive Name [Argument] deriving (Eq,Show)

View File

@ -3,29 +3,36 @@ module Data.GraphQL.AST.Core where
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.String
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)
| Mutation (NonEmpty Field)
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 Value = ValueInt Int32
-- GraphQL Float is double precision
| ValueFloat Double
| ValueBoolean Bool
| ValueString Text
| ValueBoolean Bool
| ValueNull
| ValueEnum Name
| ValueList [Value]
| ValueObject [ObjectField]
deriving (Eq,Show)
instance IsString Value where
fromString = ValueString . fromString
data ObjectField = ObjectField Name Value deriving (Eq,Show)

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

View File

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

View File

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

View File

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

View File

@ -1,9 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas.
module Data.GraphQL.Schema
( Schema(..)
( Schema
, Resolver
, Subs
, object
@ -14,55 +13,57 @@ module Data.GraphQL.Schema
, arrayA
, enum
, enumA
, resolvers
, fields
, resolve
-- * AST Reexports
, Field
, Argument(..)
, Value(..)
) where
import Data.Bifunctor (first)
import Data.Monoid (Alt(Alt,getAlt))
import Control.Applicative (Alternative((<|>), empty))
import Data.Maybe (catMaybes)
import Control.Applicative (Alternative(empty))
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 Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as T (null, unwords)
import Data.GraphQL.AST
import Data.GraphQL.Error
import Data.GraphQL.AST.Core
-- | A GraphQL schema.
-- @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
-- (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.
type Subs = Text -> Maybe Text
type Subs = Name -> Maybe Value
-- | Create a named 'Resolver' from a list of 'Resolver's.
object :: Alternative f => Text -> [Resolver f] -> Resolver f
object name resolvs = objectA name $ \case
[] -> resolvs
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Alternative f => Name -> Resolvers f -> Resolver f
object name resolvers = objectA name $ \case
[] -> resolvers
_ -> empty
-- | Like 'object' but also taking 'Argument's.
objectA
:: Alternative f
=> Text -> ([Argument] -> [Resolver f]) -> Resolver f
objectA name f fld@(Field _ _ args _ sels) =
withField name (resolvers (f args) $ fields sels) fld
=> Name -> (Arguments -> Resolvers f) -> Resolver f
objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
-- | 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
[] -> pure s
_ -> empty
@ -70,22 +71,21 @@ scalar name s = scalarA name $ \case
-- | Like 'scalar' but also taking 'Argument's.
scalarA
:: (Alternative f, Aeson.ToJSON a)
=> Text -> ([Argument] -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
=> Name -> (Arguments -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args []) = withField name (f args) fld
scalarA _ _ _ = empty
-- | Like 'object' but taking lists of 'Resolver's instead of a single list.
array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
array name resolvs = arrayA name $ \case
[] -> resolvs
array :: Alternative f => Name -> [Resolvers f] -> Resolver f
array name resolvers = arrayA name $ \case
[] -> resolvers
_ -> empty
-- | Like 'array' but also taking 'Argument's.
arrayA
:: Alternative f
=> Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
arrayA name f fld@(Field _ _ args _ sels) =
withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
=> Text -> (Arguments -> [Resolvers f]) -> Resolver f
arrayA name f fld@(Field _ _ args sels) =
withField name (traverse (`resolve` sels) $ f args) fld
-- | Represents one of a finite set of possible values.
-- 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.
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
-- | Helper function to facilitate 'Argument' handling.
withField
:: (Alternative f, Aeson.ToJSON a)
=> Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _ _) =
=> Name -> f a -> Field -> f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _) =
if name == name'
then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty
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
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value
resolvers resolvs =
fmap (first Aeson.toJSON . fold)
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld)
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
resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value
resolve resolvers =
fmap (Aeson.toJSON . fold)
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers))

View File

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

View File

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

View File

@ -1,15 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where
import Control.Applicative (Alternative, empty)
import Data.List.NonEmpty (NonEmpty((:|)))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif
import Data.GraphQL.Schema
import Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..))
import qualified Data.GraphQL.Schema as Schema
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
schema :: Alternative f => Schema f
schema = Schema [hero, human, droid]
schema = hero :| [human, droid]
hero :: Alternative f => Resolver f
hero = Schema.objectA "hero" $ \case
[] -> character artoo
[Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n)
[Argument "episode" (ValueInt n)] -> character . getHero $ fromIntegral n
_ -> empty
human :: Alternative f => Resolver f

View File

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