diff options
Diffstat (limited to 'src/Language/GraphQL/Execute')
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 72 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 113 |
2 files changed, 177 insertions, 8 deletions
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 5b26faa..ead19dc 100644 --- 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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 56b2a22..485bd51 100644 --- 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' |