blob: 734f0709a18613186c0b1a3e696b31dbd0d66360 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Schema
( Resolver(..)
, resolve
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Execution
import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
-- | 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'.
--
-- Resolving a field can result in a leaf value or an object, which is
-- represented as a list of nested resolvers, used to resolve the fields of that
-- object.
data Resolver m = Resolver Name (ActionT m Value)
resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
resolveFieldValue result (Field _ _ args _) =
flip runReaderT (Context {arguments=args, values=result})
. runExceptT
. runActionT
executeField :: Monad m
=> Value
-> Out.Field m
-> Field m
-> CollectErrsT m Aeson.Value
executeField prev (Out.Field _ fieldType _ resolver) field = do
answer <- lift $ resolveFieldValue prev field resolver
case answer of
Right result -> completeValue fieldType field result
Left errorMessage -> errmsg errorMessage
completeValue :: Monad m
=> Out.Type m
-> Field m
-> Value
-> CollectErrsT m Aeson.Value
completeValue _ _ Null = pure Aeson.Null
completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
completeValue _ _ (Enum enum) = pure $ Aeson.String enum
completeValue _ _ (String string') = pure $ Aeson.String string'
completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
resolve result objectType seqSelection
completeValue (Out.ListBaseType listType) selectionField (List list) =
Aeson.toJSON <$> traverse (completeValue listType selectionField) list
completeValue _ _ _ = errmsg "Value completion failed."
errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg errorMessage = addErrMsg errorMessage >> pure 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 -- executeSelectionSet
=> Value
-> Out.ObjectType m
-> Seq (Selection m)
-> CollectErrsT m Aeson.Value
resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
resolvedValues <- Map.traverseMaybeWithKey forEach
$ collectFields objectType selectionSet
pure $ Aeson.toJSON resolvedValues
where
forEach _responseKey (field :<| _) =
tryResolvers field >>= lift . pure . pure
forEach _ _ = pure Nothing
lookupResolver = flip HashMap.lookup resolvers
tryResolvers fld@(Field _ name _ _)
| Just typeField <- lookupResolver name =
executeField result typeField fld
| otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
{-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections'))
| Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do
let fakeField = Out.Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue result fakeField resolver
case that of
Right (String typeCondition')
| (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition
, typeCondition' == n ->
fmap fold . traverse tryResolvers $ selections'
_ -> pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections'-}
|
