diff options
Diffstat (limited to 'src/Language/GraphQL/Execute')
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 230 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 229 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 465 |
3 files changed, 826 insertions, 98 deletions
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs new file mode 100644 index 0000000..60fb71d --- /dev/null +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Types and functions used for input and result coercion. +module Language.GraphQL.Execute.Coerce + ( Output(..) + , Serialize(..) + , VariableValue(..) + , coerceInputLiteral + , matchFieldValues + ) where + +import qualified Data.Aeson as Aeson +import Data.Int (Int32) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Map.Strict (Map) +import Data.String (IsString(..)) +import Data.Text (Text) +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 (Name) +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out + +-- | 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 + :: In.Type -- ^ Expected type (variable type given in the query). + -> a -- ^ Variable value being coerced. + -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise. + +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 HashMap.null newObjectValue + then Just $ Type.Object resultMap + else Nothing + where + foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' + $ Just (objectValue, HashMap.empty) + matchFieldValues' _ _ Nothing = Nothing + matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) = + let (In.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 (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 + +-- | Looks up a value by name in the given map, coerces it and inserts into the +-- result map. If the coercion fails, returns 'Nothing'. If the value isn't +-- given, but a default value is known, inserts the default value into the +-- result map. Otherwise it fails with 'Nothing' if the Input Type is a +-- Non-Nullable type, or returns the unchanged, original map. +matchFieldValues :: forall a + . (In.Type -> a -> Maybe Type.Value) + -> HashMap Name a + -> Name + -> In.Type + -> Maybe Type.Value + -> Maybe (HashMap Name Type.Value) + -> Maybe (HashMap Name Type.Value) +matchFieldValues coerce values' fieldName type' defaultValue resultMap = + case HashMap.lookup fieldName values' of + Just variableValue -> coerceRuntimeValue $ coerce type' variableValue + Nothing + | Just value <- defaultValue -> + HashMap.insert fieldName value <$> resultMap + | Nothing <- defaultValue + , In.isNonNullType type' -> Nothing + | otherwise -> resultMap + where + coerceRuntimeValue (Just Type.Null) + | In.isNonNullType type' = Nothing + coerceRuntimeValue coercedValue = + HashMap.insert fieldName <$> coercedValue <*> resultMap + +-- | Coerces operation arguments according to the input coercion rules for the +-- corresponding types. +coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value +coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null +coerceInputLiteral (In.ScalarBaseType type') value + | (Type.String stringValue) <- value + , (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue + | (Type.Boolean booleanValue) <- value + , (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue + | (Type.Int intValue) <- value + , (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue + | (Type.Float floatValue) <- value + , (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue + | (Type.Int intValue) <- value + , (Type.ScalarType "Float" _) <- type' = + Just $ Type.Float $ fromIntegral intValue + | (Type.String stringValue) <- value + , (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue + | (Type.Int intValue) <- value + , (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue + where + decimal = Type.String + . Text.Lazy.toStrict + . Text.Builder.toLazyText + . Text.Builder.decimal +coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue) + | member enumValue type' = Just $ Type.Enum enumValue + where + member value (Type.EnumType _ _ members) = HashMap.member value members +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = + let (In.InputObjectType _ _ inputFields) = type' + in Type.Object + <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields + where + matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) = + matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue +coerceInputLiteral (In.ListBaseType listType) (Type.List list) = + Type.List <$> traverse (coerceInputLiteral listType) list +coerceInputLiteral (In.ListBaseType listType) singleton = + wrapSingleton listType singleton + where + wrapSingleton (In.ListBaseType listType') singleton' = + Type.List <$> sequence [wrapSingleton listType' singleton'] + wrapSingleton listType' singleton' = + Type.List <$> sequence [coerceInputLiteral listType' singleton'] +coerceInputLiteral _ _ = Nothing + +-- | 'Serialize' describes how a @GraphQL@ value should be serialized. +class Serialize a where + -- | Serializes a @GraphQL@ value according to the given serialization + -- format. + -- + -- Type infomration is given as a hint, e.g. if you need to know what type + -- is being serialized to serialize it properly. Don't do any validation for + -- @GraphQL@ built-in types here. + -- + -- If the value cannot be serialized without losing information, return + -- 'Nothing' — it will cause a field error. + serialize :: forall m + . Out.Type m -- ^ Expected output type. + -> Output a -- ^ The value to be serialized. + -> Maybe a -- ^ Serialized value on success or 'Nothing'. + -- | __null__ representation in the given serialization format. + null :: a + +-- | Intermediate type used to serialize a @GraphQL@ value. +-- +-- The serialization is done during the execution, and 'Output' contains +-- already serialized data (in 'List' and 'Object') as well as the new layer +-- that has to be serialized in the current step. So 'Output' is parameterized +-- by the serialization format. +data Output a + = Int Int32 + | Float Double + | String Text + | Boolean Bool + | Enum Name + | List [a] + | Object (Map Name a) + deriving (Eq, Show) + +instance forall a. IsString (Output a) where + fromString = String . fromString + +instance Serialize Aeson.Value where + serialize (Out.ScalarBaseType scalarType) value + | Type.ScalarType "Int" _ <- scalarType + , Int int <- value = Just $ Aeson.toJSON int + | Type.ScalarType "Float" _ <- scalarType + , Float float <- value = Just $ Aeson.toJSON float + | Type.ScalarType "String" _ <- scalarType + , String string <- value = Just $ Aeson.String string + | Type.ScalarType "ID" _ <- scalarType + , String string <- value = Just $ Aeson.String string + | Type.ScalarType "Boolean" _ <- scalarType + , Boolean boolean <- value = Just $ Aeson.Bool boolean + serialize _ (Enum enum) = Just $ Aeson.String enum + serialize _ (List list) = Just $ Aeson.toJSON list + serialize _ (Object object) = Just $ Aeson.toJSON object + serialize _ _ = Nothing + null = Aeson.Null diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs new file mode 100644 index 0000000..0c10419 --- /dev/null +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.GraphQL.Execute.Execution + ( executeSelectionSet + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.State (gets) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map.Strict (Map) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import Language.GraphQL.AST (Name) +import Language.GraphQL.AST.Core +import Language.GraphQL.Error +import Language.GraphQL.Execute.Coerce +import qualified Language.GraphQL.Execute.Transform as Transform +import Language.GraphQL.Trans +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema +import Prelude hiding (null) + +resolveFieldValue :: Monad m + => Type.Value + -> Type.Subs + -> ActionT m a + -> m (Either Text a) +resolveFieldValue result args = + flip runReaderT (Context {arguments = Arguments args, values = result}) + . runExceptT + . runActionT + +collectFields :: Monad m + => Out.ObjectType m + -> Seq (Transform.Selection m) + -> Map Name (NonEmpty (Transform.Field m)) +collectFields objectType = foldl forEach Map.empty + where + forEach groupedFields (Transform.SelectionField field) = + let responseKey = aliasOrName field + in Map.insertWith (<>) responseKey (field :| []) groupedFields + forEach groupedFields (Transform.SelectionFragment selectionFragment) + | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment + , doesFragmentTypeApply fragmentType objectType = + let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet + in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet + | otherwise = groupedFields + +aliasOrName :: forall m. Transform.Field m -> Name +aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias + +resolveAbstractType :: Monad m + => AbstractType m + -> Type.Subs + -> CollectErrsT m (Maybe (Out.ObjectType m)) +resolveAbstractType abstractType values' + | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do + types' <- gets types + case HashMap.lookup typeName types' of + Just (ObjectType objectType) -> + if instanceOf objectType abstractType + then pure $ Just objectType + else pure Nothing + _ -> pure Nothing + | otherwise = pure Nothing + +doesFragmentTypeApply :: forall m + . CompositeType m + -> Out.ObjectType m + -> Bool +doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = + fragmentType == objectType +doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = + instanceOf objectType $ AbstractInterfaceType fragmentType +doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = + instanceOf objectType $ AbstractUnionType fragmentType + +instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool +instanceOf objectType (AbstractInterfaceType interfaceType) = + let Out.ObjectType _ _ interfaces _ = objectType + in foldr go False interfaces + where + go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc = + acc || foldr go (interfaceType == objectInterfaceType) interfaces +instanceOf objectType (AbstractUnionType unionType) = + let Out.UnionType _ _ members = unionType + in foldr go False members + where + go unionMemberType acc = acc || objectType == unionMemberType + +executeField :: (Monad m, Serialize a) + => Out.Resolver m + -> Type.Value + -> NonEmpty (Transform.Field m) + -> CollectErrsT m a +executeField (Out.Resolver fieldDefinition resolver) prev fields = do + let Out.Field _ fieldType argumentDefinitions = fieldDefinition + let (Transform.Field _ _ arguments' _ :| []) = fields + case coerceArgumentValues argumentDefinitions arguments' of + Nothing -> errmsg "Argument coercing failed." + Just argumentValues -> do + answer <- lift $ resolveFieldValue prev argumentValues resolver + case answer of + Right result -> completeValue fieldType fields result + Left errorMessage -> errmsg errorMessage + +completeValue :: (Monad m, Serialize a) + => Out.Type m + -> NonEmpty (Transform.Field m) + -> Type.Value + -> CollectErrsT m a +completeValue (Out.isNonNullType -> False) _ Type.Null = pure null +completeValue outputType@(Out.ListBaseType listType) fields (Type.List list) + = traverse (completeValue listType fields) list + >>= coerceResult outputType . List +completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) = + coerceResult outputType $ Int int +completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) = + coerceResult outputType $ Boolean boolean +completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) = + coerceResult outputType $ Float float +completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) = + coerceResult outputType $ String string +completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = + let Type.EnumType _ _ enumMembers = enumType + in if HashMap.member enum enumMembers + then coerceResult outputType $ Enum enum + else errmsg "Value completion failed." +completeValue (Out.ObjectBaseType objectType) fields result = + executeSelectionSet result objectType $ mergeSelectionSets fields +completeValue (Out.InterfaceBaseType interfaceType) fields result + | Type.Object objectMap <- result = do + let abstractType = AbstractInterfaceType interfaceType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType -> executeSelectionSet result objectType + $ mergeSelectionSets fields + Nothing -> errmsg "Value completion failed." +completeValue (Out.UnionBaseType unionType) fields result + | Type.Object objectMap <- result = do + let abstractType = AbstractUnionType unionType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType -> executeSelectionSet result objectType + $ mergeSelectionSets fields + Nothing -> errmsg "Value completion failed." +completeValue _ _ _ = errmsg "Value completion failed." + +mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m) +mergeSelectionSets = foldr forEach mempty + where + forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet = + selectionSet <> fieldSelectionSet + +errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a +errmsg errorMessage = addErrMsg errorMessage >> pure null + +coerceResult :: (Monad m, Serialize a) + => Out.Type m + -> Output a + -> CollectErrsT m a +coerceResult outputType result + | Just serialized <- serialize outputType result = pure serialized + | otherwise = errmsg "Result coercion failed." + +-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies +-- each field to each 'Transform.Selection'. Resolves into a value containing +-- the resolved 'Transform.Selection', or a null value and error information. +executeSelectionSet :: (Monad m, Serialize a) + => Type.Value + -> Out.ObjectType m + -> Seq (Transform.Selection m) + -> CollectErrsT m a +executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do + let fields = collectFields objectType selectionSet + resolvedValues <- Map.traverseMaybeWithKey forEach fields + coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues + where + forEach _ fields@(field :| _) = + let Transform.Field _ name _ _ = field + in traverse (tryResolver fields) $ lookupResolver name + lookupResolver = flip HashMap.lookup resolvers + tryResolver fields resolver = + executeField resolver result fields >>= lift . pure + +coerceArgumentValues + :: HashMap Name In.Argument + -> HashMap Name Transform.Input + -> Maybe Type.Subs +coerceArgumentValues argumentDefinitions argumentValues = + HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions + where + forEach variableName (In.Argument _ variableType defaultValue) = + matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue + coerceArgumentValue inputType (Transform.Int integer) = + coerceInputLiteral inputType (Type.Int integer) + coerceArgumentValue inputType (Transform.Boolean boolean) = + coerceInputLiteral inputType (Type.Boolean boolean) + coerceArgumentValue inputType (Transform.String string) = + coerceInputLiteral inputType (Type.String string) + coerceArgumentValue inputType (Transform.Float float) = + coerceInputLiteral inputType (Type.Float float) + coerceArgumentValue inputType (Transform.Enum enum) = + coerceInputLiteral inputType (Type.Enum enum) + coerceArgumentValue inputType Transform.Null + | In.isNonNullType inputType = Nothing + | otherwise = coerceInputLiteral inputType Type.Null + coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = + let coerceItem = coerceInputLiteral inputType + in Type.List <$> traverse coerceItem list + coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) + | In.InputObjectType _ _ inputFields <- inputType = + let go = forEachField object + resultMap = HashMap.foldrWithKey go (pure mempty) inputFields + in Type.Object <$> resultMap + coerceArgumentValue _ (Transform.Variable variable) = pure variable + coerceArgumentValue _ _ = Nothing + forEachField object variableName (In.InputField _ variableType defaultValue) = + matchFieldValues coerceArgumentValue object variableName variableType defaultValue diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 5a9eef8..733ac8c 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -1,125 +1,356 @@ {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# 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. +-- | After the document is parsed, before getting executed, the AST is +-- transformed into a similar, simpler AST. Performed transformations include: +-- +-- * Replacing variables with their values. +-- * Inlining fragments. Some fragments can be completely eliminated and +-- replaced by the selection set they represent. Invalid (recursive and +-- non-existing) fragments are skipped. The most fragments are inlined, so the +-- executor doesn't have to perform additional lookups later. +-- * Evaluating directives (@\@include@ and @\@skip@). +-- +-- This module is also responsible for smaller rewrites that touch only parts of +-- the original AST. module Language.GraphQL.Execute.Transform - ( document + ( Document(..) + , Field(..) + , Fragment(..) + , Input(..) + , Operation(..) + , QueryError(..) + , Selection(..) + , document + , queryError ) 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 Control.Monad.Trans.State (State, evalStateT, gets, modify) +import Data.Foldable (find) +import Data.Functor.Identity (Identity(..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int32) +import Data.Maybe (fromMaybe) +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.AST.Document (Definition(..), Document) -import qualified Language.GraphQL.Schema as Schema +import Language.GraphQL.AST (Name) +import Language.GraphQL.AST.Core +import qualified Language.GraphQL.Execute.Coerce as Coerce +import Language.GraphQL.Type.Directive (Directive(..)) import qualified Language.GraphQL.Type.Directive as Directive +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema --- | Associates a fragment name with a list of 'Core.Field's. -data Replacement = Replacement - { fragments :: HashMap Core.Name Core.Fragment - , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition +-- | Associates a fragment name with a list of 'Field's. +data Replacement m = Replacement + { fragments :: HashMap Full.Name (Fragment m) + , fragmentDefinitions :: FragmentDefinitions + , variableValues :: Type.Subs + , types :: HashMap Full.Name (Type m) } -type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a +type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition -liftJust :: forall a. a -> TransformT a -liftJust = lift . lift . Just +-- | Represents fragments and inline fragments. +data Fragment m + = Fragment (CompositeType m) (Seq (Selection m)) + +-- | Single selection element. +data Selection m + = SelectionFragment (Fragment m) + | SelectionField (Field m) + +-- | GraphQL has 3 operation types: queries, mutations and subscribtions. +-- +-- Currently only queries and mutations are supported. +data Operation m + = Query (Maybe Text) (Seq (Selection m)) + | Mutation (Maybe Text) (Seq (Selection m)) + +-- | Single GraphQL field. +data Field m = Field + (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m)) + +-- | Contains the operation to be executed along with its root type. +data Document m = Document + (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m) + +data OperationDefinition = OperationDefinition + Full.OperationType + (Maybe Full.Name) + [Full.VariableDefinition] + [Full.Directive] + Full.SelectionSet + +-- | Query error types. +data QueryError + = OperationNotFound Text + | OperationNameRequired + | CoercionError + | TransformationError + | EmptyDocument + | UnsupportedRootOperation + +data Input + = Int Int32 + | Float Double + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Type.Value] + | Object (HashMap Name Input) + | Variable Type.Value + deriving (Eq, Show) + +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." +queryError UnsupportedRootOperation = + "Root operation type couldn't be found in the schema." + +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 (Type m) + -> Maybe In.Type +lookupInputType (Full.TypeNamed name) types = + case HashMap.lookup name types of + Just (ScalarType scalarType) -> + Just $ In.NamedScalarType scalarType + Just (EnumType enumType) -> + Just $ In.NamedEnumType enumType + Just (InputObjectType objectType) -> + Just $ In.NamedInputObjectType objectType + _ -> Nothing +lookupInputType (Full.TypeList list) types + = In.ListType + <$> lookupInputType list types +lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = + case HashMap.lookup nonNull types of + Just (ScalarType scalarType) -> + Just $ In.NonNullScalarType scalarType + Just (EnumType enumType) -> + Just $ In.NonNullEnumType enumType + Just (InputObjectType objectType) -> + Just $ In.NonNullInputObjectType objectType + _ -> Nothing +lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types + = In.NonNullListType + <$> lookupInputType nonNull types + +coerceVariableValues :: Coerce.VariableValue a + => forall m + . HashMap Full.Name (Type m) + -> OperationDefinition + -> HashMap.HashMap Full.Name a + -> Either QueryError Type.Subs +coerceVariableValues types operationDefinition variableValues = + let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition + in maybe (Left CoercionError) Right + $ foldr forEach (Just HashMap.empty) variableDefinitions + where + forEach variableDefinition coercedValues = do + let Full.VariableDefinition variableName variableTypeName defaultValue = + variableDefinition + let defaultValue' = constValue <$> defaultValue + variableType <- lookupInputType variableTypeName types + + Coerce.matchFieldValues + coerceVariableValue' + variableValues + variableName + variableType + defaultValue' + coercedValues + coerceVariableValue' variableType value' + = Coerce.coerceVariableValue variableType value' + >>= Coerce.coerceInputLiteral variableType + +constValue :: Full.ConstValue -> Type.Value +constValue (Full.ConstInt i) = Type.Int i +constValue (Full.ConstFloat f) = Type.Float f +constValue (Full.ConstString x) = Type.String x +constValue (Full.ConstBoolean b) = Type.Boolean b +constValue Full.ConstNull = Type.Null +constValue (Full.ConstEnum e) = Type.Enum e +constValue (Full.ConstList l) = Type.List $ constValue <$> l +constValue (Full.ConstObject o) = + Type.Object $ HashMap.fromList $ constObjectField <$> o + where + constObjectField (Full.ObjectField key value') = (key, constValue value') -- | 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 :: Coerce.VariableValue a + => forall m + . Schema m + -> Maybe Full.Name + -> HashMap Full.Name a + -> Full.Document + -> Either QueryError (Document m) +document schema operationName subs ast = do + let referencedTypes = collectReferencedTypes schema + + (operations, fragmentTable) <- defragment ast + chosenOperation <- getOperation operationName operations + coercedValues <- coerceVariableValues referencedTypes chosenOperation subs + + let replacement = Replacement + { fragments = HashMap.empty + , fragmentDefinitions = fragmentTable + , variableValues = coercedValues + , types = referencedTypes + } + case chosenOperation of + OperationDefinition Full.Query _ _ _ _ -> + pure $ Document referencedTypes (query schema) + $ operation chosenOperation replacement + OperationDefinition Full.Mutation _ _ _ _ + | Just mutationType <- mutation schema -> + pure $ Document referencedTypes mutationType + $ operation chosenOperation replacement + _ -> Left UnsupportedRootOperation + +defragment + :: Full.Document + -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions) +defragment ast = + let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast + nonEmptyOperations = NonEmpty.nonEmpty operations + emptyDocument = Left EmptyDocument + in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations 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 _ acc = 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 :: OperationDefinition -> Replacement m -> Operation m +operation operationDefinition replacement + = runIdentity + $ evalStateT (collectFragments >> transform operationDefinition) replacement + where + transform (OperationDefinition Full.Query name _ _ sels) = + Query name <$> appendSelection sels + transform (OperationDefinition Full.Mutation name _ _ sels) = + Mutation name <$> appendSelection sels -- * Selection -selection :: - Full.Selection -> - TransformT (Either (Seq Core.Selection) Core.Selection) +selection + :: Full.Selection + -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) selection (Full.Field alias name arguments' directives' selections) = - maybe (Left mempty) (Right . Core.SelectionField) <$> do - fieldArguments <- arguments arguments' + maybe (Left mempty) (Right . SelectionField) <$> do + fieldArguments <- foldM go HashMap.empty arguments' fieldSelections <- appendSelection selections fieldDirectives <- Directive.selection <$> directives directives' - let field' = Core.Field alias name fieldArguments fieldSelections + let field' = Field alias name fieldArguments fieldSelections pure $ field' <$ fieldDirectives + where + go arguments (Full.Argument name' value') = + inputField arguments name' value' + selection (Full.FragmentSpread name directives') = - maybe (Left mempty) (Right . Core.SelectionFragment) <$> do + maybe (Left mempty) (Right . SelectionFragment) <$> do spreadDirectives <- Directive.selection <$> directives directives' fragments' <- gets fragments - fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') - pure $ fragment <$ spreadDirectives - where - lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions - found <- lift . lift $ HashMap.lookup name fragmentDefinitions' - fragmentDefinition found + case HashMap.lookup name fragments' of + Just definition -> lift $ pure $ definition <$ spreadDirectives + Nothing + | Just definition <- HashMap.lookup name fragmentDefinitions' -> do + fragDef <- fragmentDefinition definition + case fragDef of + Just fragment -> lift $ pure $ fragment <$ spreadDirectives + _ -> lift $ pure Nothing + | otherwise -> lift $ pure Nothing selection (Full.InlineFragment type' directives' selections) = do fragmentDirectives <- Directive.selection <$> directives directives' case fragmentDirectives of Nothing -> pure $ Left mempty _ -> do fragmentSelectionSet <- appendSelection selections - pure $ maybe Left selectionFragment type' fragmentSelectionSet + + case type' of + Nothing -> pure $ Left fragmentSelectionSet + Just typeName -> do + typeCondition' <- lookupTypeCondition typeName + case typeCondition' of + Just typeCondition -> pure $ + selectionFragment typeCondition fragmentSelectionSet + Nothing -> pure $ Left mempty where selectionFragment typeName = Right - . Core.SelectionFragment - . Core.Fragment typeName + . SelectionFragment + . Fragment typeName -appendSelection :: - Traversable t => - t Full.Selection -> - TransformT (Seq Core.Selection) +appendSelection :: Traversable t + => t Full.Selection + -> State (Replacement m) (Seq (Selection m)) appendSelection = foldM go mempty where go acc sel = append acc <$> selection sel append acc (Left list) = list >< acc append acc (Right one) = one <| acc -directives :: [Full.Directive] -> TransformT [Core.Directive] +directives :: [Full.Directive] -> State (Replacement m) [Directive] directives = traverse directive where - directive (Full.Directive directiveName directiveArguments) = - Core.Directive directiveName <$> arguments directiveArguments + directive (Full.Directive directiveName directiveArguments) + = Directive directiveName . Arguments + <$> foldM go HashMap.empty directiveArguments + go arguments (Full.Argument name value') = do + substitutedValue <- value value' + return $ HashMap.insert name substitutedValue arguments -- * Fragment replacement -- | Extract fragment definitions into a single 'HashMap'. -collectFragments :: TransformT () +collectFragments :: State (Replacement m) () collectFragments = do fragDefs <- gets fragmentDefinitions let nextValue = head $ HashMap.elems fragDefs @@ -127,41 +358,79 @@ collectFragments = do _ <- fragmentDefinition nextValue collectFragments -fragmentDefinition :: - Full.FragmentDefinition -> - TransformT Core.Fragment +lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m)) +lookupTypeCondition type' = do + types' <- gets types + case HashMap.lookup type' types' of + Just (ObjectType objectType) -> + lift $ pure $ Just $ CompositeObjectType objectType + Just (UnionType unionType) -> + lift $ pure $ Just $ CompositeUnionType unionType + Just (InterfaceType interfaceType) -> + lift $ pure $ Just $ CompositeInterfaceType interfaceType + _ -> lift $ pure Nothing + +fragmentDefinition + :: Full.FragmentDefinition + -> State (Replacement m) (Maybe (Fragment m)) fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do modify deleteFragmentDefinition fragmentSelection <- appendSelection selections - let newValue = Core.Fragment type' fragmentSelection - modify $ insertFragment newValue - liftJust newValue + compositeType <- lookupTypeCondition type' + + case compositeType of + Just compositeType' -> do + let newValue = Fragment compositeType' fragmentSelection + modify $ insertFragment newValue + lift $ pure $ Just newValue + _ -> lift $ pure Nothing + where + deleteFragmentDefinition replacement@Replacement{..} = + let newDefinitions = HashMap.delete name fragmentDefinitions + in replacement{ fragmentDefinitions = newDefinitions } + insertFragment newValue replacement@Replacement{..} = + let newFragments = HashMap.insert name newValue fragments + in replacement{ fragments = newFragments } + +value :: forall m. Full.Value -> State (Replacement m) Type.Value +value (Full.Variable name) = + gets (fromMaybe Type.Null . HashMap.lookup name . variableValues) +value (Full.Int int) = pure $ Type.Int int +value (Full.Float float) = pure $ Type.Float float +value (Full.String string) = pure $ Type.String string +value (Full.Boolean boolean) = pure $ Type.Boolean boolean +value Full.Null = pure Type.Null +value (Full.Enum enum) = pure $ Type.Enum enum +value (Full.List list) = Type.List <$> traverse value list +value (Full.Object object) = + Type.Object . HashMap.fromList <$> traverse objectField object where - deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') = - Replacement fragments' $ HashMap.delete name fragmentDefinitions' - insertFragment newValue (Replacement fragments' fragmentDefinitions') = - let newFragments = HashMap.insert name newValue fragments' - in Replacement newFragments fragmentDefinitions' - -arguments :: [Full.Argument] -> TransformT Core.Arguments -arguments = fmap Core.Arguments . foldM go HashMap.empty + objectField (Full.ObjectField name value') = (name,) <$> value value' + +input :: forall m. Full.Value -> State (Replacement m) (Maybe Input) +input (Full.Variable name) = + gets (fmap Variable . HashMap.lookup name . variableValues) +input (Full.Int int) = pure $ pure $ Int int +input (Full.Float float) = pure $ pure $ Float float +input (Full.String string) = pure $ pure $ String string +input (Full.Boolean boolean) = pure $ pure $ Boolean boolean +input Full.Null = pure $ pure Null +input (Full.Enum enum) = pure $ pure $ Enum enum +input (Full.List list) = pure . List <$> traverse value list +input (Full.Object object) = do + objectFields <- foldM objectField HashMap.empty object + pure $ pure $ Object objectFields where - go arguments' (Full.Argument name value') = do - substitutedValue <- value value' - return $ HashMap.insert name substitutedValue arguments' - -value :: Full.Value -> TransformT Core.Value -value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift -value (Full.Int i) = pure $ Core.Int i -value (Full.Float f) = pure $ Core.Float f -value (Full.String x) = pure $ Core.String x -value (Full.Boolean b) = pure $ Core.Boolean b -value Full.Null = pure Core.Null -value (Full.Enum e) = pure $ Core.Enum e -value (Full.List l) = - Core.List <$> traverse value l -value (Full.Object o) = - Core.Object . HashMap.fromList <$> traverse objectField o - -objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value) -objectField (Full.ObjectField name value') = (name,) <$> value value' + objectField resultMap (Full.ObjectField name value') = + inputField resultMap name value' + +inputField :: forall m + . HashMap Full.Name Input + -> Full.Name + -> Full.Value + -> State (Replacement m) (HashMap Full.Name Input) +inputField resultMap name value' = do + objectFieldValue <- input value' + case objectFieldValue of + Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap + Nothing -> pure resultMap |