1 files changed, 84 insertions, 0 deletions
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
new file mode 100644
index 0000000..5b26faa
--- /dev/null
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Types and functions used for input and result coercion.
+module Language.GraphQL.Execute.Coerce
+    ( VariableValue(..)
+    ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Scientific (toBoundedInteger, toRealFloat)
+import Language.GraphQL.AST.Core
+import Language.GraphQL.Type.Definition
+
+-- | Since variables are passed separately from the query, in an independent
+-- format, they should be first coerced to the internal representation used by
+-- this implementation.
+class VariableValue a where
+    -- | Only a basic, format-specific, coercion must be done here. Type
+    -- correctness or nullability shouldn't be validated here, they will be
+    -- validated later. The type information is provided only as a hint.
+    --
+    -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an
+    -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be
+    -- coerced to 't:Int` when receiving variables as a JSON object. The same
+    -- holds for 't:Enum'. There are formats that support enumerations, @JSON@
+    -- doesn't, so the type information is given and 'coerceVariableValue' can
+    -- check that an 't:Enum' is expected and treat the given value
+    -- appropriately. Even checking whether this value is a proper member of the
+    -- corresponding 't:Enum' type isn't required here, since this can be
+    -- checked independently.
+    --
+    -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce
+    -- integers and strings to @ID@s, so if an @ID@ is received as an integer,
+    -- it can be left as is and will be coerced later.
+    --
+    -- If a value cannot be coerced without losing information, 'Nothing' should
+    -- be returned, the coercion will fail then and the query won't be executed.
+    coerceVariableValue
+        :: InputType -- ^ Expected type (variable type given in the query).
+        -> a -- ^ Variable value being coerced.
+        -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise.
+
+instance VariableValue Aeson.Value where
+    coerceVariableValue _ Aeson.Null = Just Null
+    coerceVariableValue (ScalarInputTypeDefinition scalarType) value
+        | (Aeson.String stringValue) <- value = Just $ String stringValue
+        | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
+        | (Aeson.Number numberValue) <- value
+        , (ScalarType "Float" _) <- scalarType =
+            Just $ Float $ toRealFloat numberValue
+        | (Aeson.Number numberValue) <- value = -- ID or Int
+            Int <$> toBoundedInteger numberValue
+    coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) =
+        Just $ Enum stringValue
+    coerceVariableValue (ObjectInputTypeDefinition objectType) value
+        | (Aeson.Object objectValue) <- value = do
+            let (InputObjectType _ _ inputFields) = objectType
+            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
+            if HashMap.null newObjectValue
+                then Just $ Object resultMap
+                else Nothing
+      where
+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
+            $ Just (objectValue, HashMap.empty)
+        matchFieldValues _ _ Nothing = Nothing
+        matchFieldValues fieldName inputField (Just (objectValue, resultMap)) =
+            let (InputField _ fieldType _) = inputField
+                insert = flip (HashMap.insert fieldName) resultMap
+                newObjectValue = HashMap.delete fieldName objectValue
+             in case HashMap.lookup fieldName objectValue of
+                    Just variableValue -> do
+                        coerced <- coerceVariableValue fieldType variableValue
+                        pure (newObjectValue, insert coerced)
+                    Nothing -> Just (objectValue, resultMap)
+    coerceVariableValue (ListInputTypeDefinition listType) value
+        | (Aeson.Array arrayValue) <- value = 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