diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs index 2da8a46..a2796ae 100644 --- a/Data/GraphQL.hs +++ b/Data/GraphQL.hs @@ -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 diff --git a/Data/GraphQL/Error.hs b/Data/GraphQL/Error.hs new file mode 100644 index 0000000..25632b4 --- /dev/null +++ b/Data/GraphQL/Error.hs @@ -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)] diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 47d1d03..e5998e9 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -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))]) = diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 1c45af2..345984c 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -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 diff --git a/graphql.cabal b/graphql.cabal index 18c78fa..4b3cc38 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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 diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs index ccaf481..11dd2d5 100644 --- a/tests/Test/StarWars/QueryTests.hs +++ b/tests/Test/StarWars/QueryTests.hs @@ -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