diff options
39 files changed, 2493 insertions, 926 deletions
@@ -1,2 +0,0 @@ -import Data.Attoparsec.Text -import qualified Data.Text.IO as TIO @@ -1 +1,10 @@ .stack-work/ +.cabal-sandbox/ +cabal.sandbox.config +dist/ +TAGS +.#* +.DS_Store +cabal.project.local +dist-newstyle/ +dist-newstyle/ diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 75c728a..0000000 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md index 21ed453..03743f3 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs deleted file mode 100644 index cc631e6..0000000 --- a/Data/GraphQL/AST.hs +++ /dev/null @@ -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) diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs deleted file mode 100644 index 9eed849..0000000 --- a/Data/GraphQL/Encoder.hs +++ /dev/null @@ -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 diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs deleted file mode 100644 index 1f5b8e6..0000000 --- a/Data/GraphQL/Parser.hs +++ /dev/null @@ -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) @@ -1,4 +1,5 @@ -Copyright J. Daniel Navarro (c) 2015 +Copyright 2019 Eugen Wissner, Germany +Copyright 2015-2017 J. Daniel Navarro All rights reserved. @@ -1,15 +1,17 @@ # Haskell GraphQL [](https://hackage.haskell.org/package/graphql) -[](https://travis-ci.org/jdnavarro/graphql-haskell) +[](https://semaphoreci.com/belka-ew/graphql) +[](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. @@ -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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs new file mode 100644 index 0000000..a4943c6 --- /dev/null +++ b/docs/tutorial/tutorial.lhs @@ -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 diff --git a/graphql.cabal b/graphql.cabal index 9f944fa..dc4bf54 100644 --- a/graphql.cabal +++ b/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 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..814d8c3 --- /dev/null +++ b/package.yaml @@ -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 diff --git a/semaphoreci.sh b/semaphoreci.sh new file mode 100755 index 0000000..f77ac75 --- /dev/null +++ b/semaphoreci.sh @@ -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 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs new file mode 100644 index 0000000..7ac08d7 --- /dev/null +++ b/src/Language/GraphQL.hs @@ -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 "" diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs new file mode 100644 index 0000000..667e4d7 --- /dev/null +++ b/src/Language/GraphQL/AST.hs @@ -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) diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs new file mode 100644 index 0000000..00072e0 --- /dev/null +++ b/src/Language/GraphQL/AST/Core.hs @@ -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) diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs new file mode 100644 index 0000000..64670db --- /dev/null +++ b/src/Language/GraphQL/AST/Transform.hs @@ -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 diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/Encoder.hs new file mode 100644 index 0000000..c315091 --- /dev/null +++ b/src/Language/GraphQL/Encoder.hs @@ -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 diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs new file mode 100644 index 0000000..d0bc84d --- /dev/null +++ b/src/Language/GraphQL/Error.hs @@ -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 diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs new file mode 100644 index 0000000..9dbfb36 --- /dev/null +++ b/src/Language/GraphQL/Execute.hs @@ -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)) diff --git a/src/Language/GraphQL/Lexer.hs b/src/Language/GraphQL/Lexer.hs new file mode 100644 index 0000000..8ca03bf --- /dev/null +++ b/src/Language/GraphQL/Lexer.hs @@ -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 () diff --git a/src/Language/GraphQL/Parser.hs b/src/Language/GraphQL/Parser.hs new file mode 100644 index 0000000..dac15c2 --- /dev/null +++ b/src/Language/GraphQL/Parser.hs @@ -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 diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs new file mode 100644 index 0000000..08b52ce --- /dev/null +++ b/src/Language/GraphQL/Schema.hs @@ -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 diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs new file mode 100644 index 0000000..5ca72e9 --- /dev/null +++ b/src/Language/GraphQL/Trans.hs @@ -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 = (<|>) diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs new file mode 100644 index 0000000..3f91e50 --- /dev/null +++ b/src/Language/GraphQL/Type.hs @@ -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 diff --git a/stack-7.10.yaml b/stack-7.10.yaml deleted file mode 100644 index bee0443..0000000 --- a/stack-7.10.yaml +++ /dev/null @@ -1,5 +0,0 @@ -flags: {} -packages: -- '.' -extra-deps: [] -resolver: lts-3.4 diff --git a/stack-7.8.yaml b/stack-7.8.yaml deleted file mode 100644 index 809bd2e..0000000 --- a/stack-7.8.yaml +++ /dev/null @@ -1,5 +0,0 @@ -flags: {} -packages: -- '.' -extra-deps: [] -resolver: lts-2.22 diff --git a/stack.yaml b/stack.yaml index 177aa94..8d2eae9 120000..100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1,6 @@ -stack-7.10.yaml
\ No newline at end of file +resolver: lts-13.29 +packages: +- '.' +extra-deps: [] +flags: {} +extra-package-dbs: [] diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..d2178fe --- /dev/null +++ b/stack.yaml.lock @@ -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 diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs new file mode 100644 index 0000000..8bb39ed --- /dev/null +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -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 diff --git a/tests/Language/GraphQL/LexerSpec.hs b/tests/Language/GraphQL/LexerSpec.hs new file mode 100644 index 0000000..b5b605d --- /dev/null +++ b/tests/Language/GraphQL/LexerSpec.hs @@ -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 ()) "" diff --git a/tests/Language/GraphQL/ParserSpec.hs b/tests/Language/GraphQL/ParserSpec.hs new file mode 100644 index 0000000..c412c85 --- /dev/null +++ b/tests/Language/GraphQL/ParserSpec.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Test/KitchenSinkSpec.hs b/tests/Test/KitchenSinkSpec.hs new file mode 100644 index 0000000..99a00f7 --- /dev/null +++ b/tests/Test/KitchenSinkSpec.hs @@ -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 diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs new file mode 100644 index 0000000..55ff207 --- /dev/null +++ b/tests/Test/StarWars/Data.hs @@ -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 diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs new file mode 100644 index 0000000..0f6a2ef --- /dev/null +++ b/tests/Test/StarWars/QuerySpec.hs @@ -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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs new file mode 100644 index 0000000..101bbdf --- /dev/null +++ b/tests/Test/StarWars/Schema.hs @@ -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 + ] diff --git a/tests/tasty.hs b/tests/tasty.hs deleted file mode 100644 index a034a79..0000000 --- a/tests/tasty.hs +++ /dev/null @@ -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 |