Accept resolvers given by the user as is

This commit is contained in:
Eugen Wissner 2020-05-13 16:21:48 +02:00
parent 9232e08eb9
commit 4c19c88e98
7 changed files with 166 additions and 70 deletions

View File

@ -7,6 +7,11 @@ and this project adheres to
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
## [Unreleased]
### Changed
- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can
contain a JSON value or another resolver, which is invoked during the
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
passed in the reader and not as an explicit argument.
## [0.7.0.0] - 2020-05-11
### Fixed
@ -20,7 +25,7 @@ and this project adheres to
- `Trans.argument`.
- Schema extension parser.
- Contributing guidelines.
- `Schema.resolversToMap` (intended for to be used internally).
- `Schema.resolversToMap` (intended to be used internally).
### Changed
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.

View File

@ -35,18 +35,19 @@ import qualified Language.GraphQL.Type as Type
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'.
data Resolver m = Resolver
Text -- ^ Name
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
data Resolver m = Resolver Name (FieldResolver m)
data FieldResolver m
= ValueResolver (ActionT m Aeson.Value)
| NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
-- | Converts resolvers to a map.
resolversToMap
:: (Foldable f, Functor f)
resolversToMap :: (Foldable f, Functor f)
=> f (Resolver m)
-> HashMap Text (Field -> CollectErrsT m Aeson.Object)
-> HashMap Text (FieldResolver m)
resolversToMap = HashMap.fromList . toList . fmap toKV
where
toKV (Resolver name f) = (name, f)
toKV (Resolver name r) = (name, r)
-- | Contains variables for the query. The key of the map is a variable name,
-- and the value is the variable value.
@ -54,85 +55,79 @@ type Subs = HashMap Name Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
object name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) resolver
= withField (resolve (resolversToMap resolver) flds) fld
object name = Resolver name
. NestingResolver
. fmap (Type.Named . resolversToMap)
-- | Like 'object' but can be null or a list of objects.
wrappedObject ::
Monad 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 (resolveMap sels) resolver) fld
resolveMap = flip (resolve . resolversToMap)
wrappedObject :: Monad m
=> Name
-> ActionT m (Type.Wrapping [Resolver m])
-> Resolver m
wrappedObject name = Resolver name
. NestingResolver
. (fmap . fmap) resolversToMap
-- | A scalar represents a primitive value, like a string or an integer.
scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld result = withField (return result) fld
scalar name = Resolver name . ValueResolver . fmap Aeson.toJSON
-- | Like 'scalar' but can be null or a list of scalars.
wrappedScalar ::
(Monad 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
wrappedScalar :: (Monad m, Aeson.ToJSON a)
=> Name
-> ActionT m (Type.Wrapping a)
-> Resolver m
wrappedScalar name = Resolver name . ValueResolver . fmap Aeson.toJSON
resolveFieldValue ::
Monad m =>
ActionT m a ->
(Field -> a -> CollectErrsT m Aeson.Object) ->
Field ->
CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
result <- lift $ reader . runExceptT . runActionT $ f
either resolveLeft (resolveRight fld) result
where
reader = flip runReaderT $ Context {arguments=args}
resolveLeft err = do
_ <- addErrMsg err
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
resolveFieldValue field@(Field _ _ args _) =
flip runReaderT (Context {arguments=args, info=field})
. runExceptT
. runActionT
-- | Helper function to facilitate error handling and result emitting.
withField :: (Monad m, Aeson.ToJSON a)
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
withField v fld
= HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
convert :: Type.Wrapping Aeson.Value -> Aeson.Value
convert Type.Null = Aeson.Null
convert (Type.Named value) = value
convert (Type.List value) = Aeson.toJSON value
withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object
withField field (ValueResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
withField field@(Field _ _ _ seqSelection) (NestingResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
case answer of
Right result -> do
nestedFields <- traverse (`resolve` seqSelection) result
pure $ HashMap.singleton (aliasOrName field) $ convert nestedFields
Left errorMessage -> errmsg field errorMessage
errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
errmsg field errorMessage = do
addErrMsg errorMessage
pure $ HashMap.singleton (aliasOrName field) Aeson.Null
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolve :: Monad m
=> HashMap Text (Field -> CollectErrsT m Aeson.Object)
=> HashMap Text (FieldResolver m)
-> Seq Selection
-> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
resolveTypeName f = do
value <- f $ Field Nothing "__typename" mempty mempty
return $ HashMap.lookupDefault "" "__typename" value
lookupResolver = flip HashMap.lookup resolvers
tryResolvers (SelectionField fld@(Field _ name _ _))
= fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
if maybe True (Aeson.String typeCondition ==) that
| (Just resolver) <- lookupResolver name = withField fld resolver
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
tryResolvers (SelectionFragment (Fragment typeCondition selections'))
| Just (ValueResolver resolver) <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver
if Right (Aeson.String typeCondition) == that
then fmap fold . traverse tryResolvers $ selections'
else return mempty
errmsg fld@(Field _ name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."]
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
else pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections'
aliasOrName :: Field -> Text
aliasOrName (Field alias name _ _) = fromMaybe name alias

View File

@ -18,8 +18,9 @@ import Language.GraphQL.AST.Core
import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments.
newtype Context = Context
data Context = Context
{ arguments :: Arguments
, info :: Field
}
-- | Monad transformer stack used by the resolvers to provide error handling

View File

@ -0,0 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.SchemaSpec
( spec
) where
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Sequence as Sequence
import Data.Text (Text)
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Schema
import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec
spec =
describe "resolve" $
it "ignores invalid __typename" $ do
let resolver = object "__typename" $ pure
[ scalar "field" $ pure ("T" :: Text)
]
schema = resolversToMap [resolver]
fields = Sequence.singleton
$ SelectionFragment
$ Fragment "T" Sequence.empty
expected = Aeson.object
[ ("data" , Aeson.emptyObject)
]
actual <- runCollectErrs (resolve schema fields)
actual `shouldBe` expected

View File

@ -4,7 +4,7 @@ module Test.DirectiveSpec
( spec
) where
import Data.Aeson (Value, object, (.=))
import Data.Aeson (Value(..), object, (.=))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))

View File

@ -189,3 +189,27 @@ spec = do
]
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
actual `shouldBe` expected
it "test1" $ do
let query = [r|
{
garment {
circumference
}
}
|]
expected = object
[ "data" .= object
[ "garment" .= object
[ "circumference" .= (60 :: Int)
]
]
]
actual <- graphql schema query
actual `shouldBe` expected
where
schema = HashMap.singleton "Query" $ garment' :| []
garment' = Schema.object "garment" $ return
[ circumference'
]
circumference' = Schema.scalar "circumference" $ pure (60 :: Int)

40
tests/Test/QuerySpec.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.QuerySpec
( spec
) where
import Data.Aeson ((.=), object)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r)
spec :: Spec
spec =
describe "Query executor" $
it "returns objects from the root resolvers" $ do
let query = [r|
{
garment {
circumference
}
}
|]
expected = object
[ "data" .= object
[ "garment" .= object
[ "circumference" .= (60 :: Int)
]
]
]
actual <- graphql schema query
actual `shouldBe` expected
where
schema = HashMap.singleton "Query" $ garment' :| []
garment' = Schema.object "garment" $ return
[ circumference'
]
circumference' = Schema.scalar "circumference" $ pure (60 :: Int)