Retrieve resolver arguments from the reader

This commit is contained in:
Eugen Wissner 2019-12-31 08:29:03 +01:00
parent 44dc80bb37
commit d82d5a36b3
5 changed files with 74 additions and 67 deletions

View File

@ -9,6 +9,7 @@ and this project adheres to
## [Unreleased]
### Added
- AST for the GraphQL schema.
- `Trans.argument`.
### Changed
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
@ -25,6 +26,10 @@ and this project adheres to
3 corresponding data constructors, `Field`, `InlineFragment` and
`FragmentSpread`, instead of separate types. It simplifies pattern matching
and doesn't make the code less typesafe.
- `Schema.scalarA`.
- `Schema.wrappedScalarA`.
- `Schema.wrappedObjectA`.
- `Schema.objectA`.
## [0.6.1.0] - 2019-12-23
### Fixed

View File

@ -16,7 +16,6 @@ Since this file is a literate haskell file, we start by importing some dependenc
> module Main where
>
> import Control.Monad.IO.Class (liftIO)
> import Control.Monad.Trans.Except (throwE)
> import Data.Aeson (encode)
> import Data.ByteString.Lazy.Char8 (putStrLn)
> import Data.List.NonEmpty (NonEmpty(..))
@ -25,7 +24,6 @@ Since this file is a literate haskell file, we start by importing some dependenc
>
> import Language.GraphQL
> import qualified Language.GraphQL.Schema as Schema
> import Language.GraphQL.Trans (ActionT(..))
>
> import Prelude hiding (putStrLn)
@ -70,10 +68,9 @@ For this example, we're going to be using time.
> schema2 = time :| []
>
> time :: Schema.Resolver IO
> time = Schema.scalarA "time" $ \case
> [] -> do t <- liftIO getCurrentTime
> time = Schema.scalar "time" $ do
> t <- liftIO getCurrentTime
> return $ show t
> _ -> ActionT $ throwE "Invalid arguments."
This defines a simple schema with one type and one field,
which resolves to the current time.

View File

@ -6,14 +6,10 @@ module Language.GraphQL.Schema
( Resolver
, Subs
, object
, objectA
, scalar
, scalarA
, resolve
, wrappedObject
, wrappedObjectA
, wrappedScalar
, wrappedScalarA
-- * AST Reexports
, Field
, Argument(..)
@ -50,64 +46,55 @@ type Subs = HashMap Name Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
object name = objectA name . const
-- | Like 'object' but also taking 'Argument's.
objectA :: MonadIO m
=> Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
objectA name f = Resolver name $ resolveFieldValue f resolveRight
object name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
wrappedObjectA :: MonadIO m
=> Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
-- | Like 'object' but can be null or a list of objects.
wrappedObject ::
MonadIO m =>
Name ->
ActionT m (Type.Wrapping [Resolver m]) ->
Resolver m
wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
= withField (traverse (`resolve` sels) resolver) fld
-- | Like 'object' but can be null or a list of objects.
wrappedObject :: MonadIO m
=> Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
wrappedObject name = wrappedObjectA name . const
-- | A scalar represents a primitive value, like a string or an integer.
scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name = scalarA name . const
-- | Like 'scalar' but also taking 'Argument's.
scalarA :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ([Argument] -> ActionT m a) -> Resolver m
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
scalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld result = withField (return result) fld
-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
-- | Like 'scalar' but can be null or a list of scalars.
wrappedScalar ::
(MonadIO m, Aeson.ToJSON a) =>
Name ->
ActionT m (Type.Wrapping a) ->
Resolver m
wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Type.Named result) = withField (return result) fld
resolveRight fld Type.Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld (Type.List result) = withField (return result) fld
-- | Like 'scalar' but can be null or a list of scalars.
wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ActionT m (Type.Wrapping a) -> Resolver m
wrappedScalar name = wrappedScalarA name . const
resolveFieldValue :: MonadIO m
=> ([Argument] -> ActionT m a)
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
-> Field
-> CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue ::
MonadIO m =>
ActionT m a ->
(Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) ->
Field ->
CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
result <- lift $ reader . runExceptT . runActionT $ f args
result <- lift $ reader . runExceptT . runActionT $ f
either resolveLeft (resolveRight fld) result
where
reader = flip runReaderT $ Context mempty
reader = flip runReaderT
$ Context
$ HashMap.fromList
$ argumentToTuple <$> args
argumentToTuple (Argument name value) = (name, value)
resolveLeft err = do
_ <- addErrMsg err
return $ HashMap.singleton (aliasOrName fld) Aeson.Null

View File

@ -2,6 +2,7 @@
module Language.GraphQL.Trans
( ActionT(..)
, Context(Context)
, argument
) where
import Control.Applicative (Alternative(..))
@ -9,10 +10,13 @@ import Control.Monad (MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Reader (ReaderT, asks)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Language.GraphQL.AST.Core (Name, Value)
import Language.GraphQL.AST.Core
import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments.
newtype Context = Context (HashMap Name Value)
@ -47,3 +51,13 @@ instance Monad m => Alternative (ActionT m) where
instance Monad m => MonadPlus (ActionT m) where
mzero = empty
mplus = (<|>)
-- | Retrieves an argument by its name. If the argument with this name couldn't
-- be found, returns 'Value.Null' (i.e. the argument is assumed to
-- be optional then).
argument :: MonadIO m => Name -> ActionT m Value
argument argumentName = do
argumentValue <- ActionT $ lift $ asks lookup
pure $ fromMaybe Null argumentValue
where
lookup (Context argumentMap) = HashMap.lookup argumentName argumentMap

View File

@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema
( character
@ -8,9 +7,9 @@ module Test.StarWars.Schema
, schema
) where
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (MonadIO(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes)
import qualified Language.GraphQL.Schema as Schema
@ -24,16 +23,19 @@ schema :: MonadIO m => NonEmpty (Schema.Resolver m)
schema = hero :| [human, droid]
hero :: MonadIO m => Schema.Resolver m
hero = Schema.objectA "hero" $ \case
[] -> character artoo
[Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
[Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
[Schema.Argument "episode" (Schema.Enum "JEDI" )] -> character $ getHero 6
_ -> ActionT $ throwE "Invalid arguments."
hero = Schema.object "hero" $ do
episode <- argument "episode"
character $ case episode of
Schema.Enum "NEWHOPE" -> getHero 4
Schema.Enum "EMPIRE" -> getHero 5
Schema.Enum "JEDI" -> getHero 6
_ -> artoo
human :: MonadIO m => Schema.Resolver m
human = Schema.wrappedObjectA "human" $ \case
[Schema.Argument "id" (Schema.String i)] -> do
human = Schema.wrappedObject "human" $ do
id' <- argument "id"
case id' of
Schema.String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> return Type.Null
@ -41,8 +43,10 @@ human = Schema.wrappedObjectA "human" $ \case
_ -> ActionT $ throwE "Invalid arguments."
droid :: MonadIO m => Schema.Resolver m
droid = Schema.objectA "droid" $ \case
[Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)
droid = Schema.object "droid" $ do
id' <- argument "id"
case id' of
Schema.String i -> character =<< liftIO (getDroid i)
_ -> ActionT $ throwE "Invalid arguments."
character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]