diff options
Diffstat (limited to 'src/Language')
| -rw-r--r-- | src/Language/GraphQL.hs | 37 | ||||
| -rw-r--r-- | src/Language/GraphQL/Error.hs | 80 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 55 |
3 files changed, 96 insertions, 76 deletions
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(..)) @@ -19,53 +18,37 @@ 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 |