forked from OSS/graphql
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
commit
1b8fca3658
4
.gitignore
vendored
4
.gitignore
vendored
@ -4,3 +4,7 @@ cabal.sandbox.config
|
||||
dist/
|
||||
TAGS
|
||||
.#*
|
||||
.DS_Store
|
||||
cabal.project.local
|
||||
dist-newstyle/
|
||||
dist-newstyle/
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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@ server’s 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)
|
||||
|
||||
@ -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)
|
||||
|
||||
123
Data/GraphQL/AST/Transform.hs
Normal file
123
Data/GraphQL/AST/Transform.hs
Normal 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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 == ','
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user