Compare commits
95 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | 282946560e | |
Eugen Wissner | 1b5094b6a3 | |
Eugen Wissner | 9d15b83164 | |
Eugen Wissner | 5cf10b38ec | |
Eugen Wissner | bc6a7dddd1 | |
Eugen Wissner | 74801b0483 | |
Eugen Wissner | f3b8d9b74c | |
Eugen Wissner | eb40810f25 | |
Eugen Wissner | 61879fb124 | |
Eugen Wissner | 22d4a4e583 | |
Eugen Wissner | 1431db7e63 | |
Eugen Wissner | d7b6fd0329 | |
Eugen Wissner | 2fa50d4f62 | |
Eugen Wissner | 6238b2fbfa | |
Eugen Wissner | 91679650b5 | |
Eugen Wissner | 1017b728d9 | |
Eugen Wissner | f64e186c60 | |
Eugen Wissner | 28aaa6a70b | |
Eugen Wissner | 79c734fa62 | |
Eugen Wissner | ae4038eb47 | |
Eugen Wissner | 3cc38343db | |
Eugen Wissner | 2172de3729 | |
Eugen Wissner | 5e9bf9648d | |
Eugen Wissner | ce169ecef2 | |
Danny Navarro | 40f9024b51 | |
Lupino | 8d21972c42 | |
Danny Navarro | 2b5648efda | |
Danny Navarro | fb071210cf | |
Danny Navarro | 285ccb0af9 | |
Danny Navarro | 6a10e28ba8 | |
Danny Navarro | 5954962de1 | |
Danny Navarro | 1327bcf7f7 | |
Danny Navarro | e521d92c7f | |
Danny Navarro | 1b8fca3658 | |
Danny Navarro | bada28ce24 | |
Danny Navarro | d2c138f8d1 | |
Lupino | 3be86bf69e | |
Danny Navarro | 39731ff233 | |
Danny Navarro | b7a72591fd | |
Danny Navarro | e716bc57e7 | |
Danny Navarro | 4ab4660d36 | |
Danny Navarro | 8b09c8aa76 | |
Danny Navarro | 693b7d18dc | |
Danny Navarro | f35e1f949a | |
Danny Navarro | 337b620717 | |
Danny Navarro | 642eab312f | |
Danny Navarro | 5390c4ca1e | |
jasonzoladz | 140c7df6fb | |
Danny Navarro | 3e991adf4e | |
Danny Navarro | 10fdf05aa7 | |
Danny Navarro | 933cfd2852 | |
Danny Navarro | aa66236081 | |
Danny Navarro | afb2fc4eb9 | |
Danny Navarro | 5dc9222025 | |
Tom Hunger | 87c92e9d6e | |
Danny Navarro | 61f0a06096 | |
Danny Navarro | 2cc6b00051 | |
Pweaver (Paul Weaver) | c396a4b545 | |
Pweaver (Paul Weaver) | a6c0d63049 | |
Pweaver (Paul Weaver) | 624efbbb35 | |
Pweaver (Paul Weaver) | cb73e9d53c | |
Danny Navarro | e944c76040 | |
Danny Navarro | 77853b17ae | |
solrun | 61d6af7778 | |
Matthías Páll Gissurarson | d195389102 | |
Matthías Páll Gissurarson | b74278cd19 | |
Danny Navarro | d8a731fe30 | |
Danny Navarro | 770df82718 | |
Danny Navarro | 8ee50727bd | |
Danny Navarro | a6b2fd297b | |
Danny Navarro | 7131d1c142 | |
Danny Navarro | a0f12455c5 | |
Danny Navarro | 98d2d41cda | |
Danny Navarro | 119f94b38e | |
Danny Navarro | 04d8d40b3a | |
Danny Navarro | a088c81944 | |
Danny Navarro | 70fbaf359e | |
Danny Navarro | df8e43c9aa | |
Danny Navarro | c385566912 | |
Danny Navarro | 781788e306 | |
Danny Navarro | 1561e62489 | |
Danny Navarro | 53e101f35e | |
Danny Navarro | c81ddb0335 | |
Danny Navarro | eca3c2d8d4 | |
Danny Navarro | a832991ac0 | |
Danny Navarro | b72cfc097a | |
Danny Navarro | 78e0d871d5 | |
Danny Navarro | a70732a4b6 | |
Danny Navarro | bb685c9afa | |
Danny Navarro | 4e5dc3433a | |
Danny Navarro | 3f30a44d1d | |
Danny Navarro | 8e3bae4b5c | |
Danny Navarro | c8f629e826 | |
timmy_tofu | 85941139c1 | |
timmy_tofu | 0848e65da2 |
|
@ -1 +1,10 @@
|
|||
.stack-work/
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
dist/
|
||||
TAGS
|
||||
.#*
|
||||
.DS_Store
|
||||
cabal.project.local
|
||||
dist-newstyle/
|
||||
dist-newstyle/
|
||||
|
|
79
.travis.yml
79
.travis.yml
|
@ -1,79 +0,0 @@
|
|||
# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
|
||||
language: c
|
||||
sudo: false
|
||||
|
||||
cache:
|
||||
directories:
|
||||
- $HOME/.cabsnap
|
||||
- $HOME/.cabal/packages
|
||||
|
||||
before_cache:
|
||||
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
|
||||
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
|
||||
|
||||
matrix:
|
||||
include:
|
||||
- env: CABALVER=1.18 GHCVER=7.8.4
|
||||
compiler: ": #GHC 7.8.4"
|
||||
addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
|
||||
- env: CABALVER=1.22 GHCVER=7.10.2
|
||||
compiler: ": #GHC 7.10.2"
|
||||
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
|
||||
|
||||
before_install:
|
||||
- unset CC
|
||||
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
|
||||
|
||||
install:
|
||||
- cabal --version
|
||||
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
||||
- if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
|
||||
then
|
||||
zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
|
||||
$HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
|
||||
fi
|
||||
- travis_retry cabal update -v
|
||||
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
|
||||
- cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
|
||||
- sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
|
||||
|
||||
# check whether current requested install-plan matches cached package-db snapshot
|
||||
- if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
|
||||
then
|
||||
echo "cabal build-cache HIT";
|
||||
rm -rfv .ghc;
|
||||
cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
|
||||
cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
|
||||
else
|
||||
echo "cabal build-cache MISS";
|
||||
rm -rf $HOME/.cabsnap;
|
||||
mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
|
||||
cabal install --only-dependencies --enable-tests --enable-benchmarks;
|
||||
fi
|
||||
|
||||
# snapshot package-db on cache miss
|
||||
- if [ ! -d $HOME/.cabsnap ];
|
||||
then
|
||||
echo "snapshotting package-db to build-cache";
|
||||
mkdir $HOME/.cabsnap;
|
||||
cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
|
||||
cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
|
||||
fi
|
||||
|
||||
# Here starts the actual work to be performed for the package under test;
|
||||
# any command which exits with a non-zero exit code causes the build to fail.
|
||||
script:
|
||||
- if [ -f configure.ac ]; then autoreconf -i; fi
|
||||
- cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
|
||||
- cabal build # this builds all libraries and executables (including tests/benchmarks)
|
||||
- cabal test
|
||||
- cabal check
|
||||
- cabal sdist # tests that a source-distribution can be generated
|
||||
|
||||
# Check that the resulting source distribution can be built & installed.
|
||||
# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
|
||||
# `cabal install --force-reinstalls dist/*-*.tar.gz`
|
||||
- SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
|
||||
(cd dist && cabal install --force-reinstalls "$SRC_TGZ")
|
||||
|
||||
# EOF
|
27
CHANGELOG.md
27
CHANGELOG.md
|
@ -1,6 +1,26 @@
|
|||
# Change Log
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
## [0.4.0.0] - 2019-07-23
|
||||
### Added
|
||||
- Support for mutations.
|
||||
- Error handling (with monad transformers).
|
||||
- Nullable types.
|
||||
- Arbitrary nested lists support.
|
||||
- Potential BOM header parsing.
|
||||
|
||||
### Changed
|
||||
- attoparsec is replaced with megaparsec.
|
||||
- The library is now under `Language.GraphQL` (instead of `Data.GraphQL`).
|
||||
- HUnit and tasty are replaced with Hspec.
|
||||
- `Alternative`/`MonadPlus` resolver constraints are replaced with `MonadIO`.
|
||||
|
||||
### Removed
|
||||
- Duplicates from `Language.GraphQL.AST` already available in
|
||||
`Language.GraphQL.AST.Core`.
|
||||
- All module exports are now explicit, so private and help functions aren't
|
||||
exported anymore.
|
||||
|
||||
## [0.3] - 2015-09-22
|
||||
### Changed
|
||||
- Exact match numeric types to spec.
|
||||
|
@ -33,6 +53,7 @@ All notable changes to this project will be documented in this file.
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[0.3]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2.1...v0.3
|
||||
[0.2.1]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2...v0.2.1
|
||||
[0.2]: https://github.com/jdnavarro/graphql-haskell/compare/v0.1...v0.2
|
||||
[0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0
|
||||
[0.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3
|
||||
[0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1
|
||||
[0.2]: https://github.com/caraus-ecms/graphql/compare/v0.1...v0.2
|
||||
|
|
|
@ -1,147 +0,0 @@
|
|||
module Data.GraphQL.AST where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.Text (Text)
|
||||
|
||||
-- * Name
|
||||
|
||||
type Name = Text
|
||||
|
||||
-- * Document
|
||||
|
||||
newtype Document = Document [Definition] deriving (Eq,Show)
|
||||
|
||||
data Definition = DefinitionOperation OperationDefinition
|
||||
| DefinitionFragment FragmentDefinition
|
||||
| DefinitionType TypeDefinition
|
||||
deriving (Eq,Show)
|
||||
|
||||
data OperationDefinition = Query Node
|
||||
| Mutation Node
|
||||
deriving (Eq,Show)
|
||||
|
||||
data Node = Node Name [VariableDefinition] [Directive] SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
|
||||
deriving (Eq,Show)
|
||||
|
||||
newtype Variable = Variable Name deriving (Eq,Show)
|
||||
|
||||
type SelectionSet = [Selection]
|
||||
|
||||
data Selection = SelectionField Field
|
||||
| SelectionFragmentSpread FragmentSpread
|
||||
| SelectionInlineFragment InlineFragment
|
||||
deriving (Eq,Show)
|
||||
|
||||
data Field = Field Alias Name [Argument]
|
||||
[Directive]
|
||||
SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Alias = Name
|
||||
|
||||
data Argument = Argument Name Value deriving (Eq,Show)
|
||||
|
||||
-- * Fragments
|
||||
|
||||
data FragmentSpread = FragmentSpread Name [Directive]
|
||||
deriving (Eq,Show)
|
||||
|
||||
data InlineFragment =
|
||||
InlineFragment TypeCondition [Directive] SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
data FragmentDefinition =
|
||||
FragmentDefinition Name TypeCondition [Directive] SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
type TypeCondition = NamedType
|
||||
|
||||
-- * Values
|
||||
|
||||
data Value = ValueVariable Variable
|
||||
| ValueInt Int32
|
||||
-- GraphQL Float is double precison
|
||||
| ValueFloat Double
|
||||
| ValueBoolean Bool
|
||||
| ValueString StringValue
|
||||
| ValueEnum Name
|
||||
| ValueList ListValue
|
||||
| ValueObject ObjectValue
|
||||
deriving (Eq,Show)
|
||||
|
||||
newtype StringValue = StringValue Text deriving (Eq,Show)
|
||||
|
||||
newtype ListValue = ListValue [Value] deriving (Eq,Show)
|
||||
|
||||
newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)
|
||||
|
||||
data ObjectField = ObjectField Name Value deriving (Eq,Show)
|
||||
|
||||
type DefaultValue = Value
|
||||
|
||||
-- * Directives
|
||||
|
||||
data Directive = Directive Name [Argument] deriving (Eq,Show)
|
||||
|
||||
-- * Type Reference
|
||||
|
||||
data Type = TypeNamed NamedType
|
||||
| TypeList ListType
|
||||
| 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
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- * Type definition
|
||||
|
||||
data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition
|
||||
| TypeDefinitionInterface InterfaceTypeDefinition
|
||||
| TypeDefinitionUnion UnionTypeDefinition
|
||||
| TypeDefinitionScalar ScalarTypeDefinition
|
||||
| TypeDefinitionEnum EnumTypeDefinition
|
||||
| TypeDefinitionInputObject InputObjectTypeDefinition
|
||||
| TypeDefinitionTypeExtension TypeExtensionDefinition
|
||||
deriving (Eq,Show)
|
||||
|
||||
data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition]
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Interfaces = [NamedType]
|
||||
|
||||
data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type
|
||||
deriving (Eq,Show)
|
||||
|
||||
type ArgumentsDefinition = [InputValueDefinition]
|
||||
|
||||
data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)
|
||||
deriving (Eq,Show)
|
||||
|
||||
data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]
|
||||
deriving (Eq,Show)
|
||||
|
||||
data UnionTypeDefinition = UnionTypeDefinition Name [NamedType]
|
||||
deriving (Eq,Show)
|
||||
|
||||
data ScalarTypeDefinition = ScalarTypeDefinition Name
|
||||
deriving (Eq,Show)
|
||||
|
||||
data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]
|
||||
deriving (Eq,Show)
|
||||
|
||||
newtype EnumValueDefinition = EnumValueDefinition Name
|
||||
deriving (Eq,Show)
|
||||
|
||||
data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition]
|
||||
deriving (Eq,Show)
|
||||
|
||||
newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition
|
||||
deriving (Eq,Show)
|
|
@ -1,246 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Data.GraphQL.Encoder where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.Monoid (Monoid, mconcat, mempty)
|
||||
#endif
|
||||
import Data.Monoid ((<>))
|
||||
|
||||
import Data.Text (Text, cons, intercalate, pack, snoc)
|
||||
|
||||
import Data.GraphQL.AST
|
||||
|
||||
-- * Document
|
||||
|
||||
-- TODO: Use query shorthand
|
||||
document :: Document -> Text
|
||||
document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs
|
||||
|
||||
definition :: Definition -> Text
|
||||
definition (DefinitionOperation x) = operationDefinition x
|
||||
definition (DefinitionFragment x) = fragmentDefinition x
|
||||
definition (DefinitionType x) = typeDefinition x
|
||||
|
||||
operationDefinition :: OperationDefinition -> Text
|
||||
operationDefinition (Query n) = "query " <> node n
|
||||
operationDefinition (Mutation n) = "mutation " <> node n
|
||||
|
||||
node :: Node -> Text
|
||||
node (Node name vds ds ss) =
|
||||
name
|
||||
<> optempty variableDefinitions vds
|
||||
<> optempty directives ds
|
||||
<> selectionSet ss
|
||||
|
||||
variableDefinitions :: [VariableDefinition] -> Text
|
||||
variableDefinitions = parensCommas variableDefinition
|
||||
|
||||
variableDefinition :: VariableDefinition -> Text
|
||||
variableDefinition (VariableDefinition var ty dv) =
|
||||
variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
|
||||
|
||||
defaultValue :: DefaultValue -> Text
|
||||
defaultValue val = "=" <> value val
|
||||
|
||||
variable :: Variable -> Text
|
||||
variable (Variable name) = "$" <> name
|
||||
|
||||
selectionSet :: SelectionSet -> Text
|
||||
selectionSet = bracesCommas selection
|
||||
|
||||
selection :: Selection -> Text
|
||||
selection (SelectionField x) = field x
|
||||
selection (SelectionInlineFragment x) = inlineFragment x
|
||||
selection (SelectionFragmentSpread x) = fragmentSpread x
|
||||
|
||||
field :: Field -> Text
|
||||
field (Field alias name args ds ss) =
|
||||
optempty (`snoc` ':') alias
|
||||
<> name
|
||||
<> optempty arguments args
|
||||
<> optempty directives ds
|
||||
<> optempty selectionSet ss
|
||||
|
||||
arguments :: [Argument] -> Text
|
||||
arguments = parensCommas argument
|
||||
|
||||
argument :: Argument -> Text
|
||||
argument (Argument name v) = name <> ":" <> value v
|
||||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: FragmentSpread -> Text
|
||||
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
|
||||
|
||||
fragmentDefinition :: FragmentDefinition -> Text
|
||||
fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
|
||||
"fragment " <> name <> " on " <> tc
|
||||
<> optempty directives ds
|
||||
<> selectionSet ss
|
||||
|
||||
-- * Values
|
||||
|
||||
value :: Value -> Text
|
||||
value (ValueVariable x) = variable x
|
||||
-- TODO: This will be replaced with `decimal` Buidler
|
||||
value (ValueInt x) = pack $ show x
|
||||
-- TODO: This will be replaced with `decimal` Buidler
|
||||
value (ValueFloat x) = pack $ show x
|
||||
value (ValueBoolean x) = booleanValue x
|
||||
value (ValueString x) = stringValue x
|
||||
value (ValueEnum x) = x
|
||||
value (ValueList x) = listValue x
|
||||
value (ValueObject x) = objectValue x
|
||||
|
||||
booleanValue :: Bool -> Text
|
||||
booleanValue True = "true"
|
||||
booleanValue False = "false"
|
||||
|
||||
-- TODO: Escape characters
|
||||
stringValue :: StringValue -> Text
|
||||
stringValue (StringValue v) = quotes v
|
||||
|
||||
listValue :: ListValue -> Text
|
||||
listValue (ListValue vs) = bracketsCommas value vs
|
||||
|
||||
objectValue :: ObjectValue -> Text
|
||||
objectValue (ObjectValue ofs) = bracesCommas objectField ofs
|
||||
|
||||
objectField :: ObjectField -> Text
|
||||
objectField (ObjectField name v) = name <> ":" <> value v
|
||||
|
||||
-- * Directives
|
||||
|
||||
directives :: [Directive] -> Text
|
||||
directives = spaces directive
|
||||
|
||||
directive :: Directive -> Text
|
||||
directive (Directive name args) = "@" <> name <> optempty arguments args
|
||||
|
||||
-- * Type Reference
|
||||
|
||||
type_ :: Type -> Text
|
||||
type_ (TypeNamed (NamedType 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)
|
||||
|
||||
nonNullType :: NonNullType -> Text
|
||||
nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
|
||||
nonNullType (NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
typeDefinition :: TypeDefinition -> Text
|
||||
typeDefinition (TypeDefinitionObject x) = objectTypeDefinition x
|
||||
typeDefinition (TypeDefinitionInterface x) = interfaceTypeDefinition x
|
||||
typeDefinition (TypeDefinitionUnion x) = unionTypeDefinition x
|
||||
typeDefinition (TypeDefinitionScalar x) = scalarTypeDefinition x
|
||||
typeDefinition (TypeDefinitionEnum x) = enumTypeDefinition x
|
||||
typeDefinition (TypeDefinitionInputObject x) = inputObjectTypeDefinition x
|
||||
typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x
|
||||
|
||||
objectTypeDefinition :: ObjectTypeDefinition -> Text
|
||||
objectTypeDefinition (ObjectTypeDefinition name ifaces fds) =
|
||||
"type " <> name
|
||||
<> optempty (spaced . interfaces) ifaces
|
||||
<> optempty fieldDefinitions fds
|
||||
|
||||
interfaces :: Interfaces -> Text
|
||||
interfaces = ("implements " <>) . spaces namedType
|
||||
|
||||
fieldDefinitions :: [FieldDefinition] -> Text
|
||||
fieldDefinitions = bracesCommas fieldDefinition
|
||||
|
||||
fieldDefinition :: FieldDefinition -> Text
|
||||
fieldDefinition (FieldDefinition name args ty) =
|
||||
name <> optempty argumentsDefinition args
|
||||
<> ":"
|
||||
<> type_ ty
|
||||
|
||||
argumentsDefinition :: ArgumentsDefinition -> Text
|
||||
argumentsDefinition = parensCommas inputValueDefinition
|
||||
|
||||
interfaceTypeDefinition :: InterfaceTypeDefinition -> Text
|
||||
interfaceTypeDefinition (InterfaceTypeDefinition name fds) =
|
||||
"interface " <> name <> fieldDefinitions fds
|
||||
|
||||
unionTypeDefinition :: UnionTypeDefinition -> Text
|
||||
unionTypeDefinition (UnionTypeDefinition name ums) =
|
||||
"union " <> name <> "=" <> unionMembers ums
|
||||
|
||||
unionMembers :: [NamedType] -> Text
|
||||
unionMembers = intercalate "|" . fmap namedType
|
||||
|
||||
scalarTypeDefinition :: ScalarTypeDefinition -> Text
|
||||
scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name
|
||||
|
||||
enumTypeDefinition :: EnumTypeDefinition -> Text
|
||||
enumTypeDefinition (EnumTypeDefinition name evds) =
|
||||
"enum " <> name
|
||||
<> bracesCommas enumValueDefinition evds
|
||||
|
||||
enumValueDefinition :: EnumValueDefinition -> Text
|
||||
enumValueDefinition (EnumValueDefinition name) = name
|
||||
|
||||
inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text
|
||||
inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) =
|
||||
"input " <> name <> inputValueDefinitions ivds
|
||||
|
||||
inputValueDefinitions :: [InputValueDefinition] -> Text
|
||||
inputValueDefinitions = bracesCommas inputValueDefinition
|
||||
|
||||
inputValueDefinition :: InputValueDefinition -> Text
|
||||
inputValueDefinition (InputValueDefinition name ty dv) =
|
||||
name <> ":" <> type_ ty <> maybe mempty defaultValue dv
|
||||
|
||||
typeExtensionDefinition :: TypeExtensionDefinition -> Text
|
||||
typeExtensionDefinition (TypeExtensionDefinition otd) =
|
||||
"extend " <> objectTypeDefinition otd
|
||||
|
||||
-- * Internal
|
||||
|
||||
spaced :: Text -> Text
|
||||
spaced = cons '\SP'
|
||||
|
||||
between :: Char -> Char -> Text -> Text
|
||||
between open close = cons open . (`snoc` close)
|
||||
|
||||
parens :: Text -> Text
|
||||
parens = between '(' ')'
|
||||
|
||||
brackets :: Text -> Text
|
||||
brackets = between '[' ']'
|
||||
|
||||
braces :: Text -> Text
|
||||
braces = between '{' '}'
|
||||
|
||||
quotes :: Text -> Text
|
||||
quotes = between '"' '"'
|
||||
|
||||
spaces :: (a -> Text) -> [a] -> Text
|
||||
spaces f = intercalate "\SP" . fmap f
|
||||
|
||||
parensCommas :: (a -> Text) -> [a] -> Text
|
||||
parensCommas f = parens . intercalate "," . fmap f
|
||||
|
||||
bracketsCommas :: (a -> Text) -> [a] -> Text
|
||||
bracketsCommas f = brackets . intercalate "," . fmap f
|
||||
|
||||
bracesCommas :: (a -> Text) -> [a] -> Text
|
||||
bracesCommas f = braces . intercalate "," . fmap f
|
||||
|
||||
optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
|
||||
optempty f xs = if xs == mempty then mempty else f xs
|
|
@ -1,336 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Data.GraphQL.Parser where
|
||||
|
||||
import Prelude hiding (takeWhile)
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$), pure)
|
||||
import Data.Monoid (Monoid, mempty)
|
||||
#endif
|
||||
import Control.Applicative ((<|>), empty, many, optional)
|
||||
import Control.Monad (when)
|
||||
import Data.Char (isDigit, isSpace)
|
||||
import Data.Foldable (traverse_)
|
||||
|
||||
import Data.Text (Text, append)
|
||||
import Data.Attoparsec.Text
|
||||
( Parser
|
||||
, (<?>)
|
||||
, anyChar
|
||||
, decimal
|
||||
, double
|
||||
, endOfLine
|
||||
, inClass
|
||||
, many1
|
||||
, manyTill
|
||||
, option
|
||||
, peekChar
|
||||
, sepBy1
|
||||
, signed
|
||||
, takeWhile
|
||||
, takeWhile1
|
||||
)
|
||||
|
||||
import Data.GraphQL.AST
|
||||
|
||||
-- * Name
|
||||
|
||||
name :: Parser Name
|
||||
name = tok $ append <$> takeWhile1 isA_z
|
||||
<*> takeWhile ((||) <$> isDigit <*> isA_z)
|
||||
where
|
||||
-- `isAlpha` handles many more Unicode Chars
|
||||
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!"
|
||||
|
||||
definition :: Parser Definition
|
||||
definition = DefinitionOperation <$> operationDefinition
|
||||
<|> DefinitionFragment <$> fragmentDefinition
|
||||
<|> DefinitionType <$> typeDefinition
|
||||
<?> "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
|
||||
<*> selectionSet
|
||||
|
||||
variableDefinitions :: Parser [VariableDefinition]
|
||||
variableDefinitions = parens (many1 variableDefinition)
|
||||
|
||||
variableDefinition :: Parser VariableDefinition
|
||||
variableDefinition =
|
||||
VariableDefinition <$> variable
|
||||
<* tok ":"
|
||||
<*> type_
|
||||
<*> optional defaultValue
|
||||
|
||||
defaultValue :: Parser DefaultValue
|
||||
defaultValue = tok "=" *> value
|
||||
|
||||
variable :: Parser Variable
|
||||
variable = Variable <$ tok "$" <*> name
|
||||
|
||||
selectionSet :: Parser SelectionSet
|
||||
selectionSet = braces $ many1 selection
|
||||
|
||||
selection :: Parser Selection
|
||||
selection = SelectionField <$> field
|
||||
-- Inline first to catch `on` case
|
||||
<|> SelectionInlineFragment <$> inlineFragment
|
||||
<|> SelectionFragmentSpread <$> fragmentSpread
|
||||
<?> "selection error!"
|
||||
|
||||
field :: Parser Field
|
||||
field = Field <$> optempty alias
|
||||
<*> name
|
||||
<*> optempty arguments
|
||||
<*> optempty directives
|
||||
<*> optempty selectionSet
|
||||
|
||||
alias :: Parser Alias
|
||||
alias = name <* tok ":"
|
||||
|
||||
arguments :: Parser [Argument]
|
||||
arguments = parens $ many1 argument
|
||||
|
||||
argument :: Parser Argument
|
||||
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
|
||||
|
||||
-- InlineFragment tried first in order to guard against 'on' keyword
|
||||
inlineFragment :: Parser InlineFragment
|
||||
inlineFragment = InlineFragment
|
||||
<$ tok "..."
|
||||
<* tok "on"
|
||||
<*> typeCondition
|
||||
<*> optempty directives
|
||||
<*> selectionSet
|
||||
|
||||
fragmentDefinition :: Parser FragmentDefinition
|
||||
fragmentDefinition = FragmentDefinition
|
||||
<$ tok "fragment"
|
||||
<*> name
|
||||
<* tok "on"
|
||||
<*> typeCondition
|
||||
<*> optempty directives
|
||||
<*> selectionSet
|
||||
|
||||
typeCondition :: Parser TypeCondition
|
||||
typeCondition = namedType
|
||||
|
||||
-- * 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.
|
||||
<|> ValueInt <$> tok (signed decimal)
|
||||
<|> ValueFloat <$> tok (signed double)
|
||||
<|> ValueBoolean <$> booleanValue
|
||||
<|> ValueString <$> stringValue
|
||||
-- `true` and `false` have been tried before
|
||||
<|> ValueEnum <$> name
|
||||
<|> ValueList <$> listValue
|
||||
<|> ValueObject <$> objectValue
|
||||
<?> "value error!"
|
||||
|
||||
booleanValue :: Parser Bool
|
||||
booleanValue = True <$ tok "true"
|
||||
<|> False <$ tok "false"
|
||||
|
||||
-- TODO: Escape characters. Look at `jsstring_` in aeson package.
|
||||
stringValue :: Parser StringValue
|
||||
stringValue = StringValue <$> quotes (takeWhile (/= '"'))
|
||||
|
||||
-- Notice it can be empty
|
||||
listValue :: Parser ListValue
|
||||
listValue = ListValue <$> brackets (many value)
|
||||
|
||||
-- Notice it can be empty
|
||||
objectValue :: Parser ObjectValue
|
||||
objectValue = ObjectValue <$> braces (many objectField)
|
||||
|
||||
objectField :: Parser ObjectField
|
||||
objectField = ObjectField <$> name <* tok ":" <*> value
|
||||
|
||||
-- * Directives
|
||||
|
||||
directives :: Parser [Directive]
|
||||
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!"
|
||||
|
||||
-- * Type Definition
|
||||
|
||||
typeDefinition :: Parser TypeDefinition
|
||||
typeDefinition =
|
||||
TypeDefinitionObject <$> objectTypeDefinition
|
||||
<|> TypeDefinitionInterface <$> interfaceTypeDefinition
|
||||
<|> TypeDefinitionUnion <$> unionTypeDefinition
|
||||
<|> TypeDefinitionScalar <$> scalarTypeDefinition
|
||||
<|> TypeDefinitionEnum <$> enumTypeDefinition
|
||||
<|> TypeDefinitionInputObject <$> inputObjectTypeDefinition
|
||||
<|> TypeDefinitionTypeExtension <$> typeExtensionDefinition
|
||||
<?> "typeDefinition error!"
|
||||
|
||||
objectTypeDefinition :: Parser ObjectTypeDefinition
|
||||
objectTypeDefinition = ObjectTypeDefinition
|
||||
<$ tok "type"
|
||||
<*> name
|
||||
<*> optempty interfaces
|
||||
<*> fieldDefinitions
|
||||
|
||||
interfaces :: Parser Interfaces
|
||||
interfaces = tok "implements" *> many1 namedType
|
||||
|
||||
fieldDefinitions :: Parser [FieldDefinition]
|
||||
fieldDefinitions = braces $ many1 fieldDefinition
|
||||
|
||||
fieldDefinition :: Parser FieldDefinition
|
||||
fieldDefinition = FieldDefinition
|
||||
<$> name
|
||||
<*> optempty argumentsDefinition
|
||||
<* tok ":"
|
||||
<*> type_
|
||||
|
||||
argumentsDefinition :: Parser ArgumentsDefinition
|
||||
argumentsDefinition = parens $ many1 inputValueDefinition
|
||||
|
||||
interfaceTypeDefinition :: Parser InterfaceTypeDefinition
|
||||
interfaceTypeDefinition = InterfaceTypeDefinition
|
||||
<$ tok "interface"
|
||||
<*> name
|
||||
<*> fieldDefinitions
|
||||
|
||||
unionTypeDefinition :: Parser UnionTypeDefinition
|
||||
unionTypeDefinition = UnionTypeDefinition
|
||||
<$ tok "union"
|
||||
<*> name
|
||||
<* tok "="
|
||||
<*> unionMembers
|
||||
|
||||
unionMembers :: Parser [NamedType]
|
||||
unionMembers = namedType `sepBy1` tok "|"
|
||||
|
||||
scalarTypeDefinition :: Parser ScalarTypeDefinition
|
||||
scalarTypeDefinition = ScalarTypeDefinition
|
||||
<$ tok "scalar"
|
||||
<*> name
|
||||
|
||||
enumTypeDefinition :: Parser EnumTypeDefinition
|
||||
enumTypeDefinition = EnumTypeDefinition
|
||||
<$ tok "enum"
|
||||
<*> name
|
||||
<*> enumValueDefinitions
|
||||
|
||||
enumValueDefinitions :: Parser [EnumValueDefinition]
|
||||
enumValueDefinitions = braces $ many1 enumValueDefinition
|
||||
|
||||
enumValueDefinition :: Parser EnumValueDefinition
|
||||
enumValueDefinition = EnumValueDefinition <$> name
|
||||
|
||||
inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
|
||||
inputObjectTypeDefinition = InputObjectTypeDefinition
|
||||
<$ tok "input"
|
||||
<*> name
|
||||
<*> inputValueDefinitions
|
||||
|
||||
inputValueDefinitions :: Parser [InputValueDefinition]
|
||||
inputValueDefinitions = braces $ many1 inputValueDefinition
|
||||
|
||||
inputValueDefinition :: Parser InputValueDefinition
|
||||
inputValueDefinition = InputValueDefinition
|
||||
<$> name
|
||||
<* tok ":"
|
||||
<*> type_
|
||||
<*> optional defaultValue
|
||||
|
||||
typeExtensionDefinition :: Parser TypeExtensionDefinition
|
||||
typeExtensionDefinition = TypeExtensionDefinition
|
||||
<$ tok "extend"
|
||||
<*> objectTypeDefinition
|
||||
|
||||
-- * Internal
|
||||
|
||||
tok :: Parser a -> Parser a
|
||||
tok p = p <* whiteSpace
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = between "(" ")"
|
||||
|
||||
braces :: Parser a -> Parser a
|
||||
braces = between "{" "}"
|
||||
|
||||
quotes :: Parser a -> Parser a
|
||||
quotes = between "\"" "\""
|
||||
|
||||
brackets :: Parser a -> Parser a
|
||||
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
|
||||
|
||||
-- ** WhiteSpace
|
||||
--
|
||||
whiteSpace :: Parser ()
|
||||
whiteSpace = peekChar >>= traverse_ (\c ->
|
||||
if isSpace c || c == ','
|
||||
then anyChar *> whiteSpace
|
||||
else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)
|
3
LICENSE
3
LICENSE
|
@ -1,4 +1,5 @@
|
|||
Copyright J. Daniel Navarro (c) 2015
|
||||
Copyright 2019 Eugen Wissner, Germany
|
||||
Copyright 2015-2017 J. Daniel Navarro
|
||||
|
||||
All rights reserved.
|
||||
|
||||
|
|
16
README.md
16
README.md
|
@ -1,15 +1,17 @@
|
|||
# Haskell GraphQL
|
||||
|
||||
[![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
|
||||
[![Build Status](https://img.shields.io/travis/jdnavarro/graphql-haskell.svg)](https://travis-ci.org/jdnavarro/graphql-haskell)
|
||||
[![Build Status](https://semaphoreci.com/api/v1/belka-ew/graphql/branches/master/badge.svg)](https://semaphoreci.com/belka-ew/graphql)
|
||||
[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
|
||||
|
||||
For now this only provides the data types to represent the GraphQL AST,
|
||||
but the idea is to be a Haskell port of
|
||||
[`graphql-js`](https://github.com/graphql/graphql-js). Next releases
|
||||
should include:
|
||||
For now this only provides a parser for the GraphQL query language and allows
|
||||
to execute queries and mutations without the schema validation step.
|
||||
But the idea is to be a Haskell port of
|
||||
[`graphql-js`](https://github.com/graphql/graphql-js). Next releases should
|
||||
include:
|
||||
|
||||
- [x] GraphQL AST
|
||||
- [x] Parser for the GraphQL language. See TODO for limitations.
|
||||
- [x] Parser for the GraphQL language.
|
||||
- [x] Printer for GraphQL. This is not pretty yet.
|
||||
- [ ] GraphQL Schema AST.
|
||||
- [ ] Parser for the GraphQL Schema language.
|
||||
|
@ -17,8 +19,6 @@ should include:
|
|||
- [ ] Interpreter of GraphQL requests.
|
||||
- [ ] Utilities to define GraphQL types and schema.
|
||||
|
||||
See the TODO file for more concrete tasks.
|
||||
|
||||
## Contact
|
||||
|
||||
Suggestions, contributions and bug reports are welcome.
|
||||
|
|
21
TODO
21
TODO
|
@ -1,21 +0,0 @@
|
|||
## AST
|
||||
- Docs
|
||||
- Simplify unnecessary `newtypes` with type synonyms
|
||||
- Simplify wrapper type constructors. Some types can be just constructors.
|
||||
- Data type accessors
|
||||
- Deal with strictness/unboxing
|
||||
- Deal with location
|
||||
|
||||
## Parser
|
||||
- Docs
|
||||
- Handle escape characters in string literals
|
||||
- Guard for `on` in `FragmentSpread`
|
||||
- Handle `[Const]` grammar parameter. Need examples
|
||||
- Handle `maxBound` Int values.
|
||||
- Diagnostics. Perhaps port to `parsers` and use `trifecta` for diagnostics,
|
||||
and `attoparsec` for performance.
|
||||
- Optimize `whiteSpace`, perhaps front the main parser with a lexer.
|
||||
|
||||
## Printer
|
||||
- Add pretty printer.
|
||||
- Docs
|
|
@ -0,0 +1,154 @@
|
|||
---
|
||||
title: GraphQL Haskell Tutorial
|
||||
---
|
||||
|
||||
|
||||
== Getting started ==
|
||||
|
||||
Welcome to graphql-haskell!
|
||||
|
||||
We have written a small tutorial to help you (and ourselves) understand the graphql package.
|
||||
|
||||
Since this file is a literate haskell file, we start by importing some dependencies.
|
||||
|
||||
> {-# LANGUAGE OverloadedStrings #-}
|
||||
> {-# LANGUAGE LambdaCase #-}
|
||||
> module Main where
|
||||
>
|
||||
> import Control.Monad.IO.Class (liftIO)
|
||||
> import Control.Monad.Trans.Except (throwE)
|
||||
> import Data.Aeson (encode)
|
||||
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
||||
> import Data.List.NonEmpty (NonEmpty(..))
|
||||
> import Data.Text (Text)
|
||||
> import Data.Time (getCurrentTime)
|
||||
>
|
||||
> import Language.GraphQL
|
||||
> import Language.GraphQL.Schema (Schema)
|
||||
> import qualified Language.GraphQL.Schema as Schema
|
||||
> import Language.GraphQL.Trans (ActionT(..))
|
||||
>
|
||||
> import Prelude hiding (putStrLn)
|
||||
|
||||
=== First example ===
|
||||
|
||||
Now, as our first example, we are going to look at the
|
||||
example from [graphql.js](https://github.com/graphql/graphql-js).
|
||||
|
||||
First we build a GraphQL schema.
|
||||
|
||||
> schema1 :: Schema IO
|
||||
> schema1 = hello :| []
|
||||
>
|
||||
> hello :: Schema.Resolver IO
|
||||
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
|
||||
|
||||
This defines a simple schema with one type and one field, that resolves to a fixed value.
|
||||
|
||||
Next we define our query.
|
||||
|
||||
> query1 :: Text
|
||||
> query1 = "{ hello }"
|
||||
|
||||
|
||||
To run the query, we call the `graphql` with the schema and the query.
|
||||
|
||||
> main1 :: IO ()
|
||||
> main1 = putStrLn =<< encode <$> graphql schema1 query1
|
||||
|
||||
This runs the query by fetching the one field defined,
|
||||
returning
|
||||
|
||||
```{"data" : {"hello":"it's me"}}```
|
||||
|
||||
|
||||
|
||||
=== Monadic actions ===
|
||||
|
||||
For this example, we're going to be using time.
|
||||
|
||||
> schema2 :: Schema IO
|
||||
> schema2 = time :| []
|
||||
>
|
||||
> time :: Schema.Resolver IO
|
||||
> time = Schema.scalarA "time" $ \case
|
||||
> [] -> do t <- liftIO getCurrentTime
|
||||
> return $ show t
|
||||
> _ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
This defines a simple schema with one type and one field,
|
||||
which resolves to the current time.
|
||||
|
||||
Next we define our query.
|
||||
|
||||
> query2 :: Text
|
||||
> query2 = "{ time }"
|
||||
>
|
||||
> main2 :: IO ()
|
||||
> main2 = putStrLn =<< encode <$> graphql schema2 query2
|
||||
|
||||
This runs the query, returning the current time
|
||||
|
||||
```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```
|
||||
|
||||
|
||||
=== Errors ===
|
||||
|
||||
Errors are handled according to the spec,
|
||||
with fields that cause erros being resolved to `null`,
|
||||
and an error being added to the error list.
|
||||
|
||||
An example of this is the following query:
|
||||
|
||||
> queryShouldFail :: Text
|
||||
> queryShouldFail = "{ boyhowdy }"
|
||||
|
||||
Since there is no `boyhowdy` field in our schema, it will not resolve,
|
||||
and the query will fail, as we can see in the following example.
|
||||
|
||||
> mainShouldFail :: IO ()
|
||||
> mainShouldFail = do
|
||||
> success <- graphql schema1 query1
|
||||
> putStrLn $ encode success
|
||||
> putStrLn "This will fail"
|
||||
> failure <- graphql schema1 queryShouldFail
|
||||
> putStrLn $ encode failure
|
||||
>
|
||||
|
||||
This outputs:
|
||||
|
||||
```
|
||||
{"data": {"hello": "it's me"}}
|
||||
This will fail
|
||||
{"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]}
|
||||
```
|
||||
|
||||
=== Combining resolvers ===
|
||||
|
||||
Now that we have two resolvers, we can define a schema which uses them both.
|
||||
|
||||
> schema3 :: Schema IO
|
||||
> schema3 = hello :| [time]
|
||||
>
|
||||
> query3 :: Text
|
||||
> query3 = "query timeAndHello { time hello }"
|
||||
>
|
||||
> main3 :: IO ()
|
||||
> main3 = putStrLn =<< encode <$> graphql schema3 query3
|
||||
|
||||
This queries for both time and hello, returning
|
||||
|
||||
```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}```
|
||||
|
||||
Notice that we can name our queries, as we did with `timeAndHello`. Since we have only been using single queries, we can use the shorthand `{ time hello}`, as we have been doing in the previous examples.
|
||||
|
||||
In GraphQL there can only be one operation per query.
|
||||
|
||||
|
||||
== Further examples ==
|
||||
|
||||
More examples on queries and a more complex schema can be found in the test directory,
|
||||
in the [Test.StarWars](../../tests/Test/StarWars) module. This includes a more complex schema, and more complex queries.
|
||||
|
||||
> main :: IO ()
|
||||
> main = main1 >> main2 >> mainShouldFail >> main3
|
130
graphql.cabal
130
graphql.cabal
|
@ -1,48 +1,90 @@
|
|||
name: graphql
|
||||
version: 0.3
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
This package provides a rudimentary parser for the
|
||||
<https://facebook.github.io/graphql/ GraphQL> language.
|
||||
homepage: https://github.com/jdnavarro/graphql-haskell
|
||||
bug-reports: https://github.com/jdnavarro/graphql-haskell/issues
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Danny Navarro
|
||||
maintainer: j@dannynavarro.net
|
||||
copyright: Copyright (C) 2015 J. Daniel Navarro
|
||||
category: Web
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC == 7.8.4, GHC == 7.10.2
|
||||
extra-source-files: README.md CHANGELOG.md stack.yaml
|
||||
data-files: tests/data/*.graphql
|
||||
tests/data/*.min.graphql
|
||||
cabal-version: 1.12
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
exposed-modules: Data.GraphQL.AST
|
||||
Data.GraphQL.Encoder
|
||||
Data.GraphQL.Parser
|
||||
build-depends: base >=4.7 && < 5,
|
||||
text >=0.11.3.1,
|
||||
attoparsec >=0.10.4.0
|
||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: dca80d6bcaa432cabc2499efc9f047c6f59546bc2ba75b35fed6efd694895598
|
||||
|
||||
test-suite tasty
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: tests
|
||||
main-is: tasty.hs
|
||||
ghc-options: -Wall
|
||||
other-modules: Paths_graphql
|
||||
build-depends: base >=4.6 && <5,
|
||||
text >=0.11.3.1,
|
||||
attoparsec >=0.10.4.0,
|
||||
tasty >=0.10,
|
||||
tasty-hunit >=0.9,
|
||||
graphql
|
||||
name: graphql
|
||||
version: 0.4.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
||||
category: Language
|
||||
homepage: https://github.com/caraus-ecms/graphql#readme
|
||||
bug-reports: https://github.com/caraus-ecms/graphql/issues
|
||||
author: Danny Navarro <j@dannynavarro.net>,
|
||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
LICENSE
|
||||
docs/tutorial/tutorial.lhs
|
||||
data-files:
|
||||
tests/data/kitchen-sink.graphql
|
||||
tests/data/kitchen-sink.min.graphql
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://github.com/jdnavarro/graphql-haskell.git
|
||||
type: git
|
||||
location: https://github.com/caraus-ecms/graphql
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Language.GraphQL
|
||||
Language.GraphQL.AST
|
||||
Language.GraphQL.AST.Core
|
||||
Language.GraphQL.AST.Transform
|
||||
Language.GraphQL.Encoder
|
||||
Language.GraphQL.Error
|
||||
Language.GraphQL.Execute
|
||||
Language.GraphQL.Lexer
|
||||
Language.GraphQL.Parser
|
||||
Language.GraphQL.Schema
|
||||
Language.GraphQL.Trans
|
||||
Language.GraphQL.Type
|
||||
other-modules:
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
src
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, megaparsec
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tasty
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.LexerSpec
|
||||
Language.GraphQL.ParserSpec
|
||||
Test.KitchenSinkSpec
|
||||
Test.StarWars.Data
|
||||
Test.StarWars.QuerySpec
|
||||
Test.StarWars.Schema
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, graphql
|
||||
, hspec
|
||||
, hspec-expectations
|
||||
, megaparsec
|
||||
, raw-strings-qq
|
||||
, text
|
||||
, transformers
|
||||
default-language: Haskell2010
|
||||
|
|
|
@ -0,0 +1,52 @@
|
|||
name: graphql
|
||||
version: 0.4.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
This package provides a rudimentary parser for the
|
||||
<https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
||||
maintainer: belka@caraus.de
|
||||
github: caraus-ecms/graphql
|
||||
category: Language
|
||||
copyright:
|
||||
- (c) 2019 Eugen Wissner
|
||||
- (c) 2015-2017 J. Daniel Navarro
|
||||
author:
|
||||
- Danny Navarro <j@dannynavarro.net>
|
||||
- Matthías Páll Gissurarson <mpg@mpg.is>
|
||||
- Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
|
||||
extra-source-files:
|
||||
- CHANGELOG.md
|
||||
- README.md
|
||||
- LICENSE
|
||||
- docs/tutorial/tutorial.lhs
|
||||
|
||||
data-files:
|
||||
- tests/data/*.graphql
|
||||
- tests/data/*.min.graphql
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
- base >= 4.7 && < 5
|
||||
- megaparsec
|
||||
- text
|
||||
- transformers
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
dependencies:
|
||||
- unordered-containers
|
||||
|
||||
tests:
|
||||
tasty:
|
||||
main: Spec.hs
|
||||
source-dirs: tests
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- graphql
|
||||
- hspec
|
||||
- hspec-expectations
|
||||
- raw-strings-qq
|
|
@ -0,0 +1,33 @@
|
|||
#!/bin/bash
|
||||
|
||||
STACK=$SEMAPHORE_CACHE_DIR/stack
|
||||
|
||||
setup() {
|
||||
if [ ! -e "$STACK" ]
|
||||
then
|
||||
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack'
|
||||
fi
|
||||
$STACK --no-terminal setup
|
||||
}
|
||||
|
||||
setup_test() {
|
||||
$STACK --no-terminal test --only-snapshot
|
||||
}
|
||||
|
||||
test() {
|
||||
$STACK --no-terminal test --pedantic
|
||||
}
|
||||
|
||||
test_docs() {
|
||||
$STACK --no-terminal ghc -- -Wall -fno-code docs/tutorial/tutorial.lhs
|
||||
}
|
||||
|
||||
setup_lint() {
|
||||
$STACK --no-terminal install hlint
|
||||
}
|
||||
|
||||
lint() {
|
||||
$STACK --no-terminal exec hlint -- src tests
|
||||
}
|
||||
|
||||
$1
|
|
@ -0,0 +1,36 @@
|
|||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
module Language.GraphQL
|
||||
( graphql
|
||||
, graphqlSubs
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
import Language.GraphQL.Execute
|
||||
import Language.GraphQL.Parser
|
||||
import Language.GraphQL.Schema
|
||||
|
||||
import Language.GraphQL.Error
|
||||
|
||||
-- | Takes a 'Schema' and text representing a @GraphQL@ request document.
|
||||
-- If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed according to the given 'Schema'.
|
||||
--
|
||||
-- Returns the response as an @Aeson.@'Aeson.Value'.
|
||||
graphql :: MonadIO m => Schema m -> T.Text -> m Aeson.Value
|
||||
graphql = flip graphqlSubs $ const Nothing
|
||||
|
||||
-- | Takes a 'Schema', a variable substitution function and text
|
||||
-- representing a @GraphQL@ request document. If the text parses
|
||||
-- correctly as a @GraphQL@ query the substitution is applied to the
|
||||
-- query and the query is then executed according to the given 'Schema'.
|
||||
--
|
||||
-- Returns the response as an @Aeson.@'Aeson.Value'.
|
||||
graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value
|
||||
graphqlSubs schema f =
|
||||
either parseError (execute schema f)
|
||||
. parse document ""
|
|
@ -0,0 +1,134 @@
|
|||
-- | 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 Language.GraphQL.AST
|
||||
( Alias
|
||||
, Argument(..)
|
||||
, Arguments
|
||||
, Definition(..)
|
||||
, Directive(..)
|
||||
, Directives
|
||||
, Document
|
||||
, Field(..)
|
||||
, FragmentDefinition(..)
|
||||
, FragmentName
|
||||
, FragmentSpread(..)
|
||||
, InlineFragment(..)
|
||||
, Name
|
||||
, NonNullType(..)
|
||||
, ObjectField(..)
|
||||
, OperationDefinition(..)
|
||||
, OperationType(..)
|
||||
, Selection(..)
|
||||
, SelectionSet
|
||||
, SelectionSetOpt
|
||||
, Type(..)
|
||||
, TypeCondition
|
||||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
, VariableDefinitions
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Core ( Alias
|
||||
, Name
|
||||
)
|
||||
|
||||
-- * Document
|
||||
|
||||
type Document = NonEmpty Definition
|
||||
|
||||
-- * Operations
|
||||
|
||||
data Definition = DefinitionOperation OperationDefinition
|
||||
| DefinitionFragment FragmentDefinition
|
||||
deriving (Eq,Show)
|
||||
|
||||
data OperationDefinition = OperationSelectionSet SelectionSet
|
||||
| OperationDefinition OperationType
|
||||
(Maybe Name)
|
||||
VariableDefinitions
|
||||
Directives
|
||||
SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
data OperationType = Query | Mutation deriving (Eq,Show)
|
||||
|
||||
-- * SelectionSet
|
||||
|
||||
type SelectionSet = NonEmpty Selection
|
||||
|
||||
type SelectionSetOpt = [Selection]
|
||||
|
||||
data Selection = SelectionField Field
|
||||
| SelectionFragmentSpread FragmentSpread
|
||||
| SelectionInlineFragment InlineFragment
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- * Field
|
||||
|
||||
data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- * Arguments
|
||||
|
||||
type Arguments = [Argument]
|
||||
|
||||
data Argument = Argument Name Value deriving (Eq,Show)
|
||||
|
||||
-- * Fragments
|
||||
|
||||
data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
|
||||
|
||||
data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
data FragmentDefinition =
|
||||
FragmentDefinition FragmentName TypeCondition Directives SelectionSet
|
||||
deriving (Eq,Show)
|
||||
|
||||
type FragmentName = Name
|
||||
|
||||
type TypeCondition = Name
|
||||
|
||||
-- * Input values
|
||||
|
||||
data Value = ValueVariable Name
|
||||
| ValueInt Int32
|
||||
| ValueFloat Double
|
||||
| ValueString Text
|
||||
| ValueBoolean Bool
|
||||
| ValueNull
|
||||
| ValueEnum Name
|
||||
| ValueList [Value]
|
||||
| ValueObject [ObjectField]
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
||||
|
||||
-- * Variables
|
||||
|
||||
type VariableDefinitions = [VariableDefinition]
|
||||
|
||||
data VariableDefinition = VariableDefinition Name Type (Maybe Value)
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- * Input types
|
||||
|
||||
data Type = TypeNamed Name
|
||||
| TypeList Type
|
||||
| TypeNonNull NonNullType
|
||||
deriving (Eq,Show)
|
||||
|
||||
data NonNullType = NonNullTypeNamed Name
|
||||
| NonNullTypeList Type
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- * Directives
|
||||
|
||||
type Directives = [Directive]
|
||||
|
||||
data Directive = Directive Name [Argument] deriving (Eq,Show)
|
|
@ -0,0 +1,48 @@
|
|||
-- | This is the AST meant to be executed.
|
||||
module Language.GraphQL.AST.Core
|
||||
( Alias
|
||||
, Argument(..)
|
||||
, Document
|
||||
, Field(..)
|
||||
, Name
|
||||
, ObjectField(..)
|
||||
, Operation(..)
|
||||
, Value(..)
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.String
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | Name
|
||||
type Name = Text
|
||||
|
||||
type Document = NonEmpty Operation
|
||||
|
||||
data Operation = Query (NonEmpty Field)
|
||||
| Mutation (NonEmpty 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
|
||||
| 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)
|
|
@ -0,0 +1,120 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.GraphQL.AST.Transform
|
||||
( document
|
||||
) 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 qualified Language.GraphQL.AST as Full
|
||||
import qualified Language.GraphQL.AST.Core as Core
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
|
||||
-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
|
||||
-- empty list is returned.
|
||||
type Fragmenter = Core.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
|
|
@ -0,0 +1,180 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | This module defines a printer for the @GraphQL@ language.
|
||||
module Language.GraphQL.Encoder
|
||||
( document
|
||||
, spaced
|
||||
) where
|
||||
|
||||
import Data.Foldable (fold)
|
||||
import Data.Monoid ((<>))
|
||||
import qualified Data.List.NonEmpty as NonEmpty (toList)
|
||||
import Data.Text (Text, cons, intercalate, pack, snoc)
|
||||
import Language.GraphQL.AST
|
||||
|
||||
-- * Document
|
||||
|
||||
document :: Document -> Text
|
||||
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 (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 :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
|
||||
node name vars dirs sels =
|
||||
name
|
||||
<> optempty variableDefinitions vars
|
||||
<> optempty directives dirs
|
||||
<> selectionSet sels
|
||||
|
||||
variableDefinitions :: [VariableDefinition] -> Text
|
||||
variableDefinitions = parensCommas variableDefinition
|
||||
|
||||
variableDefinition :: VariableDefinition -> Text
|
||||
variableDefinition (VariableDefinition var ty dv) =
|
||||
variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
|
||||
|
||||
defaultValue :: Value -> Text
|
||||
defaultValue val = "=" <> value val
|
||||
|
||||
variable :: Name -> Text
|
||||
variable var = "$" <> var
|
||||
|
||||
selectionSet :: SelectionSet -> Text
|
||||
selectionSet = bracesCommas selection . NonEmpty.toList
|
||||
|
||||
selectionSetOpt :: SelectionSetOpt -> Text
|
||||
selectionSetOpt = bracesCommas selection
|
||||
|
||||
selection :: Selection -> Text
|
||||
selection (SelectionField x) = field x
|
||||
selection (SelectionInlineFragment x) = inlineFragment x
|
||||
selection (SelectionFragmentSpread x) = fragmentSpread x
|
||||
|
||||
field :: Field -> Text
|
||||
field (Field alias name args dirs selso) =
|
||||
optempty (`snoc` ':') (fold alias)
|
||||
<> name
|
||||
<> optempty arguments args
|
||||
<> optempty directives dirs
|
||||
<> optempty selectionSetOpt selso
|
||||
|
||||
arguments :: [Argument] -> Text
|
||||
arguments = parensCommas argument
|
||||
|
||||
argument :: Argument -> Text
|
||||
argument (Argument name v) = name <> ":" <> value v
|
||||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: FragmentSpread -> Text
|
||||
fragmentSpread (FragmentSpread name ds) =
|
||||
"..." <> name <> optempty directives ds
|
||||
|
||||
inlineFragment :: InlineFragment -> Text
|
||||
inlineFragment (InlineFragment tc dirs sels) =
|
||||
"... on " <> fold tc
|
||||
<> directives dirs
|
||||
<> selectionSet sels
|
||||
|
||||
fragmentDefinition :: FragmentDefinition -> Text
|
||||
fragmentDefinition (FragmentDefinition name tc dirs sels) =
|
||||
"fragment " <> name <> " on " <> tc
|
||||
<> optempty directives dirs
|
||||
<> selectionSet sels
|
||||
|
||||
-- * Values
|
||||
|
||||
value :: Value -> Text
|
||||
value (ValueVariable x) = variable x
|
||||
-- TODO: This will be replaced with `decimal` Builder
|
||||
value (ValueInt x) = pack $ show x
|
||||
-- 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
|
||||
value (ValueObject x) = objectValue x
|
||||
|
||||
booleanValue :: Bool -> Text
|
||||
booleanValue True = "true"
|
||||
booleanValue False = "false"
|
||||
|
||||
-- TODO: Escape characters
|
||||
stringValue :: Text -> Text
|
||||
stringValue = quotes
|
||||
|
||||
listValue :: [Value] -> Text
|
||||
listValue = bracketsCommas value
|
||||
|
||||
objectValue :: [ObjectField] -> Text
|
||||
objectValue = bracesCommas objectField
|
||||
|
||||
objectField :: ObjectField -> Text
|
||||
objectField (ObjectField name v) = name <> ":" <> value v
|
||||
|
||||
-- * Directives
|
||||
|
||||
directives :: [Directive] -> Text
|
||||
directives = spaces directive
|
||||
|
||||
directive :: Directive -> Text
|
||||
directive (Directive name args) = "@" <> name <> optempty arguments args
|
||||
|
||||
-- * Type Reference
|
||||
|
||||
type_ :: Type -> Text
|
||||
type_ (TypeNamed x) = x
|
||||
type_ (TypeList x) = listType x
|
||||
type_ (TypeNonNull x) = nonNullType x
|
||||
|
||||
listType :: Type -> Text
|
||||
listType x = brackets (type_ x)
|
||||
|
||||
nonNullType :: NonNullType -> Text
|
||||
nonNullType (NonNullTypeNamed x) = x <> "!"
|
||||
nonNullType (NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
-- * Internal
|
||||
|
||||
spaced :: Text -> Text
|
||||
spaced = cons '\SP'
|
||||
|
||||
between :: Char -> Char -> Text -> Text
|
||||
between open close = cons open . (`snoc` close)
|
||||
|
||||
parens :: Text -> Text
|
||||
parens = between '(' ')'
|
||||
|
||||
brackets :: Text -> Text
|
||||
brackets = between '[' ']'
|
||||
|
||||
braces :: Text -> Text
|
||||
braces = between '{' '}'
|
||||
|
||||
quotes :: Text -> Text
|
||||
quotes = between '"' '"'
|
||||
|
||||
spaces :: (a -> Text) -> [a] -> Text
|
||||
spaces f = intercalate "\SP" . fmap f
|
||||
|
||||
parensCommas :: (a -> Text) -> [a] -> Text
|
||||
parensCommas f = parens . intercalate "," . fmap f
|
||||
|
||||
bracketsCommas :: (a -> Text) -> [a] -> Text
|
||||
bracketsCommas f = brackets . intercalate "," . fmap f
|
||||
|
||||
bracesCommas :: (a -> Text) -> [a] -> Text
|
||||
bracesCommas f = braces . intercalate "," . fmap f
|
||||
|
||||
optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
|
||||
optempty f xs = if xs == mempty then mempty else f xs
|
|
@ -0,0 +1,83 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Language.GraphQL.Error
|
||||
( parseError
|
||||
, CollectErrsT
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, runCollectErrs
|
||||
, runAppendErrs
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State ( StateT
|
||||
, modify
|
||||
, runStateT
|
||||
)
|
||||
import Text.Megaparsec ( ParseErrorBundle(..)
|
||||
, SourcePos(..)
|
||||
, errorOffset
|
||||
, parseErrorTextPretty
|
||||
, reachOffset
|
||||
, unPos
|
||||
)
|
||||
|
||||
-- | Wraps a parse error into a list of errors.
|
||||
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
||||
parseError ParseErrorBundle{..} =
|
||||
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
|
||||
where
|
||||
errorObject s SourcePos{..} = Aeson.object
|
||||
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
|
||||
, ("line", Aeson.toJSON $ unPos sourceLine)
|
||||
, ("column", Aeson.toJSON $ unPos sourceColumn)
|
||||
]
|
||||
go (result, state) x =
|
||||
let (sourcePosition, _, newState) = reachOffset (errorOffset x) state
|
||||
in (errorObject x sourcePosition : result, newState)
|
||||
|
||||
-- | A wrapper to pass error messages around.
|
||||
type CollectErrsT m = StateT [Aeson.Value] m
|
||||
|
||||
-- | Adds an error to the list of errors.
|
||||
addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
|
||||
addErr v = modify (v :)
|
||||
|
||||
makeErrorMessage :: Text -> Aeson.Value
|
||||
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
|
||||
|
||||
-- | Constructs a response object containing only the error with the given
|
||||
-- message.
|
||||
singleError :: Text -> Aeson.Value
|
||||
singleError message = Aeson.object
|
||||
[ ("errors", Aeson.toJSON [makeErrorMessage message])
|
||||
]
|
||||
|
||||
-- | Convenience function for just wrapping an error message.
|
||||
addErrMsg :: Monad m => Text -> CollectErrsT m ()
|
||||
addErrMsg = addErr . makeErrorMessage
|
||||
|
||||
-- | Appends the given list of errors to the current list of errors.
|
||||
appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
|
||||
appendErrs errs = modify (errs ++)
|
||||
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
|
||||
runCollectErrs res = do
|
||||
(dat, errs) <- runStateT res []
|
||||
if null errs
|
||||
then return $ Aeson.object [("data", dat)]
|
||||
else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
|
||||
|
||||
-- | Runs the given computation, collecting the errors and appending them
|
||||
-- to the previous list of errors.
|
||||
runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a
|
||||
runAppendErrs f = do
|
||||
(v, errs) <- lift $ runStateT f []
|
||||
appendErrs errs
|
||||
return v
|
|
@ -0,0 +1,42 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module provides the function to execute a @GraphQL@ request --
|
||||
-- according to a 'Schema'.
|
||||
module Language.GraphQL.Execute
|
||||
( execute
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Language.GraphQL.AST as AST
|
||||
import qualified Language.GraphQL.AST.Core as AST.Core
|
||||
import qualified Language.GraphQL.AST.Transform as Transform
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Schema (Schema)
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
|
||||
-- | 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
|
||||
:: MonadIO m
|
||||
=> Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value
|
||||
execute schema subs doc =
|
||||
maybe transformError (document schema) $ Transform.document subs doc
|
||||
where
|
||||
transformError = return $ singleError "Schema transformation error."
|
||||
|
||||
document :: MonadIO m => Schema m -> AST.Core.Document -> m Aeson.Value
|
||||
document schema (op :| []) = operation schema op
|
||||
document _ _ = return $ singleError "Multiple operations not supported yet."
|
||||
|
||||
operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value
|
||||
operation schema (AST.Core.Query flds)
|
||||
= runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
|
||||
operation schema (AST.Core.Mutation flds)
|
||||
= runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
|
|
@ -0,0 +1,226 @@
|
|||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module defines a bunch of small parsers used to parse individual
|
||||
-- lexemes.
|
||||
module Language.GraphQL.Lexer
|
||||
( Parser
|
||||
, amp
|
||||
, at
|
||||
, bang
|
||||
, blockString
|
||||
, braces
|
||||
, brackets
|
||||
, colon
|
||||
, dollar
|
||||
, comment
|
||||
, equals
|
||||
, integer
|
||||
, float
|
||||
, lexeme
|
||||
, name
|
||||
, parens
|
||||
, pipe
|
||||
, spaceConsumer
|
||||
, spread
|
||||
, string
|
||||
, symbol
|
||||
, unicodeBOM
|
||||
) where
|
||||
|
||||
import Control.Applicative ( Alternative(..)
|
||||
, liftA2
|
||||
)
|
||||
import Data.Char ( chr
|
||||
, digitToInt
|
||||
, isAsciiLower
|
||||
, isAsciiUpper
|
||||
, ord
|
||||
)
|
||||
import Data.Foldable (foldl')
|
||||
import Data.List (dropWhileEnd)
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec ( Parsec
|
||||
, between
|
||||
, chunk
|
||||
, chunkToTokens
|
||||
, notFollowedBy
|
||||
, oneOf
|
||||
, option
|
||||
, optional
|
||||
, satisfy
|
||||
, sepBy
|
||||
, skipSome
|
||||
, takeP
|
||||
, takeWhile1P
|
||||
, try
|
||||
)
|
||||
import Text.Megaparsec.Char ( char
|
||||
, digitChar
|
||||
, space1
|
||||
)
|
||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
-- | Standard parser.
|
||||
-- Accepts the type of the parsed token.
|
||||
type Parser = Parsec Void T.Text
|
||||
|
||||
ignoredCharacters :: Parser ()
|
||||
ignoredCharacters = space1 <|> skipSome (char ',')
|
||||
|
||||
spaceConsumer :: Parser ()
|
||||
spaceConsumer = Lexer.space ignoredCharacters comment empty
|
||||
|
||||
-- | Parser for comments.
|
||||
comment :: Parser ()
|
||||
comment = Lexer.skipLineComment "#"
|
||||
|
||||
-- | Lexeme definition which ignores whitespaces and commas.
|
||||
lexeme :: forall a. Parser a -> Parser a
|
||||
lexeme = Lexer.lexeme spaceConsumer
|
||||
|
||||
-- | Symbol definition which ignores whitespaces and commas.
|
||||
symbol :: T.Text -> Parser T.Text
|
||||
symbol = Lexer.symbol spaceConsumer
|
||||
|
||||
-- | Parser for "!".
|
||||
bang :: Parser Char
|
||||
bang = char '!'
|
||||
|
||||
-- | Parser for "$".
|
||||
dollar :: Parser Char
|
||||
dollar = char '$'
|
||||
|
||||
-- | Parser for "@".
|
||||
at :: Parser Char
|
||||
at = char '@'
|
||||
|
||||
-- | Parser for "&".
|
||||
amp :: Parser T.Text
|
||||
amp = symbol "&"
|
||||
|
||||
-- | Parser for ":".
|
||||
colon :: Parser T.Text
|
||||
colon = symbol ":"
|
||||
|
||||
-- | Parser for "=".
|
||||
equals :: Parser T.Text
|
||||
equals = symbol "="
|
||||
|
||||
-- | Parser for the spread operator (...).
|
||||
spread :: Parser T.Text
|
||||
spread = symbol "..."
|
||||
|
||||
-- | Parser for "|".
|
||||
pipe :: Parser T.Text
|
||||
pipe = symbol "|"
|
||||
|
||||
-- | Parser for an expression between "(" and ")".
|
||||
parens :: forall a. Parser a -> Parser a
|
||||
parens = between (symbol "(") (symbol ")")
|
||||
|
||||
-- | Parser for an expression between "[" and "]".
|
||||
brackets :: forall a. Parser a -> Parser a
|
||||
brackets = between (symbol "[") (symbol "]")
|
||||
|
||||
-- | Parser for an expression between "{" and "}".
|
||||
braces :: forall a. Parser a -> Parser a
|
||||
braces = between (symbol "{") (symbol "}")
|
||||
|
||||
-- | Parser for strings.
|
||||
string :: Parser T.Text
|
||||
string = between "\"" "\"" stringValue
|
||||
where
|
||||
stringValue = T.pack <$> many stringCharacter
|
||||
stringCharacter = satisfy isStringCharacter1
|
||||
<|> escapeSequence
|
||||
isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter
|
||||
|
||||
-- | Parser for block strings.
|
||||
blockString :: Parser T.Text
|
||||
blockString = between "\"\"\"" "\"\"\"" stringValue
|
||||
where
|
||||
stringValue = do
|
||||
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
||||
let indentSize = foldr countIndent 0 $ tail byLine
|
||||
withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
|
||||
withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
|
||||
|
||||
return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
||||
removeEmptyLine [] = True
|
||||
removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
|
||||
removeEmptyLine _ = False
|
||||
blockStringCharacter
|
||||
= takeWhile1P Nothing isWhiteSpace
|
||||
<|> takeWhile1P Nothing isBlockStringCharacter1
|
||||
<|> escapeTripleQuote
|
||||
<|> try (chunk "\"" <* notFollowedBy (chunk "\"\""))
|
||||
escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"")
|
||||
isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter
|
||||
countIndent [] acc = acc
|
||||
countIndent (x:_) acc
|
||||
| T.null x = acc
|
||||
| not (isWhiteSpace $ T.head x) = acc
|
||||
| acc == 0 = T.length x
|
||||
| otherwise = min acc $ T.length x
|
||||
removeIndent _ [] = []
|
||||
removeIndent n (x:chunks) = T.drop n x : chunks
|
||||
|
||||
-- | Parser for integers.
|
||||
integer :: Integral a => Parser a
|
||||
integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal
|
||||
|
||||
-- | Parser for floating-point numbers.
|
||||
float :: Parser Double
|
||||
float = Lexer.signed (pure ()) $ lexeme Lexer.float
|
||||
|
||||
-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).
|
||||
name :: Parser T.Text
|
||||
name = do
|
||||
firstLetter <- nameFirstLetter
|
||||
rest <- many $ nameFirstLetter <|> digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
||||
where
|
||||
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
||||
|
||||
isChunkDelimiter :: Char -> Bool
|
||||
isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
|
||||
|
||||
isWhiteSpace :: Char -> Bool
|
||||
isWhiteSpace = liftA2 (||) (== ' ') (== '\t')
|
||||
|
||||
lineTerminator :: Parser T.Text
|
||||
lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
|
||||
|
||||
isSourceCharacter :: Char -> Bool
|
||||
isSourceCharacter = isSourceCharacter' . ord
|
||||
where
|
||||
isSourceCharacter' code = code >= 0x0020
|
||||
|| code == 0x0009
|
||||
|| code == 0x000a
|
||||
|| code == 0x000d
|
||||
|
||||
escapeSequence :: Parser Char
|
||||
escapeSequence = do
|
||||
_ <- char '\\'
|
||||
escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
|
||||
case escaped of
|
||||
'b' -> return '\b'
|
||||
'f' -> return '\f'
|
||||
'n' -> return '\n'
|
||||
'r' -> return '\r'
|
||||
't' -> return '\t'
|
||||
'u' -> chr . foldl' step 0
|
||||
. chunkToTokens (Proxy :: Proxy T.Text)
|
||||
<$> takeP Nothing 4
|
||||
_ -> return escaped
|
||||
where
|
||||
step accumulator = (accumulator * 16 +) . digitToInt
|
||||
|
||||
-- | Parser for the "Byte Order Mark".
|
||||
unicodeBOM :: Parser ()
|
||||
unicodeBOM = optional (char '\xfeff') >> pure ()
|
|
@ -0,0 +1,185 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.GraphQL.Parser
|
||||
( document
|
||||
) where
|
||||
|
||||
import Control.Applicative ( Alternative(..)
|
||||
, optional
|
||||
)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Language.GraphQL.AST
|
||||
import Language.GraphQL.Lexer
|
||||
import Text.Megaparsec ( lookAhead
|
||||
, option
|
||||
, try
|
||||
, (<?>)
|
||||
)
|
||||
|
||||
document :: Parser Document
|
||||
document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
|
||||
|
||||
definition :: Parser Definition
|
||||
definition = DefinitionOperation <$> operationDefinition
|
||||
<|> DefinitionFragment <$> fragmentDefinition
|
||||
<?> "definition error!"
|
||||
|
||||
operationDefinition :: Parser OperationDefinition
|
||||
operationDefinition = OperationSelectionSet <$> selectionSet
|
||||
<|> OperationDefinition <$> operationType
|
||||
<*> optional name
|
||||
<*> opt variableDefinitions
|
||||
<*> opt directives
|
||||
<*> selectionSet
|
||||
<?> "operationDefinition error"
|
||||
|
||||
operationType :: Parser OperationType
|
||||
operationType = Query <$ symbol "query"
|
||||
<|> Mutation <$ symbol "mutation"
|
||||
<?> "operationType error"
|
||||
|
||||
-- * SelectionSet
|
||||
|
||||
selectionSet :: Parser SelectionSet
|
||||
selectionSet = braces $ manyNE selection
|
||||
|
||||
selectionSetOpt :: Parser SelectionSetOpt
|
||||
selectionSetOpt = braces $ some selection
|
||||
|
||||
selection :: Parser Selection
|
||||
selection = SelectionField <$> field
|
||||
<|> try (SelectionFragmentSpread <$> fragmentSpread)
|
||||
<|> SelectionInlineFragment <$> inlineFragment
|
||||
<?> "selection error!"
|
||||
|
||||
-- * Field
|
||||
|
||||
field :: Parser Field
|
||||
field = Field <$> optional alias
|
||||
<*> name
|
||||
<*> opt arguments
|
||||
<*> opt directives
|
||||
<*> opt selectionSetOpt
|
||||
|
||||
alias :: Parser Alias
|
||||
alias = try $ name <* colon
|
||||
|
||||
-- * Arguments
|
||||
|
||||
arguments :: Parser Arguments
|
||||
arguments = parens $ some argument
|
||||
|
||||
argument :: Parser Argument
|
||||
argument = Argument <$> name <* colon <*> value
|
||||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: Parser FragmentSpread
|
||||
fragmentSpread = FragmentSpread <$ spread
|
||||
<*> fragmentName
|
||||
<*> opt directives
|
||||
|
||||
inlineFragment :: Parser InlineFragment
|
||||
inlineFragment = InlineFragment <$ spread
|
||||
<*> optional typeCondition
|
||||
<*> opt directives
|
||||
<*> selectionSet
|
||||
|
||||
fragmentDefinition :: Parser FragmentDefinition
|
||||
fragmentDefinition = FragmentDefinition
|
||||
<$ symbol "fragment"
|
||||
<*> name
|
||||
<*> typeCondition
|
||||
<*> opt directives
|
||||
<*> selectionSet
|
||||
|
||||
fragmentName :: Parser FragmentName
|
||||
fragmentName = but (symbol "on") *> name
|
||||
|
||||
typeCondition :: Parser TypeCondition
|
||||
typeCondition = symbol "on" *> name
|
||||
|
||||
-- * Input Values
|
||||
|
||||
value :: Parser Value
|
||||
value = ValueVariable <$> variable
|
||||
<|> ValueFloat <$> try float
|
||||
<|> ValueInt <$> integer
|
||||
<|> ValueBoolean <$> booleanValue
|
||||
<|> ValueNull <$ symbol "null"
|
||||
<|> ValueString <$> string
|
||||
<|> ValueString <$> blockString
|
||||
<|> ValueEnum <$> try enumValue
|
||||
<|> ValueList <$> listValue
|
||||
<|> ValueObject <$> objectValue
|
||||
<?> "value error!"
|
||||
where
|
||||
booleanValue :: Parser Bool
|
||||
booleanValue = True <$ symbol "true"
|
||||
<|> False <$ symbol "false"
|
||||
|
||||
enumValue :: Parser Name
|
||||
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
||||
|
||||
listValue :: Parser [Value]
|
||||
listValue = brackets $ some value
|
||||
|
||||
objectValue :: Parser [ObjectField]
|
||||
objectValue = braces $ some objectField
|
||||
|
||||
objectField :: Parser ObjectField
|
||||
objectField = ObjectField <$> name <* symbol ":" <*> value
|
||||
|
||||
-- * Variables
|
||||
|
||||
variableDefinitions :: Parser VariableDefinitions
|
||||
variableDefinitions = parens $ some variableDefinition
|
||||
|
||||
variableDefinition :: Parser VariableDefinition
|
||||
variableDefinition = VariableDefinition <$> variable
|
||||
<* colon
|
||||
<*> type_
|
||||
<*> optional defaultValue
|
||||
variable :: Parser Name
|
||||
variable = dollar *> name
|
||||
|
||||
defaultValue :: Parser Value
|
||||
defaultValue = equals *> value
|
||||
|
||||
-- * Input Types
|
||||
|
||||
type_ :: Parser Type
|
||||
type_ = try (TypeNamed <$> name <* but "!")
|
||||
<|> TypeList <$> brackets type_
|
||||
<|> TypeNonNull <$> nonNullType
|
||||
<?> "type_ error!"
|
||||
|
||||
nonNullType :: Parser NonNullType
|
||||
nonNullType = NonNullTypeNamed <$> name <* bang
|
||||
<|> NonNullTypeList <$> brackets type_ <* bang
|
||||
<?> "nonNullType error!"
|
||||
|
||||
-- * Directives
|
||||
|
||||
directives :: Parser Directives
|
||||
directives = some directive
|
||||
|
||||
directive :: Parser Directive
|
||||
directive = Directive
|
||||
<$ at
|
||||
<*> name
|
||||
<*> opt arguments
|
||||
|
||||
-- * Internal
|
||||
|
||||
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
|
|
@ -0,0 +1,172 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||
-- functions for defining and manipulating Schemas.
|
||||
module Language.GraphQL.Schema
|
||||
( Resolver
|
||||
, Schema
|
||||
, Subs
|
||||
, object
|
||||
, objectA
|
||||
, scalar
|
||||
, scalarA
|
||||
, enum
|
||||
, enumA
|
||||
, resolve
|
||||
, wrappedEnum
|
||||
, wrappedEnumA
|
||||
, wrappedObject
|
||||
, wrappedObjectA
|
||||
, wrappedScalar
|
||||
, wrappedScalarA
|
||||
-- * AST Reexports
|
||||
, Field
|
||||
, Argument(..)
|
||||
, Value(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Data.Foldable ( find
|
||||
, fold
|
||||
)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe (fromMaybe)
|
||||
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
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Trans
|
||||
import Language.GraphQL.Type
|
||||
import Language.GraphQL.AST.Core
|
||||
|
||||
-- | A GraphQL schema.
|
||||
-- @m@ is usually expected to be an instance of 'MonadIO'.
|
||||
type Schema m = NonEmpty (Resolver m)
|
||||
|
||||
-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
|
||||
-- (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
|
||||
data Resolver m = Resolver
|
||||
Text -- ^ Name
|
||||
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
||||
|
||||
type Fields = [Field]
|
||||
|
||||
type Arguments = [Argument]
|
||||
|
||||
-- | Variable substitution function.
|
||||
type Subs = Name -> Maybe Value
|
||||
|
||||
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
|
||||
object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
|
||||
object name = objectA name . const
|
||||
|
||||
-- | Like 'object' but also taking 'Argument's.
|
||||
objectA :: MonadIO m
|
||||
=> Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
|
||||
objectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
|
||||
|
||||
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
|
||||
wrappedObjectA :: MonadIO m
|
||||
=> Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
|
||||
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ sels) resolver
|
||||
= withField (traverse (`resolve` sels) resolver) fld
|
||||
|
||||
-- | Like 'object' but can be null or a list of objects.
|
||||
wrappedObject :: MonadIO m
|
||||
=> Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m
|
||||
wrappedObject name = wrappedObjectA name . const
|
||||
|
||||
-- | A scalar represents a primitive value, like a string or an integer.
|
||||
scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
|
||||
scalar name = scalarA name . const
|
||||
|
||||
-- | Like 'scalar' but also taking 'Argument's.
|
||||
scalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> (Arguments -> ActionT m a) -> Resolver m
|
||||
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld result = withField (return result) fld
|
||||
|
||||
-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
|
||||
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
|
||||
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld (Named result) = withField (return result) fld
|
||||
resolveRight fld Null
|
||||
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
resolveRight fld (List result) = withField (return result) fld
|
||||
|
||||
-- | Like 'scalar' but can be null or a list of scalars.
|
||||
wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> ActionT m (Wrapping a) -> Resolver m
|
||||
wrappedScalar name = wrappedScalarA name . const
|
||||
|
||||
-- | Represents one of a finite set of possible values.
|
||||
-- Used in place of a 'scalar' when the possible responses are easily enumerable.
|
||||
enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
|
||||
enum name = enumA name . const
|
||||
|
||||
-- | Like 'enum' but also taking 'Argument's.
|
||||
enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
|
||||
enumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld resolver = withField (return resolver) fld
|
||||
|
||||
-- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.
|
||||
wrappedEnumA :: MonadIO m
|
||||
=> Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
|
||||
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld (Named resolver) = withField (return resolver) fld
|
||||
resolveRight fld Null
|
||||
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
resolveRight fld (List resolver) = withField (return resolver) fld
|
||||
|
||||
-- | Like 'enum' but can be null or a list of enums.
|
||||
wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
|
||||
wrappedEnum name = wrappedEnumA name . const
|
||||
|
||||
resolveFieldValue :: MonadIO m
|
||||
=> ([Argument] -> ActionT m a)
|
||||
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
|
||||
-> Field
|
||||
-> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
|
||||
result <- lift $ runExceptT . runActionT $ f args
|
||||
either resolveLeft (resolveRight fld) result
|
||||
where
|
||||
resolveLeft err = do
|
||||
_ <- addErrMsg err
|
||||
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
|
||||
-- | Helper function to facilitate 'Argument' handling.
|
||||
withField :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
withField v fld
|
||||
= HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
|
||||
|
||||
-- | 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.
|
||||
resolve :: MonadIO m
|
||||
=> [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
|
||||
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
||||
where
|
||||
tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
|
||||
compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
|
||||
tryResolver fld (Resolver _ resolver) = resolver fld
|
||||
errmsg fld@(Field _ name _ _) = do
|
||||
addErrMsg $ T.unwords ["field", name, "not resolved."]
|
||||
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
|
||||
aliasOrName :: Field -> Text
|
||||
aliasOrName (Field alias name _ _) = fromMaybe name alias
|
|
@ -0,0 +1,37 @@
|
|||
module Language.GraphQL.Trans
|
||||
( ActionT(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Data.Text (Text)
|
||||
|
||||
newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }
|
||||
|
||||
instance Functor m => Functor (ActionT m) where
|
||||
fmap f = ActionT . fmap f . runActionT
|
||||
|
||||
instance Monad m => Applicative (ActionT m) where
|
||||
pure = ActionT . pure
|
||||
(ActionT f) <*> (ActionT x) = ActionT $ f <*> x
|
||||
|
||||
instance Monad m => Monad (ActionT m) where
|
||||
return = pure
|
||||
(ActionT action) >>= f = ActionT $ action >>= runActionT . f
|
||||
|
||||
instance MonadTrans ActionT where
|
||||
lift = ActionT . lift
|
||||
|
||||
instance MonadIO m => MonadIO (ActionT m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance Monad m => Alternative (ActionT m) where
|
||||
empty = ActionT empty
|
||||
(ActionT x) <|> (ActionT y) = ActionT $ x <|> y
|
||||
|
||||
instance Monad m => MonadPlus (ActionT m) where
|
||||
mzero = empty
|
||||
mplus = (<|>)
|
|
@ -0,0 +1,57 @@
|
|||
-- | Definitions for @GraphQL@ type system.
|
||||
module Language.GraphQL.Type
|
||||
( Wrapping(..)
|
||||
) where
|
||||
|
||||
import Data.Aeson as Aeson ( ToJSON
|
||||
, toJSON
|
||||
)
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
|
||||
-- type can wrap other wrapping or named types. Wrapping types are lists and
|
||||
-- Non-Null types (named types are nullable by default).
|
||||
--
|
||||
-- This 'Wrapping' type doesn\'t reflect this distinction exactly but it is
|
||||
-- used in the resolvers to take into account that the returned value can be
|
||||
-- nullable or an (arbitrary nested) list.
|
||||
data Wrapping a
|
||||
= List [Wrapping a] -- ^ Arbitrary nested list
|
||||
| Named a -- ^ Named type without further wrapping
|
||||
| Null -- ^ Null
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Functor Wrapping where
|
||||
fmap f (List list) = List $ fmap (fmap f) list
|
||||
fmap f (Named named) = Named $ f named
|
||||
fmap _ Null = Null
|
||||
|
||||
instance Foldable Wrapping where
|
||||
foldr f acc (List list) = foldr (flip $ foldr f) acc list
|
||||
foldr f acc (Named named) = f named acc
|
||||
foldr _ acc Null = acc
|
||||
|
||||
instance Traversable Wrapping where
|
||||
traverse f (List list) = List <$> traverse (traverse f) list
|
||||
traverse f (Named named) = Named <$> f named
|
||||
traverse _ Null = pure Null
|
||||
|
||||
instance Applicative Wrapping where
|
||||
pure = Named
|
||||
Null <*> _ = Null
|
||||
_ <*> Null = Null
|
||||
(Named f) <*> (Named x) = Named $ f x
|
||||
(List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs
|
||||
(Named f) <*> list = f <$> list
|
||||
(List fs) <*> named = List $ (<*> named) <$> fs
|
||||
|
||||
instance Monad Wrapping where
|
||||
return = pure
|
||||
Null >>= _ = Null
|
||||
(Named x) >>= f = f x
|
||||
(List xs) >>= f = List $ fmap (>>= f) xs
|
||||
|
||||
instance ToJSON a => ToJSON (Wrapping a) where
|
||||
toJSON (List list) = toJSON list
|
||||
toJSON (Named named) = toJSON named
|
||||
toJSON Null = Aeson.Null
|
|
@ -1,5 +0,0 @@
|
|||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps: []
|
||||
resolver: lts-3.4
|
|
@ -1,5 +0,0 @@
|
|||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps: []
|
||||
resolver: lts-2.22
|
|
@ -1 +0,0 @@
|
|||
stack-7.10.yaml
|
|
@ -0,0 +1,6 @@
|
|||
resolver: lts-13.29
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps: []
|
||||
flags: {}
|
||||
extra-package-dbs: []
|
|
@ -0,0 +1,12 @@
|
|||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 500539
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/29.yaml
|
||||
sha256: 006398c5e92d1d64737b7e98ae4d63987c36808814504d1451f56ebd98093f75
|
||||
original: lts-13.29
|
|
@ -0,0 +1,24 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.GraphQL.ErrorSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Language.GraphQL.Error
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "singleError" $
|
||||
it "constructs an error with the given message" $
|
||||
let expected = Aeson.object
|
||||
[
|
||||
("errors", Aeson.toJSON
|
||||
[ Aeson.object [("message", "Message.")]
|
||||
]
|
||||
)
|
||||
]
|
||||
in singleError "Message." `shouldBe` expected
|
|
@ -0,0 +1,104 @@
|
|||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Language.GraphQL.LexerSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Either (isRight)
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import Language.GraphQL.Lexer
|
||||
import Test.Hspec ( Spec
|
||||
, context
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
, shouldSatisfy
|
||||
)
|
||||
import Text.Megaparsec ( ParseErrorBundle
|
||||
, parse
|
||||
)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Lexer" $ do
|
||||
context "Reference tests" $ do
|
||||
it "accepts BOM header" $
|
||||
runParser unicodeBOM "\xfeff" `shouldSatisfy` isRight
|
||||
|
||||
it "lexes strings" $ do
|
||||
runParser string [r|"simple"|] `shouldBe` Right "simple"
|
||||
runParser string [r|" white space "|] `shouldBe` Right " white space "
|
||||
runParser string [r|"quote \""|] `shouldBe` Right [r|quote "|]
|
||||
runParser string [r|"escaped \n"|] `shouldBe` Right "escaped \n"
|
||||
runParser string [r|"slashes \\ \/"|] `shouldBe` Right [r|slashes \ /|]
|
||||
runParser string [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
|
||||
`shouldBe` Right "unicode ሴ噸邫췯"
|
||||
|
||||
it "lexes block string" $ do
|
||||
runParser blockString [r|"""simple"""|] `shouldBe` Right "simple"
|
||||
runParser blockString [r|""" white space """|]
|
||||
`shouldBe` Right " white space "
|
||||
runParser blockString [r|"""contains " quote"""|]
|
||||
`shouldBe` Right [r|contains " quote|]
|
||||
runParser blockString [r|"""contains \""" triplequote"""|]
|
||||
`shouldBe` Right [r|contains """ triplequote|]
|
||||
runParser blockString "\"\"\"multi\nline\"\"\"" `shouldBe` Right "multi\nline"
|
||||
runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldBe` Right "multi\nline\nnormalized"
|
||||
runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldBe` Right "multi\nline\nnormalized"
|
||||
runParser blockString [r|"""unescaped \n\r\b\t\f\u1234"""|]
|
||||
`shouldBe` Right [r|unescaped \n\r\b\t\f\u1234|]
|
||||
runParser blockString [r|"""slashes \\ \/"""|]
|
||||
`shouldBe` Right [r|slashes \\ \/|]
|
||||
runParser blockString [r|"""
|
||||
|
||||
spans
|
||||
multiple
|
||||
lines
|
||||
|
||||
"""|] `shouldBe` Right "spans\n multiple\n lines"
|
||||
|
||||
it "lexes numbers" $ do
|
||||
runParser integer "4" `shouldBe` Right (4 :: Int)
|
||||
runParser float "4.123" `shouldBe` Right 4.123
|
||||
runParser integer "-4" `shouldBe` Right (-4 :: Int)
|
||||
runParser integer "9" `shouldBe` Right (9 :: Int)
|
||||
runParser integer "0" `shouldBe` Right (0 :: Int)
|
||||
runParser float "-4.123" `shouldBe` Right (-4.123)
|
||||
runParser float "0.123" `shouldBe` Right 0.123
|
||||
runParser float "123e4" `shouldBe` Right 123e4
|
||||
runParser float "123E4" `shouldBe` Right 123E4
|
||||
runParser float "123e-4" `shouldBe` Right 123e-4
|
||||
runParser float "123e+4" `shouldBe` Right 123e+4
|
||||
runParser float "-1.123e4" `shouldBe` Right (-1.123e4)
|
||||
runParser float "-1.123E4" `shouldBe` Right (-1.123E4)
|
||||
runParser float "-1.123e-4" `shouldBe` Right (-1.123e-4)
|
||||
runParser float "-1.123e+4" `shouldBe` Right (-1.123e+4)
|
||||
runParser float "-1.123e4567" `shouldBe` Right (-1.123e4567)
|
||||
|
||||
it "lexes punctuation" $ do
|
||||
runParser bang "!" `shouldBe` Right '!'
|
||||
runParser dollar "$" `shouldBe` Right '$'
|
||||
runBetween parens "()" `shouldSatisfy` isRight
|
||||
runParser spread "..." `shouldBe` Right "..."
|
||||
runParser colon ":" `shouldBe` Right ":"
|
||||
runParser equals "=" `shouldBe` Right "="
|
||||
runParser at "@" `shouldBe` Right '@'
|
||||
runBetween brackets "[]" `shouldSatisfy` isRight
|
||||
runBetween braces "{}" `shouldSatisfy` isRight
|
||||
runParser pipe "|" `shouldBe` Right "|"
|
||||
|
||||
context "Implementation tests" $ do
|
||||
it "lexes empty block strings" $
|
||||
runParser blockString [r|""""""|] `shouldBe` Right ""
|
||||
it "lexes ampersand" $
|
||||
runParser amp "&" `shouldBe` Right "&"
|
||||
|
||||
runParser :: forall a. Parser a -> Text -> Either (ParseErrorBundle Text Void) a
|
||||
runParser = flip parse ""
|
||||
|
||||
runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
|
||||
runBetween parser = parse (parser $ pure ()) ""
|
|
@ -0,0 +1,18 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.GraphQL.ParserSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Either (isRight)
|
||||
import Language.GraphQL.Parser (document)
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldSatisfy
|
||||
)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Parser" $
|
||||
it "accepts BOM header" $
|
||||
parse document "" "\xfeff{foo}" `shouldSatisfy` isRight
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
|
@ -0,0 +1,29 @@
|
|||
module Test.KitchenSinkSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import qualified Data.Text.IO as Text.IO
|
||||
import qualified Language.GraphQL.Encoder as Encoder
|
||||
import qualified Language.GraphQL.Parser as Parser
|
||||
import Paths_graphql (getDataFileName)
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
)
|
||||
import Test.Hspec.Expectations ( expectationFailure
|
||||
, shouldBe
|
||||
)
|
||||
import Text.Megaparsec ( errorBundlePretty
|
||||
, parse
|
||||
)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Kitchen Sink" $
|
||||
it "prints the query" $ do
|
||||
dataFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
|
||||
expected <- Text.IO.readFile dataFileName
|
||||
|
||||
either
|
||||
(expectationFailure . errorBundlePretty)
|
||||
(flip shouldBe expected . Encoder.document)
|
||||
$ parse Parser.document dataFileName expected
|
|
@ -0,0 +1,197 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Test.StarWars.Data
|
||||
( Character
|
||||
, appearsIn
|
||||
, artoo
|
||||
, getDroid
|
||||
, getDroid'
|
||||
, getEpisode
|
||||
, getFriends
|
||||
, getHero
|
||||
, getHeroIO
|
||||
, getHuman
|
||||
, id_
|
||||
, homePlanet
|
||||
, name
|
||||
, secretBackstory
|
||||
, typeName
|
||||
) where
|
||||
|
||||
import Data.Monoid (mempty)
|
||||
import Control.Applicative ( Alternative(..)
|
||||
, liftA2
|
||||
)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.Trans
|
||||
|
||||
-- * Data
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
||||
|
||||
-- ** Characters
|
||||
|
||||
type ID = Text
|
||||
|
||||
data CharCommon = CharCommon
|
||||
{ _id_ :: ID
|
||||
, _name :: Text
|
||||
, _friends :: [ID]
|
||||
, _appearsIn :: [Int]
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
data Human = Human
|
||||
{ _humanChar :: CharCommon
|
||||
, homePlanet :: Text
|
||||
}
|
||||
|
||||
data Droid = Droid
|
||||
{ _droidChar :: CharCommon
|
||||
, primaryFunction :: Text
|
||||
}
|
||||
|
||||
type Character = Either Droid Human
|
||||
|
||||
id_ :: Character -> ID
|
||||
id_ (Left x) = _id_ . _droidChar $ x
|
||||
id_ (Right x) = _id_ . _humanChar $ x
|
||||
|
||||
name :: Character -> Text
|
||||
name (Left x) = _name . _droidChar $ x
|
||||
name (Right x) = _name . _humanChar $ x
|
||||
|
||||
friends :: Character -> [ID]
|
||||
friends (Left x) = _friends . _droidChar $ x
|
||||
friends (Right x) = _friends . _humanChar $ x
|
||||
|
||||
appearsIn :: Character -> [Int]
|
||||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||
|
||||
secretBackstory :: MonadIO m => Character -> ActionT m Text
|
||||
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
|
||||
|
||||
typeName :: Character -> Text
|
||||
typeName = either (const "Droid") (const "Human")
|
||||
|
||||
luke :: Character
|
||||
luke = Right luke'
|
||||
|
||||
luke' :: Human
|
||||
luke' = Human
|
||||
{ _humanChar = CharCommon
|
||||
{ _id_ = "1000"
|
||||
, _name = "Luke Skywalker"
|
||||
, _friends = ["1002","1003","2000","2001"]
|
||||
, _appearsIn = [4,5,6]
|
||||
}
|
||||
, homePlanet = "Tatooine"
|
||||
}
|
||||
|
||||
vader :: Human
|
||||
vader = Human
|
||||
{ _humanChar = CharCommon
|
||||
{ _id_ = "1001"
|
||||
, _name = "Darth Vader"
|
||||
, _friends = ["1004"]
|
||||
, _appearsIn = [4,5,6]
|
||||
}
|
||||
, homePlanet = "Tatooine"
|
||||
}
|
||||
|
||||
han :: Human
|
||||
han = Human
|
||||
{ _humanChar = CharCommon
|
||||
{ _id_ = "1002"
|
||||
, _name = "Han Solo"
|
||||
, _friends = ["1000","1003","2001" ]
|
||||
, _appearsIn = [4,5,6]
|
||||
}
|
||||
, homePlanet = mempty
|
||||
}
|
||||
|
||||
leia :: Human
|
||||
leia = Human
|
||||
{ _humanChar = CharCommon
|
||||
{ _id_ = "1003"
|
||||
, _name = "Leia Organa"
|
||||
, _friends = ["1000","1002","2000","2001"]
|
||||
, _appearsIn = [4,5,6]
|
||||
}
|
||||
, homePlanet = "Alderaan"
|
||||
}
|
||||
|
||||
tarkin :: Human
|
||||
tarkin = Human
|
||||
{ _humanChar = CharCommon
|
||||
{ _id_ = "1004"
|
||||
, _name = "Wilhuff Tarkin"
|
||||
, _friends = ["1001"]
|
||||
, _appearsIn = [4]
|
||||
}
|
||||
, homePlanet = mempty
|
||||
}
|
||||
|
||||
threepio :: Droid
|
||||
threepio = Droid
|
||||
{ _droidChar = CharCommon
|
||||
{ _id_ = "2000"
|
||||
, _name = "C-3PO"
|
||||
, _friends = ["1000","1002","1003","2001" ]
|
||||
, _appearsIn = [ 4, 5, 6 ]
|
||||
}
|
||||
, primaryFunction = "Protocol"
|
||||
}
|
||||
|
||||
artoo :: Character
|
||||
artoo = Left artoo'
|
||||
|
||||
artoo' :: Droid
|
||||
artoo' = Droid
|
||||
{ _droidChar = CharCommon
|
||||
{ _id_ = "2001"
|
||||
, _name = "R2-D2"
|
||||
, _friends = ["1000","1002","1003"]
|
||||
, _appearsIn = [4,5,6]
|
||||
}
|
||||
, primaryFunction = "Astrometch"
|
||||
}
|
||||
|
||||
-- ** Helper functions
|
||||
|
||||
getHero :: Int -> Character
|
||||
getHero 5 = luke
|
||||
getHero _ = artoo
|
||||
|
||||
getHeroIO :: Int -> IO Character
|
||||
getHeroIO = pure . getHero
|
||||
|
||||
getHuman :: Alternative f => ID -> f Character
|
||||
getHuman = fmap Right . getHuman'
|
||||
|
||||
getHuman' :: Alternative f => ID -> f Human
|
||||
getHuman' "1000" = pure luke'
|
||||
getHuman' "1001" = pure vader
|
||||
getHuman' "1002" = pure han
|
||||
getHuman' "1003" = pure leia
|
||||
getHuman' "1004" = pure tarkin
|
||||
getHuman' _ = empty
|
||||
|
||||
getDroid :: Alternative f => ID -> f Character
|
||||
getDroid = fmap Left . getDroid'
|
||||
|
||||
getDroid' :: Alternative f => ID -> f Droid
|
||||
getDroid' "2000" = pure threepio
|
||||
getDroid' "2001" = pure artoo'
|
||||
getDroid' _ = empty
|
||||
|
||||
getFriends :: Character -> [Character]
|
||||
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
||||
|
||||
getEpisode :: Alternative f => Int -> f Text
|
||||
getEpisode 4 = pure "NEWHOPE"
|
||||
getEpisode 5 = pure "EMPIRE"
|
||||
getEpisode 6 = pure "JEDI"
|
||||
getEpisode _ = empty
|
|
@ -0,0 +1,351 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Test.StarWars.QuerySpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson ( object
|
||||
, (.=)
|
||||
)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import Language.GraphQL.Schema (Subs)
|
||||
import Text.RawString.QQ (r)
|
||||
import Test.Hspec.Expectations ( Expectation
|
||||
, shouldBe
|
||||
)
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
)
|
||||
import Test.StarWars.Schema
|
||||
|
||||
-- * Test
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Star Wars Query Tests" $ do
|
||||
describe "Basic Queries" $ do
|
||||
it "R2-D2 hero" $ testQuery
|
||||
[r| query HeroNameQuery {
|
||||
hero {
|
||||
id
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
|
||||
it "R2-D2 ID and friends" $ testQuery
|
||||
[r| query HeroNameAndFriendsQuery {
|
||||
hero {
|
||||
id
|
||||
name
|
||||
friends {
|
||||
name
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"hero" .= object
|
||||
[ "id" .= ("2001" :: Text)
|
||||
, r2d2Name
|
||||
, "friends" .=
|
||||
[ object [lukeName]
|
||||
, object [hanName]
|
||||
, object [leiaName]
|
||||
]
|
||||
]
|
||||
]]
|
||||
|
||||
describe "Nested Queries" $ do
|
||||
it "R2-D2 friends" $ testQuery
|
||||
[r| query NestedQuery {
|
||||
hero {
|
||||
name
|
||||
friends {
|
||||
name
|
||||
appearsIn
|
||||
friends {
|
||||
name
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"hero" .= object [
|
||||
"name" .= ("R2-D2" :: Text)
|
||||
, "friends" .= [
|
||||
object [
|
||||
"name" .= ("Luke Skywalker" :: Text)
|
||||
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
object [hanName]
|
||||
, object [leiaName]
|
||||
, object [c3poName]
|
||||
, object [r2d2Name]
|
||||
]
|
||||
]
|
||||
, object [
|
||||
hanName
|
||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
object [lukeName]
|
||||
, object [leiaName]
|
||||
, object [r2d2Name]
|
||||
]
|
||||
]
|
||||
, object [
|
||||
leiaName
|
||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
object [lukeName]
|
||||
, object [hanName]
|
||||
, object [c3poName]
|
||||
, object [r2d2Name]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
]]
|
||||
it "Luke ID" $ testQuery
|
||||
[r| query FetchLukeQuery {
|
||||
human(id: "1000") {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"human" .= object [lukeName]
|
||||
]]
|
||||
|
||||
it "Luke ID with variable" $ testQueryParams
|
||||
(\v -> if v == "someId" then Just "1000" else Nothing)
|
||||
[r| query FetchSomeIDQuery($someId: String!) {
|
||||
human(id: $someId) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"human" .= object [lukeName]
|
||||
]]
|
||||
it "Han ID with variable" $ testQueryParams
|
||||
(\v -> if v == "someId" then Just "1002" else Nothing)
|
||||
[r| query FetchSomeIDQuery($someId: String!) {
|
||||
human(id: $someId) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"human" .= object [hanName]
|
||||
]]
|
||||
it "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" .= Aeson.Null]]
|
||||
it "Luke aliased" $ testQuery
|
||||
[r| query FetchLukeAliased {
|
||||
luke: human(id: "1000") {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName]
|
||||
]]
|
||||
it "R2-D2 ID and friends aliased" $ testQuery
|
||||
[r| query HeroNameAndFriendsQuery {
|
||||
hero {
|
||||
id
|
||||
name
|
||||
friends {
|
||||
friendName: name
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"hero" .= object [
|
||||
"id" .= ("2001" :: Text)
|
||||
, r2d2Name
|
||||
, "friends" .= [
|
||||
object ["friendName" .= ("Luke Skywalker" :: Text)]
|
||||
, object ["friendName" .= ("Han Solo" :: Text)]
|
||||
, object ["friendName" .= ("Leia Organa" :: Text)]
|
||||
]
|
||||
]
|
||||
]]
|
||||
it "Luke and Leia aliased" $ testQuery
|
||||
[r| query FetchLukeAndLeiaAliased {
|
||||
luke: human(id: "1000") {
|
||||
name
|
||||
}
|
||||
leia: human(id: "1003") {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName]
|
||||
, "leia" .= object [leiaName]
|
||||
]]
|
||||
|
||||
describe "Fragments for complex queries" $ do
|
||||
it "Aliases to query for duplicate content" $ testQuery
|
||||
[r| query DuplicateFields {
|
||||
luke: human(id: "1000") {
|
||||
name
|
||||
homePlanet
|
||||
}
|
||||
leia: human(id: "1003") {
|
||||
name
|
||||
homePlanet
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName, tatooine]
|
||||
, "leia" .= object [leiaName, alderaan]
|
||||
]]
|
||||
it "Fragment for duplicate content" $ testQuery
|
||||
[r| query UseFragment {
|
||||
luke: human(id: "1000") {
|
||||
...HumanFragment
|
||||
}
|
||||
leia: human(id: "1003") {
|
||||
...HumanFragment
|
||||
}
|
||||
}
|
||||
fragment HumanFragment on Human {
|
||||
name
|
||||
homePlanet
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName, tatooine]
|
||||
, "leia" .= object [leiaName, alderaan]
|
||||
]]
|
||||
|
||||
describe "__typename" $ do
|
||||
it "R2D2 is a Droid" $ testQuery
|
||||
[r| query CheckTypeOfR2 {
|
||||
hero {
|
||||
__typename
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]
|
||||
]]
|
||||
it "Luke is a human" $ testQuery
|
||||
[r| query CheckTypeOfLuke {
|
||||
hero(episode: EMPIRE) {
|
||||
__typename
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"hero" .= object ["__typename" .= ("Human" :: Text), lukeName]
|
||||
]]
|
||||
|
||||
describe "Errors in resolvers" $ do
|
||||
it "error on secretBackstory" $ testQuery
|
||||
[r|
|
||||
query HeroNameQuery {
|
||||
hero {
|
||||
name
|
||||
secretBackstory
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object
|
||||
[ "data" .= object
|
||||
[ "hero" .= object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object
|
||||
["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
it "Error in a list" $ testQuery
|
||||
[r| query HeroNameQuery {
|
||||
hero {
|
||||
name
|
||||
friends {
|
||||
name
|
||||
secretBackstory
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object
|
||||
[ "hero" .= object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "friends" .=
|
||||
[ object
|
||||
[ "name" .= ("Luke Skywalker" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
, object
|
||||
[ "name" .= ("Han Solo" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
, object
|
||||
[ "name" .= ("Leia Organa" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
it "error on secretBackstory with alias" $ testQuery
|
||||
[r| query HeroNameQuery {
|
||||
mainHero: hero {
|
||||
name
|
||||
story: secretBackstory
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object
|
||||
[ "data" .= object
|
||||
[ "mainHero" .= object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "story" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
|
||||
where
|
||||
lukeName = "name" .= ("Luke Skywalker" :: Text)
|
||||
leiaName = "name" .= ("Leia Organa" :: Text)
|
||||
hanName = "name" .= ("Han Solo" :: Text)
|
||||
r2d2Name = "name" .= ("R2-D2" :: Text)
|
||||
c3poName = "name" .= ("C-3PO" :: Text)
|
||||
tatooine = "homePlanet" .= ("Tatooine" :: Text)
|
||||
alderaan = "homePlanet" .= ("Alderaan" :: Text)
|
||||
|
||||
testQuery :: Text -> Aeson.Value -> Expectation
|
||||
testQuery q expected = graphql schema q >>= flip shouldBe expected
|
||||
|
||||
testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
|
||||
testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected
|
|
@ -0,0 +1,63 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Test.StarWars.Schema
|
||||
( character
|
||||
, droid
|
||||
, hero
|
||||
, human
|
||||
, schema
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Language.GraphQL.Schema ( Schema
|
||||
, Resolver
|
||||
, Argument(..)
|
||||
, Value(..)
|
||||
)
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Language.GraphQL.Trans
|
||||
import Language.GraphQL.Type
|
||||
import Test.StarWars.Data
|
||||
|
||||
-- * Schema
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||
|
||||
schema :: MonadIO m => Schema m
|
||||
schema = hero :| [human, droid]
|
||||
|
||||
hero :: MonadIO m => Resolver m
|
||||
hero = Schema.objectA "hero" $ \case
|
||||
[] -> character artoo
|
||||
[Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
|
||||
[Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
|
||||
[Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
human :: MonadIO m => Resolver m
|
||||
human = Schema.wrappedObjectA "human" $ \case
|
||||
[Argument "id" (ValueString i)] -> do
|
||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||
case humanCharacter of
|
||||
Nothing -> return Null
|
||||
Just e -> Named <$> character e
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
droid :: MonadIO m => Resolver m
|
||||
droid = Schema.objectA "droid" $ \case
|
||||
[Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i)
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
character :: MonadIO m => Character -> ActionT m [Resolver m]
|
||||
character char = return
|
||||
[ Schema.scalar "id" $ return $ id_ char
|
||||
, Schema.scalar "name" $ return $ name char
|
||||
, Schema.wrappedObject "friends"
|
||||
$ traverse character $ List $ Named <$> getFriends char
|
||||
, Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
|
||||
, Schema.scalar "secretBackstory" $ secretBackstory char
|
||||
, Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
|
||||
, Schema.scalar "__typename" $ return $ typeName char
|
||||
]
|
|
@ -1,28 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Data.Attoparsec.Text (parseOnly)
|
||||
import qualified Data.Text.IO as Text
|
||||
import Test.Tasty (defaultMain)
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import qualified Data.GraphQL.Parser as Parser
|
||||
import qualified Data.GraphQL.Encoder as Encoder
|
||||
|
||||
import Paths_graphql (getDataFileName)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain =<< testCase "Kitchen Sink"
|
||||
<$> (assertEqual "Encode" <$> expected <*> actual)
|
||||
where
|
||||
expected = Text.readFile
|
||||
=<< getDataFileName "tests/data/kitchen-sink.min.graphql"
|
||||
|
||||
actual = either (error "Parsing error!") Encoder.document
|
||||
<$> parseOnly Parser.document
|
||||
<$> expected
|
Loading…
Reference in New Issue