├── .ghci ├── .gitignore ├── .travis.yml ├── AUTHORS.md ├── CHANGELOG.md ├── Data ├── GraphQL.hs └── GraphQL │ ├── AST.hs │ ├── AST │ ├── Core.hs │ └── Transform.hs │ ├── Encoder.hs │ ├── Error.hs │ ├── Execute.hs │ ├── Parser.hs │ └── Schema.hs ├── LICENSE ├── README.md ├── Setup.hs ├── TODO ├── docs └── tutorial │ ├── Makefile │ ├── tutorial.css │ ├── tutorial.html │ ├── tutorial.lhs │ ├── tutorial.pdf │ └── tutorial.rst ├── graphql.cabal ├── stack.yaml └── tests ├── Test └── StarWars │ ├── Data.hs │ ├── QueryTests.hs │ └── Schema.hs ├── data ├── kitchen-sink.graphql └── kitchen-sink.min.graphql └── tasty.hs /.ghci: -------------------------------------------------------------------------------- 1 | import Data.Attoparsec.Text 2 | import qualified Data.Text.IO as TIO 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .cabal-sandbox/ 3 | cabal.sandbox.config 4 | dist/ 5 | TAGS 6 | .#* 7 | .DS_Store 8 | cabal.project.local 9 | dist-newstyle/ 10 | dist-newstyle/ 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.22 GHCVER=7.10.3 17 | compiler: ": #GHC 7.10.3" 18 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 19 | - env: CABALVER=1.24 GHCVER=8.0.1 20 | compiler: ": #GHC 8.0.1" 21 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} 22 | 23 | before_install: 24 | - unset CC 25 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 26 | 27 | install: 28 | - cabal --version 29 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 30 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 31 | then 32 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 33 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 34 | fi 35 | - travis_retry cabal update -v 36 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 37 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 38 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 39 | 40 | # check whether current requested install-plan matches cached package-db snapshot 41 | - if diff -u $HOME/.cabsnap/installplan.txt installplan.txt; 42 | then 43 | echo "cabal build-cache HIT"; 44 | rm -rfv .ghc; 45 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 46 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 47 | else 48 | echo "cabal build-cache MISS"; 49 | rm -rf $HOME/.cabsnap; 50 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 51 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 52 | fi 53 | 54 | # snapshot package-db on cache miss 55 | - if [ ! -d $HOME/.cabsnap ]; 56 | then 57 | echo "snapshotting package-db to build-cache"; 58 | mkdir $HOME/.cabsnap; 59 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 60 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 61 | fi 62 | 63 | # Here starts the actual work to be performed for the package under test; 64 | # any command which exits with a non-zero exit code causes the build to fail. 65 | script: 66 | - if [ -f configure.ac ]; then autoreconf -i; fi 67 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 68 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 69 | - cabal test 70 | - cabal check 71 | - cabal sdist # tests that a source-distribution can be generated 72 | 73 | # Check that the resulting source distribution can be built & installed. 74 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 75 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 76 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 77 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 78 | 79 | # EOF 80 | -------------------------------------------------------------------------------- /AUTHORS.md: -------------------------------------------------------------------------------- 1 | The following people have participated in creating this library, either by 2 | directly contributing code, by providing thoughtful input in discussions about 3 | the library design, or somehow else. In order of appearance: 4 | 5 | - [Danny Navarro](mailto:j@dannynavarro.net) - [@jdnavarro](https://github.com/jdnavarro) 6 | - [Matthías Páll Gissurarson](mailto:mpg@mpg.is) - [@Tritlo](https://github.com/Tritlo) 7 | - [Sólrún Halla Einarsdóttir](mailto:she@mpg.is) - [@solrun](https://github.com/solrun) 8 | - [Pweaver (Paul Weaver)] (mailto:paul@mordor.org) - [@pweaver](https://github.com/pweaver) 9 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | All notable changes to this project will be documented in this file. 3 | 4 | ## [0.3] - 2015-09-22 5 | ### Changed 6 | - Exact match numeric types to spec. 7 | - Names follow now the spec. 8 | - AST slightly different for better readability or easier parsing. 9 | - Replace golden test for test to validate parsing/encoding. 10 | 11 | ### Added 12 | - Parsing errors in all cases where `Alternative` is used. 13 | - GraphQL encoder. 14 | 15 | ### Fixed 16 | - Expect braces `inputValueDefinitions` instead of parens when parsing. 17 | 18 | ## [0.2.1] - 2015-09-16 19 | ### Fixed 20 | - Include data files for golden tests in Cabal package. 21 | - Support for ghc-7.8. 22 | 23 | ## [0.2] - 2015-09-14 24 | ### Added 25 | - Rudimentary parser for `GraphQL` which successfully parses the sample file 26 | `kitchen-sink.graphql` from `graphql-js` tests. 27 | - Golden test for `kitchen-sink.grahql` parsing. 28 | ### Changed 29 | - Many optional data types in `GraphQl` didn't need to be wrapped in a `Maybe`. 30 | - Some `newtype`s became type synonyms for easier parsing. 31 | 32 | ## 0.1 - 2015-09-12 33 | ### Added 34 | - Data types for the GraphQL language. 35 | 36 | [0.3]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2.1...v0.3 37 | [0.2.1]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2...v0.2.1 38 | [0.2]: https://github.com/jdnavarro/graphql-haskell/compare/v0.1...v0.2 39 | -------------------------------------------------------------------------------- /Data/GraphQL.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides the functions to parse and execute @GraphQL@ queries. 2 | module Data.GraphQL where 3 | 4 | import Control.Applicative (Alternative) 5 | 6 | import Data.Text (Text) 7 | 8 | import qualified Data.Aeson as Aeson 9 | import qualified Data.Attoparsec.Text as Attoparsec 10 | 11 | import Data.GraphQL.Execute 12 | import Data.GraphQL.Parser 13 | import Data.GraphQL.Schema 14 | 15 | import Data.GraphQL.Error 16 | 17 | -- | Takes a 'Schema' and text representing a @GraphQL@ request document. 18 | -- If the text parses correctly as a @GraphQL@ query the query is 19 | -- executed according to the given 'Schema'. 20 | -- 21 | -- Returns the response as an @Aeson.@'Aeson.Value'. 22 | graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value 23 | graphql = flip graphqlSubs $ const Nothing 24 | 25 | -- | Takes a 'Schema', a variable substitution function and text 26 | -- representing a @GraphQL@ request document. If the text parses 27 | -- correctly as a @GraphQL@ query the substitution is applied to the 28 | -- query and the query is then executed according to the given 'Schema'. 29 | -- 30 | -- Returns the response as an @Aeson.@'Aeson.Value'. 31 | graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value 32 | graphqlSubs schema f = 33 | either parseError (execute schema f) 34 | . Attoparsec.parseOnly document 35 | -------------------------------------------------------------------------------- /Data/GraphQL/AST.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines an abstract syntax tree for the @GraphQL@ language based on 2 | -- . 3 | -- 4 | -- Target AST for Parser. 5 | 6 | module Data.GraphQL.AST where 7 | 8 | import Data.Int (Int32) 9 | import Data.List.NonEmpty (NonEmpty) 10 | import Data.Text (Text) 11 | 12 | -- * Name 13 | 14 | type Name = Text 15 | 16 | -- * Document 17 | 18 | type Document = NonEmpty Definition 19 | 20 | -- * Operations 21 | 22 | data Definition = DefinitionOperation OperationDefinition 23 | | DefinitionFragment FragmentDefinition 24 | deriving (Eq,Show) 25 | 26 | data OperationDefinition = OperationSelectionSet SelectionSet 27 | | OperationDefinition OperationType 28 | (Maybe Name) 29 | VariableDefinitions 30 | Directives 31 | SelectionSet 32 | deriving (Eq,Show) 33 | 34 | data OperationType = Query | Mutation deriving (Eq,Show) 35 | 36 | -- * SelectionSet 37 | 38 | type SelectionSet = NonEmpty Selection 39 | 40 | type SelectionSetOpt = [Selection] 41 | 42 | data Selection = SelectionField Field 43 | | SelectionFragmentSpread FragmentSpread 44 | | SelectionInlineFragment InlineFragment 45 | deriving (Eq,Show) 46 | 47 | -- * Field 48 | 49 | data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt 50 | deriving (Eq,Show) 51 | 52 | type Alias = Name 53 | 54 | -- * Arguments 55 | 56 | type Arguments = [Argument] 57 | 58 | data Argument = Argument Name Value deriving (Eq,Show) 59 | 60 | -- * Fragments 61 | 62 | data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show) 63 | 64 | data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet 65 | deriving (Eq,Show) 66 | 67 | data FragmentDefinition = 68 | FragmentDefinition FragmentName TypeCondition Directives SelectionSet 69 | deriving (Eq,Show) 70 | 71 | type FragmentName = Name 72 | 73 | type TypeCondition = Name 74 | 75 | -- Input Values 76 | 77 | data Value = ValueVariable Variable 78 | | ValueInt IntValue 79 | | ValueFloat FloatValue 80 | | ValueString StringValue 81 | | ValueBoolean BooleanValue 82 | | ValueNull 83 | | ValueEnum EnumValue 84 | | ValueList ListValue 85 | | ValueObject ObjectValue 86 | deriving (Eq,Show) 87 | 88 | type IntValue = Int32 89 | 90 | -- GraphQL Float is double precison 91 | type FloatValue = Double 92 | 93 | type StringValue = Text 94 | 95 | type BooleanValue = Bool 96 | 97 | type EnumValue = Name 98 | 99 | type ListValue = [Value] 100 | 101 | type ObjectValue = [ObjectField] 102 | 103 | data ObjectField = ObjectField Name Value deriving (Eq,Show) 104 | 105 | -- * Variables 106 | 107 | type VariableDefinitions = [VariableDefinition] 108 | 109 | data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) 110 | deriving (Eq,Show) 111 | 112 | type Variable = Name 113 | 114 | type DefaultValue = Value 115 | 116 | -- * Input Types 117 | 118 | data Type = TypeNamed Name 119 | | TypeList Type 120 | | TypeNonNull NonNullType 121 | deriving (Eq,Show) 122 | 123 | data NonNullType = NonNullTypeNamed Name 124 | | NonNullTypeList Type 125 | deriving (Eq,Show) 126 | 127 | -- * Directives 128 | 129 | type Directives = [Directive] 130 | 131 | data Directive = Directive Name [Argument] deriving (Eq,Show) 132 | -------------------------------------------------------------------------------- /Data/GraphQL/AST/Core.hs: -------------------------------------------------------------------------------- 1 | -- | This is the AST meant to be executed. 2 | module Data.GraphQL.AST.Core where 3 | 4 | import Data.Int (Int32) 5 | import Data.List.NonEmpty (NonEmpty) 6 | import Data.String 7 | 8 | import Data.Text (Text) 9 | 10 | type Name = Text 11 | 12 | type Document = NonEmpty Operation 13 | 14 | data Operation = Query (NonEmpty Field) 15 | | Mutation (NonEmpty Field) 16 | deriving (Eq,Show) 17 | 18 | data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show) 19 | 20 | type Alias = Name 21 | 22 | data Argument = Argument Name Value deriving (Eq,Show) 23 | 24 | data Value = ValueInt Int32 25 | -- GraphQL Float is double precision 26 | | ValueFloat Double 27 | | ValueString Text 28 | | ValueBoolean Bool 29 | | ValueNull 30 | | ValueEnum Name 31 | | ValueList [Value] 32 | | ValueObject [ObjectField] 33 | deriving (Eq,Show) 34 | 35 | instance IsString Value where 36 | fromString = ValueString . fromString 37 | 38 | data ObjectField = ObjectField Name Value deriving (Eq,Show) 39 | -------------------------------------------------------------------------------- /Data/GraphQL/AST/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.GraphQL.AST.Transform where 3 | 4 | import Control.Applicative (empty) 5 | import Control.Monad ((<=<)) 6 | import Data.Bifunctor (first) 7 | import Data.Either (partitionEithers) 8 | import Data.Foldable (fold, foldMap) 9 | import qualified Data.List.NonEmpty as NonEmpty 10 | import Data.Monoid (Alt(Alt,getAlt), (<>)) 11 | 12 | import Data.Text (Text) 13 | 14 | import qualified Data.GraphQL.AST as Full 15 | import qualified Data.GraphQL.AST.Core as Core 16 | import qualified Data.GraphQL.Schema as Schema 17 | 18 | type Name = Text 19 | 20 | -- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an 21 | -- empty list is returned. 22 | type Fragmenter = Name -> [Core.Field] 23 | 24 | -- TODO: Replace Maybe by MonadThrow with CustomError 25 | document :: Schema.Subs -> Full.Document -> Maybe Core.Document 26 | document subs doc = operations subs fr ops 27 | where 28 | (fr, ops) = first foldFrags 29 | . partitionEithers 30 | . NonEmpty.toList 31 | $ defrag subs 32 | <$> doc 33 | 34 | foldFrags :: [Fragmenter] -> Fragmenter 35 | foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs 36 | 37 | -- * Operation 38 | 39 | -- TODO: Replace Maybe by MonadThrow CustomError 40 | operations 41 | :: Schema.Subs 42 | -> Fragmenter 43 | -> [Full.OperationDefinition] 44 | -> Maybe Core.Document 45 | operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr) 46 | 47 | -- TODO: Replace Maybe by MonadThrow CustomError 48 | operation 49 | :: Schema.Subs 50 | -> Fragmenter 51 | -> Full.OperationDefinition 52 | -> Maybe Core.Operation 53 | operation subs fr (Full.OperationSelectionSet sels) = 54 | operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels 55 | -- TODO: Validate Variable definitions with substituter 56 | operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) = 57 | case ot of 58 | Full.Query -> Core.Query <$> node 59 | Full.Mutation -> Core.Mutation <$> node 60 | where 61 | node = traverse (hush . selection subs fr) sels 62 | 63 | selection 64 | :: Schema.Subs 65 | -> Fragmenter 66 | -> Full.Selection 67 | -> Either [Core.Field] Core.Field 68 | selection subs fr (Full.SelectionField fld) = 69 | Right $ field subs fr fld 70 | selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = 71 | Left $ fr n 72 | selection _ _ (Full.SelectionInlineFragment _) = 73 | error "Inline fragments not supported yet" 74 | 75 | -- * Fragment replacement 76 | 77 | -- | Extract Fragments into a single Fragmenter function and a Operation 78 | -- Definition. 79 | defrag 80 | :: Schema.Subs 81 | -> Full.Definition 82 | -> Either Fragmenter Full.OperationDefinition 83 | defrag _ (Full.DefinitionOperation op) = 84 | Right op 85 | defrag subs (Full.DefinitionFragment fragDef) = 86 | Left $ fragmentDefinition subs fragDef 87 | 88 | fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter 89 | fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' = 90 | -- TODO: Support fragments within fragments. Fold instead of map. 91 | if name == name' 92 | then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels) 93 | else empty 94 | 95 | field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field 96 | field subs fr (Full.Field a n args _dirs sels) = 97 | Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels) 98 | where 99 | go :: Full.Selection -> [Core.Field] -> [Core.Field] 100 | go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>) 101 | go sel = (either id pure (selection subs fr sel) <>) 102 | 103 | argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument 104 | argument subs (Full.Argument n v) = Core.Argument n <$> value subs v 105 | 106 | value :: Schema.Subs -> Full.Value -> Maybe Core.Value 107 | value subs (Full.ValueVariable n) = subs n 108 | value _ (Full.ValueInt i) = pure $ Core.ValueInt i 109 | value _ (Full.ValueFloat f) = pure $ Core.ValueFloat f 110 | value _ (Full.ValueString x) = pure $ Core.ValueString x 111 | value _ (Full.ValueBoolean b) = pure $ Core.ValueBoolean b 112 | value _ Full.ValueNull = pure Core.ValueNull 113 | value _ (Full.ValueEnum e) = pure $ Core.ValueEnum e 114 | value subs (Full.ValueList l) = 115 | Core.ValueList <$> traverse (value subs) l 116 | value subs (Full.ValueObject o) = 117 | Core.ValueObject <$> traverse (objectField subs) o 118 | 119 | objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField 120 | objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v 121 | 122 | hush :: Either a b -> Maybe b 123 | hush = either (const Nothing) Just 124 | -------------------------------------------------------------------------------- /Data/GraphQL/Encoder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | This module defines a printer for the @GraphQL@ language. 3 | module Data.GraphQL.Encoder where 4 | 5 | import Data.Foldable (fold) 6 | import Data.Monoid ((<>)) 7 | import qualified Data.List.NonEmpty as NonEmpty (toList) 8 | 9 | import Data.Text (Text, cons, intercalate, pack, snoc) 10 | 11 | import Data.GraphQL.AST 12 | 13 | -- * Document 14 | 15 | document :: Document -> Text 16 | document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs 17 | 18 | definition :: Definition -> Text 19 | definition (DefinitionOperation x) = operationDefinition x 20 | definition (DefinitionFragment x) = fragmentDefinition x 21 | 22 | operationDefinition :: OperationDefinition -> Text 23 | operationDefinition (OperationSelectionSet sels) = selectionSet sels 24 | operationDefinition (OperationDefinition Query name vars dirs sels) = 25 | "query " <> node (fold name) vars dirs sels 26 | operationDefinition (OperationDefinition Mutation name vars dirs sels) = 27 | "mutation " <> node (fold name) vars dirs sels 28 | 29 | node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text 30 | node name vars dirs sels = 31 | name 32 | <> optempty variableDefinitions vars 33 | <> optempty directives dirs 34 | <> selectionSet sels 35 | 36 | variableDefinitions :: [VariableDefinition] -> Text 37 | variableDefinitions = parensCommas variableDefinition 38 | 39 | variableDefinition :: VariableDefinition -> Text 40 | variableDefinition (VariableDefinition var ty dv) = 41 | variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv 42 | 43 | defaultValue :: DefaultValue -> Text 44 | defaultValue val = "=" <> value val 45 | 46 | variable :: Variable -> Text 47 | variable var = "$" <> var 48 | 49 | selectionSet :: SelectionSet -> Text 50 | selectionSet = bracesCommas selection . NonEmpty.toList 51 | 52 | selectionSetOpt :: SelectionSetOpt -> Text 53 | selectionSetOpt = bracesCommas selection 54 | 55 | selection :: Selection -> Text 56 | selection (SelectionField x) = field x 57 | selection (SelectionInlineFragment x) = inlineFragment x 58 | selection (SelectionFragmentSpread x) = fragmentSpread x 59 | 60 | field :: Field -> Text 61 | field (Field alias name args dirs selso) = 62 | optempty (`snoc` ':') (fold alias) 63 | <> name 64 | <> optempty arguments args 65 | <> optempty directives dirs 66 | <> optempty selectionSetOpt selso 67 | 68 | arguments :: [Argument] -> Text 69 | arguments = parensCommas argument 70 | 71 | argument :: Argument -> Text 72 | argument (Argument name v) = name <> ":" <> value v 73 | 74 | -- * Fragments 75 | 76 | fragmentSpread :: FragmentSpread -> Text 77 | fragmentSpread (FragmentSpread name ds) = 78 | "..." <> name <> optempty directives ds 79 | 80 | inlineFragment :: InlineFragment -> Text 81 | inlineFragment (InlineFragment tc dirs sels) = 82 | "... on " <> fold tc 83 | <> directives dirs 84 | <> selectionSet sels 85 | 86 | fragmentDefinition :: FragmentDefinition -> Text 87 | fragmentDefinition (FragmentDefinition name tc dirs sels) = 88 | "fragment " <> name <> " on " <> tc 89 | <> optempty directives dirs 90 | <> selectionSet sels 91 | 92 | -- * Values 93 | 94 | value :: Value -> Text 95 | value (ValueVariable x) = variable x 96 | -- TODO: This will be replaced with `decimal` Builder 97 | value (ValueInt x) = pack $ show x 98 | -- TODO: This will be replaced with `decimal` Builder 99 | value (ValueFloat x) = pack $ show x 100 | value (ValueBoolean x) = booleanValue x 101 | value ValueNull = mempty 102 | value (ValueString x) = stringValue x 103 | value (ValueEnum x) = x 104 | value (ValueList x) = listValue x 105 | value (ValueObject x) = objectValue x 106 | 107 | booleanValue :: Bool -> Text 108 | booleanValue True = "true" 109 | booleanValue False = "false" 110 | 111 | -- TODO: Escape characters 112 | stringValue :: Text -> Text 113 | stringValue = quotes 114 | 115 | listValue :: ListValue -> Text 116 | listValue = bracketsCommas value 117 | 118 | objectValue :: ObjectValue -> Text 119 | objectValue = bracesCommas objectField 120 | 121 | objectField :: ObjectField -> Text 122 | objectField (ObjectField name v) = name <> ":" <> value v 123 | 124 | -- * Directives 125 | 126 | directives :: [Directive] -> Text 127 | directives = spaces directive 128 | 129 | directive :: Directive -> Text 130 | directive (Directive name args) = "@" <> name <> optempty arguments args 131 | 132 | -- * Type Reference 133 | 134 | type_ :: Type -> Text 135 | type_ (TypeNamed x) = x 136 | type_ (TypeList x) = listType x 137 | type_ (TypeNonNull x) = nonNullType x 138 | 139 | listType :: Type -> Text 140 | listType x = brackets (type_ x) 141 | 142 | nonNullType :: NonNullType -> Text 143 | nonNullType (NonNullTypeNamed x) = x <> "!" 144 | nonNullType (NonNullTypeList x) = listType x <> "!" 145 | 146 | -- * Internal 147 | 148 | spaced :: Text -> Text 149 | spaced = cons '\SP' 150 | 151 | between :: Char -> Char -> Text -> Text 152 | between open close = cons open . (`snoc` close) 153 | 154 | parens :: Text -> Text 155 | parens = between '(' ')' 156 | 157 | brackets :: Text -> Text 158 | brackets = between '[' ']' 159 | 160 | braces :: Text -> Text 161 | braces = between '{' '}' 162 | 163 | quotes :: Text -> Text 164 | quotes = between '"' '"' 165 | 166 | spaces :: (a -> Text) -> [a] -> Text 167 | spaces f = intercalate "\SP" . fmap f 168 | 169 | parensCommas :: (a -> Text) -> [a] -> Text 170 | parensCommas f = parens . intercalate "," . fmap f 171 | 172 | bracketsCommas :: (a -> Text) -> [a] -> Text 173 | bracketsCommas f = brackets . intercalate "," . fmap f 174 | 175 | bracesCommas :: (a -> Text) -> [a] -> Text 176 | bracesCommas f = braces . intercalate "," . fmap f 177 | 178 | optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b 179 | optempty f xs = if xs == mempty then mempty else f xs 180 | -------------------------------------------------------------------------------- /Data/GraphQL/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.GraphQL.Error ( 3 | parseError, 4 | CollectErrsT, 5 | addErr, 6 | addErrMsg, 7 | runCollectErrs, 8 | joinErrs, 9 | errWrap 10 | ) where 11 | 12 | import qualified Data.Aeson as Aeson 13 | import Data.Text (Text, pack) 14 | 15 | import Control.Arrow ((&&&)) 16 | 17 | -- | Wraps a parse error into a list of errors. 18 | parseError :: Applicative f => String -> f Aeson.Value 19 | parseError s = 20 | pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])] 21 | 22 | -- | A wrapper for an 'Applicative' to pass error messages around. 23 | type CollectErrsT f a = f (a,[Aeson.Value]) 24 | 25 | -- | Takes a (wrapped) list (foldable functor) of values and errors, 26 | -- joins the values into a list and concatenates the errors. 27 | joinErrs 28 | :: (Functor m, Functor f, Foldable f) 29 | => m (f (a,[Aeson.Value])) -> CollectErrsT m (f a) 30 | joinErrs = fmap $ fmap fst &&& concatMap snd 31 | 32 | -- | Wraps the given 'Applicative' to handle errors 33 | errWrap :: Functor f => f a -> f (a, [Aeson.Value]) 34 | errWrap = fmap (flip (,) []) 35 | 36 | -- | Adds an error to the list of errors. 37 | addErr :: Functor f => Aeson.Value -> CollectErrsT f a -> CollectErrsT f a 38 | addErr v = (fmap . fmap) (v :) 39 | 40 | makeErrorMsg :: Text -> Aeson.Value 41 | makeErrorMsg s = Aeson.object [("message",Aeson.toJSON s)] 42 | 43 | -- | Convenience function for just wrapping an error message. 44 | addErrMsg :: Functor f => Text -> CollectErrsT f a -> CollectErrsT f a 45 | addErrMsg = addErr . makeErrorMsg 46 | 47 | -- | Runs the given query, but collects the errors into an error 48 | -- list which is then sent back with the data. 49 | runCollectErrs :: Functor f => CollectErrsT f Aeson.Value -> f Aeson.Value 50 | runCollectErrs = fmap finalD 51 | where 52 | finalD (dat,errs) = 53 | Aeson.object 54 | $ if null errs 55 | then [("data",dat)] 56 | else [("data",dat),("errors",Aeson.toJSON $ reverse errs)] 57 | -------------------------------------------------------------------------------- /Data/GraphQL/Execute.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | This module provides the function to execute a @GraphQL@ request -- 3 | -- according to a 'Schema'. 4 | module Data.GraphQL.Execute (execute) where 5 | 6 | import Control.Applicative (Alternative, empty) 7 | import qualified Data.List.NonEmpty as NE 8 | import Data.List.NonEmpty (NonEmpty((:|))) 9 | 10 | import qualified Data.Aeson as Aeson 11 | import qualified Data.HashMap.Strict as HashMap 12 | 13 | import qualified Data.GraphQL.AST as AST 14 | import qualified Data.GraphQL.AST.Core as AST.Core 15 | import qualified Data.GraphQL.AST.Transform as Transform 16 | import Data.GraphQL.Schema (Schema) 17 | import qualified Data.GraphQL.Schema as Schema 18 | 19 | -- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a 20 | -- @GraphQL@ 'document'. The substitution is applied to the document using 21 | -- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields. 22 | -- 23 | -- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or 24 | -- errors wrapped in an /errors/ field. 25 | execute 26 | :: (Alternative f, Monad f) 27 | => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value 28 | execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc) 29 | 30 | document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value 31 | document schema (op :| []) = operation schema op 32 | document _ _ = error "Multiple operations not supported yet" 33 | 34 | operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value 35 | operation schema (AST.Core.Query flds) = 36 | Aeson.Object . HashMap.singleton "data" 37 | <$> Schema.resolve (NE.toList schema) (NE.toList flds) 38 | operation _ _ = error "Mutations not supported yet" 39 | -------------------------------------------------------------------------------- /Data/GraphQL/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | -- | This module defines a parser for @GraphQL@ request documents. 4 | module Data.GraphQL.Parser where 5 | 6 | import Prelude hiding (takeWhile) 7 | 8 | import Control.Applicative ((<|>), Alternative, empty, many, optional) 9 | import Control.Monad (when) 10 | import Data.Char (isDigit, isSpace) 11 | import Data.Foldable (traverse_) 12 | import Data.Monoid ((<>)) 13 | import Data.List.NonEmpty (NonEmpty((:|))) 14 | import Data.Scientific (floatingOrInteger, scientific, toBoundedInteger) 15 | 16 | import Data.Text (Text, append) 17 | import Data.Attoparsec.Combinator (lookAhead) 18 | import Data.Attoparsec.Text 19 | ( Parser 20 | , () 21 | , anyChar 22 | , endOfLine 23 | , inClass 24 | , many1 25 | , manyTill 26 | , option 27 | , peekChar 28 | , takeWhile 29 | , takeWhile1 30 | ) 31 | import qualified Data.Attoparsec.Text as Attoparsec (scientific) 32 | 33 | import Data.GraphQL.AST 34 | 35 | -- * Name 36 | 37 | name :: Parser Name 38 | name = tok $ append <$> takeWhile1 isA_z 39 | <*> takeWhile ((||) <$> isDigit <*> isA_z) 40 | where 41 | -- `isAlpha` handles many more Unicode Chars 42 | isA_z = inClass $ '_' : ['A'..'Z'] <> ['a'..'z'] 43 | 44 | -- * Document 45 | 46 | document :: Parser Document 47 | document = whiteSpace *> manyNE definition 48 | 49 | definition :: Parser Definition 50 | definition = DefinitionOperation <$> operationDefinition 51 | <|> DefinitionFragment <$> fragmentDefinition 52 | "definition error!" 53 | 54 | operationDefinition :: Parser OperationDefinition 55 | operationDefinition = OperationSelectionSet <$> selectionSet 56 | <|> OperationDefinition <$> operationType 57 | <*> optional name 58 | <*> opt variableDefinitions 59 | <*> opt directives 60 | <*> selectionSet 61 | "operationDefinition error" 62 | 63 | operationType :: Parser OperationType 64 | operationType = Query <$ tok "query" 65 | <|> Mutation <$ tok "mutation" 66 | "operationType error" 67 | 68 | -- * SelectionSet 69 | 70 | selectionSet :: Parser SelectionSet 71 | selectionSet = braces $ manyNE selection 72 | 73 | selectionSetOpt :: Parser SelectionSetOpt 74 | selectionSetOpt = braces $ many1 selection 75 | 76 | selection :: Parser Selection 77 | selection = SelectionField <$> field 78 | <|> SelectionFragmentSpread <$> fragmentSpread 79 | <|> SelectionInlineFragment <$> inlineFragment 80 | "selection error!" 81 | 82 | -- * Field 83 | 84 | field :: Parser Field 85 | field = Field <$> optional alias 86 | <*> name 87 | <*> opt arguments 88 | <*> opt directives 89 | <*> opt selectionSetOpt 90 | 91 | alias :: Parser Alias 92 | alias = name <* tok ":" 93 | 94 | -- * Arguments 95 | 96 | arguments :: Parser Arguments 97 | arguments = parens $ many1 argument 98 | 99 | argument :: Parser Argument 100 | argument = Argument <$> name <* tok ":" <*> value 101 | 102 | -- * Fragments 103 | 104 | fragmentSpread :: Parser FragmentSpread 105 | fragmentSpread = FragmentSpread <$ tok "..." 106 | <*> fragmentName 107 | <*> opt directives 108 | 109 | inlineFragment :: Parser InlineFragment 110 | inlineFragment = InlineFragment <$ tok "..." 111 | <*> optional typeCondition 112 | <*> opt directives 113 | <*> selectionSet 114 | 115 | fragmentDefinition :: Parser FragmentDefinition 116 | fragmentDefinition = FragmentDefinition 117 | <$ tok "fragment" 118 | <*> name 119 | <*> typeCondition 120 | <*> opt directives 121 | <*> selectionSet 122 | 123 | fragmentName :: Parser FragmentName 124 | fragmentName = but (tok "on") *> name 125 | 126 | typeCondition :: Parser TypeCondition 127 | typeCondition = tok "on" *> name 128 | 129 | -- * Input Values 130 | 131 | value :: Parser Value 132 | value = ValueVariable <$> variable 133 | <|> tok floatOrInt32Value 134 | <|> ValueBoolean <$> booleanValue 135 | <|> ValueNull <$ tok "null" 136 | <|> ValueString <$> stringValue 137 | <|> ValueEnum <$> enumValue 138 | <|> ValueList <$> listValue 139 | <|> ValueObject <$> objectValue 140 | "value error!" 141 | where 142 | booleanValue :: Parser Bool 143 | booleanValue = True <$ tok "true" 144 | <|> False <$ tok "false" 145 | 146 | floatOrInt32Value :: Parser Value 147 | floatOrInt32Value = 148 | Attoparsec.scientific >>= 149 | either (pure . ValueFloat) 150 | (maybe (fail "Integer value is out of range.") 151 | (pure . ValueInt) 152 | . toBoundedInteger . (`scientific` 0)) 153 | . floatingOrInteger 154 | 155 | -- TODO: Escape characters. Look at `jsstring_` in aeson package. 156 | stringValue :: Parser Text 157 | stringValue = quotes (takeWhile (/= '"')) 158 | 159 | enumValue :: Parser Name 160 | enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name 161 | 162 | listValue :: Parser [Value] 163 | listValue = brackets $ many1 value 164 | 165 | objectValue :: Parser [ObjectField] 166 | objectValue = braces $ many1 objectField 167 | 168 | objectField :: Parser ObjectField 169 | objectField = ObjectField <$> name <* tok ":" <*> value 170 | 171 | -- * Variables 172 | 173 | variableDefinitions :: Parser VariableDefinitions 174 | variableDefinitions = parens $ many1 variableDefinition 175 | 176 | variableDefinition :: Parser VariableDefinition 177 | variableDefinition = VariableDefinition <$> variable 178 | <* tok ":" 179 | <*> type_ 180 | <*> optional defaultValue 181 | 182 | variable :: Parser Variable 183 | variable = tok "$" *> name 184 | 185 | defaultValue :: Parser DefaultValue 186 | defaultValue = tok "=" *> value 187 | 188 | -- * Input Types 189 | 190 | type_ :: Parser Type 191 | type_ = TypeNamed <$> name <* but "!" 192 | <|> TypeList <$> brackets type_ 193 | <|> TypeNonNull <$> nonNullType 194 | "type_ error!" 195 | 196 | nonNullType :: Parser NonNullType 197 | nonNullType = NonNullTypeNamed <$> name <* tok "!" 198 | <|> NonNullTypeList <$> brackets type_ <* tok "!" 199 | "nonNullType error!" 200 | 201 | -- * Directives 202 | 203 | directives :: Parser Directives 204 | directives = many1 directive 205 | 206 | directive :: Parser Directive 207 | directive = Directive 208 | <$ tok "@" 209 | <*> name 210 | <*> opt arguments 211 | 212 | -- * Internal 213 | 214 | tok :: Parser a -> Parser a 215 | tok p = p <* whiteSpace 216 | 217 | parens :: Parser a -> Parser a 218 | parens = between "(" ")" 219 | 220 | braces :: Parser a -> Parser a 221 | braces = between "{" "}" 222 | 223 | quotes :: Parser a -> Parser a 224 | quotes = between "\"" "\"" 225 | 226 | brackets :: Parser a -> Parser a 227 | brackets = between "[" "]" 228 | 229 | between :: Parser Text -> Parser Text -> Parser a -> Parser a 230 | between open close p = tok open *> p <* tok close 231 | 232 | opt :: Monoid a => Parser a -> Parser a 233 | opt = option mempty 234 | 235 | -- Hack to reverse parser success 236 | but :: Parser a -> Parser () 237 | but pn = False <$ lookAhead pn <|> pure True >>= \case 238 | False -> empty 239 | True -> pure () 240 | 241 | manyNE :: Alternative f => f a -> f (NonEmpty a) 242 | manyNE p = (:|) <$> p <*> many p 243 | 244 | whiteSpace :: Parser () 245 | whiteSpace = peekChar >>= traverse_ (\c -> 246 | if isSpace c || c == ',' 247 | then anyChar *> whiteSpace 248 | else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace) 249 | -------------------------------------------------------------------------------- /Data/GraphQL/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | -- | This module provides a representation of a @GraphQL@ Schema in addition to 3 | -- functions for defining and manipulating Schemas. 4 | module Data.GraphQL.Schema 5 | ( Schema 6 | , Resolver 7 | , Subs 8 | , object 9 | , object' 10 | , objectA 11 | , objectA' 12 | , scalar 13 | , scalarA 14 | , array 15 | , array' 16 | , arrayA 17 | , arrayA' 18 | , enum 19 | , enumA 20 | , resolve 21 | -- * AST Reexports 22 | , Field 23 | , Argument(..) 24 | , Value(..) 25 | ) where 26 | 27 | import Control.Applicative (Alternative(empty), (<|>)) 28 | import Data.Foldable (fold) 29 | import Data.List.NonEmpty (NonEmpty) 30 | import Data.Maybe (fromMaybe) 31 | import Data.Monoid (Alt(Alt,getAlt)) 32 | 33 | import qualified Data.Aeson as Aeson 34 | import Data.HashMap.Strict (HashMap) 35 | import qualified Data.HashMap.Strict as HashMap 36 | import Data.Text (Text) 37 | 38 | import Data.GraphQL.AST.Core 39 | 40 | -- | A GraphQL schema. 41 | -- @f@ is usually expected to be an instance of 'Alternative'. 42 | type Schema f = NonEmpty (Resolver f) 43 | 44 | -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information 45 | -- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'. 46 | type Resolver f = Field -> f Aeson.Object 47 | 48 | type Resolvers f = [Resolver f] 49 | 50 | type Fields = [Field] 51 | 52 | type Arguments = [Argument] 53 | 54 | -- | Variable substitution function. 55 | type Subs = Name -> Maybe Value 56 | 57 | -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. 58 | object :: Alternative f => Name -> Resolvers f -> Resolver f 59 | object name resolvers = objectA name $ \case 60 | [] -> resolvers 61 | _ -> empty 62 | 63 | -- | Like 'object' but also taking 'Argument's. 64 | objectA 65 | :: Alternative f 66 | => Name -> (Arguments -> Resolvers f) -> Resolver f 67 | objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld 68 | 69 | 70 | -- | Create a named 'Resolver' from a list of 'Resolver's. 71 | object' :: (Alternative f, Monad f) => Text -> f [Resolver f] -> Resolver f 72 | object' name resolvs = objectA' name $ \case 73 | [] -> resolvs 74 | _ -> empty 75 | 76 | -- | Like 'object'' but also taking 'Argument's. 77 | objectA' 78 | :: (Alternative f, Monad f) 79 | => Text -> ([Argument] -> f [Resolver f]) -> Resolver f 80 | objectA' name f fld@(Field _ _ args flds) = do 81 | resolvs <- f args 82 | withField name (resolve resolvs flds) fld 83 | 84 | 85 | -- | A scalar represents a primitive value, like a string or an integer. 86 | scalar :: (Alternative f, Aeson.ToJSON a) => Name -> a -> Resolver f 87 | scalar name s = scalarA name $ \case 88 | [] -> pure s 89 | _ -> empty 90 | 91 | -- | Like 'scalar' but also taking 'Argument's. 92 | scalarA 93 | :: (Alternative f, Aeson.ToJSON a) 94 | => Name -> (Arguments -> f a) -> Resolver f 95 | scalarA name f fld@(Field _ _ args []) = withField name (f args) fld 96 | scalarA _ _ _ = empty 97 | 98 | array :: Alternative f => Name -> [Resolvers f] -> Resolver f 99 | array name resolvers = arrayA name $ \case 100 | [] -> resolvers 101 | _ -> empty 102 | 103 | -- | Like 'array' but also taking 'Argument's. 104 | arrayA 105 | :: Alternative f 106 | => Text -> (Arguments -> [Resolvers f]) -> Resolver f 107 | arrayA name f fld@(Field _ _ args sels) = 108 | withField name (traverse (`resolve` sels) $ f args) fld 109 | 110 | -- | Like 'object'' but taking lists of 'Resolver's instead of a single list. 111 | array' :: (Alternative f, Monad f) => Text -> f [[Resolver f]] -> Resolver f 112 | array' name resolvs = arrayA' name $ \case 113 | [] -> resolvs 114 | _ -> empty 115 | 116 | -- | Like 'array'' but also taking 'Argument's. 117 | arrayA' 118 | :: (Alternative f, Monad f) 119 | => Text -> ([Argument] -> f [[Resolver f]]) -> Resolver f 120 | arrayA' name f fld@(Field _ _ args sels) = do 121 | resolvs <- f args 122 | withField name (traverse (`resolve` sels) resolvs) fld 123 | 124 | -- | Represents one of a finite set of possible values. 125 | -- Used in place of a 'scalar' when the possible responses are easily enumerable. 126 | enum :: Alternative f => Text -> f [Text] -> Resolver f 127 | enum name enums = enumA name $ \case 128 | [] -> enums 129 | _ -> empty 130 | 131 | -- | Like 'enum' but also taking 'Argument's. 132 | enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f 133 | enumA name f fld@(Field _ _ args []) = withField name (f args) fld 134 | enumA _ _ _ = empty 135 | 136 | -- | Helper function to facilitate 'Argument' handling. 137 | withField 138 | :: (Alternative f, Aeson.ToJSON a) 139 | => Name -> f a -> Field -> f (HashMap Text Aeson.Value) 140 | withField name v (Field alias name' _ _) = 141 | if name == name' 142 | then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) v 143 | -- TODO: Report error when Non-Nullable type for field argument. 144 | <|> pure (HashMap.singleton aliasOrName Aeson.Null) 145 | else empty 146 | where 147 | aliasOrName = fromMaybe name alias 148 | 149 | -- | Takes a list of 'Resolver's and a list of 'Field's and applies each 150 | -- 'Resolver' to each 'Field'. Resolves into a value containing the 151 | -- resolved 'Field', or a null value and error information. 152 | resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value 153 | resolve resolvers = 154 | fmap (Aeson.toJSON . fold) 155 | . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers)) 156 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright J. Daniel Navarro (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of J. Daniel Navarro nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell GraphQL 2 | 3 | [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql) 4 | [![Build Status](https://img.shields.io/travis/jdnavarro/graphql-haskell.svg)](https://travis-ci.org/jdnavarro/graphql-haskell) 5 | 6 | For now this only provides the data types to represent the GraphQL AST, 7 | but the idea is to be a Haskell port of 8 | [`graphql-js`](https://github.com/graphql/graphql-js). Next releases 9 | should include: 10 | 11 | - [x] GraphQL AST 12 | - [x] Parser for the GraphQL language. See TODO for limitations. 13 | - [x] Printer for GraphQL. This is not pretty yet. 14 | - [ ] GraphQL Schema AST. 15 | - [ ] Parser for the GraphQL Schema language. 16 | - [ ] Printer for the GraphQL Schema language. 17 | - [ ] Interpreter of GraphQL requests. 18 | - [ ] Utilities to define GraphQL types and schema. 19 | 20 | See the TODO file for more concrete tasks. 21 | 22 | ## Contact 23 | 24 | Suggestions, contributions and bug reports are welcome. 25 | 26 | Feel free to contact on Slack in [#haskell on 27 | GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an 28 | invitation [here](https://graphql-slack.herokuapp.com/). 29 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | ## AST 2 | - Docs 3 | - Simplify unnecessary `newtypes` with type synonyms 4 | - Simplify wrapper type constructors. Some types can be just constructors. 5 | - Data type accessors 6 | - Deal with strictness/unboxing 7 | - Deal with location 8 | 9 | ## Parser 10 | - Docs 11 | - Handle escape characters in string literals 12 | - Guard for `on` in `FragmentSpread` 13 | - Handle `[Const]` grammar parameter. Need examples 14 | - Handle `maxBound` Int values. 15 | - Diagnostics. Perhaps port to `parsers` and use `trifecta` for diagnostics, 16 | and `attoparsec` for performance. 17 | - Optimize `whiteSpace`, perhaps front the main parser with a lexer. 18 | 19 | ## Printer 20 | - Add pretty printer. 21 | - Docs 22 | -------------------------------------------------------------------------------- /docs/tutorial/Makefile: -------------------------------------------------------------------------------- 1 | default: 2 | pandoc -f markdown+lhs+yaml_metadata_block --highlight-style=haddock -S -c "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css" --section-divs -c tutorial.css --toc --standalone -t html5 -o tutorial.html tutorial.lhs 3 | pandoc -f markdown+lhs+yaml_metadata_block --highlight-style=haddock --toc --standalone -t rst -o tutorial.rst tutorial.lhs 4 | pandoc -f markdown+lhs+yaml_metadata_block --highlight-style=haddock --toc --standalone -t latex -o tutorial.pdf tutorial.lhs 5 | -------------------------------------------------------------------------------- /docs/tutorial/tutorial.css: -------------------------------------------------------------------------------- 1 | body { 2 | padding: 0 20px; 3 | } 4 | -------------------------------------------------------------------------------- /docs/tutorial/tutorial.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | GraphQL Haskell Tutorial 8 | 9 | 41 | 42 | 43 | 46 | 47 | 48 |
49 |

GraphQL Haskell Tutorial

50 |
51 | 62 |
63 |

Getting started

64 |

Welcome to graphql-haskell!

65 |

We have written a small tutorial to help you (and ourselves) understand the graphql package.

66 |

Since this file is a literate haskell file, we start by importing some dependencies.

67 | 
{-# LANGUAGE OverloadedStrings #-}
 68 | {-# LANGUAGE LambdaCase #-}
 69 | module Main where
 70 | 
 71 | import Prelude hiding (empty, putStrLn)
 72 | import Data.GraphQL
 73 | import Data.GraphQL.Schema
 74 | import qualified Data.GraphQL.Schema as Schema
 75 | 
 76 | import Control.Applicative
 77 | import Data.List.NonEmpty (NonEmpty((:|)))
 78 | import Data.Text hiding (empty)
 79 | import Data.Aeson
 80 | import Data.ByteString.Lazy.Char8 (putStrLn)
 81 | 
 82 | import Data.Time
 83 | 
 84 | import Debug.Trace
85 |
86 |

First example

87 |

Now, as our first example, we are going to look at the example from graphql.js.

88 |

First we build a GraphQL schema.

89 | 
schema1 :: Alternative f => Schema f
 90 | schema1 = hello :| []
 91 | 
 92 | hello :: Alternative f => Resolver f
 93 | hello = Schema.scalar "hello" ("it's me" :: Text)
94 |

This defines a simple schema with one type and one field, that resolves to a fixed value.

95 |

Next we define our query.

96 | 
query1 :: Text
 97 | query1 = "{ hello }"
98 |

To run the query, we call the graphql with the schema and the query.

99 | 
main1 :: IO ()
100 | main1 = putStrLn =<< encode <$> graphql schema1 query1
101 |

This runs the query by fetching the one field defined, returning

102 |

{"data" : {"hello":"it's me"}}

103 |
104 |
105 |

Monadic actions

106 |

For this example, we’re going to be using time.

107 | 
schema2 :: Schema IO
108 | schema2 = time :| []
109 | 
110 | time :: Resolver IO
111 | time = Schema.scalarA "time" $ \case
112 |   [] -> do t <- getCurrentTime
113 |            return $ show t
114 |   _  -> empty
115 |

This defines a simple schema with one type and one field, which resolves to the current time.

116 |

Next we define our query.

117 | 
query2 :: Text
118 | query2 = "{ time }"
119 | 
120 | main2 :: IO ()
121 | main2 = putStrLn =<< encode <$> graphql schema2 query2
122 |

This runs the query, returning the current time

123 |

{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}

124 |
125 |
126 |

Errors

127 |

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.

128 |

An example of this is the following query:

129 | 
queryShouldFail :: Text
130 | queryShouldFail = "{ boyhowdy }"
131 |

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.

132 | 
mainShouldFail :: IO ()
133 | mainShouldFail = do
134 |   r <- graphql schema1 query1
135 |   putStrLn $ encode r
136 |   putStrLn "This will fail"
137 |   r <- graphql schema1 queryShouldFail
138 |   putStrLn $ encode r
139 |

This outputs:

140 | 
{"data": {"hello": "it's me"}}
141 | This will fail
142 | {"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]}
143 |
144 |
145 |

Combining resolvers

146 |

Now that we have two resolvers, we can define a schema which uses them both.

147 | 
schema3 :: Schema IO
148 | schema3 = hello :| [time]
149 | 
150 | query3 :: Text
151 | query3 = "query timeAndHello { time hello }"
152 | 
153 | main3 :: IO ()
154 | main3 = putStrLn =<< encode <$> graphql schema3 query3
155 |

This queries for both time and hello, returning

156 |

{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}

157 |

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.

158 |

In GraphQL there can only be one operation per query.

159 |
160 |
161 |
162 |

Further examples

163 |

More examples on queries and a more complex schema can be found in the test directory, in the Test.StarWars module. This includes a more complex schema, and more complex queries.

164 |
165 | 166 | 167 | -------------------------------------------------------------------------------- /docs/tutorial/tutorial.lhs: -------------------------------------------------------------------------------- 1 | --- 2 | title: GraphQL Haskell Tutorial 3 | --- 4 | 5 | 6 | == Getting started == 7 | 8 | Welcome to graphql-haskell! 9 | 10 | We have written a small tutorial to help you (and ourselves) understand the graphql package. 11 | 12 | Since this file is a literate haskell file, we start by importing some dependencies. 13 | 14 | > {-# LANGUAGE OverloadedStrings #-} 15 | > {-# LANGUAGE LambdaCase #-} 16 | > module Main where 17 | > 18 | > import Prelude hiding (empty, putStrLn) 19 | > import Data.GraphQL 20 | > import Data.GraphQL.Schema 21 | > import qualified Data.GraphQL.Schema as Schema 22 | > 23 | > import Control.Applicative 24 | > import Data.List.NonEmpty (NonEmpty((:|))) 25 | > import Data.Text hiding (empty) 26 | > import Data.Aeson 27 | > import Data.ByteString.Lazy.Char8 (putStrLn) 28 | > 29 | > import Data.Time 30 | > 31 | > import Debug.Trace 32 | 33 | === First example === 34 | 35 | Now, as our first example, we are going to look at the 36 | example from [graphql.js](https://github.com/graphql/graphql-js). 37 | 38 | First we build a GraphQL schema. 39 | 40 | > schema1 :: Alternative f => Schema f 41 | > schema1 = hello :| [] 42 | > 43 | > hello :: Alternative f => Resolver f 44 | > hello = Schema.scalar "hello" ("it's me" :: Text) 45 | 46 | This defines a simple schema with one type and one field, that resolves to a fixed value. 47 | 48 | Next we define our query. 49 | 50 | > query1 :: Text 51 | > query1 = "{ hello }" 52 | 53 | 54 | To run the query, we call the `graphql` with the schema and the query. 55 | 56 | > main1 :: IO () 57 | > main1 = putStrLn =<< encode <$> graphql schema1 query1 58 | 59 | This runs the query by fetching the one field defined, 60 | returning 61 | 62 | ```{"data" : {"hello":"it's me"}}``` 63 | 64 | 65 | 66 | === Monadic actions === 67 | 68 | For this example, we're going to be using time. 69 | 70 | > schema2 :: Schema IO 71 | > schema2 = time :| [] 72 | > 73 | > time :: Resolver IO 74 | > time = Schema.scalarA "time" $ \case 75 | > [] -> do t <- getCurrentTime 76 | > return $ show t 77 | > _ -> empty 78 | 79 | This defines a simple schema with one type and one field, 80 | which resolves to the current time. 81 | 82 | Next we define our query. 83 | 84 | > query2 :: Text 85 | > query2 = "{ time }" 86 | > 87 | > main2 :: IO () 88 | > main2 = putStrLn =<< encode <$> graphql schema2 query2 89 | 90 | This runs the query, returning the current time 91 | 92 | ```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}``` 93 | 94 | 95 | === Errors === 96 | 97 | Errors are handled according to the spec, 98 | with fields that cause erros being resolved to `null`, 99 | and an error being added to the error list. 100 | 101 | An example of this is the following query: 102 | 103 | > queryShouldFail :: Text 104 | > queryShouldFail = "{ boyhowdy }" 105 | 106 | Since there is no `boyhowdy` field in our schema, it will not resolve, 107 | and the query will fail, as we can see in the following example. 108 | 109 | > mainShouldFail :: IO () 110 | > mainShouldFail = do 111 | > r <- graphql schema1 query1 112 | > putStrLn $ encode r 113 | > putStrLn "This will fail" 114 | > r <- graphql schema1 queryShouldFail 115 | > putStrLn $ encode r 116 | > 117 | 118 | This outputs: 119 | 120 | ``` 121 | {"data": {"hello": "it's me"}} 122 | This will fail 123 | {"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]} 124 | ``` 125 | 126 | === Combining resolvers === 127 | 128 | Now that we have two resolvers, we can define a schema which uses them both. 129 | 130 | > schema3 :: Schema IO 131 | > schema3 = hello :| [time] 132 | > 133 | > query3 :: Text 134 | > query3 = "query timeAndHello { time hello }" 135 | > 136 | > main3 :: IO () 137 | > main3 = putStrLn =<< encode <$> graphql schema3 query3 138 | 139 | This queries for both time and hello, returning 140 | 141 | ```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}``` 142 | 143 | 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. 144 | 145 | In GraphQL there can only be one operation per query. 146 | 147 | 148 | == Further examples == 149 | 150 | More examples on queries and a more complex schema can be found in the test directory, 151 | in the [Test.StarWars](../../tests/Test/StarWars) module. This includes a more complex schema, and more complex queries. 152 | -------------------------------------------------------------------------------- /docs/tutorial/tutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jdnavarro/graphql-haskell/40f9024b51900c73bc0f65444c16022bd73820be/docs/tutorial/tutorial.pdf -------------------------------------------------------------------------------- /docs/tutorial/tutorial.rst: -------------------------------------------------------------------------------- 1 | ======================== 2 | GraphQL Haskell Tutorial 3 | ======================== 4 | 5 | .. contents:: 6 | :depth: 3 7 | .. 8 | 9 | Getting started 10 | =============== 11 | 12 | Welcome to graphql-haskell! 13 | 14 | We have written a small tutorial to help you (and ourselves) understand 15 | the graphql package. 16 | 17 | Since this file is a literate haskell file, we start by importing some 18 | dependencies. 19 | 20 | .. code:: haskell 21 | 22 | {-# LANGUAGE OverloadedStrings #-} 23 | {-# LANGUAGE LambdaCase #-} 24 | module Main where 25 | 26 | import Prelude hiding (empty, putStrLn) 27 | import Data.GraphQL 28 | import Data.GraphQL.Schema 29 | import qualified Data.GraphQL.Schema as Schema 30 | 31 | import Control.Applicative 32 | import Data.List.NonEmpty (NonEmpty((:|))) 33 | import Data.Text hiding (empty) 34 | import Data.Aeson 35 | import Data.ByteString.Lazy.Char8 (putStrLn) 36 | 37 | import Data.Time 38 | 39 | import Debug.Trace 40 | 41 | First example 42 | ------------- 43 | 44 | Now, as our first example, we are going to look at the example from 45 | `graphql.js `__. 46 | 47 | First we build a GraphQL schema. 48 | 49 | .. code:: haskell 50 | 51 | schema1 :: Alternative f => Schema f 52 | schema1 = hello :| [] 53 | 54 | hello :: Alternative f => Resolver f 55 | hello = Schema.scalar "hello" ("it's me" :: Text) 56 | 57 | This defines a simple schema with one type and one field, that resolves 58 | to a fixed value. 59 | 60 | Next we define our query. 61 | 62 | .. code:: haskell 63 | 64 | query1 :: Text 65 | query1 = "{ hello }" 66 | 67 | To run the query, we call the ``graphql`` with the schema and the query. 68 | 69 | .. code:: haskell 70 | 71 | main1 :: IO () 72 | main1 = putStrLn =<< encode <$> graphql schema1 query1 73 | 74 | This runs the query by fetching the one field defined, returning 75 | 76 | ``{"data" : {"hello":"it's me"}}`` 77 | 78 | Monadic actions 79 | --------------- 80 | 81 | For this example, we're going to be using time. 82 | 83 | .. code:: haskell 84 | 85 | schema2 :: Schema IO 86 | schema2 = time :| [] 87 | 88 | time :: Resolver IO 89 | time = Schema.scalarA "time" $ \case 90 | [] -> do t <- getCurrentTime 91 | return $ show t 92 | _ -> empty 93 | 94 | This defines a simple schema with one type and one field, which resolves 95 | to the current time. 96 | 97 | Next we define our query. 98 | 99 | .. code:: haskell 100 | 101 | query2 :: Text 102 | query2 = "{ time }" 103 | 104 | main2 :: IO () 105 | main2 = putStrLn =<< encode <$> graphql schema2 query2 106 | 107 | This runs the query, returning the current time 108 | 109 | ``{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}`` 110 | 111 | Errors 112 | ------ 113 | 114 | Errors are handled according to the spec, with fields that cause erros 115 | being resolved to ``null``, and an error being added to the error list. 116 | 117 | An example of this is the following query: 118 | 119 | .. code:: haskell 120 | 121 | queryShouldFail :: Text 122 | queryShouldFail = "{ boyhowdy }" 123 | 124 | Since there is no ``boyhowdy`` field in our schema, it will not resolve, 125 | and the query will fail, as we can see in the following example. 126 | 127 | .. code:: haskell 128 | 129 | mainShouldFail :: IO () 130 | mainShouldFail = do 131 | r <- graphql schema1 query1 132 | putStrLn $ encode r 133 | putStrLn "This will fail" 134 | r <- graphql schema1 queryShouldFail 135 | putStrLn $ encode r 136 | 137 | This outputs: 138 | 139 | :: 140 | 141 | {"data": {"hello": "it's me"}} 142 | This will fail 143 | {"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]} 144 | 145 | Combining resolvers 146 | ------------------- 147 | 148 | Now that we have two resolvers, we can define a schema which uses them 149 | both. 150 | 151 | .. code:: haskell 152 | 153 | schema3 :: Schema IO 154 | schema3 = hello :| [time] 155 | 156 | query3 :: Text 157 | query3 = "query timeAndHello { time hello }" 158 | 159 | main3 :: IO () 160 | main3 = putStrLn =<< encode <$> graphql schema3 query3 161 | 162 | This queries for both time and hello, returning 163 | 164 | ``{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}`` 165 | 166 | Notice that we can name our queries, as we did with ``timeAndHello``. 167 | Since we have only been using single queries, we can use the shorthand 168 | ``{ time hello}``, as we have been doing in the previous examples. 169 | 170 | In GraphQL there can only be one operation per query. 171 | 172 | Further examples 173 | ================ 174 | 175 | More examples on queries and a more complex schema can be found in the 176 | test directory, in the `Test.StarWars <../../tests/Test/StarWars>`__ 177 | module. This includes a more complex schema, and more complex queries. 178 | -------------------------------------------------------------------------------- /graphql.cabal: -------------------------------------------------------------------------------- 1 | name: graphql 2 | version: 0.3 3 | synopsis: Haskell GraphQL implementation 4 | description: 5 | This package provides a rudimentary parser for the 6 | language. 7 | homepage: https://github.com/jdnavarro/graphql-haskell 8 | bug-reports: https://github.com/jdnavarro/graphql-haskell/issues 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Danny Navarro, Matthías Páll Gissurarson, Sólrún Halla Einarsdóttir 12 | maintainer: j@dannynavarro.net 13 | copyright: Copyright (C) 2015-2016 J. Daniel Navarro 14 | category: Web 15 | build-type: Simple 16 | cabal-version: >=1.10 17 | tested-with: GHC == 7.10.3, GHC==8.0.1 18 | extra-source-files: README.md CHANGELOG.md stack.yaml 19 | docs/tutorial/tutorial.lhs 20 | data-files: tests/data/*.graphql 21 | tests/data/*.min.graphql 22 | 23 | library 24 | default-language: Haskell2010 25 | ghc-options: -Wall 26 | exposed-modules: Data.GraphQL 27 | Data.GraphQL.AST 28 | Data.GraphQL.AST.Core 29 | Data.GraphQL.AST.Transform 30 | Data.GraphQL.Execute 31 | Data.GraphQL.Encoder 32 | Data.GraphQL.Error 33 | Data.GraphQL.Schema 34 | Data.GraphQL.Parser 35 | build-depends: aeson >= 0.7.0.3, 36 | attoparsec >= 0.10.4.0, 37 | base >= 4.7 && < 5, 38 | text >= 0.11.3.1, 39 | unordered-containers >= 0.2.5.0, 40 | scientific >=0.3.1 && <0.4 41 | if impl(ghc >= 8.0) 42 | ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances 43 | else 44 | -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 45 | build-depends: fail == 4.9.*, semigroups == 0.18.* 46 | 47 | test-suite tasty 48 | default-language: Haskell2010 49 | type: exitcode-stdio-1.0 50 | hs-source-dirs: tests 51 | main-is: tasty.hs 52 | ghc-options: -Wall 53 | other-modules: Paths_graphql 54 | Test.StarWars.Data 55 | Test.StarWars.Schema 56 | Test.StarWars.QueryTests 57 | build-depends: aeson >= 0.7.0.3, 58 | attoparsec >= 0.10.4.0, 59 | base >= 4.6 && <5, 60 | graphql, 61 | raw-strings-qq >= 1.1, 62 | tasty >= 0.10, 63 | tasty-hunit >= 0.9, 64 | text >= 0.11.3.1, 65 | unordered-containers >= 0.2.5.0 66 | 67 | source-repository head 68 | type: git 69 | location: git://github.com/jdnavarro/graphql-haskell.git 70 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-5.3 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /tests/Test/StarWars/Data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Test.StarWars.Data where 3 | 4 | import Data.Monoid (mempty) 5 | import Control.Applicative (Alternative, (<|>), empty, liftA2) 6 | import Data.Maybe (catMaybes) 7 | 8 | import Data.Text (Text) 9 | 10 | -- * Data 11 | -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js 12 | 13 | -- ** Characters 14 | 15 | type ID = Text 16 | 17 | data CharCommon = CharCommon 18 | { _id_ :: ID 19 | , _name :: Text 20 | , _friends :: [ID] 21 | , _appearsIn :: [Int] 22 | } deriving (Show) 23 | 24 | 25 | data Human = Human 26 | { _humanChar :: CharCommon 27 | , homePlanet :: Text 28 | } 29 | 30 | data Droid = Droid 31 | { _droidChar :: CharCommon 32 | , primaryFunction :: Text 33 | } 34 | 35 | type Character = Either Droid Human 36 | 37 | id_ :: Character -> ID 38 | id_ (Left x) = _id_ . _droidChar $ x 39 | id_ (Right x) = _id_ . _humanChar $ x 40 | 41 | name :: Character -> Text 42 | name (Left x) = _name . _droidChar $ x 43 | name (Right x) = _name . _humanChar $ x 44 | 45 | friends :: Character -> [ID] 46 | friends (Left x) = _friends . _droidChar $ x 47 | friends (Right x) = _friends . _humanChar $ x 48 | 49 | appearsIn :: Character -> [Int] 50 | appearsIn (Left x) = _appearsIn . _droidChar $ x 51 | appearsIn (Right x) = _appearsIn . _humanChar $ x 52 | 53 | secretBackstory :: Character -> Text 54 | secretBackstory = error "secretBackstory is secret." 55 | 56 | typeName :: Character -> Text 57 | typeName = either (const "Droid") (const "Human") 58 | 59 | luke :: Character 60 | luke = Right luke' 61 | 62 | luke' :: Human 63 | luke' = Human 64 | { _humanChar = CharCommon 65 | { _id_ = "1000" 66 | , _name = "Luke Skywalker" 67 | , _friends = ["1002","1003","2000","2001"] 68 | , _appearsIn = [4,5,6] 69 | } 70 | , homePlanet = "Tatooine" 71 | } 72 | 73 | vader :: Human 74 | vader = Human 75 | { _humanChar = CharCommon 76 | { _id_ = "1001" 77 | , _name = "Darth Vader" 78 | , _friends = ["1004"] 79 | , _appearsIn = [4,5,6] 80 | } 81 | , homePlanet = "Tatooine" 82 | } 83 | 84 | han :: Human 85 | han = Human 86 | { _humanChar = CharCommon 87 | { _id_ = "1002" 88 | , _name = "Han Solo" 89 | , _friends = ["1000","1003","2001" ] 90 | , _appearsIn = [4,5,6] 91 | } 92 | , homePlanet = mempty 93 | } 94 | 95 | leia :: Human 96 | leia = Human 97 | { _humanChar = CharCommon 98 | { _id_ = "1003" 99 | , _name = "Leia Organa" 100 | , _friends = ["1000","1002","2000","2001"] 101 | , _appearsIn = [4,5,6] 102 | } 103 | , homePlanet = "Alderaan" 104 | } 105 | 106 | tarkin :: Human 107 | tarkin = Human 108 | { _humanChar = CharCommon 109 | { _id_ = "1004" 110 | , _name = "Wilhuff Tarkin" 111 | , _friends = ["1001"] 112 | , _appearsIn = [4] 113 | } 114 | , homePlanet = mempty 115 | } 116 | 117 | threepio :: Droid 118 | threepio = Droid 119 | { _droidChar = CharCommon 120 | { _id_ = "2000" 121 | , _name = "C-3PO" 122 | , _friends = ["1000","1002","1003","2001" ] 123 | , _appearsIn = [ 4, 5, 6 ] 124 | } 125 | , primaryFunction = "Protocol" 126 | } 127 | 128 | artoo :: Character 129 | artoo = Left artoo' 130 | 131 | artoo' :: Droid 132 | artoo' = Droid 133 | { _droidChar = CharCommon 134 | { _id_ = "2001" 135 | , _name = "R2-D2" 136 | , _friends = ["1000","1002","1003"] 137 | , _appearsIn = [4,5,6] 138 | } 139 | , primaryFunction = "Astrometch" 140 | } 141 | 142 | -- ** Helper functions 143 | 144 | getHero :: Int -> Character 145 | getHero 5 = luke 146 | getHero _ = artoo 147 | 148 | getHeroIO :: Int -> IO Character 149 | getHeroIO = pure . getHero 150 | 151 | getHuman :: Alternative f => ID -> f Character 152 | getHuman = fmap Right . getHuman' 153 | 154 | getHuman' :: Alternative f => ID -> f Human 155 | getHuman' "1000" = pure luke' 156 | getHuman' "1001" = pure vader 157 | getHuman' "1002" = pure han 158 | getHuman' "1003" = pure leia 159 | getHuman' "1004" = pure tarkin 160 | getHuman' _ = empty 161 | 162 | getDroid :: Alternative f => ID -> f Character 163 | getDroid = fmap Left . getDroid' 164 | 165 | getDroid' :: Alternative f => ID -> f Droid 166 | getDroid' "2000" = pure threepio 167 | getDroid' "2001" = pure artoo' 168 | getDroid' _ = empty 169 | 170 | getFriends :: Character -> [Character] 171 | getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char 172 | 173 | getEpisode :: Alternative f => Int -> f Text 174 | getEpisode 4 = pure "NEWHOPE" 175 | getEpisode 5 = pure "EMPIRE" 176 | getEpisode 6 = pure "JEDI" 177 | getEpisode _ = empty 178 | -------------------------------------------------------------------------------- /tests/Test/StarWars/QueryTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module Test.StarWars.QueryTests (test) where 4 | 5 | import qualified Data.Aeson as Aeson (Value(Null), toJSON) 6 | import Data.Aeson (object, (.=)) 7 | import Data.Text (Text) 8 | import Text.RawString.QQ (r) 9 | 10 | import Test.Tasty (TestTree, testGroup) 11 | import Test.Tasty.HUnit (Assertion, testCase, (@?=)) 12 | 13 | import Data.GraphQL 14 | import Data.GraphQL.Schema (Subs) 15 | 16 | import Test.StarWars.Schema 17 | 18 | -- * Test 19 | -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js 20 | 21 | test :: TestTree 22 | test = testGroup "Star Wars Query Tests" 23 | [ testGroup "Basic Queries" 24 | [ testCase "R2-D2 hero" . testQuery 25 | [r| query HeroNameQuery { 26 | hero { 27 | id 28 | } 29 | } 30 | |] 31 | $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]] 32 | , testCase "R2-D2 ID and friends" . testQuery 33 | [r| query HeroNameAndFriendsQuery { 34 | hero { 35 | id 36 | name 37 | friends { 38 | name 39 | } 40 | } 41 | } 42 | |] 43 | $ object [ "data" .= object [ 44 | "hero" .= object [ 45 | "id" .= ("2001" :: Text) 46 | , r2d2Name 47 | , "friends" .= [ 48 | object [lukeName] 49 | , object [hanName] 50 | , object [leiaName] 51 | ] 52 | ] 53 | ]] 54 | ] 55 | , testGroup "Nested Queries" 56 | [ testCase "R2-D2 friends" . testQuery 57 | [r| query NestedQuery { 58 | hero { 59 | name 60 | friends { 61 | name 62 | appearsIn 63 | friends { 64 | name 65 | } 66 | } 67 | } 68 | } 69 | |] 70 | $ object [ "data" .= object [ 71 | "hero" .= object [ 72 | "name" .= ("R2-D2" :: Text) 73 | , "friends" .= [ 74 | object [ 75 | "name" .= ("Luke Skywalker" :: Text) 76 | , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text] 77 | , "friends" .= [ 78 | object [hanName] 79 | , object [leiaName] 80 | , object [c3poName] 81 | , object [r2d2Name] 82 | ] 83 | ] 84 | , object [ 85 | hanName 86 | , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] 87 | , "friends" .= [ 88 | object [lukeName] 89 | , object [leiaName] 90 | , object [r2d2Name] 91 | ] 92 | ] 93 | , object [ 94 | leiaName 95 | , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] 96 | , "friends" .= [ 97 | object [lukeName] 98 | , object [hanName] 99 | , object [c3poName] 100 | , object [r2d2Name] 101 | ] 102 | ] 103 | ] 104 | ] 105 | ]] 106 | , testCase "Luke ID" . testQuery 107 | [r| query FetchLukeQuery { 108 | human(id: "1000") { 109 | name 110 | } 111 | } 112 | |] 113 | $ object [ "data" .= object [ 114 | "human" .= object [lukeName] 115 | ] 116 | ]] 117 | , testCase "Luke ID with variable" . testQueryParams 118 | (\v -> if v == "someId" 119 | then Just "1000" 120 | else Nothing) 121 | [r| query FetchSomeIDQuery($someId: String!) { 122 | human(id: $someId) { 123 | name 124 | } 125 | } 126 | |] 127 | $ object [ "data" .= object [ 128 | "human" .= object [lukeName] 129 | ]] 130 | , testCase "Han ID with variable" . testQueryParams 131 | (\v -> if v == "someId" 132 | then Just "1002" 133 | else Nothing) 134 | [r| query FetchSomeIDQuery($someId: String!) { 135 | human(id: $someId) { 136 | name 137 | } 138 | } 139 | |] 140 | $ object [ "data" .= object [ 141 | "human" .= object [hanName] 142 | ]] 143 | , testCase "Invalid ID" . testQueryParams 144 | (\v -> if v == "id" 145 | then Just "Not a valid ID" 146 | else Nothing) 147 | [r| query humanQuery($id: String!) { 148 | human(id: $id) { 149 | name 150 | } 151 | } 152 | -- The GraphQL spec specifies that an error should be reported when the 153 | -- type of the argument is Non-Nullable. However the equivalent test in 154 | -- `graphql-js` doesn't check for any errors. 155 | |] $ object ["data" .= object ["human" .= Aeson.Null]] 156 | , testCase "Luke aliased" . testQuery 157 | [r| query FetchLukeAliased { 158 | luke: human(id: "1000") { 159 | name 160 | } 161 | } 162 | |] 163 | $ object [ "data" .= object [ 164 | "luke" .= object [lukeName] 165 | ]] 166 | , testCase "R2-D2 ID and friends aliased" . testQuery 167 | [r| query HeroNameAndFriendsQuery { 168 | hero { 169 | id 170 | name 171 | friends { 172 | friendName: name 173 | } 174 | } 175 | } 176 | |] 177 | $ object [ "data" .= object [ 178 | "hero" .= object [ 179 | "id" .= ("2001" :: Text) 180 | , r2d2Name 181 | , "friends" .= [ 182 | object ["friendName" .= ("Luke Skywalker" :: Text)] 183 | , object ["friendName" .= ("Han Solo" :: Text)] 184 | , object ["friendName" .= ("Leia Organa" :: Text)] 185 | ] 186 | ] 187 | ]] 188 | , testCase "Luke and Leia aliased" . testQuery 189 | [r| query FetchLukeAndLeiaAliased { 190 | luke: human(id: "1000") { 191 | name 192 | } 193 | leia: human(id: "1003") { 194 | name 195 | } 196 | } 197 | |] 198 | $ object [ "data" .= object [ 199 | "luke" .= object [lukeName] 200 | , "leia" .= object [leiaName] 201 | ]] 202 | , testGroup "Fragments for complex queries" 203 | [ testCase "Aliases to query for duplicate content" . testQuery 204 | [r| query DuplicateFields { 205 | luke: human(id: "1000") { 206 | name 207 | homePlanet 208 | } 209 | leia: human(id: "1003") { 210 | name 211 | homePlanet 212 | } 213 | } 214 | |] 215 | $ object [ "data" .= object [ 216 | "luke" .= object [lukeName, tatooine] 217 | , "leia" .= object [leiaName, alderaan] 218 | ]] 219 | , testCase "Fragment for duplicate content" . testQuery 220 | [r| query UseFragment { 221 | luke: human(id: "1000") { 222 | ...HumanFragment 223 | } 224 | leia: human(id: "1003") { 225 | ...HumanFragment 226 | } 227 | } 228 | fragment HumanFragment on Human { 229 | name 230 | homePlanet 231 | } 232 | |] 233 | $ object [ "data" .= object [ 234 | "luke" .= object [lukeName, tatooine] 235 | , "leia" .= object [leiaName, alderaan] 236 | ]] 237 | ] 238 | , testGroup "__typename" 239 | [ testCase "R2D2 is a Droid" . testQuery 240 | [r| query CheckTypeOfR2 { 241 | hero { 242 | __typename 243 | name 244 | } 245 | } 246 | |] 247 | $ object ["data" .= object [ 248 | "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name] 249 | ]] 250 | , testCase "Luke is a human" . testQuery 251 | [r| query CheckTypeOfLuke { 252 | hero(episode: EMPIRE) { 253 | __typename 254 | name 255 | } 256 | } 257 | |] 258 | $ object ["data" .= object [ 259 | "hero" .= object ["__typename" .= ("Human" :: Text), lukeName] 260 | ]] 261 | ] 262 | , testGroup "Errors in resolvers" 263 | [ testCase "error on secretBackstory" . testQuery 264 | [r| query HeroNameQuery { 265 | hero { 266 | name 267 | secretBackstory 268 | } 269 | } 270 | |] 271 | $ object ["data" .= object [ 272 | "hero" .= [r2d2Name, secretBackstory] 273 | ] 274 | , "errors" .= object [ 275 | "message" .= Aeson.toJSON [secretText] 276 | , "path" .= Aeson.toJSON [[ "hero" :: Text, "secretBackstory" :: Text ]] 277 | ]] 278 | , testCase "Error in a list" . testQuery 279 | [r| query HeroNameQuery { 280 | hero { 281 | name 282 | friends { 283 | name 284 | secretBackstory 285 | } 286 | } 287 | } 288 | |] 289 | $ object ["data" .= object [ 290 | "hero" .= [r2d2Name, "friends" .= [ 291 | object [lukeName, secretBackstory] 292 | , object [hanName, secretBackstory] 293 | , object [leiaName, secretBackstory] 294 | ]] 295 | ] 296 | , "errors" .= object [ 297 | "message" .= Aeson.toJSON [secretText, secretText, secretText] 298 | , "path" .= Aeson.toJSON [secretPath 0, secretPath 1, secretPath 2] 299 | ]] 300 | , testCase "error on secretBackstory with alias" . testQuery 301 | [r| query HeroNameQuery { 302 | mainHero: hero { 303 | name 304 | story: secretBackstory 305 | } 306 | } 307 | |] 308 | $ object ["data" .= object [ 309 | "mainHero" .= [r2d2Name, "story" .= ()] 310 | ] 311 | , "errors" .= object [ 312 | "message" .= Aeson.toJSON [secretText] 313 | , "path" .= Aeson.toJSON [[ "mainHero" :: Text, "story" :: Text ]] 314 | ]] 315 | ] 316 | ] 317 | where 318 | lukeName = "name" .= ("Luke Skywalker" :: Text) 319 | leiaName = "name" .= ("Leia Organa" :: Text) 320 | hanName = "name" .= ("Han Solo" :: Text) 321 | r2d2Name = "name" .= ("R2-D2" :: Text) 322 | c3poName = "name" .= ("C-3PO" :: Text) 323 | tatooine = "homePlanet" .= ("Tatooine" :: Text) 324 | alderaan = "homePlanet" .= ("Alderaan" :: Text) 325 | secretBackstory = "secretBackstory" .= () 326 | secretText = "secretBackstory is secret" :: Text 327 | secretPath n = ("hero", "friends", n, "secretBackstory") :: (Text, Text, Int, Text) 328 | 329 | testQuery :: Text -> Aeson.Value -> Assertion 330 | testQuery q expected = graphql schema q @?= Just expected 331 | 332 | -- testFail :: Text -> Assertion 333 | -- testFail q = graphql schema q @?= Nothing 334 | 335 | testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion 336 | testQueryParams f q expected = graphqlSubs schema f q @?= Just expected 337 | 338 | -- testFailParams :: Subs -> Text -> Assertion 339 | -- testFailParams f q = graphqlSubs schema f q @?= Nothing 340 | -------------------------------------------------------------------------------- /tests/Test/StarWars/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Test.StarWars.Schema where 4 | 5 | import Control.Applicative (Alternative, empty) 6 | import Data.List.NonEmpty (NonEmpty((:|))) 7 | 8 | import Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..)) 9 | import qualified Data.GraphQL.Schema as Schema 10 | 11 | import Test.StarWars.Data 12 | 13 | -- * Schema 14 | -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js 15 | 16 | schema :: Alternative f => Schema f 17 | schema = hero :| [human, droid] 18 | 19 | hero :: Alternative f => Resolver f 20 | hero = Schema.objectA "hero" $ \case 21 | [] -> character artoo 22 | [Argument "episode" (ValueInt n)] -> character . getHero $ fromIntegral n 23 | [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4 24 | [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5 25 | [Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6 26 | _ -> empty 27 | 28 | human :: Alternative f => Resolver f 29 | human = Schema.objectA "human" $ \case 30 | [Argument "id" (ValueString i)] -> character =<< getHuman i 31 | _ -> empty 32 | 33 | droid :: Alternative f => Resolver f 34 | droid = Schema.objectA "droid" $ \case 35 | [Argument "id" (ValueString i)] -> character =<< getDroid i 36 | _ -> empty 37 | 38 | character :: Alternative f => Character -> [Resolver f] 39 | character char = 40 | [ Schema.scalar "id" $ id_ char 41 | , Schema.scalar "name" $ name char 42 | , Schema.array "friends" $ character <$> getFriends char 43 | , Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char 44 | , Schema.scalar "secretBackstory" $ secretBackstory char 45 | , Schema.scalar "homePlanet" $ either mempty homePlanet char 46 | , Schema.scalar "__typename" $ typeName char 47 | ] 48 | -------------------------------------------------------------------------------- /tests/data/kitchen-sink.graphql: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2015, Facebook, Inc. 2 | # All rights reserved. 3 | # 4 | # This source code is licensed under the BSD-style license found in the 5 | # LICENSE file in the root directory of this source tree. An additional grant 6 | # of patent rights can be found in the PATENTS file in the same directory. 7 | 8 | query queryName($foo: ComplexType, $site: Site = MOBILE) { 9 | whoever123is: node(id: [123, 456]) { 10 | id , # Inline test comment 11 | ... on User @defer { 12 | field2 { 13 | id , 14 | alias: field1(first:10, after:$foo,) @include(if: $foo) { 15 | id, 16 | ...frag 17 | } 18 | } 19 | } 20 | } 21 | } 22 | 23 | mutation likeStory { 24 | like(story: 123) @defer { 25 | story { 26 | id 27 | } 28 | } 29 | } 30 | 31 | fragment frag on Friend { 32 | foo(size: $size, bar: $b, obj: {key: "value"}) 33 | } 34 | 35 | { 36 | unnamed(truthy: true, falsey: false), 37 | query 38 | } 39 | -------------------------------------------------------------------------------- /tests/data/kitchen-sink.min.graphql: -------------------------------------------------------------------------------- 1 | query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})} 2 | -------------------------------------------------------------------------------- /tests/tasty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | #if !MIN_VERSION_base(4,8,0) 6 | import Control.Applicative ((<$>), (<*>)) 7 | #endif 8 | 9 | import Data.Attoparsec.Text (parseOnly) 10 | import qualified Data.Text.IO as Text 11 | import Test.Tasty (TestTree, defaultMain, testGroup) 12 | import Test.Tasty.HUnit 13 | 14 | import qualified Data.GraphQL.Parser as Parser 15 | import qualified Data.GraphQL.Encoder as Encoder 16 | 17 | import qualified Test.StarWars.QueryTests as SW 18 | import Paths_graphql (getDataFileName) 19 | 20 | main :: IO () 21 | main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< kitchenTest 22 | 23 | kitchenTest :: IO TestTree 24 | kitchenTest = testCase "Kitchen Sink" 25 | <$> (assertEqual "Encode" <$> expected <*> actual) 26 | where 27 | expected = Text.readFile 28 | =<< getDataFileName "tests/data/kitchen-sink.min.graphql" 29 | 30 | actual = either (error "Parsing error!") Encoder.document 31 | . parseOnly Parser.document 32 | <$> expected 33 | --------------------------------------------------------------------------------