Coerce variable values

2 files changed, 133 insertions, 26 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
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 5a9eef8..56b2a22 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -1,25 +1,28 @@
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 
 -- | After the document is parsed, before getting executed the AST is
 --   transformed into a similar, simpler AST. This module is responsible for
 --   this transformation.
 module Language.GraphQL.Execute.Transform
-    ( document
+    ( Document(..)
+    , OperationDefinition(..)
+    , document
+    , operation
     ) where
 
-import Control.Arrow (first)
 import Control.Monad (foldM, unless)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
 import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
-import Language.GraphQL.AST.Document (Definition(..), Document)
 import qualified Language.GraphQL.Schema as Schema
 import qualified Language.GraphQL.Type.Directive as Directive
 
@@ -34,36 +37,56 @@ type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
 liftJust :: forall a. a -> TransformT a
 liftJust = lift . lift . Just
 
+-- | GraphQL document is a non-empty list of operations.
+data Document = Document
+    (NonEmpty OperationDefinition)
+    (HashMap Full.Name Full.FragmentDefinition)
+
+data OperationDefinition = OperationDefinition
+    Full.OperationType
+    (Maybe Full.Name)
+    [Full.VariableDefinition]
+    [Full.Directive]
+    Full.SelectionSet
+
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
-document :: Schema.Subs -> Document -> Maybe Core.Document
-document subs document' =
-    flip runReaderT subs
-        $ evalStateT (collectFragments >> operations operationDefinitions)
-        $ Replacement HashMap.empty fragmentTable
+document :: Full.Document -> Maybe Document
+document ast =
+    let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
+     in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable
   where
-    (fragmentTable, operationDefinitions) = foldr defragment mempty document'
-    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
-        (definition :) <$> acc
-    defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
-        let (Full.FragmentDefinition name _ _ _) = definition
-         in first (HashMap.insert name definition) acc
+    defragment definition (operations, fragments')
+        | (Full.ExecutableDefinition executable) <- definition
+        , (Full.DefinitionOperation operation') <- executable =
+            (transform operation' : operations, fragments')
+        | (Full.ExecutableDefinition executable) <- definition
+        , (Full.DefinitionFragment fragment) <- executable
+        , (Full.FragmentDefinition name _ _ _) <- fragment =
+            (operations, HashMap.insert name fragment fragments')
     defragment _ acc = acc
+    transform = \case
+        Full.OperationDefinition type' name variables directives' selections ->
+            OperationDefinition type' name variables directives' selections
+        Full.SelectionSet selectionSet ->
+            OperationDefinition Full.Query Nothing mempty mempty selectionSet
 
 -- * Operation
 
-operations :: [Full.OperationDefinition] -> TransformT Core.Document
-operations operations' = do
-    coreOperations <- traverse operation operations'
-    lift . lift $ NonEmpty.nonEmpty coreOperations
-
-operation :: Full.OperationDefinition -> TransformT Core.Operation
-operation (Full.SelectionSet sels)
-    = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
-operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
-    = Core.Query name <$> appendSelection sels
-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
-    = Core.Mutation name <$> appendSelection sels
+operation
+    :: HashMap Full.Name Full.FragmentDefinition
+    -> Schema.Subs
+    -> OperationDefinition
+    -> Maybe Core.Operation
+operation fragmentTable subs operationDefinition = flip runReaderT subs
+    $ evalStateT (collectFragments >> transform operationDefinition)
+    $ Replacement HashMap.empty fragmentTable
+  where
+    transform :: OperationDefinition -> TransformT Core.Operation
+    transform (OperationDefinition Full.Query name _ _ sels) =
+        Core.Query name <$> appendSelection sels
+    transform (OperationDefinition Full.Mutation name _ _ sels) =
+        Core.Mutation name <$> appendSelection sels
 
 -- * Selection