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
|
{-# 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(..)
, Subs
, object
, resolve
, resolversToMap
, scalar
, wrappedObject
, wrappedScalar
-- * AST Reexports
, Field
, Value(..)
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (fold, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.Definition as Definition
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 Name (Definition.FieldResolver m)
-- | Converts resolvers to a map.
resolversToMap :: (Foldable f, Functor f)
=> f (Resolver m)
-> HashMap Text (Definition.FieldResolver m)
resolversToMap = HashMap.fromList . toList . fmap toKV
where
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.
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 = Resolver name
. Definition.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 = Resolver name
. Definition.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 = Resolver name . Definition.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 = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
resolveFieldValue field@(Field _ _ args _) =
flip runReaderT (Context {arguments=args, info=field})
. runExceptT
. runActionT
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
-> Definition.FieldResolver m
-> CollectErrsT m Aeson.Object
withField field (Definition.ValueResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
withField field@(Field _ _ _ seqSelection) (Definition.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 (Definition.FieldResolver m)
-> Seq Selection
-> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
lookupResolver = flip HashMap.lookup resolvers
tryResolvers (SelectionField fld@(Field _ name _ _))
| (Just resolver) <- lookupResolver name = withField fld resolver
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
tryResolvers (SelectionFragment (Fragment typeCondition selections'))
| Just (Definition.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 pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections'
aliasOrName :: Field -> Text
aliasOrName (Field alias name _ _) = fromMaybe name alias
|
