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
|
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Serialize
( JSON(..)
) where
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Scientific (toBoundedInteger, toRealFloat)
import Data.Text (Text)
import Language.GraphQL.AST (Name)
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type
newtype JSON = JSON Aeson.Value
instance Aeson.ToJSON JSON where
toJSON (JSON value) = value
instance Aeson.FromJSON JSON where
parseJSON = pure . JSON
instance Serialize JSON where
serialize (Out.ScalarBaseType scalarType) value
| Type.ScalarType "Int" _ <- scalarType
, Int int <- value = Just $ JSON $ Aeson.Number $ fromIntegral int
| Type.ScalarType "Float" _ <- scalarType
, Float float <- value = Just $ JSON $ Aeson.toJSON float
| Type.ScalarType "String" _ <- scalarType
, String string <- value = Just $ JSON $ Aeson.String string
| Type.ScalarType "ID" _ <- scalarType
, String string <- value = Just $ JSON $ Aeson.String string
| Type.ScalarType "Boolean" _ <- scalarType
, Boolean boolean <- value = Just $ JSON $ Aeson.Bool boolean
serialize _ (Enum enum) = Just $ JSON $ Aeson.String enum
serialize _ (List list) = Just $ JSON $ Aeson.toJSON list
serialize _ (Object object) = Just
$ JSON
$ Aeson.object
$ toJSONKeyValue <$> OrderedMap.toList object
where
toJSONKeyValue (key, value) = (Aeson.Key.fromText key, Aeson.toJSON value)
serialize _ _ = Nothing
null = JSON Aeson.Null
instance VariableValue JSON where
coerceVariableValue _ (JSON Aeson.Null) = Just Type.Null
coerceVariableValue (In.ScalarBaseType scalarType) (JSON value)
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
| (Aeson.Number numberValue) <- value
, (Type.ScalarType "Float" _) <- scalarType =
Just $ Type.Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int
Type.Int <$> toBoundedInteger numberValue
coerceVariableValue (In.EnumBaseType _) (JSON (Aeson.String stringValue)) =
Just $ Type.Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) (JSON value)
| (Aeson.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if KeyMap.null newObjectValue
then Just $ Type.Object resultMap
else Nothing
where
foldWithKey :: Aeson.Object
-> HashMap Name In.InputField
-> Maybe (Aeson.Object, HashMap Name Type.Value)
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
$ Just (objectValue, HashMap.empty)
matchFieldValues' :: Text
-> In.InputField
-> Maybe (Aeson.Object, HashMap Name Type.Value)
-> Maybe (Aeson.Object, HashMap Name Type.Value)
matchFieldValues' _ _ Nothing = Nothing
matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
let fieldKey = Aeson.Key.fromText fieldName
In.InputField _ fieldType _ = inputField
insert = flip (HashMap.insert fieldName) resultMap
newObjectValue = KeyMap.delete fieldKey objectValue
in case KeyMap.lookup fieldKey objectValue of
Just variableValue -> do
coerced <- coerceVariableValue fieldType
$ JSON variableValue
pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap)
coerceVariableValue (In.ListBaseType listType) (JSON value)
| (Aeson.Array arrayValue) <- value =
Type.List <$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType $ JSON value
where
foldVector _ Nothing = Nothing
foldVector variableValue (Just list) = do
coerced <- coerceVariableValue listType $ JSON variableValue
pure $ coerced : list
coerceVariableValue _ _ = Nothing
|
