blob: 140df816201eb0347d3c3c2c3aa39e621ac5aa8f (
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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Execute.Execution
( executeSelectionSet
) where
import qualified Data.Aeson as Aeson
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.Map.Strict (Map)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
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
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
-> Map Name (Seq (Field m))
collectFields objectType = foldl forEach Map.empty
where
forEach groupedFields (SelectionField field) =
let responseKey = aliasOrName field
in Map.insertWith (<>) responseKey (Seq.singleton field) groupedFields
forEach groupedFields (SelectionFragment selectionFragment)
| Fragment fragmentType fragmentSelectionSet <- selectionFragment
, doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
| otherwise = groupedFields
aliasOrName :: forall m. Field m -> Name
aliasOrName (Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> AbstractType m
-> HashMap Name Value
-> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types
case HashMap.lookup typeName types' of
Just (ObjectType objectType) ->
if instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
| otherwise = pure Nothing
doesFragmentTypeApply :: forall m
. CompositeType m
-> Out.ObjectType m
-> Bool
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
let Out.ObjectType fragmentName _ _ _ = fragmentType
Out.ObjectType objectName _ _ _ = objectType
in fragmentName == objectName
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
instanceOf objectType $ AbstractInterfaceType fragmentType
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
instanceOf objectType $ AbstractUnionType fragmentType
instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
instanceOf objectType (AbstractInterfaceType interfaceType) =
let Out.ObjectType _ _ interfaces _ = objectType
in foldr go False interfaces
where
go (Out.InterfaceType that _ interfaces _) acc =
let Out.InterfaceType this _ _ _ = interfaceType
in acc || foldr go (this == that) interfaces
instanceOf objectType (AbstractUnionType unionType) =
let Out.UnionType _ _ members = unionType
in foldr go False members
where
go (Out.ObjectType that _ _ _) acc =
let Out.ObjectType this _ _ _ = objectType
in acc || this == that
executeField :: Monad m
=> Value
-> Out.Resolver m
-> Field m
-> CollectErrsT m Aeson.Value
executeField prev (Out.Resolver fieldDefinition resolver) field = do
let Out.Field _ fieldType _ = fieldDefinition
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 =
executeSelectionSet result objectType seqSelection
completeValue (Out.ListBaseType listType) selectionField (List list) =
Aeson.toJSON <$> traverse (completeValue listType selectionField) list
completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
| Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
case abstractType of
Just objectType -> executeSelectionSet result objectType seqSelection
Nothing -> errmsg "Value completion failed."
completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
| Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
case abstractType of
Just objectType -> executeSelectionSet result objectType seqSelection
Nothing -> errmsg "Value completion failed."
completeValue _ _ _ = errmsg "Value completion failed."
errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
-- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field
-- to each 'Selection'. Resolves into a value containing the resolved
-- 'Selection', or a null value and error information.
executeSelectionSet :: Monad m
=> Value
-> Out.ObjectType m
-> Seq (Selection m)
-> CollectErrsT m Aeson.Value
executeSelectionSet 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."]
|
