From dc813621fdfa0dfba44f0cc2497a0a8f3b2fe701 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Tue, 18 Jan 2022 13:00:58 +0100
Subject: [PATCH] Add VariableValue Aeson instance

---
 graphql-spice.cabal               |  5 ++-
 src/Language/GraphQL/Serialize.hs | 58 +++++++++++++++++++++++++++++++
 2 files changed, 62 insertions(+), 1 deletion(-)

diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index 0622ea7..a56d044 100644
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@@ -32,7 +32,10 @@ library
     build-depends:
       aeson ^>= 2.0.3,
       base ^>=4.14.3.0,
-      graphql ^>= 1.0.2
+      graphql ^>= 1.0.2,
+      scientific ^>= 0.3.7,
+      text ^>= 1.2.5,
+      unordered-containers ^>= 0.2.16
     default-language: Haskell2010
 
 test-suite graphql-test
diff --git a/src/Language/GraphQL/Serialize.hs b/src/Language/GraphQL/Serialize.hs
index 1d7675b..38a7ec7 100644
--- a/src/Language/GraphQL/Serialize.hs
+++ b/src/Language/GraphQL/Serialize.hs
@@ -6,8 +6,15 @@ module Language.GraphQL.Serialize
 
 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
 
@@ -41,3 +48,54 @@ instance Serialize JSON where
         toJSONKeyValue (key, value) = (Aeson.Key.fromText key, Aeson.toJSON value)
     serialize _ _ = Nothing
     null = JSON Aeson.Null
+
+instance VariableValue Aeson.Value where
+    coerceVariableValue _ Aeson.Null = Just Type.Null
+    coerceVariableValue (In.ScalarBaseType scalarType) 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 _) (Aeson.String stringValue) =
+        Just $ Type.Enum stringValue
+    coerceVariableValue (In.InputObjectBaseType objectType) 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 variableValue
+                        pure (newObjectValue, insert coerced)
+                    Nothing -> Just (objectValue, resultMap)
+    coerceVariableValue (In.ListBaseType listType) value
+        | (Aeson.Array arrayValue) <- value =
+            Type.List <$> foldr foldVector (Just []) arrayValue
+        | otherwise = coerceVariableValue listType value
+      where
+        foldVector _ Nothing = Nothing
+        foldVector variableValue (Just list) = do
+            coerced <- coerceVariableValue listType variableValue
+            pure $ coerced : list 
+    coerceVariableValue _ _ = Nothing