Reject variables as default values

2020-05-22 10:11:48 +02:00
parent c3ecfece03
commit 26cc53ce06
10 changed files with 374 additions and 210 deletions
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@ -3,12 +3,19 @@
 -- | Types and functions used for input and result coercion.
 module Language.GraphQL.Execute.Coerce
    ( VariableValue(..)
+    , coerceInputLiterals
    ) where

 import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
+import qualified Data.Text.Lazy as Text.Lazy
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy.Builder.Int as Text.Builder
 import Data.Scientific (toBoundedInteger, toRealFloat)
 import Language.GraphQL.AST.Core
+import Language.GraphQL.Schema
 import Language.GraphQL.Type.Definition

 -- | Since variables are passed separately from the query, in an independent
@ -82,3 +89,68 @@ instance VariableValue Aeson.Value where
            coerced <- coerceVariableValue listType variableValue
            pure $ coerced : list 
    coerceVariableValue _ _ = Nothing
+
+-- | Coerces operation arguments according to the input coercion rules for the
+--   corresponding types.
+coerceInputLiterals
+    :: HashMap Name InputType
+    -> HashMap Name Value
+    -> Maybe Subs
+coerceInputLiterals variableTypes variableValues =
+    foldWithKey operator variableTypes
+  where
+    operator variableName variableType resultMap =
+        HashMap.insert variableName
+        <$> (lookupVariable variableName >>= coerceInputLiteral variableType)
+        <*> resultMap
+    coerceInputLiteral (ScalarInputType type') value
+        | (String stringValue) <- value
+        , (ScalarType "String" _) <- type' = Just $ String stringValue
+        | (Boolean booleanValue) <- value
+        , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
+        | (Int intValue) <- value
+        , (ScalarType "Int" _) <- type' = Just $ Int intValue
+        | (Float floatValue) <- value
+        , (ScalarType "Float" _) <- type' = Just $ Float floatValue
+        | (Int intValue) <- value
+        , (ScalarType "Float" _) <- type' =
+            Just $ Float $ fromIntegral intValue
+        | (String stringValue) <- value
+        , (ScalarType "ID" _) <- type' = Just $ String stringValue
+        | (Int intValue) <- value
+        , (ScalarType "ID" _) <- type' = Just $ decimal intValue
+    coerceInputLiteral (EnumInputType type') (Enum enumValue)
+        | member enumValue type' = Just $ Enum enumValue
+    coerceInputLiteral (ObjectInputType type') (Object _) = 
+        let (InputObjectType _ _ inputFields) = type'
+            in Object <$> foldWithKey matchFieldValues inputFields
+    coerceInputLiteral _ _ = Nothing
+    member value (EnumType _ _ members) = Set.member value members
+    matchFieldValues fieldName (InputField _ type' defaultValue) resultMap =
+        case lookupVariable fieldName of
+            Just Null
+                | isNonNullInputType type' -> Nothing
+                | otherwise ->
+                    HashMap.insert fieldName Null <$> resultMap
+            Just variableValue -> HashMap.insert fieldName
+                <$> coerceInputLiteral type' variableValue
+                <*> resultMap
+            Nothing
+                | Just value <- defaultValue ->
+                    HashMap.insert fieldName value <$> resultMap
+                | Nothing <- defaultValue
+                , isNonNullInputType type' -> Nothing
+                | otherwise -> resultMap
+    lookupVariable = flip HashMap.lookup variableValues
+    foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
+    decimal = String
+        . Text.Lazy.toStrict
+        . Text.Builder.toLazyText
+        . Text.Builder.decimal
+
+isNonNullInputType :: InputType -> Bool
+isNonNullInputType (NonNullScalarInputType _) = True
+isNonNullInputType (NonNullEnumInputType _) = True
+isNonNullInputType (NonNullObjectInputType _) = True
+isNonNullInputType (NonNullListInputType _) = True
+isNonNullInputType _ = False
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}

 -- | After the document is parsed, before getting executed the AST is
@ -7,24 +8,30 @@
 --   this transformation.
 module Language.GraphQL.Execute.Transform
    ( Document(..)
-    , OperationDefinition(..)
+    , QueryError(..)
    , document
-    , operation
+    , queryError
    ) where

 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.Foldable (find)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
+import Data.Text (Text)
+import qualified Data.Text as Text
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
+import Language.GraphQL.Execute.Coerce
 import qualified Language.GraphQL.Schema as Schema
+import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Directive as Directive
+import Language.GraphQL.Type.Schema

 -- | Associates a fragment name with a list of 'Core.Field's.
 data Replacement = Replacement
@ -39,7 +46,7 @@ liftJust = lift . lift . Just

 -- | GraphQL document is a non-empty list of operations.
 data Document = Document
-    (NonEmpty OperationDefinition)
+    Core.Operation
    (HashMap Full.Name Full.FragmentDefinition)

 data OperationDefinition = OperationDefinition
@ -49,12 +56,102 @@ data OperationDefinition = OperationDefinition
    [Full.Directive]
    Full.SelectionSet

+-- | Query error types.
+data QueryError
+    = OperationNotFound Text
+    | OperationNameRequired
+    | CoercionError
+    | TransformationError
+    | EmptyDocument
+
+queryError :: QueryError -> Text
+queryError (OperationNotFound operationName) = Text.unwords
+    ["Operation", operationName, "couldn't be found in the document."]
+queryError OperationNameRequired = "Missing operation name."
+queryError CoercionError = "Coercion error."
+queryError TransformationError = "Schema transformation error."
+queryError EmptyDocument =
+    "The document doesn't contain any executable operations."
+
+getOperation
+    :: Maybe Full.Name
+    -> NonEmpty OperationDefinition
+    -> Either QueryError OperationDefinition
+getOperation Nothing (operation' :| []) = pure operation'
+getOperation Nothing _ = Left OperationNameRequired
+getOperation (Just operationName) operations
+    | Just operation' <- find matchingName operations = pure operation'
+    | otherwise = Left $ OperationNotFound operationName
+  where
+    matchingName (OperationDefinition _ name _ _ _) =
+        name == Just operationName
+
+lookupInputType
+    :: Full.Type
+    -> HashMap.HashMap Full.Name (Definition.TypeDefinition m)
+    -> Maybe Definition.InputType
+lookupInputType (Full.TypeNamed name) types =
+    case HashMap.lookup name types of
+        Just (Definition.ScalarTypeDefinition scalarType) ->
+            Just $ Definition.ScalarInputType scalarType
+        Just (Definition.EnumTypeDefinition enumType) ->
+            Just $ Definition.EnumInputType enumType
+        Just (Definition.InputObjectTypeDefinition objectType) ->
+            Just $ Definition.ObjectInputType objectType
+        _ -> Nothing
+lookupInputType (Full.TypeList list) types
+    = Definition.ListInputType
+    <$> lookupInputType list types
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
+    case HashMap.lookup nonNull types of
+        Just (Definition.ScalarTypeDefinition scalarType) ->
+            Just $ Definition.NonNullScalarInputType scalarType
+        Just (Definition.EnumTypeDefinition enumType) ->
+            Just $ Definition.NonNullEnumInputType enumType
+        Just (Definition.InputObjectTypeDefinition objectType) ->
+            Just $ Definition.NonNullObjectInputType objectType
+        _ -> Nothing
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
+    = Definition.NonNullListInputType
+    <$> lookupInputType nonNull types
+
+coerceVariableValues :: (Monad m, VariableValue a)
+    => Schema m
+    -> OperationDefinition
+    -> HashMap.HashMap Full.Name a
+    -> Either QueryError Schema.Subs
+coerceVariableValues schema (OperationDefinition _ _ variables _ _) values =
+    let referencedTypes = collectReferencedTypes schema
+     in maybe (Left CoercionError) Right
+        $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
+  where
+    coerceValue referencedTypes variableDefinition coercedValues = do
+        let Full.VariableDefinition variableName variableTypeName _defaultValue =
+                variableDefinition
+        variableType <- lookupInputType variableTypeName referencedTypes
+        value' <- HashMap.lookup variableName values
+        coercedValue <- coerceVariableValue variableType value'
+        HashMap.insert variableName coercedValue <$> coercedValues
+
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
-document :: Full.Document -> Maybe Document
-document ast =
+document :: (Monad m, VariableValue a)
+    => Schema m
+    -> Maybe Full.Name
+    -> HashMap Full.Name a
+    -> Full.Document
+    -> Either QueryError Document
+document schema operationName subs ast = do
    let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
-     in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable
+    nonEmptyOperations <- maybe (Left EmptyDocument) Right
+        $ NonEmpty.nonEmpty operations
+    chosenOperation <- getOperation operationName nonEmptyOperations
+    coercedValues <- coerceVariableValues schema chosenOperation subs
+
+    maybe (Left TransformationError) Right
+        $ Document
+        <$> operation fragmentTable coercedValues chosenOperation
+        <*> pure fragmentTable
  where
    defragment definition (operations, fragments')
        | (Full.ExecutableDefinition executable) <- definition
@ -186,5 +283,5 @@ value (Full.List l) =
 value (Full.Object o) =
    Core.Object . HashMap.fromList <$> traverse objectField o

-objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
+objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, Core.Value)
 objectField (Full.ObjectField name value') = (name,) <$> value value'