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 module Data.GraphQL where
import Control.Applicative (Alternative, empty) import Control.Applicative (Alternative)
import Data.Text (Text) import Data.Text (Text)
@ -11,10 +11,13 @@ import Data.GraphQL.Execute
import Data.GraphQL.Parser import Data.GraphQL.Parser
import Data.GraphQL.Schema import Data.GraphQL.Schema
import Data.GraphQL.Error
graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
graphql = flip graphqlSubs $ const Nothing graphql = flip graphqlSubs $ const Nothing
graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
graphqlSubs schema f = graphqlSubs schema f =
either (const empty) (execute schema f) either parseError (execute schema f)
. Attoparsec.parseOnly document . 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 CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.GraphQL.Execute (execute) where module Data.GraphQL.Execute (execute) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -13,10 +14,19 @@ import Data.GraphQL.AST
import Data.GraphQL.Schema (Schema(..)) import Data.GraphQL.Schema (Schema(..))
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
execute import Data.GraphQL.Error
:: Alternative f
=> Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value {- | Takes a schema, a substitution and a GraphQL document.
execute (Schema resolvs) subs = Schema.resolvers resolvs . rootFields subs 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 :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =

30
Data/GraphQL/Schema.hs
View File

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

17
graphql.cabal
View File

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

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

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