OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Define Schema using Core AST

Browse Source 
Also, temporarily remove error reporting to simplify execution. This should be
restored once the new execution model is nailed.
This commit is contained in:
Danny Navarro 2017-01-29 12:53:15 -03:00
parent 337b620717
commit f35e1f949a
No known key found for this signature in database
GPG Key ID: 81E5F99780FA6A32
3 changed files with 67 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
Data/GraphQL/Execute.hs
View File

@ -3,15 +3,23 @@
module Data.GraphQL.Execute (execute) where
import Control.Applicative (Alternative)
import Data.Maybe (catMaybes)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Aeson as Aeson
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 Data.GraphQL.Schema (Schema)
import qualified Data.GraphQL.Schema as Schema
import Data.GraphQL.Error
core :: Schema.Subs -> AST.Document -> AST.Core.Document
core subs ((AST.DefinitionOperation opDef) :| []) = error "Not implemented yet"
core _ ((AST.DefinitionFragment fragDef) :| []) =
error "Fragment definitions not supported yet"
core _ _ = error "Multiple definitions not supported yet"
-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
-- @GraphQL@ 'document'. The substitution is applied to the document using
@ -19,9 +27,19 @@ import Data.GraphQL.Error
--
-- 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 resolvers subs doc = undefined -- resolver resolvs $ rootFields subs doc
execute
:: Alternative f
=> Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
execute schema subs doc = document schema $ core 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) =
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)

74
Data/GraphQL/Schema.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas.
@ -14,15 +13,14 @@ module Data.GraphQL.Schema
, arrayA
, enum
, enumA
, resolvers
, resolve
-- * AST Reexports
, Field
, Argument(..)
, Value(..)
) where
import Control.Applicative (Alternative((<|>), empty))
import Data.Bifunctor (first)
import Control.Applicative (Alternative( empty))
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
@ -32,10 +30,8 @@ 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 (unwords)
import Data.GraphQL.AST.Core
import Data.GraphQL.Error
-- | A GraphQL schema.
-- @f@ is usually expected to be an instance of 'Alternative'.
@ -43,24 +39,31 @@ 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
object :: Alternative f => Name -> [Resolver f] -> Resolver f
object name resolvs = objectA name $ \case
[] -> resolvs
_ -> empty
-- | 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
=> Name -> ([Argument] -> [Resolver f]) -> Resolver f
objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) 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
@ -68,21 +71,21 @@ scalar name s = scalarA name $ \case
-- | Like 'scalar' but also taking 'Argument's.
scalarA
:: (Alternative f, Aeson.ToJSON a)
=> Name -> ([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
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
=> Text -> (Arguments -> [Resolvers f]) -> Resolver f
arrayA name f fld@(Field _ _ args sels) =
withField name (joinErrs $ traverse (`resolvers` sels) $ f args) fld
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.
@ -93,30 +96,25 @@ 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)
=> Name -> 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' _ _) =
if name == name'
then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty
where
aliasOrName = fromMaybe name' alias
if name == name'
then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty
where
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 = fromMaybe name alias
resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value
resolve resolvers =
fmap (Aeson.toJSON . fold)
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers))

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

@ -19,7 +19,7 @@ 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
@ -34,10 +34,10 @@ droid = Schema.objectA "droid" $ \case
character :: Alternative f => Character -> [Resolver f]
character char =
[ Schema.scalar "id" $ id_ char
, Schema.scalar "name" $ name char
, Schema.array "friends" $ character <$> getFriends char
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char
[ Schema.scalar "id" $ id_ char
, Schema.scalar "name" $ name char
, Schema.array "friends" $ character <$> getFriends char
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char
, Schema.scalar "secretBackstory" $ secretBackstory char
, Schema.scalar "homePlanet" $ either mempty homePlanet char
, Schema.scalar "homePlanet" $ either mempty homePlanet char
]