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

Added exception handling with Alternative constraint according to spec.

Browse Source
This commit is contained in:
Matthías Páll Gissurarson 2016-03-12 00:59:51 +01:00
parent b74278cd19
commit d195389102
6 changed files with 133 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Data/GraphQL.hs
View File

@ -1,6 +1,6 @@
module Data.GraphQL where
import Control.Applicative (Alternative, empty)
import Control.Applicative (Alternative)
import Data.Text (Text)
@ -11,10 +11,13 @@ import Data.GraphQL.Execute
import Data.GraphQL.Parser
import Data.GraphQL.Schema
import Data.GraphQL.Error
graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
graphql = flip graphqlSubs $ const Nothing
graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
graphqlSubs schema f =
either (const empty) (execute schema f)
either parseError (execute schema f)
. Attoparsec.parseOnly document

62
Data/GraphQL/Error.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.GraphQL.Error (
parseError,
CollectErrsT,
addErr,
addErrMsg,
runCollectErrs,
joinErrs,
errWrap
) where
import qualified Data.Aeson as Aeson
import Data.Text (Text, pack)
import Control.Arrow ((&&&))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, pure)
import Data.Foldable (Foldable, concatMap)
import Prelude hiding (concatMap)
#endif
-- | Wraps a parse error into a list of errors.
parseError :: Applicative f => String -> f Aeson.Value
parseError s =
pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])]
-- | A wrapper for an applicative functor, for passing around error messages.
type CollectErrsT f a = f (a,[Aeson.Value])
-- | Takes a (wrapped) list (foldable functor) of values and errors and
-- joins the values into a list and concatenates the errors.
joinErrs
:: (Functor m, Functor f, Foldable f)
=> m (f (a,[Aeson.Value])) -> CollectErrsT m (f a)
joinErrs = fmap $ fmap fst &&& concatMap snd
-- | Wraps the given applicative to handle errors
errWrap :: Functor f => f a -> f (a, [Aeson.Value])
errWrap = fmap (flip (,) [])
-- | Adds an error to the list of errors.
addErr :: Functor f => Aeson.Value -> CollectErrsT f a -> CollectErrsT f a
addErr v = (fmap . fmap) (v :)
makeErrorMsg :: Text -> Aeson.Value
makeErrorMsg s = Aeson.object [("message",Aeson.toJSON s)]
-- | Convenience function for just wrapping an error message.
addErrMsg :: Functor f => Text -> CollectErrsT f a -> CollectErrsT f a
addErrMsg = addErr . makeErrorMsg
-- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data.
runCollectErrs :: Functor f => CollectErrsT f Aeson.Value -> f Aeson.Value
runCollectErrs = fmap finalD
where finalD (dat,errs) =
Aeson.object $
if null errs
then [("data",dat)]
else [("data",dat),("errors",Aeson.toJSON $ reverse errs)]

18
Data/GraphQL/Execute.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.GraphQL.Execute (execute) where
#if !MIN_VERSION_base(4,8,0)
@ -13,10 +14,19 @@ import Data.GraphQL.AST
import Data.GraphQL.Schema (Schema(..))
import qualified Data.GraphQL.Schema as Schema
execute
:: Alternative f
=> Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
execute (Schema resolvs) subs = Schema.resolvers resolvs . rootFields subs
import Data.GraphQL.Error
{- | Takes a schema, a substitution and a GraphQL document.
The substition 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 a "errors field".
-}
execute :: Alternative m
=> Schema.Schema m -> Schema.Subs -> Document -> m Aeson.Value
execute (Schema resolvs) subs doc = runCollectErrs res
where res = Schema.resolvers resolvs $ rootFields subs doc
rootFields :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =

30
Data/GraphQL/Schema.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Schema
( Schema(..)
@ -28,7 +29,7 @@ import Data.Monoid (Monoid(mempty,mappend))
#else
import Data.Monoid (Alt(Alt,getAlt))
#endif
import Control.Applicative (Alternative, empty)
import Control.Applicative (Alternative(..))
import Data.Maybe (catMaybes)
import Data.Foldable (fold)
@ -36,13 +37,16 @@ import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as T (null)
import qualified Data.Text as T (null, unwords)
import Control.Arrow
import Data.GraphQL.AST
import Data.GraphQL.Error
data Schema f = Schema [Resolver f]
type Resolver f = Field -> f Aeson.Object
type Resolver f = Field -> CollectErrsT f Aeson.Object
type Subs = Text -> Maybe Text
@ -65,7 +69,7 @@ scalar name s = scalarA name $ \case
scalarA
:: (Alternative f, Aeson.ToJSON a)
=> Text -> ([Argument] -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args _ []) = withField name (f args) fld
scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
scalarA _ _ _ = empty
array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
@ -77,7 +81,7 @@ arrayA
:: Alternative f
=> Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
arrayA name f fld@(Field _ _ args _ sels) =
withField name (traverse (flip resolvers $ fields sels) $ f args) fld
withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
enum :: Alternative f => Text -> f [Text] -> Resolver f
enum name enums = enumA name $ \case
@ -85,23 +89,27 @@ enum name enums = enumA name $ \case
_ -> empty
enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
enumA name f fld@(Field _ _ args _ []) = withField name (f args) fld
enumA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
enumA _ _ _ = empty
withField
:: (Alternative f, Aeson.ToJSON a)
=> Text -> f a -> Field -> f (HashMap Text Aeson.Value)
=> Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _ _) =
if name == name'
then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty
where
aliasOrName = if T.null alias then name' else alias
resolvers :: Alternative f => [Resolver f] -> [Field] -> f Aeson.Value
resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value
resolvers resolvs =
fmap (Aeson.toJSON . fold)
. traverse (\fld -> getAlt $ foldMap (Alt . ($ fld)) resolvs)
fmap (first Aeson.toJSON . fold)
. traverse (\fld -> (getAlt $ foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld)
where errmsg (Field alias name _ _ _) = addErrMsg msg $ (errWrap . pure) val
where val = HashMap.singleton aliasOrName Aeson.Null
msg = T.unwords ["field", name, "not resolved."]
aliasOrName = if T.null alias then name else alias
field :: Selection -> Maybe Field
field (SelectionField x) = Just x

17
graphql.cabal
View File

@ -28,10 +28,11 @@ library
Data.GraphQL.Execute
Data.GraphQL.Schema
Data.GraphQL.Parser
build-depends: base >= 4.7 && < 5,
text >= 0.11.3.1,
aeson >= 0.7.0.3,
Data.GraphQL.Error
build-depends: aeson >= 0.7.0.3,
attoparsec >= 0.10.4.0,
base >= 4.7 && < 5,
text >= 0.11.3.1,
unordered-containers >= 0.2.5.0
test-suite tasty
@ -44,15 +45,15 @@ test-suite tasty
Test.StarWars.Data
Test.StarWars.Schema
Test.StarWars.QueryTests
build-depends: base >= 4.6 && <5,
aeson >= 0.7.0.3,
text >= 0.11.3.1,
build-depends: aeson >= 0.7.0.3,
attoparsec >= 0.10.4.0,
base >= 4.6 && <5,
graphql,
raw-strings-qq >= 1.1,
tasty >= 0.10,
tasty-hunit >= 0.9,
unordered-containers >= 0.2.5.0,
graphql
text >= 0.11.3.1,
unordered-containers >= 0.2.5.0
source-repository head
type: git

47
tests/Test/StarWars/QueryTests.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE QuasiQuotes #-}
module Test.StarWars.QueryTests (test) where
import qualified Data.Aeson as Aeson (Value)
import qualified Data.Aeson as Aeson (Value(Null), toJSON)
import Data.Aeson (object, (.=))
import Data.Text (Text)
import Text.RawString.QQ (r)
@ -28,7 +28,7 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object ["hero" .= object ["id" .= ("2001" :: Text)]]
$ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
, testCase "R2-D2 ID and friends" . testQuery
[r| query HeroNameAndFriendsQuery {
hero {
@ -40,7 +40,7 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"hero" .= object [
"id" .= ("2001" :: Text)
, "name" .= ("R2-D2" :: Text)
@ -50,7 +50,7 @@ test = testGroup "Star Wars Query Tests"
, object ["name" .= ("Leia Organa" :: Text)]
]
]
]
]]
]
, testGroup "Nested Queries"
[ testCase "R2-D2 friends" . testQuery
@ -67,7 +67,7 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"hero" .= object [
"name" .= ("R2-D2" :: Text)
, "friends" .= [
@ -102,7 +102,7 @@ test = testGroup "Star Wars Query Tests"
]
]
]
]
]]
, testCase "Luke ID" . testQuery
[r| query FetchLukeQuery {
human(id: "1000") {
@ -110,12 +110,12 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"human" .= object [
"name" .= ("Luke Skywalker" :: Text)
]
]
]
]]
, testCase "Luke ID with variable" . testQueryParams
(\v -> if v == "someId"
then Just "1000"
@ -126,9 +126,9 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"human" .= object ["name" .= ("Luke Skywalker" :: Text)]
]
]]
, testCase "Han ID with variable" . testQueryParams
(\v -> if v == "someId"
then Just "1002"
@ -139,10 +139,10 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"human" .= object ["name" .= ("Han Solo" :: Text)]
]
, testCase "Invalid ID" $ testFailParams
]]
, testCase "Invalid ID" . testQueryParams
(\v -> if v == "id"
then Just "Not a valid ID"
else Nothing)
@ -151,13 +151,14 @@ test = testGroup "Star Wars Query Tests"
name
}
}
|]
|] $ object ["data" .= object ["human" .= object ["name" .= Aeson.Null]],
"errors" .= (Aeson.toJSON [object ["message" .= ("field name not resolved." :: Text)]])]
-- TODO: This test is directly ported from `graphql-js`, however do we want
-- to mimic the same behavior? Is this part of the spec? Once proper
-- exceptions are implemented this test might no longer be meaningful.
-- If the same behavior needs to be replicated, should it be implemented
-- when defining the `Schema` or when executing?
-- $ object ["human" .= Aeson.Null]
-- $ object [ "data" .= object ["human" .= Aeson.Null] ]
, testCase "Luke aliased" . testQuery
[r| query FetchLukeAliased {
luke: human(id: "1000") {
@ -165,11 +166,11 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"luke" .= object [
"name" .= ("Luke Skywalker" :: Text)
]
]
]]
, testCase "R2-D2 ID and friends aliased" . testQuery
[r| query HeroNameAndFriendsQuery {
hero {
@ -181,7 +182,7 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"hero" .= object [
"id" .= ("2001" :: Text)
, "name" .= ("R2-D2" :: Text)
@ -191,7 +192,7 @@ test = testGroup "Star Wars Query Tests"
, object ["friendName" .= ("Leia Organa" :: Text)]
]
]
]
]]
, testCase "Luke and Leia aliased" . testQuery
[r| query FetchLukeAndLeiaAliased {
luke: human(id: "1000") {
@ -202,14 +203,14 @@ test = testGroup "Star Wars Query Tests"
}
}
|]
$ object [
$ object [ "data" .= object [
"luke" .= object [
"name" .= ("Luke Skywalker" :: Text)
]
, "leia" .= object [
"name" .= ("Leia Organa" :: Text)
]
]
]]
]
testQuery :: Text -> Aeson.Value -> Assertion
@ -221,5 +222,5 @@ testQuery q expected = graphql schema q @?= Just expected
testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
testFailParams :: Subs -> Text -> Assertion
testFailParams f q = graphqlSubs schema f q @?= Nothing
-- testFailParams :: Subs -> Text -> Assertion
-- testFailParams f q = graphqlSubs schema f q @?= Nothing