diff --git a/CHANGELOG.md b/CHANGELOG.md index 52abf77..7cfe229 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,9 @@ and this project adheres to ## [Unreleased] ## Added - `AST` reexports `AST.Parser`. +- `Execute` reexports `Execute.Coerce`. +- `Error.Error` is an error representation with a message and source location. +- `Error.Response` represents a result of running a GraphQL query. ## Changed - `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver` @@ -18,10 +21,15 @@ and this project adheres to - `AST.Core` contained only `Arguments` which was moved to `Type.Definition`. `AST` provides now only functionality related to parsing and encoding, as it should be. +- `Execute.execute` takes an additional argument, a possible operation name. +- `Error` module was changed to work with dedicated types for errors and the + response instead of JSON. ## Removed - `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a part of the fields and are called `Trans.ResolverT`. +- `Execute.executeWithName`. `Execute.execute` takes the operation name and + completely replaces `executeWithName`. ## [0.8.0.0] - 2020-06-20 ### Fixed diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 961253f..adda7a1 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + -- | This module provides the functions to parse and execute @GraphQL@ queries. module Language.GraphQL ( graphql @@ -5,13 +8,11 @@ module Language.GraphQL ) where import qualified Data.Aeson as Aeson -import Data.HashMap.Strict (HashMap) +import qualified Data.Sequence as Seq import Data.Text (Text) -import Language.GraphQL.AST.Document -import Language.GraphQL.AST.Parser +import Language.GraphQL.AST import Language.GraphQL.Error import Language.GraphQL.Execute -import Language.GraphQL.Execute.Coerce import Language.GraphQL.Type.Schema import Text.Megaparsec (parse) @@ -21,16 +22,32 @@ graphql :: Monad m => Schema m -- ^ Resolvers. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. -graphql = flip graphqlSubs (mempty :: Aeson.Object) +graphql schema = graphqlSubs schema mempty mempty -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given -- 'Schema'. -graphqlSubs :: (Monad m, VariableValue a) +graphqlSubs :: Monad m => Schema m -- ^ Resolvers. - -> HashMap Name a -- ^ Variable substitution function. + -> Maybe Text -- ^ Operation name. + -> Aeson.Object -- ^ Variable substitution function. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. -graphqlSubs schema f - = either parseError (execute schema f) - . parse document "" +graphqlSubs schema operationName variableValues document' = + either parseError executeRequest parsed >>= formatResponse + where + parsed = parse document "" document' + formatResponse (Response data'' Seq.Empty) = + pure $ Aeson.object [("data", data'')] + formatResponse (Response data'' errors') = pure $ Aeson.object + [ ("data", data'') + , ("errors", Aeson.toJSON $ toJSON <$> errors') + ] + toJSON Error{ line = 0, column = 0, ..} = + Aeson.object [("message", Aeson.toJSON message)] + toJSON Error{..} = Aeson.object + [ ("message", Aeson.toJSON message) + , ("line", Aeson.toJSON line) + , ("column", Aeson.toJSON column) + ] + executeRequest = execute schema operationName variableValues diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 59719b0..4c37f6a 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -5,7 +6,9 @@ module Language.GraphQL.Error ( parseError , CollectErrsT + , Error(..) , Resolution(..) + , Response(..) , addErr , addErrMsg , runCollectErrs @@ -13,12 +16,16 @@ module Language.GraphQL.Error ) where import Control.Monad.Trans.State (StateT, modify, runStateT) -import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) +import Data.Sequence (Seq(..), (|>)) +import qualified Data.Sequence as Seq import Data.Text (Text) +import qualified Data.Text as Text import Data.Void (Void) import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.Execute.Coerce import Language.GraphQL.Type.Schema +import Prelude hiding (null) import Text.Megaparsec ( ParseErrorBundle(..) , PosState(..) @@ -31,59 +38,72 @@ import Text.Megaparsec -- | Executor context. data Resolution m = Resolution - { errors :: [Aeson.Value] + { errors :: Seq Error , types :: HashMap Name (Type m) } -- | Wraps a parse error into a list of errors. -parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value +parseError :: (Applicative f, Serialize a) + => ParseErrorBundle Text Void + -> f (Response a) parseError ParseErrorBundle{..} = - pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)] + pure $ Response null $ fst + $ foldl go (Seq.empty, bundlePosState) bundleErrors where - errorObject s SourcePos{..} = Aeson.object - [ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s) - , ("line", Aeson.toJSON $ unPos sourceLine) - , ("column", Aeson.toJSON $ unPos sourceColumn) - ] + errorObject s SourcePos{..} = Error + (Text.pack $ init $ parseErrorTextPretty s) + (unPos' sourceLine) + (unPos' sourceColumn) + unPos' = fromIntegral . unPos go (result, state) x = let (_, newState) = reachOffset (errorOffset x) state sourcePosition = pstateSourcePos newState - in (errorObject x sourcePosition : result, newState) + in (result |> errorObject x sourcePosition, newState) -- | A wrapper to pass error messages around. type CollectErrsT m = StateT (Resolution m) m -- | Adds an error to the list of errors. -addErr :: Monad m => Aeson.Value -> CollectErrsT m () +addErr :: Monad m => Error -> CollectErrsT m () addErr v = modify appender where - appender resolution@Resolution{..} = resolution{ errors = v : errors } + appender :: Monad m => Resolution m -> Resolution m + appender resolution@Resolution{..} = resolution{ errors = errors |> v } -makeErrorMessage :: Text -> Aeson.Value -makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)] +makeErrorMessage :: Text -> Error +makeErrorMessage s = Error s 0 0 -- | 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]) - ] +-- message. +singleError :: Serialize a => Text -> Response a +singleError message = Response null $ Seq.singleton $ makeErrorMessage message -- | Convenience function for just wrapping an error message. addErrMsg :: Monad m => Text -> CollectErrsT m () addErrMsg = addErr . makeErrorMessage +-- | @GraphQL@ error. +data Error = Error + { message :: Text + , line :: Word + , column :: Word + } deriving (Eq, Show) + +-- | The server\'s response describes the result of executing the requested +-- operation if successful, and describes any errors encountered during the +-- request. +data Response a = Response + { data' :: a + , errors :: Seq Error + } deriving (Eq, Show) + -- | Runs the given query computation, but collects the errors into an error --- list, which is then sent back with the data. -runCollectErrs :: Monad m +-- list, which is then sent back with the data. +runCollectErrs :: (Monad m, Serialize a) => HashMap Name (Type m) - -> CollectErrsT m Aeson.Value - -> m Aeson.Value + -> CollectErrsT m a + -> m (Response a) runCollectErrs types' res = do - (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' } - if null errors - then return $ Aeson.object [("data", dat)] - else return $ Aeson.object - [ ("data", dat) - , ("errors", Aeson.toJSON $ reverse errors) - ] + (dat, Resolution{..}) <- runStateT res + $ Resolution{ errors = Seq.empty, types = types' } + pure $ Response dat errors diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 45bace0..ff1078c 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,10 +1,9 @@ -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute ( execute - , executeWithName + , module Language.GraphQL.Execute.Coerce ) where -import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Sequence (Seq(..)) @@ -18,54 +17,38 @@ import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema --- | The substitution is applied to the document, and the 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 :: (Monad m, VariableValue a) - => Schema m -- ^ Resolvers. - -> HashMap.HashMap Name a -- ^ Variable substitution function. - -> Document -- @GraphQL@ document. - -> m Aeson.Value -execute schema = executeRequest schema Nothing - -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document -- defines multiple root operations. -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -executeWithName :: (Monad m, VariableValue a) - => Schema m -- ^ Resolvers - -> Text -- ^ Operation name. +execute :: (Monad m, VariableValue a, Serialize b) + => Schema m -- ^ Resolvers. + -> Maybe Text -- ^ Operation name. -> HashMap.HashMap Name a -- ^ Variable substitution function. - -> Document -- ^ @GraphQL@ Document. - -> m Aeson.Value -executeWithName schema operationName = - executeRequest schema (Just operationName) - -executeRequest :: (Monad m, VariableValue a) - => Schema m - -> Maybe Text - -> HashMap.HashMap Name a - -> Document - -> m Aeson.Value -executeRequest schema operationName subs document = + -> Document -- @GraphQL@ document. + -> m (Response b) +execute schema operationName subs document = case Transform.document schema operationName subs document of Left queryError -> pure $ singleError $ Transform.queryError queryError - Right (Transform.Document types' rootObjectType operation) - | (Transform.Query _ fields) <- operation -> - executeOperation types' rootObjectType fields - | (Transform.Mutation _ fields) <- operation -> - executeOperation types' rootObjectType fields + Right transformed -> executeRequest transformed + +executeRequest :: (Monad m, Serialize a) + => Transform.Document m + -> m (Response a) +executeRequest (Transform.Document types' rootObjectType operation) + | (Transform.Query _ fields) <- operation = + executeOperation types' rootObjectType fields + | (Transform.Mutation _ fields) <- operation = + executeOperation types' rootObjectType fields -- This is actually executeMutation, but we don't distinguish between queries -- and mutations yet. -executeOperation :: Monad m +executeOperation :: (Monad m, Serialize a) => HashMap Name (Type m) -> Out.ObjectType m -> Seq (Transform.Selection m) - -> m Aeson.Value + -> m (Response a) executeOperation types' objectType fields = runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs index 8bb39ed..179f3b0 100644 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -4,6 +4,7 @@ module Language.GraphQL.ErrorSpec ) where import qualified Data.Aeson as Aeson +import qualified Data.Sequence as Seq import Language.GraphQL.Error import Test.Hspec ( Spec , describe @@ -14,11 +15,6 @@ import Test.Hspec ( Spec spec :: Spec spec = describe "singleError" $ it "constructs an error with the given message" $ - let expected = Aeson.object - [ - ("errors", Aeson.toJSON - [ Aeson.object [("message", "Message.")] - ] - ) - ] + let errors'' = Seq.singleton $ Error "Message." 0 0 + expected = Response Aeson.Null errors'' in singleError "Message." `shouldBe` expected diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 632e4dd..e7ab9f8 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -47,28 +47,26 @@ spec :: Spec spec = describe "execute" $ do it "skips unknown fields" $ - let expected = Aeson.object - [ "data" .= Aeson.object - [ "philosopher" .= Aeson.object - [ "firstName" .= ("Friedrich" :: String) - ] + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) ] ] - execute' = execute schema (mempty :: HashMap Name Aeson.Value) + expected = Response data'' mempty + execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) actual = runIdentity $ either parseError execute' $ parse document "" "{ philosopher { firstName surname } }" in actual `shouldBe` expected it "merges selections" $ - let expected = Aeson.object - [ "data" .= Aeson.object - [ "philosopher" .= Aeson.object - [ "firstName" .= ("Friedrich" :: String) - , "lastName" .= ("Nietzsche" :: String) - ] + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + , "lastName" .= ("Nietzsche" :: String) ] ] - execute' = execute schema (mempty :: HashMap Name Aeson.Value) + expected = Response data'' mempty + execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) actual = runIdentity $ either parseError execute' $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index cf451f8..4e48dbf 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -361,4 +361,4 @@ testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams f q expected = - runIdentity (graphqlSubs schema f q) `shouldBe` expected + runIdentity (graphqlSubs schema Nothing f q) `shouldBe` expected