diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,7 +29,7 @@ resolver: lts-14.8 extra-deps: - - morpheus-graphql-0.7.1 + - morpheus-graphql-0.8.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update` @@ -118,10 +118,7 @@ data Deity = Deity { fullName :: Text -- Non-Nullable Field , power :: Maybe Text -- Nullable Field - } deriving (Generic) - -instance GQLType Deity where - type KIND Deity = OBJECT + } deriving (Generic,GQLType) data DeityArgs = DeityArgs { name :: Text -- Required Argument @@ -152,8 +149,6 @@ askDB = ... ``` -Note that the type `a -> IORes b` is just Synonym for `a -> ExceptT String IO b` - To make this `Query` type available as an API, we define a `GQLRootResolver` and feed it to the Morpheus `interpreter`. A `GQLRootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example: ```haskell @@ -236,14 +231,70 @@ ```haskell data Character - = DEITY Deity - | HUMAN Human - deriving (Generic) + = data Character = + CharacterDeity Deity -- Only should generate direct link + -- RECORDS + | Creature { creatureName :: Text, creatureAge :: Int } + --- Types + | SomeDeity Deity + | CharacterInt Int + | SomeMutli Int Text + --- ENUMS + | Zeus + | Cronus + deriving (Generic, GQLType) +``` -instance GQLType Character where - type KIND Character = UNION +where deity is and object + +as you see there ar different kinds of unions. `morpheus` handles them all. + +this type will be represented as + +```gql +union Character = + Deity # unwrapped union: becouse Character + Deity = CharacterDeity + | Creature + | SomeDeity # wrapped union: becouse Character + Deity != SomeDeity + | CharacterInt + | SomeMutli + | CharacterEnumObject # object wrapped for enums + +type Creature { + creatureName: String! + creatureAge: Int! +} + +type SomeDeity { + _0: Deity! +} + +type CharacterInt { + _0: Int! +} + +type SomeMutli { + _0: Int! + _1: String! +} + +# enum +type CharacterEnumObject { + enum: CharacterEnum! +} + +enum CharacterEnum { + Zeus + Cronus +} ``` +- namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union + +- for for all other unions will be generated new object type. for types without record syntaxt, fields will be automatally indexed. + +- all empty constructors in union will be summed in type `Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and added to union members. + ### Scalar types To use custom scalar types, you need to provide implementations for `parseValue` and `serialize` respectively. @@ -285,6 +336,28 @@ ![alt text](https://morpheusgraphql.com/assets/img/introspection/spelling.png "spelling") ![alt text](https://morpheusgraphql.com/assets/img/introspection/autocomplete.png "autocomplete") ![alt text](https://morpheusgraphql.com/assets/img/introspection/type.png "type") + +## Handling Errors + +for errors you can use use either `liftEither` or `failRes`: +at the and they have same result. + +with `liftEither` + +```haskell +resolveDeity :: DeityArgs -> IORes e Deity +resolveDeity DeityArgs {} = liftEither $ dbDeity + +dbDeity :: IO Either Deity +dbDeity = pure $ Left "db error" +``` + +with `failRes` + +```haskell +resolveDeity :: DeityArgs -> IORes e Deity +resolveDeity DeityArgs { } = failRes "db error" +``` ### Mutations diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,14 +1,187 @@ +## [0.8.0] - 15.12.2009 + +### Changed + +- deprecated: `INPUT_OBJECT`, `OBJECT`, `UNION`, + + - use `INPUT` instead of `INPUT_OBJECT` + - use `deriving(GQLType)` insead of `OBJECT` or `UNION` + +- only namespaced Unions generate regular graphql Union, other attempts will be wrapped inside an object with constructor name : + + e.g: + + ```hs + data Character = + CharacterDeity Deity + SomeDeity Deity + deriving (GQLType) + ``` + + where `Deity` is Object. + will generate + + ```gql + union CHaracter = Deity | SomeDeity + + type SomeDeity { + _0: Deity + } + ``` + +### Added + +- `failRes` for resolver failures +- added kind: INPUT , OUTPUT +- Automatic Type Inference (only for Object, Union and Enum) +- More general stateful resolvers which accept instances of MonadIO (Authored by Sebastian Pulido [sebashack]) +- Utility to create web-socket applications with custom MonadIO instances (Authored by Sebastian Pulido [sebashack]) + +```hs + +data Realm = + Sky + | Sea + | Underworld + deriving (Generic, GQLType) + +data Deity = Deity{ + fullName:: Text, + realm:: Realm + } deriving (Generic, GQLType) + +data Character = + CharacterDeity Deity -- Only should generate direct link + -- RECORDS + | Creature { creatureName :: Text, creatureAge :: Int } + --- Types + | SomeDeity Deity + | CharacterInt Int + | SomeMutli Int Text + --- ENUMS + | Zeus + | Cronus deriving (Generic, GQLType) + + +``` + +will generate schema: + +```gql +enum Realm { + Sky + Sea + Underworld +} + +type Deity { + fullName: String! + realm: Realm! +} + +union Character = + Deity + | Creature + | SomeDeity + | CharacterInt + | SomeMutli + | CharacterEnumObject + +type Creature { + creatureName: String! + creatureAge: Int! +} + +type SomeDeity { + _0: Deity! +} + +type CharacterInt { + _0: Int! +} + +type SomeMutli { + _0: Int! + _1: String! +} + +# enum +type CharacterEnumObject { + enum: CharacterEnum! +} + +enum CharacterEnum { + Zeus + Cronus +} +``` + +rules: + +- haskell union type with only empty constructors (e.g `Realm`), will generate graphql `enum` +- haskell record without union (e.g `Deity`), will generate graphql `object` +- namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union + + ```gql + union Character = + Deity + | ... + ``` + +- for union recrods (`Creature { creatureName :: Text, creatureAge :: Int }`) will be referenced in union type, plus type `Creature`will be added in schema. + + e.g + + ```gql + union Character = + ... + | Creature + | ... + + type Creature { + creatureName : String! + creatureAge: Int! + } + + ``` + + - all empty constructors in union will be summed in type `Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and this type will be added to union `Character`. as in example above + + - there is only types left with form `TypeName Type1 2Type ..`(e.g `SomeDeity Deity` ,`CharacterInt Int`, `SomeMutli Int Text`), + + morpheus will generate objet type from it: + + ```gql + type TypeName { + _0: Type1! + _1: Type2! + ... + } + ``` + +### Removed + +- removed kind: INPUT_UNION + +### Fixed + +- on filed resolver was displayed. unexhausted case exception of graphql error +- support of signed numbers (e.g `-4`) +- support of round floats (e.g `1.000`) +- validation checks undefined fields on inputObject +- variables are supported inside input values + ## [0.7.1] - 26.11.2019 - max bound icludes: support-megaparsec-8.0 ## [0.7.0] - 24.11.2019 -## Removed +### Removed - `toMorpheusHaskellAPi` from `Data.Morpheus.Document` functionality will be migrated in `morpheus-graphql-cli` -## Changed +### Changed - `liftM` to `MonadTrans` instance method `lift` diff --git a/morpheus-graphql.cabal b/morpheus-graphql.cabal --- a/morpheus-graphql.cabal +++ b/morpheus-graphql.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: efbb028b66786193717210bd506961ab228d3150ecf66b7d6645e5f972aa3c95 +-- hash: edc0f21d61026ad6d50de9239e2f190424c4f7c8968b0908c467f9c487bf4e5b name: morpheus-graphql -version: 0.7.1 +version: 0.8.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -26,6 +26,7 @@ test/Feature/Holistic/arguments/nameConflict/query.gql test/Feature/Holistic/arguments/undefinedArgument/query.gql test/Feature/Holistic/arguments/unknownArguments/query.gql + test/Feature/Holistic/failure/resolveFailure/query.gql test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql test/Feature/Holistic/fragment/inlineFragment/query.gql test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql @@ -72,6 +73,7 @@ test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql test/Feature/Holistic/parsing/missingCloseBrace/query.gql test/Feature/Holistic/parsing/notNullSpacing/query.gql + test/Feature/Holistic/parsing/numbers/query.gql test/Feature/Holistic/parsing/singleLineComments/query.gql test/Feature/Holistic/schema.gql test/Feature/Holistic/selection/AliasNameConflict/query.gql @@ -91,6 +93,15 @@ test/Feature/Input/Enum/decodeMany/con4/query.gql test/Feature/Input/Enum/decodeMany/con5/query.gql test/Feature/Input/Enum/decodeMany/con6/query.gql + test/Feature/Input/Object/nullableUndefinedField/query.gql + test/Feature/Input/Object/resolveObject/query.gql + test/Feature/Input/Object/resolveVariable/query.gql + test/Feature/Input/Object/undefinedField/query.gql + test/Feature/Input/Object/unexpectedValue/query.gql + test/Feature/Input/Object/unexpectedVariable/query.gql + test/Feature/Input/Object/unknownField/query.gql + test/Feature/Input/Scalar/decodeFloat/query.gql + test/Feature/Input/Scalar/decodeInt/query.gql test/Feature/InputType/variables/incompatibleType/equalType/query.gql test/Feature/InputType/variables/incompatibleType/stricterType/query.gql test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql @@ -112,6 +123,18 @@ test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql test/Feature/InputType/variables/valueNotProvided/nullableVariable/query.gql test/Feature/Schema/nameCollision/query.gql + test/Feature/TypeInference/introspection/complexInput/query.gql + test/Feature/TypeInference/introspection/complexUnion/query.gql + test/Feature/TypeInference/introspection/complexUnionEnum/query.gql + test/Feature/TypeInference/introspection/complexUnionIndexedTypes/query.gql + test/Feature/TypeInference/introspection/complexUnionRecord/query.gql + test/Feature/TypeInference/introspection/complexUnionScalar/query.gql + test/Feature/TypeInference/introspection/enum/query.gql + test/Feature/TypeInference/introspection/inputObject/query.gql + test/Feature/TypeInference/introspection/object/query.gql + test/Feature/TypeInference/resolving/complexUnion/query.gql + test/Feature/TypeInference/resolving/input/query.gql + test/Feature/TypeInference/resolving/object/query.gql test/Feature/UnionType/cannotBeSpreadOnType/query.gql test/Feature/UnionType/fragmentOnAAndB/query.gql test/Feature/UnionType/fragmentOnlyOnA/query.gql @@ -127,6 +150,7 @@ test/Feature/Holistic/arguments/undefinedArgument/response.json test/Feature/Holistic/arguments/unknownArguments/response.json test/Feature/Holistic/cases.json + test/Feature/Holistic/failure/resolveFailure/response.json test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json test/Feature/Holistic/fragment/inlineFragment/response.json test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json @@ -174,6 +198,7 @@ test/Feature/Holistic/parsing/missingCloseBrace/response.json test/Feature/Holistic/parsing/notNullSpacing/response.json test/Feature/Holistic/parsing/notNullSpacing/variables.json + test/Feature/Holistic/parsing/numbers/response.json test/Feature/Holistic/parsing/singleLineComments/response.json test/Feature/Holistic/selection/AliasNameConflict/response.json test/Feature/Holistic/selection/AliasResolve/response.json @@ -193,6 +218,18 @@ test/Feature/Input/Enum/decodeMany/con4/response.json test/Feature/Input/Enum/decodeMany/con5/response.json test/Feature/Input/Enum/decodeMany/con6/response.json + test/Feature/Input/Object/cases.json + test/Feature/Input/Object/nullableUndefinedField/response.json + test/Feature/Input/Object/resolveObject/response.json + test/Feature/Input/Object/resolveVariable/response.json + test/Feature/Input/Object/resolveVariable/variables.json + test/Feature/Input/Object/undefinedField/response.json + test/Feature/Input/Object/unexpectedValue/response.json + test/Feature/Input/Object/unexpectedVariable/response.json + test/Feature/Input/Object/unknownField/response.json + test/Feature/Input/Scalar/cases.json + test/Feature/Input/Scalar/decodeFloat/response.json + test/Feature/Input/Scalar/decodeInt/response.json test/Feature/InputType/cases.json test/Feature/InputType/variables/incompatibleType/equalType/response.json test/Feature/InputType/variables/incompatibleType/equalType/variables.json @@ -229,6 +266,19 @@ test/Feature/InputType/variables/valueNotProvided/nullableVariable/response.json test/Feature/Schema/cases.json test/Feature/Schema/nameCollision/response.json + test/Feature/TypeInference/cases.json + test/Feature/TypeInference/introspection/complexInput/response.json + test/Feature/TypeInference/introspection/complexUnion/response.json + test/Feature/TypeInference/introspection/complexUnionEnum/response.json + test/Feature/TypeInference/introspection/complexUnionIndexedTypes/response.json + test/Feature/TypeInference/introspection/complexUnionRecord/response.json + test/Feature/TypeInference/introspection/complexUnionScalar/response.json + test/Feature/TypeInference/introspection/enum/response.json + test/Feature/TypeInference/introspection/inputObject/response.json + test/Feature/TypeInference/introspection/object/response.json + test/Feature/TypeInference/resolving/complexUnion/response.json + test/Feature/TypeInference/resolving/input/response.json + test/Feature/TypeInference/resolving/object/response.json test/Feature/UnionType/cannotBeSpreadOnType/response.json test/Feature/UnionType/cases.json test/Feature/UnionType/fragmentOnAAndB/response.json @@ -313,7 +363,6 @@ Data.Morpheus.Types.ID Data.Morpheus.Types.Internal.AST.Base Data.Morpheus.Types.Internal.AST.Data - Data.Morpheus.Types.Internal.AST.Operation Data.Morpheus.Types.Internal.AST.Selection Data.Morpheus.Types.Internal.AST.Value Data.Morpheus.Types.Internal.Resolving @@ -359,9 +408,12 @@ other-modules: Feature.Holistic.API Feature.Input.Enum.API + Feature.Input.Object.API + Feature.Input.Scalar.API Feature.InputType.API Feature.Schema.A2 Feature.Schema.API + Feature.TypeInference.API Feature.UnionType.API Feature.WrappedTypeName.API Lib diff --git a/src/Data/Morpheus/Error/Fragment.hs b/src/Data/Morpheus/Error/Fragment.hs --- a/src/Data/Morpheus/Error/Fragment.hs +++ b/src/Data/Morpheus/Error/Fragment.hs @@ -11,7 +11,9 @@ where import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) +import Data.Text ( Text + , intercalate + ) import qualified Data.Text as T -- MORPHEUS @@ -40,7 +42,7 @@ fragmentNameCollision = map toError where toError Ref { refName, refPosition } = GQLError - { message = "There can be only one fragment named \"" <> refName <> "\"." + { message = "There can be only one fragment named \"" <> refName <> "\"." , locations = [refPosition] } @@ -48,7 +50,7 @@ unusedFragment = map toError where toError Ref { refName, refPosition } = GQLError - { message = "Fragment \"" <> refName <> "\" is never used." + { message = "Fragment \"" <> refName <> "\" is never used." , locations = [refPosition] } @@ -60,7 +62,7 @@ [ "Cannot spread fragment \"" , refName $ head fragments , "\" within itself via " - , T.intercalate "," (map refName fragments) + , T.intercalate ", " (map refName fragments) , "." ] @@ -70,19 +72,18 @@ where text = T.concat ["Unknown Fragment \"", key', "\"."] -- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"." -cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> Text -> GQLErrors -cannotBeSpreadOnType key' type' position' selectionType' = errorMessage - position' - text +cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> [Text] -> GQLErrors +cannotBeSpreadOnType key fragmentType position typeMembers = errorMessage + position + message where - text = T.concat - [ "Fragment" - , getName key' - , " cannot be spread here as objects of type \"" - , selectionType' - , "\" can never be of type \"" - , type' - , "\"." - ] - getName (Just x') = T.concat [" \"", x', "\""] - getName Nothing = "" + message = + "Fragment " + <> getName key + <> "cannot be spread here as objects of type \"" + <> intercalate ", " typeMembers + <> "\" can never be of type \"" + <> fragmentType + <> "\"." + getName (Just x) = "\"" <> x <> "\" " + getName Nothing = "" diff --git a/src/Data/Morpheus/Error/Input.hs b/src/Data/Morpheus/Error/Input.hs --- a/src/Data/Morpheus/Error/Input.hs +++ b/src/Data/Morpheus/Error/Input.hs @@ -13,19 +13,25 @@ import Data.Aeson ( encode ) import Data.ByteString.Lazy.Char8 ( unpack ) import Data.Morpheus.Types.Internal.AST.Value - ( Value ) + ( ResolvedValue ) import Data.Text ( Text ) import qualified Data.Text as T ( concat , intercalate , pack ) + + +import Data.Morpheus.Types.Internal.Resolving.Core + ( GQLErrors ) + type InputValidation a = Either InputError a data InputError - = UnexpectedType [Prop] Text Value (Maybe Text) + = UnexpectedType [Prop] Text ResolvedValue (Maybe Text) | UndefinedField [Prop] Text | UnknownField [Prop] Text + | GlobalInputError GQLErrors data Prop = Prop @@ -33,17 +39,20 @@ , propType :: Text } -inputErrorMessage :: InputError -> Text +inputErrorMessage :: InputError -> Either GQLErrors Text inputErrorMessage (UnexpectedType path type' value errorMessage) = - expectedTypeAFoundB path type' value errorMessage -inputErrorMessage (UndefinedField path' field') = undefinedField path' field' -inputErrorMessage (UnknownField path' field') = unknownField path' field' + Right $ expectedTypeAFoundB path type' value errorMessage +inputErrorMessage (UndefinedField path' field') = + Right $ undefinedField path' field' +inputErrorMessage (UnknownField path' field') = + Right $ unknownField path' field' +inputErrorMessage (GlobalInputError err) = Left err pathToText :: [Prop] -> Text pathToText [] = "" pathToText path' = T.concat ["on ", T.intercalate "." $ fmap propKey path'] -expectedTypeAFoundB :: [Prop] -> Text -> Value -> Maybe Text -> Text +expectedTypeAFoundB :: [Prop] -> Text -> ResolvedValue -> Maybe Text -> Text expectedTypeAFoundB path' expected found Nothing = T.concat [ pathToText path' , " Expected type \"" diff --git a/src/Data/Morpheus/Error/Internal.hs b/src/Data/Morpheus/Error/Internal.hs --- a/src/Data/Morpheus/Error/Internal.hs +++ b/src/Data/Morpheus/Error/Internal.hs @@ -5,6 +5,7 @@ , internalArgumentError , internalUnknownTypeMessage , internalError + , internalResolvingError ) where @@ -23,7 +24,7 @@ , Failure(..) ) import Data.Morpheus.Types.Internal.AST.Value - ( Value(..) ) + ( ValidValue ) -- GQL:: if no mutation defined -> "Schema is not configured for mutations." @@ -32,6 +33,11 @@ internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x -- if type did not not found, but was defined by Schema +internalResolvingError :: Text -> GQLErrors +internalResolvingError = globalErrorMessage . ("INTERNAL RESOLVING ERROR:" <>) + + +-- if type did not not found, but was defined by Schema internalUnknownTypeMessage :: Text -> GQLErrors internalUnknownTypeMessage x = globalErrorMessage $ T.concat ["type did not not found, but was defined by Schema", x] @@ -41,6 +47,6 @@ internalArgumentError x = internalError $ "Argument " <> x -- if value is already validated but value has different type -internalTypeMismatch :: Text -> Value -> Validation b +internalTypeMismatch :: Text -> ValidValue -> Validation b internalTypeMismatch text jsType = internalError $ "Type mismatch " <> text <> T.pack (show jsType) diff --git a/src/Data/Morpheus/Execution/Client/Compile.hs b/src/Data/Morpheus/Execution/Client/Compile.hs --- a/src/Data/Morpheus/Execution/Client/Compile.hs +++ b/src/Data/Morpheus/Execution/Client/Compile.hs @@ -58,7 +58,8 @@ validateWith :: DataTypeLib -> (GQLQuery, String) -> Validation ClientQuery validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest - (queryArgsType, queryTypes) <- operationTypes schema - (O.operationArgs operation) - validOperation + (queryArgsType, queryTypes) <- operationTypes + schema + (O.operationArguments operation) + validOperation return ClientQuery { queryText, queryTypes, queryArgsType } diff --git a/src/Data/Morpheus/Execution/Client/Selection.hs b/src/Data/Morpheus/Execution/Client/Selection.hs --- a/src/Data/Morpheus/Execution/Client/Selection.hs +++ b/src/Data/Morpheus/Execution/Client/Selection.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,25 +24,24 @@ import Data.Morpheus.Execution.Internal.Utils ( nameSpaceType ) import Data.Morpheus.Types.Internal.AST - ( DefaultValue - , Operation(..) + ( Operation(..) , ValidOperation , Variable(..) , VariableDefinitions , getOperationName , getOperationDataType , Selection(..) - , SelectionRec(..) - , SelectionSet + , SelectionContent(..) + , ValidSelectionSet , ValidSelection - , Ref(..) + , Ref(..) , DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeKind(..) , DataTypeLib(..) , Key - , TypeAlias(..) + , TypeRef(..) , DataEnumValue(..) , allDataTypes , lookupType @@ -50,6 +50,7 @@ , TypeD(..) , lookupDeprecated , lookupDeprecatedReason + , RAW ) import Data.Morpheus.Types.Internal.Resolving ( GQLErrors @@ -79,13 +80,13 @@ operationTypes lib variables = genOperation where genOperation operation@Operation { operationName, operationSelection } = do - datatype <- DataObject <$> getOperationDataType operation lib + datatype <- getOperationDataType operation lib (queryTypes, enums) <- genRecordType [] (getOperationName operationName) datatype operationSelection inputTypeRequests <- resolveUpdates [] - $ map (scanInputTypes lib . variableType . snd) variables + $ map (scanInputTypes lib . typeConName . variableType . snd) variables inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums) pure ( rootArguments (getOperationName operationName <> "Args") @@ -112,15 +113,12 @@ , tMeta = Nothing } where - fieldD :: (Text, Variable DefaultValue) -> DataField - fieldD (key, Variable { variableType, variableTypeWrappers }) = DataField + fieldD :: (Text, Variable RAW) -> DataField + fieldD (key, Variable { variableType }) = DataField { fieldName = key , fieldArgs = [] , fieldArgsType = Nothing - , fieldType = TypeAlias { aliasWrappers = variableTypeWrappers - , aliasTyCon = variableType - , aliasArgs = Nothing - } + , fieldType = variableType , fieldMeta = Nothing } --------------------------------------------------------- @@ -129,7 +127,7 @@ :: [Key] -> Key -> DataType - -> SelectionSet + -> ValidSelectionSet -> Validation ([ClientType], [Text]) genRecordType path name dataType recordSelSet = do (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet @@ -150,7 +148,7 @@ genConsD :: String -> DataType - -> SelectionSet + -> ValidSelectionSet -> Validation (ConsD, [ClientType], [Text]) genConsD cName datatype selSet = do (cFields, subTypes, requests) <- unzip3 <$> traverse genField selSet @@ -184,13 +182,13 @@ ------------------------------------------ subTypesBySelection :: DataType -> ValidSelection -> Validation ([ClientType], [Text]) - subTypesBySelection dType Selection { selectionRec = SelectionField } = - leafType dType + subTypesBySelection dType Selection { selectionContent = SelectionField } + = leafType dType --withLeaf buildLeaf dType - subTypesBySelection dType Selection { selectionRec = SelectionSet selectionSet } + subTypesBySelection dType Selection { selectionContent = SelectionSet selectionSet } = genRecordType fieldPath (typeFrom [] dType) dType selectionSet ---- UNION - subTypesBySelection dType Selection { selectionRec = UnionSelection unionSelections } + subTypesBySelection dType Selection { selectionContent = UnionSelection unionSelections } = do (tCons, subTypes, requests) <- unzip3 <$> mapM getUnionType unionSelections @@ -213,55 +211,58 @@ scanInputTypes :: DataTypeLib -> Key -> LibUpdater [Key] scanInputTypes lib name collected | name `elem` collected = pure collected - | otherwise = getType lib name >>= scanType + | otherwise = getType lib name >>= scanInpType where - scanType (DataInputObject DataTyCon { typeData }) = resolveUpdates - (name : collected) - (map toInputTypeD typeData) + scanInpType DataType { typeContent, typeName } = scanType typeContent where - toInputTypeD :: (Text, DataField) -> LibUpdater [Key] - toInputTypeD (_, DataField { fieldType = TypeAlias { aliasTyCon } }) = - scanInputTypes lib aliasTyCon - scanType (DataEnum DataTyCon { typeName }) = pure (collected <> [typeName]) - scanType _ = pure collected + scanType (DataInputObject fields) = resolveUpdates + (name : collected) + (map toInputTypeD fields) + where + toInputTypeD :: (Text, DataField) -> LibUpdater [Key] + toInputTypeD (_, DataField { fieldType = TypeRef { typeConName } }) = + scanInputTypes lib typeConName + scanType (DataEnum _) = pure (collected <> [typeName]) + scanType _ = pure collected buildInputType :: DataTypeLib -> Text -> Validation [ClientType] -buildInputType lib name = getType lib name >>= subTypes +buildInputType lib name = getType lib name >>= generateTypes where - subTypes (DataInputObject DataTyCon { typeName, typeData }) = do - fields <- traverse toFieldD typeData - pure + generateTypes DataType { typeName, typeContent } = subTypes typeContent + where + subTypes (DataInputObject inputFields) = do + fields <- traverse toFieldD inputFields + pure + [ ClientType + { clientType = + TypeD + { tName = unpack typeName + , tNamespace = [] + , tCons = [ConsD { cName = unpack typeName, cFields = fields }] + , tMeta = Nothing + } + , clientKind = KindInputObject + } + ] + where + toFieldD :: (Text, DataField) -> Validation DataField + toFieldD (_, field@DataField { fieldType }) = do + typeConName <- typeFrom [] <$> getType lib (typeConName fieldType) + pure $ field { fieldType = fieldType { typeConName } } + subTypes (DataEnum enumTags) = pure [ ClientType - { clientType = - TypeD - { tName = unpack typeName - , tNamespace = [] - , tCons = [ConsD { cName = unpack typeName, cFields = fields }] - , tMeta = Nothing - } - , clientKind = KindInputObject + { clientType = TypeD { tName = unpack typeName + , tNamespace = [] + , tCons = map enumOption enumTags + , tMeta = Nothing + } + , clientKind = KindEnum } ] - - where - toFieldD :: (Text, DataField) -> Validation DataField - toFieldD (_, field@DataField { fieldType }) = do - aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType) - pure $ field { fieldType = fieldType { aliasTyCon } } - subTypes (DataEnum DataTyCon { typeName, typeData }) = pure - [ ClientType - { clientType = TypeD { tName = unpack typeName - , tNamespace = [] - , tCons = map enumOption typeData - , tMeta = Nothing - } - , clientKind = KindEnum - } - ] - where - enumOption DataEnumValue { enumName } = - ConsD { cName = unpack enumName, cFields = [] } - subTypes _ = pure [] + where + enumOption DataEnumValue { enumName } = + ConsD { cName = unpack enumName, cFields = [] } + subTypes _ = pure [] lookupFieldType @@ -270,14 +271,14 @@ -> DataType -> Position -> Text - -> Validation (DataType, TypeAlias) -lookupFieldType lib path (DataObject DataTyCon { typeData, typeName }) refPosition key - = case lookup key typeData of - Just DataField { fieldType = alias@TypeAlias { aliasTyCon }, fieldMeta } -> - checkDeprecated >> (trans <$> getType lib aliasTyCon) + -> Validation (DataType, TypeRef) +lookupFieldType lib path DataType { typeContent = DataObject typeContent, typeName } refPosition key + = case lookup key typeContent of + Just DataField { fieldType = alias@TypeRef { typeConName }, fieldMeta } -> + checkDeprecated >> (trans <$> getType lib typeConName) where trans x = - (x, alias { aliasTyCon = typeFrom path x, aliasArgs = Nothing }) + (x, alias { typeConName = typeFrom path x, typeArgs = Nothing }) ------------------------------------------------------------------ checkDeprecated :: Validation () checkDeprecated = case fieldMeta >>= lookupDeprecated of @@ -288,16 +289,20 @@ (lookupDeprecatedReason deprecation) Nothing -> pure () ------------------ - Nothing -> failure - (compileError $ "cant find field \"" <> pack (show typeData) <> "\"") + Nothing -> + failure + (compileError $ "cant find field \"" <> pack (show typeContent) <> "\"") lookupFieldType _ _ dt _ _ = failure (compileError $ "Type should be output Object \"" <> pack (show dt)) leafType :: DataType -> Validation ([ClientType], [Text]) -leafType (DataEnum DataTyCon { typeName }) = pure ([], [typeName]) -leafType DataScalar{} = pure ([], []) -leafType _ = failure $ compileError "Invalid schema Expected scalar" +leafType DataType { typeName, typeContent } = fromKind typeContent + where + fromKind :: DataTypeContent -> Validation ([ClientType], [Text]) + fromKind DataEnum{} = pure ([], [typeName]) + fromKind DataScalar{} = pure ([], []) + fromKind _ = failure $ compileError "Invalid schema Expected scalar" getType :: DataTypeLib -> Text -> Validation DataType getType lib typename = @@ -312,9 +317,9 @@ typeFromScalar _ = "ScalarValue" typeFrom :: [Key] -> DataType -> Text -typeFrom _ (DataScalar DataTyCon { typeName }) = typeFromScalar typeName -typeFrom _ (DataEnum x) = typeName x -typeFrom _ (DataInputObject x) = typeName x -typeFrom path (DataObject x) = pack $ nameSpaceType path $ typeName x -typeFrom path (DataUnion x) = pack $ nameSpaceType path $ typeName x -typeFrom _ (DataInputUnion x) = typeName x +typeFrom path DataType { typeName, typeContent } = __typeFrom typeContent + where + __typeFrom DataScalar{} = typeFromScalar typeName + __typeFrom DataObject{} = pack $ nameSpaceType path typeName + __typeFrom DataUnion{} = pack $ nameSpaceType path typeName + __typeFrom _ = typeName diff --git a/src/Data/Morpheus/Execution/Document/Convert.hs b/src/Data/Morpheus/Execution/Document/Convert.hs --- a/src/Data/Morpheus/Execution/Document/Convert.hs +++ b/src/Data/Morpheus/Execution/Document/Convert.hs @@ -23,12 +23,12 @@ import Data.Morpheus.Types.Internal.AST ( ArgsType(..) , DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeKind(..) , OperationType(..) , ResolverKind(..) - , TypeAlias(..) + , TypeRef(..) , DataEnumValue(..) , sysTypes , ConsD(..) @@ -42,7 +42,7 @@ renderTHTypes namespace lib = traverse renderTHType lib where renderTHType :: (Text, DataType) -> Validation GQLTypeD - renderTHType (tyConName, x) = genType x + renderTHType (tyConName, x) = generateType x where genArgsTypeName fieldName | namespace = sysName tyConName <> argTName | otherwise = argTName @@ -73,19 +73,19 @@ sysName = unpack . genTypeName --------------------------------------------------------------------------------------------- genField :: (Text, DataField) -> DataField - genField (_, field@DataField { fieldType = alias@TypeAlias { aliasTyCon } }) - = field { fieldType = alias { aliasTyCon = genFieldTypeName aliasTyCon } + genField (_, field@DataField { fieldType = alias@TypeRef { typeConName } }) + = field { fieldType = alias { typeConName = genFieldTypeName typeConName } } --------------------------------------------------------------------------------------------- genResField :: (Text, DataField) -> DataField - genResField (_, field@DataField { fieldName, fieldArgs, fieldType = alias@TypeAlias { aliasTyCon } }) - = field { fieldType = alias { aliasTyCon = ftName, aliasArgs } + genResField (_, field@DataField { fieldName, fieldArgs, fieldType = alias@TypeRef { typeConName } }) + = field { fieldType = alias { typeConName = ftName, typeArgs } , fieldArgsType } where - ftName = genFieldTypeName aliasTyCon + ftName = genFieldTypeName typeConName --------------------------------------- - aliasArgs = case lookup aliasTyCon lib of + typeArgs = case typeContent <$> lookup typeConName lib of Just DataObject{} -> Just "m" Just DataUnion{} -> Just "m" _ -> Nothing @@ -96,37 +96,38 @@ argsTypeName | null fieldArgs = "()" | otherwise = pack $ genArgsTypeName $ unpack fieldName -------------------------------------- - getFieldType key = case lookup key lib of + getFieldType key = case typeContent <$> lookup key lib of Nothing -> ExternalResolver Just DataObject{} -> TypeVarResolver Just DataUnion{} -> TypeVarResolver Just _ -> PlainResolver -------------------------------------------- - genType dt@(DataEnum DataTyCon { typeName, typeData, typeMeta }) = pure - GQLTypeD + generateType dt@DataType { typeName, typeContent, typeMeta } = genType + typeContent + where + genType (DataEnum tags) = pure GQLTypeD { typeD = TypeD { tName = sysName typeName , tNamespace = [] - , tCons = map enumOption typeData + , tCons = map enumOption tags , tMeta = typeMeta } , typeKindD = KindEnum , typeArgD = [] , typeOriginal = (typeName, dt) } - where - enumOption DataEnumValue { enumName } = - ConsD { cName = sysName enumName, cFields = [] } - genType (DataScalar _) = - internalError "Scalar Types should defined By Native Haskell Types" - genType (DataInputUnion _) = internalError "Input Unions not Supported" - genType dt@(DataInputObject DataTyCon { typeName, typeData, typeMeta }) = - pure GQLTypeD + where + enumOption DataEnumValue { enumName } = + ConsD { cName = sysName enumName, cFields = [] } + genType (DataScalar _) = + internalError "Scalar Types should defined By Native Haskell Types" + genType (DataInputUnion _) = internalError "Input Unions not Supported" + genType (DataInputObject fields) = pure GQLTypeD { typeD = TypeD { tName = sysName typeName , tNamespace = [] , tCons = [ ConsD { cName = sysName typeName - , cFields = map genField typeData + , cFields = map genField fields } ] , tMeta = typeMeta @@ -135,51 +136,52 @@ , typeArgD = [] , typeOriginal = (typeName, dt) } - genType dt@(DataObject DataTyCon { typeName, typeData, typeMeta }) = do - typeArgD <- concat <$> traverse genArgumentType typeData - pure GQLTypeD - { typeD = TypeD - { tName = sysName typeName - , tNamespace = [] - , tCons = [ ConsD { cName = sysName typeName - , cFields = map genResField typeData - } - ] - , tMeta = typeMeta - } - , typeKindD = if typeName == "Subscription" - then KindObject (Just Subscription) - else KindObject Nothing - , typeArgD - , typeOriginal = (typeName, dt) - } - genType dt@(DataUnion DataTyCon { typeName, typeData, typeMeta }) = do - let tCons = map unionCon typeData - pure GQLTypeD - { typeD = TypeD { tName = unpack typeName - , tNamespace = [] - , tCons - , tMeta = typeMeta - } - , typeKindD = KindUnion - , typeArgD = [] - , typeOriginal = (typeName, dt) - } - where - unionCon memberName = ConsD - { cName - , cFields = [ DataField - { fieldName = pack $ "un" <> cName - , fieldType = TypeAlias { aliasTyCon = pack utName - , aliasArgs = Just "m" - , aliasWrappers = [] - } - , fieldMeta = Nothing - , fieldArgs = [] - , fieldArgsType = Nothing - } - ] - } + genType (DataObject fields) = do + typeArgD <- concat <$> traverse genArgumentType fields + pure GQLTypeD + { typeD = + TypeD + { tName = sysName typeName + , tNamespace = [] + , tCons = [ ConsD { cName = sysName typeName + , cFields = map genResField fields + } + ] + , tMeta = typeMeta + } + , typeKindD = if typeName == "Subscription" + then KindObject (Just Subscription) + else KindObject Nothing + , typeArgD + , typeOriginal = (typeName, dt) + } + genType (DataUnion members) = do + let tCons = map unionCon members + pure GQLTypeD + { typeD = TypeD { tName = unpack typeName + , tNamespace = [] + , tCons + , tMeta = typeMeta + } + , typeKindD = KindUnion + , typeArgD = [] + , typeOriginal = (typeName, dt) + } where - cName = sysName typeName <> utName - utName = sysName memberName + unionCon memberName = ConsD + { cName + , cFields = [ DataField + { fieldName = pack $ "un" <> cName + , fieldType = TypeRef { typeConName = pack utName + , typeArgs = Just "m" + , typeWrappers = [] + } + , fieldMeta = Nothing + , fieldArgs = [] + , fieldArgsType = Nothing + } + ] + } + where + cName = sysName typeName <> utName + utName = sysName memberName diff --git a/src/Data/Morpheus/Execution/Document/Declare.hs b/src/Data/Morpheus/Execution/Document/Declare.hs --- a/src/Data/Morpheus/Execution/Document/Declare.hs +++ b/src/Data/Morpheus/Execution/Document/Declare.hs @@ -47,7 +47,7 @@ where gqlInstances | isObject typeKindD && isInput typeKindD - = [deriveObjectRep (typeD, Just typeKindD), deriveDecode typeD] + = [deriveObjectRep (typeD, Nothing), deriveDecode typeD] | isObject typeKindD = [deriveObjectRep (typeD, Just typeKindD), deriveEncode gqlType] | otherwise diff --git a/src/Data/Morpheus/Execution/Document/Decode.hs b/src/Data/Morpheus/Execution/Document/Decode.hs --- a/src/Data/Morpheus/Execution/Document/Decode.hs +++ b/src/Data/Morpheus/Execution/Document/Decode.hs @@ -18,30 +18,30 @@ import Data.Morpheus.Execution.Internal.Decode ( decodeFieldWith , decodeObjectExpQ + , withObject ) import Data.Morpheus.Execution.Server.Decode ( Decode(..) - , DecodeObject(..) + , DecodeType(..) ) import Data.Morpheus.Types.Internal.AST ( TypeD(..) - , Object + , ValidValue ) import Data.Morpheus.Types.Internal.TH ( instanceHeadT ) import Data.Morpheus.Types.Internal.Resolving ( Validation ) - -(.:) :: Decode a => Object -> Text -> Validation a -object .: selectorName = decodeFieldWith decode selectorName object +(.:) :: Decode a => ValidValue -> Text -> Validation a +value .: selectorName = withObject (decodeFieldWith decode selectorName) value deriveDecode :: TypeD -> Q [Dec] deriveDecode TypeD { tName, tCons = [cons] } = pure <$> instanceD (cxt []) appHead methods where - appHead = instanceHeadT ''DecodeObject tName [] - methods = [funD 'decodeObject [clause argsE (normalB body) []]] + appHead = instanceHeadT ''DecodeType tName [] + methods = [funD 'decodeType [clause argsE (normalB body) []]] where argsE = map (varP . mkName) ["o"] body = decodeObjectExpQ [|(.:)|] cons diff --git a/src/Data/Morpheus/Execution/Document/Encode.hs b/src/Data/Morpheus/Execution/Document/Encode.hs --- a/src/Data/Morpheus/Execution/Document/Encode.hs +++ b/src/Data/Morpheus/Execution/Document/Encode.hs @@ -17,7 +17,7 @@ -- MORPHEUS import Data.Morpheus.Execution.Server.Encode ( Encode(..) - , ObjectResolvers(..) + , ExploreResolvers(..) ) import Data.Morpheus.Types.GQLType ( TRUE ) import Data.Morpheus.Types.Internal.AST @@ -34,6 +34,7 @@ , MapStrategy(..) , LiftEither , ResolvingStrategy + , DataResolver(..) ) import Data.Morpheus.Types.Internal.TH ( applyT @@ -88,15 +89,16 @@ ] ------------------------------------------------------------------- -- defines: instance => ObjectResolvers ('TRUE) ( (ResolveT m)) (ResolveT m value) where - appHead = - instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) (mainType : instanceArgs) + appHead = instanceHeadMultiT ''ExploreResolvers + (conT ''TRUE) + (mainType : instanceArgs) ------------------------------------------------------------------ -- defines: objectResolvers = [("field1",encode field1),("field2",encode field2), ...] - methods = [funD 'objectResolvers [clause argsE (normalB body) []]] + methods = [funD 'exploreResolvers [clause argsE (normalB body) []]] where argsE = [varP (mkName "_"), destructRecord tName varNames] - body = listE $ map decodeVar varNames - decodeVar name = [|(name, encode $(varName))|] + body = appE (conE 'ObjectRes) (listE $ map decodeVar varNames) + decodeVar name = [| (name, encode $(varName))|] where varName = varE $ mkName name varNames = map (unpack . fieldName) cFields deriveEncode _ = pure [] diff --git a/src/Data/Morpheus/Execution/Document/GQLType.hs b/src/Data/Morpheus/Execution/Document/GQLType.hs --- a/src/Data/Morpheus/Execution/Document/GQLType.hs +++ b/src/Data/Morpheus/Execution/Document/GQLType.hs @@ -19,12 +19,10 @@ import Data.Morpheus.Execution.Internal.Declare ( tyConArgs ) import Data.Morpheus.Kind ( ENUM - , INPUT_OBJECT - , INPUT_UNION - , OBJECT , SCALAR - , UNION , WRAPPER + , INPUT + , OUTPUT ) import Data.Morpheus.Types.GQLType ( GQLType(..) , TRUE @@ -84,9 +82,9 @@ --------------------------------- toKIND KindScalar = ''SCALAR toKIND KindEnum = ''ENUM - toKIND (KindObject _) = ''OBJECT - toKIND KindUnion = ''UNION - toKIND KindInputObject = ''INPUT_OBJECT + toKIND (KindObject _) = ''OUTPUT + toKIND KindUnion = ''OUTPUT + toKIND KindInputObject = ''INPUT toKIND KindList = ''WRAPPER toKIND KindNonNull = ''WRAPPER - toKIND KindInputUnion = ''INPUT_UNION + toKIND KindInputUnion = ''INPUT diff --git a/src/Data/Morpheus/Execution/Document/Introspect.hs b/src/Data/Morpheus/Execution/Document/Introspect.hs --- a/src/Data/Morpheus/Execution/Document/Introspect.hs +++ b/src/Data/Morpheus/Execution/Document/Introspect.hs @@ -9,15 +9,15 @@ import Data.Maybe(maybeToList) import Data.Proxy (Proxy (..)) -import Data.Text (unpack) +import Data.Text (unpack,Text) import Data.Typeable (Typeable) import Language.Haskell.TH -- MORPHEUS import Data.Morpheus.Execution.Internal.Declare (tyConArgs) -import Data.Morpheus.Execution.Server.Introspect (Introspect (..), ObjectFields (..)) +import Data.Morpheus.Execution.Server.Introspect (Introspect (..), objectFields, IntrospectRep (..),TypeScope(..)) import Data.Morpheus.Types.GQLType (GQLType (__typeName), TRUE) -import Data.Morpheus.Types.Internal.AST (ConsD (..), TypeD (..), ArgsType (..),Key, DataType(..), DataField (..),insertType,DataTypeKind(..), TypeAlias (..)) +import Data.Morpheus.Types.Internal.AST (ConsD (..), TypeD (..), ArgsType (..),Key, DataType(..), DataTypeContent(..), DataField (..),insertType,DataTypeKind(..), TypeRef (..)) import Data.Morpheus.Types.Internal.TH (instanceFunD, instanceProxyFunD,instanceHeadT, instanceHeadMultiT, typeT) @@ -25,14 +25,23 @@ -- FIXME: dirty fix for introspection instanceIntrospect ("__DirectiveLocation",_) = pure [] instanceIntrospect ("__TypeKind",_) = pure [] -instanceIntrospect (name, DataEnum enumType) = - pure <$> instanceD (cxt []) iHead [defineIntrospect] +instanceIntrospect (name, DataType { + typeContent = DataEnum enumType, + typeName + , typeMeta + , typeFingerprint + }) = pure <$> instanceD (cxt []) iHead [defineIntrospect] where ----------------------------------------------- iHead = instanceHeadT ''Introspect (unpack name) [] defineIntrospect = instanceProxyFunD ('introspect,body) where - body =[| insertType (name, DataEnum enumType) |] + body =[| insertType (name,DataType { + typeName + ,typeMeta + , typeFingerprint + ,typeContent = DataEnum enumType + }) |] instanceIntrospect _ = pure [] -- [((Text, DataField), TypeUpdater)] @@ -40,16 +49,20 @@ deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) = pure <$> instanceD (cxt constrains) iHead methods where + mainTypeName = typeT (mkName tName) typeArgs typeArgs = concatMap tyConArgs (maybeToList tKind) constrains = map conTypeable typeArgs where conTypeable name = typeT ''Typeable [name] ----------------------------------------------- - iHead = instanceHeadMultiT ''ObjectFields (conT ''TRUE) [typeT (mkName tName) typeArgs] - methods = [instanceFunD 'objectFields ["_proxy1", "_proxy2"] body] + iHead = instanceHeadMultiT ''IntrospectRep (conT ''TRUE) [mainTypeName] + methods = [instanceFunD 'introspectRep ["_proxy1", "_proxy2"] body] where - body = [|($(buildFields cFields), concat $(buildTypes cFields))|] + body + | tKind == Just KindInputObject || null tKind = [| (DataInputObject $(buildFields cFields), concat $(buildTypes cFields))|] + | otherwise = [| (DataObject $(buildFields cFields), concat $(buildTypes cFields))|] deriveObjectRep _ = pure [] + buildTypes :: [DataField] -> ExpQ buildTypes = listE . concatMap introspectField @@ -58,30 +71,35 @@ [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgsType where inputTypes (Just ArgsType {argsTypeName}) - | argsTypeName /= "()" = [[|snd $ objectFields (Proxy :: Proxy TRUE) $(proxyT tAlias)|]] + | argsTypeName /= "()" = [[|snd $ objectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]] where - tAlias = TypeAlias {aliasTyCon = argsTypeName, aliasWrappers = [], aliasArgs = Nothing} + tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing} inputTypes _ = [] -proxyT :: TypeAlias -> Q Exp -proxyT TypeAlias {aliasTyCon, aliasArgs} = [|(Proxy :: Proxy $(genSig aliasArgs))|] +conTX :: Text -> Q Type +conTX = conT . mkName . unpack + +varTX :: Text -> Q Type +varTX = varT . mkName . unpack + +proxyT :: TypeRef -> Q Exp +proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|] where - genSig (Just m) = appT (conT $ mkName $ unpack aliasTyCon) (varT $ mkName $ unpack m) - genSig _ = conT $ mkName $ unpack aliasTyCon + genSig (Just m) = appT (conTX typeConName) (varTX m) + genSig _ = conTX typeConName buildFields :: [DataField] -> ExpQ buildFields = listE . map buildField where - buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeAlias {aliasArgs, aliasWrappers}, fieldMeta} = - [|( fName + buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeRef {typeArgs, typeWrappers}, fieldMeta} = + [|( fieldName , DataField - { fieldName = fName + { fieldName , fieldArgs = fArgs , fieldArgsType = Nothing - , fieldType = TypeAlias {aliasTyCon = __typeName $(proxyT alias), aliasArgs = aArgs, aliasWrappers} + , fieldType = TypeRef {typeConName = __typeName $(proxyT alias), typeArgs = aArgs, typeWrappers} , fieldMeta })|] where - fName = unpack fieldName fArgs = map (\(k, v) -> (unpack k, v)) fieldArgs - aArgs = unpack <$> aliasArgs + aArgs = unpack <$> typeArgs diff --git a/src/Data/Morpheus/Execution/Internal/Declare.hs b/src/Data/Morpheus/Execution/Internal/Declare.hs --- a/src/Data/Morpheus/Execution/Internal/Declare.hs +++ b/src/Data/Morpheus/Execution/Internal/Declare.hs @@ -30,7 +30,7 @@ , DataField(..) , DataTypeKind(..) , DataTypeKind(..) - , TypeAlias(..) + , TypeRef(..) , TypeWrapper(..) , isOutputObject , isSubscription @@ -42,16 +42,16 @@ type Arrow = (->) -declareTypeAlias :: Bool -> TypeAlias -> Type -declareTypeAlias isSub TypeAlias { aliasTyCon, aliasWrappers, aliasArgs } = - wrappedT aliasWrappers +declareTypeRef :: Bool -> TypeRef -> Type +declareTypeRef isSub TypeRef { typeConName, typeWrappers, typeArgs } = + wrappedT typeWrappers where wrappedT :: [TypeWrapper] -> Type wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs - wrappedT [] = decType aliasArgs + wrappedT [] = decType typeArgs ------------------------------------------------------ - typeName = ConT (mkName $ unpack aliasTyCon) + typeName = ConT (mkName $ unpack typeConName) -------------------------------------------- decType _ | isSub = AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName "m")) @@ -98,4 +98,4 @@ | isResolver = AppT monadVar result | otherwise = result ------------------------------------------------ - result = declareTypeAlias (maybe False isSubscription kindD) fieldType + result = declareTypeRef (maybe False isSubscription kindD) fieldType diff --git a/src/Data/Morpheus/Execution/Internal/Decode.hs b/src/Data/Morpheus/Execution/Internal/Decode.hs --- a/src/Data/Morpheus/Execution/Internal/Decode.hs +++ b/src/Data/Morpheus/Execution/Internal/Decode.hs @@ -13,7 +13,6 @@ ) where -import Data.Semigroup ( (<>) ) import Data.Text ( unpack ) import Language.Haskell.TH ( ExpQ , conE @@ -23,17 +22,20 @@ ) -- MORPHEUS -import Data.Morpheus.Error.Internal ( internalArgumentError - , internalTypeMismatch +import Data.Morpheus.Error.Internal ( + internalTypeMismatch ) import Data.Morpheus.Types.Internal.AST ( DataField(..) , Key , ConsD(..) - , Object - , Value(..)) + , ValidObject + , Value(..) + , ValidValue + , Message + ) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Validation, Failure(..) ) decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ @@ -52,32 +54,31 @@ [|fName|] where fName = unpack fieldName -withObject :: (Object -> Validation a) -> Value -> Validation a +withObject :: (ValidObject -> Validation a) -> ValidValue -> Validation a withObject f (Object object) = f object withObject _ isType = internalTypeMismatch "Object" isType -withMaybe :: Monad m => (Value -> m a) -> Value -> m (Maybe a) +withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a) withMaybe _ Null = pure Nothing withMaybe decode x = Just <$> decode x -withList :: (Value -> Validation a) -> Value -> Validation [a] +withList :: (ValidValue -> Validation a) -> ValidValue -> Validation [a] withList decode (List li) = mapM decode li withList _ isType = internalTypeMismatch "List" isType -withEnum :: (Key -> Validation a) -> Value -> Validation a +withEnum :: (Key -> Validation a) -> ValidValue -> Validation a withEnum decode (Enum value) = decode value withEnum _ isType = internalTypeMismatch "Enum" isType -withUnion :: (Key -> Object -> Object -> Validation a) -> Object -> Validation a -withUnion decoder unions = case lookup "tag" unions of +withUnion :: (Key -> ValidObject -> ValidObject -> Validation a) -> ValidObject -> Validation a +withUnion decoder unions = case lookup "__typename" unions of Just (Enum key) -> case lookup key unions of - Nothing -> internalArgumentError - ("type \"" <> key <> "\" was not provided on object") + Nothing -> withObject (decoder key unions) (Object []) Just value -> withObject (decoder key unions) value - Just _ -> internalArgumentError "tag must be Enum" - Nothing -> internalArgumentError "tag not found on Input Union" + Just _ -> failure ("__typename must be Enum" :: Message) + Nothing -> failure ("__typename not found on Input Union" :: Message) -decodeFieldWith :: (Value -> Validation a) -> Key -> Object -> Validation a +decodeFieldWith :: (ValidValue -> Validation a) -> Key -> ValidObject -> Validation a decodeFieldWith decoder name object = case lookup name object of - Nothing -> internalArgumentError ("Missing Field: \"" <> name <> "\"") + Nothing -> decoder Null Just value -> decoder value diff --git a/src/Data/Morpheus/Execution/Server/Decode.hs b/src/Data/Morpheus/Execution/Server/Decode.hs --- a/src/Data/Morpheus/Execution/Server/Decode.hs +++ b/src/Data/Morpheus/Execution/Server/Decode.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,57 +10,67 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} module Data.Morpheus.Execution.Server.Decode ( decodeArguments , Decode(..) - , DecodeObject(..) + , DecodeType(..) ) where import Data.Proxy ( Proxy(..) ) -import Data.Semigroup ( (<>) ) +import Data.Semigroup ( Semigroup(..) ) import Data.Text ( pack ) import GHC.Generics -- MORPHEUS -import Data.Morpheus.Error.Internal ( internalArgumentError - , internalTypeMismatch +import Data.Morpheus.Error.Internal ( internalTypeMismatch + , internalError ) import Data.Morpheus.Execution.Internal.Decode ( decodeFieldWith - , withEnum , withList , withMaybe , withObject , withUnion ) -import Data.Morpheus.Execution.Server.Generics.EnumRep - ( EnumRep(..) ) import Data.Morpheus.Kind ( ENUM , GQL_KIND - , INPUT_OBJECT - , INPUT_UNION , SCALAR + , OUTPUT + , INPUT ) import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) , toScalar ) import Data.Morpheus.Types.GQLType ( GQLType(KIND, __typeName) ) import Data.Morpheus.Types.Internal.AST - ( Key + ( Name , Argument(..) - , Arguments - , Object + , ValidArguments + , ValidArgument + , ValidObject , Value(..) + , ValidValue ) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Validation + , Failure(..) + ) +-- GENERIC +decodeArguments :: DecodeType a => ValidArguments -> Validation a +decodeArguments = decodeType . Object . map toObject + where + toObject :: (Name, ValidArgument) -> (Name, ValidValue) + toObject (x, Argument { argumentValue }) = (x, argumentValue) + + -- | Decode GraphQL query arguments and input values class Decode a where - decode :: Value -> Validation a + decode :: ValidValue -> Validation a instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where decode = decodeKind (Proxy @(KIND a)) @@ -72,7 +83,7 @@ -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: GQL_KIND) a where - decodeKind :: Proxy kind -> Value -> Validation a + decodeKind :: Proxy kind -> ValidValue -> Validation a -- SCALAR instance (GQLScalar a) => DecodeKind SCALAR a where @@ -81,74 +92,140 @@ Left errorMessage -> internalTypeMismatch errorMessage value -- ENUM -instance (Generic a, EnumRep (Rep a)) => DecodeKind ENUM a where - decodeKind _ = withEnum (fmap to . decodeEnum) +instance DecodeType a => DecodeKind ENUM a where + decodeKind _ = decodeType --- INPUT_OBJECT -instance DecodeObject a => DecodeKind INPUT_OBJECT a where - decodeKind _ = withObject decodeObject +-- TODO: remove +instance DecodeType a => DecodeKind OUTPUT a where + decodeKind _ = decodeType --- INPUT_UNION -instance (Generic a, GDecode (Rep a)) => DecodeKind INPUT_UNION a where - decodeKind _ = withObject (fmap to . decodeUnion) +-- INPUT_OBJECT and INPUT_UNION +instance DecodeType a => DecodeKind INPUT a where + decodeKind _ = decodeType --- GENERIC -decodeArguments :: DecodeObject p => Arguments -> Validation p -decodeArguments = decodeObject . fmap toObject - where toObject (x, y) = (x, argumentValue y) -class DecodeObject a where - decodeObject :: Object -> Validation a +class DecodeType a where + decodeType :: ValidValue -> Validation a -instance {-# OVERLAPPABLE #-} (Generic a, GDecode (Rep a)) => DecodeObject a where - decodeObject = fmap to . __decodeObject . Object +instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a))=> DecodeType a where + decodeType = fmap to . decodeRep . (, Cont D_CONS "") +-- data Inpuz = +-- InputHuman Human -- direct link: { __typename: Human, Human: {field: ""} } +-- | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} } +-- | IndexedType Int Text -- { __typename: InputRecord, _0:2 , _1:"" } +-- | Zeus -- { __typename: Zeus } +-- deriving (Generic, GQLType) + +decideUnion + :: ([Name], value -> Validation (f1 a)) + -> ([Name], value -> Validation (f2 a)) + -> Name + -> value + -> Validation ((:+:) f1 f2 a) +decideUnion (left, f1) (right, f2) name value + | name `elem` left + = L1 <$> f1 value + | name `elem` right + = R1 <$> f2 value + | otherwise + = failure $ "Constructor \"" <> name <> "\" could not find in Union" + +data Tag = D_CONS | D_UNION deriving (Eq ,Ord) + +data Cont = Cont { + contKind:: Tag, + typeName :: Name +} + +data Info = Info { + kind :: Tag, + tagName :: [Name] +} + +instance Semigroup Info where + Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2) + Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2) + Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2) + -- -- GENERICS -- -class GDecode f where - unionTags :: Proxy f -> [Key] - decodeUnion :: Object -> Validation (f a) - __decodeObject :: Value -> Validation (f a) +class DecodeRep f where + tags :: Proxy f -> Name -> Info + decodeRep :: (ValidValue,Cont) -> Validation (f a) -instance GDecode U1 where - unionTags _ = [] - __decodeObject _ = pure U1 - decodeUnion _ = pure U1 +instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where + tags _ = tags (Proxy @f) + decodeRep (x, y) = M1 <$> decodeRep + (x, y { typeName = pack $ datatypeName (undefined :: (M1 D d f a)) }) --- Recursive Decoding: (Selector (Rec1 )) -instance (Selector s, GQLType a, Decode a) => GDecode (M1 S s (K1 i a)) where - unionTags _ = [__typeName (Proxy @a)] - decodeUnion = fmap (M1 . K1) . decode . Object - __decodeObject = fmap (M1 . K1) . decodeRec +getEnumTag :: ValidObject -> Validation Name +getEnumTag [("enum", Enum value)] = pure value +getEnumTag _ = internalError "bad union enum object" + +instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where + tags _ = tags (Proxy @a) <> tags (Proxy @b) + decodeRep = __decode where - fieldName = pack $ selName (undefined :: M1 S s f a) - decodeRec = withObject (decodeFieldWith decode fieldName) -instance (Datatype c, GDecode f) => GDecode (M1 D c f) where - decodeUnion = fmap M1 . decodeUnion - unionTags _ = unionTags (Proxy @f) - __decodeObject = fmap M1 . __decodeObject + __decode (Object obj, cont) = withUnion handleUnion obj + where + handleUnion name unions object + | name == typeName cont <> "EnumObject" + = getEnumTag object >>= __decode . (, ctx) . Enum + | [name] == l1 + = L1 <$> decodeRep (Object object, ctx) + | [name] == r1 + = R1 <$> decodeRep (Object object, ctx) + | otherwise + = decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx) + l1 = tagName l1t + r1 = tagName r1t + l1t = tags (Proxy @a) (typeName cont) + r1t = tags (Proxy @b) (typeName cont) + ctx = cont { contKind = kind (l1t <> r1t) } + __decode (Enum name, cxt) = decideUnion + (tagName $ tags (Proxy @a) (typeName cxt), decodeRep) + (tagName $ tags (Proxy @b) (typeName cxt), decodeRep) + name + (Enum name, cxt) + __decode _ = internalError "lists and scalars are not allowed in Union" -instance (Constructor c, GDecode f) => GDecode (M1 C c f) where - decodeUnion = fmap M1 . decodeUnion - unionTags _ = unionTags (Proxy @f) - __decodeObject = fmap M1 . __decodeObject +instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where + decodeRep = fmap M1 . decodeFields + tags _ baseName = getTag (refType (Proxy @a)) + where + getTag (Just memberRef) + | isUnionRef memberRef = Info { kind = D_UNION, tagName = [memberRef] } + | otherwise = Info { kind = D_CONS, tagName = [consName] } + getTag Nothing = Info { kind = D_CONS, tagName = [consName] } + -------- + consName = pack $ conName unsafeType + ---------- + isUnionRef x = baseName <> x == consName + -------------------------- + unsafeType :: (M1 C c U1 x) + unsafeType = undefined -instance (GDecode f, GDecode g) => GDecode (f :*: g) where - __decodeObject gql = (:*:) <$> __decodeObject gql <*> __decodeObject gql +class DecodeFields f where + refType :: Proxy f -> Maybe Name + decodeFields :: (ValidValue,Cont) -> Validation (f a) -instance (GDecode a, GDecode b) => GDecode (a :+: b) where - decodeUnion = withUnion handleUnion +instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where + refType _ = Nothing + decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql + +instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where + refType _ = Just $ __typeName (Proxy @a) + decodeFields (value, Cont { contKind }) + | contKind == D_UNION = M1 . K1 <$> decode value + | otherwise = __decode value where - handleUnion name unions object - | [name] == l1Tags = L1 <$> decodeUnion object - | [name] == r1Tags = R1 <$> decodeUnion object - | name `elem` l1Tags = L1 <$> decodeUnion unions - | name `elem` r1Tags = R1 <$> decodeUnion unions - | otherwise = internalArgumentError - ("type \"" <> name <> "\" could not find in union") - where - l1Tags = unionTags $ Proxy @a - r1Tags = unionTags $ Proxy @b - unionTags _ = unionTags (Proxy @a) ++ unionTags (Proxy @b) + __decode = fmap (M1 . K1) . decodeRec + fieldName = pack $ selName (undefined :: M1 S s f a) + decodeRec = withObject (decodeFieldWith decode fieldName) + +instance DecodeFields U1 where + refType _ = Nothing + decodeFields _ = pure U1 diff --git a/src/Data/Morpheus/Execution/Server/Encode.hs b/src/Data/Morpheus/Execution/Server/Encode.hs --- a/src/Data/Morpheus/Execution/Server/Encode.hs +++ b/src/Data/Morpheus/Execution/Server/Encode.hs @@ -13,12 +13,11 @@ module Data.Morpheus.Execution.Server.Encode ( EncodeCon - , GResolver(..) , Encode(..) , encodeQuery , encodeSubscription , encodeMutation - , ObjectResolvers(..) + , ExploreResolvers(..) ) where @@ -35,45 +34,41 @@ import GHC.Generics -- MORPHEUS -import Data.Morpheus.Error.Internal ( internalUnknownTypeMessage ) +import Data.Morpheus.Error.Internal ( internalResolvingError ) import Data.Morpheus.Execution.Server.Decode - ( DecodeObject + ( DecodeType , decodeArguments ) import Data.Morpheus.Execution.Server.Generics.EnumRep ( EnumRep(..) ) import Data.Morpheus.Kind ( ENUM , GQL_KIND - , OBJECT , ResContext(..) , SCALAR - , UNION + , OUTPUT , VContext(..) ) -import Data.Morpheus.Types.Types ( MapKind +import Data.Morpheus.Types.Types ( MapKind , Pair(..) , mapKindFromList ) import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) ) -import Data.Morpheus.Types.GQLType ( GQLType - ( CUSTOM - , KIND - , __typeName - ) - ) +import Data.Morpheus.Types.GQLType ( GQLType(..) ) import Data.Morpheus.Types.Internal.AST - ( Operation(..) + ( Name + , Operation(..) , ValidOperation - , Key, - MUTATION + , Key + , MUTATION , OperationType , QUERY , SUBSCRIPTION , Selection(..) - , SelectionRec(..) + , SelectionContent(..) , ValidSelection , GQLValue(..) - , Value(..) + , ValidValue + , ValidSelectionSet ) import Data.Morpheus.Types.Internal.Resolving ( MapStrategy(..) @@ -82,14 +77,18 @@ , resolving , toResolver , ResolvingStrategy(..) - , resolveObject , withObject , Validation , failure + , DataResolver(..) + , resolveObject + , resolve__typename + , resolveEnum + , FieldRes ) class Encode resolver o e (m :: * -> *) where - encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m Value + encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftEither o ResolvingStrategy) => Encode a o e m where encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a) @@ -116,16 +115,19 @@ encode list query = gqlList <$> traverse (`encode` query) list -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY -instance (DecodeObject a, Monad m,LiftEither fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where +instance (DecodeType a,Generic a, Monad m,LiftEither fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where encode resolver selection@(_, Selection { selectionArguments }) = mapStrategy $ resolving encode (toResolver args resolver) selection where args :: Validation a args = decodeArguments selectionArguments + + + -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where - encodeKind :: LiftEither o ResolvingStrategy => VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m Value + encodeKind :: LiftEither o ResolvingStrategy => VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue -- SCALAR instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where @@ -135,87 +137,83 @@ instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o e m where encodeKind = pure . pure . gqlString . encodeRep . from . unVContext --- OBJECT -instance (Monad m, EncodeCon o e m a, Monad m, GResolver OBJECT (Rep a) o e m) => EncodeKind OBJECT a o e m where - encodeKind (VContext value) = withObject encodeK +instance (Monad m,Generic a, GQLType a,ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where + encodeKind (VContext value) (key, sel@Selection { selectionContent }) = + encodeNode (exploreResolvers (Proxy @(CUSTOM a)) value) selectionContent where - encodeK selection = resolveObject - selection - (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value) - __typenameResolver = - ("__typename", const $ pure $ gqlString $ __typeName (Proxy @a)) + encodeNode (ObjectRes fields) _ = withObject encodeObject (key, sel) + where + encodeObject selection = + resolveObject selection + $ ObjectRes + $ resolve__typename (__typeName (Proxy @a)) + : fields + encodeNode (EnumRes enum) _ = + resolveEnum (__typeName (Proxy @a)) enum selectionContent + -- Type References -------------------------------------------------------------- + encodeNode (UnionRef (fieldTypeName, fieldResolver)) (UnionSelection selections) + = fieldResolver + (key, sel { selectionContent = SelectionSet currentSelection }) + where currentSelection = pickSelection fieldTypeName selections + -- RECORDS ---------------------------------------------------------------------------- + encodeNode (UnionRes (name, fields)) (UnionSelection selections) = + resolveObject selection resolvers + where + selection = pickSelection name selections + resolvers = ObjectRes (resolve__typename name : fields) + encodeNode _ _ = failure $ internalResolvingError + "union Resolver should only recieve UnionSelection" --- exploreKindChannels --- UNION -instance (Monad m, GQL_RES a, GResolver UNION (Rep a) o e m) => EncodeKind UNION a o e m where - encodeKind (VContext value) (key, sel@Selection { selectionRec = UnionSelection selections }) - = resolver (key, sel { selectionRec = SelectionSet lookupSelection }) + +convertNode + :: (Monad m, LiftEither o ResolvingStrategy) + => ResNode o e m + -> DataResolver o e m +convertNode ResNode { resKind = REP_OBJECT, resFields } = + ObjectRes $ map toFieldRes resFields +convertNode ResNode { resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord } + = encodeUnion resFields + where + -- ENUM + encodeUnion [] = EnumRes resTypeName + -- Type References -------------------------------------------------------------- + encodeUnion [FieldNode { fieldTypeName, fieldResolver, isFieldObject }] + | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName + = UnionRef (fieldTypeName, fieldResolver) + -- RECORDS ---------------------------------------------------------------------------- + encodeUnion fields = UnionRes + (resTypeName, resolve__typename resTypeName : map toFieldRes resolvers) where - lookupSelection = fromMaybe [] $ lookup typeName selections - (typeName, resolver) = unionResolver value - encodeKind _ _ = failure $ internalUnknownTypeMessage - "union Resolver only should recieve UnionSelection" + resolvers | isResRecord = fields + | otherwise = setFieldNames fields -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a) type EncodeOperator o e m a - = a -> ValidOperation -> ResolvingStrategy o e m Value + = a -> ValidOperation -> ResolvingStrategy o e m ValidValue -type EncodeCon o e m a = (GQL_RES a, ObjectResolvers (CUSTOM a) a o e m) +type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) -type FieldRes o e m - = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value) -type family GRes (kind :: GQL_KIND) value :: * +objectResolvers + :: forall custom a o e m + . ExploreResolvers custom a o e m + => Proxy custom + -> a + -> DataResolver o e m +objectResolvers isCustom value = case exploreResolvers isCustom value of + ObjectRes resFields -> ObjectRes resFields + _ -> InvalidRes "resolver must be an object" -type instance GRes OBJECT v = [(Key, (Key, ValidSelection) -> v)] -type instance GRes UNION v = (Key, (Key, ValidSelection) -> v) - --- GENERICS ------------------------------------------------ -class ObjectResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where - objectResolvers :: Proxy custom -> a -> [(Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)] - -instance (Generic a, GResolver OBJECT (Rep a) o e m ) => ObjectResolvers 'False a o e m where - objectResolvers _ = - getResolvers (ResContext :: ResContext OBJECT o e m value) . from - -unionResolver - :: (Generic a, GResolver UNION (Rep a) o e m) - => a - -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value) -unionResolver = - getResolvers (ResContext :: ResContext UNION o e m value) . from - --- | Derives resolvers for OBJECT and UNION -class GResolver (kind :: GQL_KIND) f o e (m :: * -> *) where - getResolvers :: ResContext kind o e m value -> f a -> GRes kind (ResolvingStrategy o e m Value) - -instance GResolver kind f o e m => GResolver kind (M1 D c f) o e m where - getResolvers context (M1 src) = getResolvers context src - -instance GResolver kind f o e m => GResolver kind (M1 C c f) o e m where - getResolvers context (M1 src) = getResolvers context src - --- OBJECT -instance GResolver OBJECT U1 o e m where - getResolvers _ _ = [] - -instance (Selector s, GQLType a, Encode a o e m) => GResolver OBJECT (M1 S s (K1 s2 a)) o e m where - getResolvers _ m@(M1 (K1 src)) = [(pack (selName m), encode src)] - -instance (GResolver OBJECT f o e m, GResolver OBJECT g o e m) => GResolver OBJECT (f :*: g) o e m where - getResolvers context (a :*: b) = - getResolvers context a ++ getResolvers context b - --- UNION -instance (Selector s, GQLType a, Encode a o e m ) => GResolver UNION (M1 S s (K1 s2 a)) o e m where - getResolvers _ (M1 (K1 src)) = (__typeName (Proxy @a), encode src) +class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where + exploreResolvers :: Proxy custom -> a -> DataResolver o e m -instance (GResolver UNION a o e m, GResolver UNION b o e m) => GResolver UNION (a :+: b) o e m where - getResolvers context (L1 x) = getResolvers context x - getResolvers context (R1 x) = getResolvers context x +instance (Generic a,Monad m,LiftEither o ResolvingStrategy,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where + exploreResolvers _ value = convertNode + $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value) ----- HELPERS ---------------------------- encodeQuery @@ -227,29 +225,107 @@ => schema (Resolver QUERY event m) -> EncodeOperator QUERY event m query encodeQuery schema = encodeOperationWith - (objectResolvers (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m)))) - schema + (Just $ objectResolvers + (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m)))) + schema ) encodeMutation :: forall event m mut . (Monad m, EncodeCon MUTATION event m mut) => EncodeOperator MUTATION event m mut -encodeMutation = encodeOperationWith [] +encodeMutation = encodeOperationWith Nothing encodeSubscription :: forall m event mut . (Monad m, EncodeCon SUBSCRIPTION event m mut) => EncodeOperator SUBSCRIPTION event m mut -encodeSubscription = encodeOperationWith [] +encodeSubscription = encodeOperationWith Nothing encodeOperationWith :: forall o e m a . (Monad m, EncodeCon o e m a, LiftEither o ResolvingStrategy) - => [FieldRes o e m] + => Maybe (DataResolver o e m) -> EncodeOperator o e m a encodeOperationWith externalRes rootResolver Operation { operationSelection } = - resolveObject operationSelection resolvers + resolveObject operationSelection (rootDataRes <> extDataRes) where - resolvers = - externalRes <> objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver + rootDataRes = objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver + extDataRes = fromMaybe (ObjectRes []) externalRes + +toFieldRes :: FieldNode o e m -> FieldRes o e m +toFieldRes FieldNode { fieldSelName, fieldResolver } = + (fieldSelName, fieldResolver) + + +-- NEW AUTOMATIC DERIVATION SYSTEM + +pickSelection :: Name -> [(Name, ValidSelectionSet)] -> ValidSelectionSet +pickSelection name = fromMaybe [] . lookup name + +data REP_KIND = REP_UNION | REP_OBJECT + +data ResNode o e m = ResNode { + resDatatypeName :: Name, + resTypeName :: Name, + resKind :: REP_KIND, + resFields :: [FieldNode o e m], + isResRecord :: Bool + } + +data FieldNode o e m = FieldNode { + fieldTypeName :: Name, + fieldSelName :: Name, + fieldResolver :: (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue, + isFieldObject :: Bool + } + +-- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text } +setFieldNames :: [FieldNode o e m] -> [FieldNode o e m] +setFieldNames = zipWith setFieldName ([0 ..] :: [Int]) + where setFieldName i field = field { fieldSelName = "_" <> pack (show i) } + +class TypeRep f o e (m :: * -> *) where + typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m + +instance (Datatype d,TypeRep f o e m) => TypeRep (M1 D d f) o e m where + typeResolvers context (M1 src) = (typeResolvers context src) + { resDatatypeName = pack $ datatypeName (undefined :: M1 D d f a) + } + + + --- UNION OR OBJECT +instance (TypeRep a o e m,TypeRep b o e m) => TypeRep (a :+: b) o e m where + typeResolvers context (L1 x) = + (typeResolvers context x) { resKind = REP_UNION } + typeResolvers context (R1 x) = + (typeResolvers context x) { resKind = REP_UNION } + +instance (FieldRep f o e m,Constructor c) => TypeRep (M1 C c f) o e m where + typeResolvers context (M1 src) = ResNode { resDatatypeName = "" + , resTypeName = pack (conName proxy) + , resKind = REP_OBJECT + , resFields = fieldRep context src + , isResRecord = conIsRecord proxy + } + where proxy = undefined :: (M1 C c U1 x) + + --- FIELDS +class FieldRep f o e (m :: * -> *) where + fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m] + +instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where + fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b + +instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where + fieldRep _ m@(M1 (K1 src)) = + [ FieldNode { fieldSelName = pack (selName m) + , fieldTypeName = __typeName (Proxy @a) + , fieldResolver = encode src + , isFieldObject = isObjectKind (Proxy @a) + } + ] + +instance FieldRep U1 o e m where + fieldRep _ _ = [] + diff --git a/src/Data/Morpheus/Execution/Server/Interpreter.hs b/src/Data/Morpheus/Execution/Server/Interpreter.hs --- a/src/Data/Morpheus/Execution/Server/Interpreter.hs +++ b/src/Data/Morpheus/Execution/Server/Interpreter.hs @@ -24,6 +24,7 @@ import Data.Text.Lazy.Encoding ( decodeUtf8 , encodeUtf8 ) +import Control.Monad.IO.Class ( MonadIO() ) -- MORPHEUS import Data.Morpheus.Execution.Server.Resolve @@ -96,18 +97,18 @@ -} type WSPub m e a = GQLState m e -> a -> m a -instance Interpreter (WSPub IO e LB.ByteString) IO e where +instance MonadIO m => Interpreter (WSPub m e LB.ByteString) m e where interpreter root state = statefulResolver state (coreResolver root) -instance Interpreter (WSPub IO e LT.Text) IO e where +instance MonadIO m => Interpreter (WSPub m e LT.Text) m e where interpreter root state request = decodeUtf8 <$> interpreter root state (encodeUtf8 request) -instance Interpreter (WSPub IO e ByteString) IO e where +instance MonadIO m => Interpreter (WSPub m e ByteString) m e where interpreter root state request = LB.toStrict <$> interpreter root state (LB.fromStrict request) -instance Interpreter (WSPub IO e Text) IO e where +instance MonadIO m => Interpreter (WSPub m e Text) m e where interpreter root state request = LT.toStrict <$> interpreter root state (LT.fromStrict request) diff --git a/src/Data/Morpheus/Execution/Server/Introspect.hs b/src/Data/Morpheus/Execution/Server/Introspect.hs --- a/src/Data/Morpheus/Execution/Server/Introspect.hs +++ b/src/Data/Morpheus/Execution/Server/Introspect.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -17,10 +18,12 @@ module Data.Morpheus.Execution.Server.Introspect ( TypeUpdater , Introspect(..) - , ObjectFields(..) + , IntrospectRep(..) , IntroCon , updateLib , buildType + , objectFields + , TypeScope(..) ) where @@ -31,21 +34,22 @@ , pack ) import GHC.Generics +import Data.Semigroup ( (<>) ) +import Data.List ( partition ) -- MORPHEUS +import Data.Morpheus.Error.Utils ( globalErrorMessage ) import Data.Morpheus.Error.Schema ( nameCollisionError ) import Data.Morpheus.Execution.Server.Generics.EnumRep ( EnumRep(..) ) import Data.Morpheus.Kind ( Context(..) , ENUM , GQL_KIND - , INPUT_OBJECT - , INPUT_UNION - , OBJECT , SCALAR - , UNION + , OUTPUT + , INPUT ) -import Data.Morpheus.Types.Types ( MapKind +import Data.Morpheus.Types.Types ( MapKind , Pair ) import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) ) @@ -55,10 +59,11 @@ , resolveUpdates ) import Data.Morpheus.Types.Internal.AST - ( DataArguments + ( Name + , DataArguments , Meta(..) , DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , Key , createAlias @@ -68,13 +73,21 @@ , toNullableField , createEnumValue , TypeUpdater + , DataFingerprint(..) + , DataUnion + , DataObject + , TypeRef(..) ) -type IntroCon a = (GQLType a, ObjectFields (CUSTOM a) a) +type IntroCon a = (GQLType a, IntrospectRep (CUSTOM a) a) + -- | Generates internal GraphQL Schema for query validation and introspection rendering class Introspect a where + isObject :: proxy a -> Bool + default isObject :: GQLType a => proxy a -> Bool + isObject _ = isObjectKind (Proxy @a) field :: proxy a -> Text -> DataField introspect :: proxy a -> TypeUpdater ----------------------------------------------- @@ -87,39 +100,50 @@ -- Maybe instance Introspect a => Introspect (Maybe a) where + isObject _ = False field _ = toNullableField . field (Proxy @a) introspect _ = introspect (Proxy @a) -- List instance Introspect a => Introspect [a] where + isObject _ = False field _ = toListField . field (Proxy @a) introspect _ = introspect (Proxy @a) -- Tuple instance Introspect (Pair k v) => Introspect (k, v) where + isObject _ = True field _ = field (Proxy @(Pair k v)) introspect _ = introspect (Proxy @(Pair k v)) -- Set instance Introspect [a] => Introspect (Set a) where + isObject _ = False field _ = field (Proxy @[a]) introspect _ = introspect (Proxy @[a]) -- Map instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where + isObject _ = True field _ = field (Proxy @(MapKind k v Maybe)) introspect _ = introspect (Proxy @(MapKind k v Maybe)) -- Resolver : a -> Resolver b -instance (ObjectFields 'False a, Introspect b) => Introspect (a -> m b) where - field _ name = (field (Proxy @b) name) - { fieldArgs = fst $ objectFields (Proxy :: Proxy 'False) (Proxy @a) - } +instance (GQLType b, IntrospectRep 'False a, Introspect b) => Introspect (a -> m b) where + isObject _ = False + field _ name = fieldObj { fieldArgs } + where + fieldObj = field (Proxy @b) name + fieldArgs = fst $ objectFields + (Proxy :: Proxy 'False) + (__typeName (Proxy @b), OutputType, Proxy @a) introspect _ typeLib = resolveUpdates typeLib - (introspect (Proxy @b) : argTypes) + (introspect (Proxy @b) : inputs) where - argTypes :: [TypeUpdater] - argTypes = snd $ objectFields (Proxy :: Proxy 'False) (Proxy @a) + name = "Arguments for " <> __typeName (Proxy @b) + inputs :: [TypeUpdater] + inputs = + snd $ objectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a) -- | Introspect With specific Kind: 'kind': object, scalar, enum ... class IntrospectKind (kind :: GQL_KIND) a where @@ -128,102 +152,66 @@ -- SCALAR instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where introspectKind _ = updateLib scalarType [] (Proxy @a) - where scalarType = DataScalar . buildType (scalarValidator (Proxy @a)) + where scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a) -- ENUM instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where introspectKind _ = updateLib enumType [] (Proxy @a) where enumType = - DataEnum . buildType (map createEnumValue $ enumTags (Proxy @(Rep a))) - --- INPUT_OBJECT -instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind INPUT_OBJECT a where - introspectKind _ = updateLib (DataInputObject . buildType fields) - types - (Proxy @a) - where (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a) - --- OBJECTS -instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind OBJECT a where - introspectKind _ = updateLib (DataObject . buildType (__typename : fields)) - types - (Proxy @a) - where - __typename = - ( "__typename" - , DataField { fieldName = "__typename" - , fieldArgs = [] - , fieldArgsType = Nothing - , fieldType = createAlias "String" - , fieldMeta = Nothing - } - ) - (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a) + buildType $ DataEnum $ map createEnumValue $ enumTags (Proxy @(Rep a)) --- UNION -instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind UNION a where - introspectKind _ = updateLib (DataUnion . buildType memberTypes) - stack - (Proxy @a) - where - (memberTypes, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a)) +instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind INPUT a where + introspectKind _ = derivingData (Proxy @a) InputType --- INPUT_UNION -instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind INPUT_UNION a where - introspectKind _ = updateLib (DataInputUnion . buildType memberTypes) - stack - (Proxy @a) - where - (memberTypes, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a)) +instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind OUTPUT a where + introspectKind _ = derivingData (Proxy @a) OutputType --- Types +derivingData + :: forall a + . (GQLType a, IntrospectRep (CUSTOM a) a) + => Proxy a + -> TypeScope + -> TypeUpdater +derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a) + where + (datatypeContent, updates) = introspectRep + (Proxy @(CUSTOM a)) + (Proxy @a, scope, baseName, baseFingerprint) + baseName = __typeName (Proxy @a) + baseFingerprint = __typeFingerprint (Proxy @a) type GQL_TYPE a = (Generic a, GQLType a) --- Object Fields -class ObjectFields (custom :: Bool) a where - objectFields :: proxy1 custom -> proxy2 a -> ([(Text, DataField)], [TypeUpdater]) -instance GQLRep OBJECT (Rep a) => ObjectFields 'False a where - objectFields _ _ = unzip $ gqlRep (Context :: Context OBJECT (Rep a)) - -type family GQLRepResult (a :: GQL_KIND) :: * - -type instance GQLRepResult OBJECT = (Text, DataField) - -type instance GQLRepResult UNION = Key - --- GENERIC UNION -class GQLRep (kind :: GQL_KIND) f where - gqlRep :: Context kind f -> [(GQLRepResult kind, TypeUpdater)] - -instance GQLRep kind f => GQLRep kind (M1 D d f) where - gqlRep _ = gqlRep (Context :: Context kind f) - -instance GQLRep kind f => GQLRep kind (M1 C c f) where - gqlRep _ = gqlRep (Context :: Context kind f) - --- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION' -instance (GQLRep UNION a, GQLRep UNION b) => GQLRep UNION (a :+: b) where - gqlRep _ = - gqlRep (Context :: Context UNION a) ++ gqlRep (Context :: Context UNION b) - -instance (GQL_TYPE a, Introspect a) => GQLRep UNION (M1 S s (Rec0 a)) where - gqlRep _ = [(__typeName (Proxy @a), introspect (Proxy @a))] - --- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT' -instance (GQLRep OBJECT a, GQLRep OBJECT b) => GQLRep OBJECT (a :*: b) where - gqlRep _ = - gqlRep (Context :: Context OBJECT a) ++ gqlRep (Context :: Context OBJECT b) - -instance (Selector s, Introspect a) => GQLRep OBJECT (M1 S s (Rec0 a)) where - gqlRep _ = [((name, field (Proxy @a) name), introspect (Proxy @a))] - where name = pack $ selName (undefined :: M1 S s (Rec0 ()) ()) +objectFields + :: IntrospectRep custom a + => proxy1 (custom :: Bool) + -> (Name, TypeScope, proxy2 a) + -> ([(Name, DataField)], [TypeUpdater]) +objectFields p1 (name, scope, proxy) = withObject + (introspectRep p1 (proxy, scope, "", DataFingerprint "" [])) + where + withObject (DataObject x, ts) = (x, ts) + withObject (DataInputObject x, ts) = (x, ts) + withObject _ = + ( [] + , [ const + $ failure + $ globalErrorMessage + $ "invalid schema: " + <> name + <> " should have only one nonempty constructor" + ] + ) -instance GQLRep OBJECT U1 where - gqlRep _ = [] +-- Object Fields +class IntrospectRep (custom :: Bool) a where + introspectRep :: proxy1 custom -> ( proxy2 a,TypeScope,Name,DataFingerprint) -> (DataTypeContent, [TypeUpdater]) +instance (TypeRep (Rep a) , Generic a) => IntrospectRep 'False a where + introspectRep _ (_, scope, name, fing) = + derivingDataContent (Proxy @a) (name, fing) scope buildField :: GQLType a => Proxy a -> DataArguments -> Text -> DataField buildField proxy fieldArgs fieldName = DataField @@ -234,14 +222,14 @@ , fieldMeta = Nothing } -buildType :: GQLType a => t -> Proxy a -> DataTyCon t -buildType typeData proxy = DataTyCon +buildType :: GQLType a => DataTypeContent -> Proxy a -> DataType +buildType typeContent proxy = DataType { typeName = __typeName proxy , typeFingerprint = __typeFingerprint proxy , typeMeta = Just Meta { metaDescription = description proxy , metaDirectives = [] } - , typeData + , typeContent } updateLib @@ -258,3 +246,258 @@ Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib' -- throw error if 2 different types has same name Just _ -> failure $ nameCollisionError (__typeName proxy) + + +-- NEW AUTOMATIC DERIVATION SYSTEM + +data ConsRep = ConsRep { + consName :: Key, + consIsRecord :: Bool, + consFields :: [FieldRep] +} + +data FieldRep = FieldRep { + fieldTypeName :: Name, + fieldData :: (Name, DataField), + fieldTypeUpdater :: TypeUpdater, + fieldIsObject :: Bool +} + +data ResRep = ResRep { + enumCons :: [Name], + unionRef :: [Name], + unionRecordRep :: [ConsRep] +} + +isEmpty :: ConsRep -> Bool +isEmpty ConsRep { consFields = [] } = True +isEmpty _ = False + +isUnionRecord :: ConsRep -> Bool +isUnionRecord ConsRep { consIsRecord } = consIsRecord + +isUnionRef :: Name -> ConsRep -> Bool +isUnionRef baseName ConsRep { consName, consFields = [FieldRep { fieldIsObject = True, fieldTypeName }] } + = consName == baseName <> fieldTypeName +isUnionRef _ _ = False + +setFieldNames :: ConsRep -> ConsRep +setFieldNames cons@ConsRep { consFields } = cons + { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields + } + where + setFieldName i fieldR@FieldRep { fieldData = (_, fieldD) } = fieldR + { fieldData = (fieldName, fieldD { fieldName }) + } + where fieldName = "_" <> pack (show i) + +analyseRep :: Name -> [ConsRep] -> ResRep +analyseRep baseName cons = ResRep + { enumCons = map consName enumRep + , unionRef = map fieldTypeName $ concatMap consFields unionRefRep + , unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep + } + where + (enumRep , left1 ) = partition isEmpty cons + (unionRefRep , left2 ) = partition (isUnionRef baseName) left1 + (unionRecordRep, anyonimousUnionRep) = partition isUnionRecord left2 + +derivingDataContent + :: forall a + . (Generic a, TypeRep (Rep a)) + => Proxy a + -> (Name, DataFingerprint) + -> TypeScope + -> (DataTypeContent, [TypeUpdater]) +derivingDataContent _ (baseName, baseFingerprint) scope = + builder $ typeRep $ Proxy @(Rep a) + where + builder [ConsRep { consFields }] = buildObject scope consFields + builder cons = genericUnion scope cons + where + genericUnion InputType = buildInputUnion (baseName, baseFingerprint) + genericUnion OutputType = + buildUnionType (baseName, baseFingerprint) DataUnion DataObject + + +buildInputUnion + :: (Name, DataFingerprint) -> [ConsRep] -> (DataTypeContent, [TypeUpdater]) +buildInputUnion (baseName, baseFingerprint) cons = datatype + (analyseRep baseName cons) + where + datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } = + (DataEnum (map createEnumValue enumCons), types) + datatype ResRep { unionRef, unionRecordRep, enumCons } = + (DataInputUnion typeMembers, types <> unionTypes) + where + typeMembers = + map (, True) (unionRef <> unionMembers) <> map (, False) enumCons + (unionMembers, unionTypes) = + buildUnions DataInputObject baseFingerprint unionRecordRep + types = map fieldTypeUpdater $ concatMap consFields cons + +buildUnionType + :: (Name, DataFingerprint) + -> (DataUnion -> DataTypeContent) + -> (DataObject -> DataTypeContent) + -> [ConsRep] + -> (DataTypeContent, [TypeUpdater]) +buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype + (analyseRep baseName cons) + where + datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } = + (DataEnum (map createEnumValue enumCons), types) + datatype ResRep { unionRef, unionRecordRep, enumCons } = + (wrapUnion typeMembers, types <> enumTypes <> unionTypes) + where + typeMembers = unionRef <> enumMembers <> unionMembers + (enumMembers, enumTypes) = + buildUnionEnum wrapObject baseName baseFingerprint enumCons + (unionMembers, unionTypes) = + buildUnions wrapObject baseFingerprint unionRecordRep + types = map fieldTypeUpdater $ concatMap consFields cons + + +buildObject :: TypeScope -> [FieldRep] -> (DataTypeContent, [TypeUpdater]) +buildObject isOutput consFields = (wrap fields, types) + where + (fields, types) = buildDataObject consFields + wrap | isOutput == OutputType = DataObject + | otherwise = DataInputObject + +buildDataObject :: [FieldRep] -> (DataObject, [TypeUpdater]) +buildDataObject consFields = (fields, types) + where + fields = map fieldData consFields + types = map fieldTypeUpdater consFields + +buildUnions + :: (DataObject -> DataTypeContent) + -> DataFingerprint + -> [ConsRep] + -> ([Name], [TypeUpdater]) +buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons) + where + buildURecType consRep = pure . defineType + (consName consRep, buildUnionRecord wrapObject baseFingerprint consRep) + members = map consName cons + +buildUnionRecord + :: (DataObject -> DataTypeContent) -> DataFingerprint -> ConsRep -> DataType +buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } = + DataType { typeName = consName + , typeFingerprint + , typeMeta = Nothing + , typeContent = wrapObject $ genFields consFields + } + + where + genFields [FieldRep { fieldData = ("", fData) }] = + [("value", fData { fieldName = "value" })] + genFields fields = map uRecField fields + uRecField FieldRep { fieldData = (fName, fData) } = (fName, fData) + + +buildUnionEnum + :: (DataObject -> DataTypeContent) + -> Name + -> DataFingerprint + -> [Name] + -> ([Name], [TypeUpdater]) +buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates) + where + members | null enums = [] + | otherwise = [enumTypeWrapperName] + enumTypeName = baseName <> "Enum" + enumTypeWrapperName = enumTypeName <> "Object" + ------------------------- + updates :: [TypeUpdater] + updates + | null enums + = [] + | otherwise + = [ buildEnumObject wrapObject + enumTypeWrapperName + baseFingerprint + enumTypeName + , buildEnum enumTypeName baseFingerprint enums + ] + +buildEnum :: Name -> DataFingerprint -> [Name] -> TypeUpdater +buildEnum typeName typeFingerprint tags = pure . defineType + ( typeName + , DataType { typeName + , typeFingerprint + , typeMeta = Nothing + , typeContent = DataEnum $ map createEnumValue tags + } + ) + +buildEnumObject + :: (DataObject -> DataTypeContent) + -> Name + -> DataFingerprint + -> Name + -> TypeUpdater +buildEnumObject wrapObject typeName typeFingerprint enumTypeName = + pure . defineType + ( typeName + , DataType + { typeName + , typeFingerprint + , typeMeta = Nothing + , typeContent = wrapObject + [ ( "enum" + , DataField { fieldName = "enum" + , fieldArgs = [] + , fieldArgsType = Nothing + , fieldType = createAlias enumTypeName + , fieldMeta = Nothing + } + ) + ] + } + ) + +data TypeScope = InputType | OutputType deriving (Show,Eq,Ord) + +-- GENERIC UNION +class TypeRep f where + typeRep :: Proxy f -> [ConsRep] + +instance TypeRep f => TypeRep (M1 D d f) where + typeRep _ = typeRep (Proxy @f) + +-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT' +instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where + typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b) + +instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where + typeRep _ = + [ ConsRep { consName = pack $ conName (undefined :: (M1 C c f a)) + , consFields = conRep (Proxy @f) + , consIsRecord = conIsRecord (undefined :: (M1 C c f a)) + } + ] + +class ConRep f where + conRep :: Proxy f -> [FieldRep] + +-- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION' +instance (ConRep a, ConRep b) => ConRep (a :*: b) where + conRep _ = conRep (Proxy @a) <> conRep (Proxy @b) + +instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where + conRep _ = + [ FieldRep { fieldTypeName = typeConName $ fieldType fieldData + , fieldData = (name, fieldData) + , fieldTypeUpdater = introspect (Proxy @a) + , fieldIsObject = isObject (Proxy @a) + } + ] + where + name = pack $ selName (undefined :: M1 S s (Rec0 ()) ()) + fieldData = field (Proxy @a) name + +instance ConRep U1 where + conRep _ = [] diff --git a/src/Data/Morpheus/Execution/Server/Resolve.hs b/src/Data/Morpheus/Execution/Server/Resolve.hs --- a/src/Data/Morpheus/Execution/Server/Resolve.hs +++ b/src/Data/Morpheus/Execution/Server/Resolve.hs @@ -39,7 +39,8 @@ ) import Data.Morpheus.Execution.Server.Introspect ( IntroCon - , ObjectFields(..) + , objectFields + , TypeScope(..) ) import Data.Morpheus.Execution.Subscription.ClientRegister ( GQLState @@ -57,14 +58,17 @@ ( Operation(..) , ValidOperation , DataFingerprint(..) - , DataTyCon(..) + , DataTypeContent(..) , DataTypeLib(..) + , DataType(..) , MUTATION , OperationType(..) , QUERY , SUBSCRIPTION , initTypeLib - , Value + , ValidValue + , Name + , DataField ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..) @@ -89,7 +93,7 @@ import Data.Morpheus.Validation.Query.Validation ( validateRequest ) import Data.Typeable ( Typeable ) - +import Control.Monad.IO.Class ( MonadIO() ) type EventCon event = (Eq (StreamChannel event), Typeable event, GQLChannel event) @@ -147,7 +151,7 @@ . (Monad m, RootResCon m event query mut sub) => GQLRootResolver m event query mut sub -> GQLRequest - -> ResponseStream event m Value + -> ResponseStream event m ValidValue coreResolver root@GQLRootResolver { queryResolver, mutationResolver, subscriptionResolver } request = validRequest >>= execOperator where @@ -169,11 +173,11 @@ toResponseRes (encodeSubscription subscriptionResolver operation) statefulResolver - :: EventCon event - => GQLState IO event - -> (GQLRequest -> ResponseStream event IO Value) + :: (EventCon event, MonadIO m) + => GQLState m event + -> (GQLRequest -> ResponseStream event m ValidValue) -> L.ByteString - -> IO L.ByteString + -> m L.ByteString statefulResolver state streamApi requestText = do res <- runResultT (decodeNoDup requestText >>= streamApi) mapM_ execute (unpackEvents res) @@ -182,7 +186,6 @@ execute (Publish updates) = publishUpdates state updates execute Subscribe{} = pure () - fullSchema :: forall proxy m event query mutation subscription . (IntrospectConstraint m event query mutation subscription) @@ -196,7 +199,7 @@ where (fields, types) = objectFields (Proxy @(CUSTOM (query (Resolver QUERY event m)))) - (Proxy @(query (Resolver QUERY event m))) + ("type for query", OutputType, Proxy @(query (Resolver QUERY event m))) ------------------------------ mutationSchema lib = resolveUpdates (lib { mutation = maybeOperator fields "Mutation" }) @@ -204,7 +207,10 @@ where (fields, types) = objectFields (Proxy @(CUSTOM (mutation (Resolver MUTATION event m)))) - (Proxy @(mutation (Resolver MUTATION event m))) + ( "type for mutation" + , OutputType + , Proxy @(mutation (Resolver MUTATION event m)) + ) ------------------------------ subscriptionSchema lib = resolveUpdates (lib { subscription = maybeOperator fields "Subscription" }) @@ -212,16 +218,20 @@ where (fields, types) = objectFields (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m)))) - (Proxy @(subscription (Resolver SUBSCRIPTION event m))) - -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a]) + ( "type for subscription" + , OutputType + , Proxy @(subscription (Resolver SUBSCRIPTION event m)) + ) + maybeOperator :: [(Name, DataField)] -> Name -> Maybe (Name, DataType) maybeOperator [] = const Nothing maybeOperator fields = Just . operatorType fields - -- operatorType :: [a] -> Text -> (Text, DataTyCon[a]) - operatorType typeData typeName = + ------------------------------------------------- + operatorType :: [(Name, DataField)] -> Name -> (Name, DataType) + operatorType fields typeName = ( typeName - , DataTyCon { typeData - , typeName - , typeFingerprint = SystemFingerprint typeName - , typeMeta = Nothing - } + , DataType { typeContent = DataObject fields + , typeName + , typeFingerprint = DataFingerprint typeName [] + , typeMeta = Nothing + } ) diff --git a/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs b/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs --- a/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs +++ b/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs @@ -13,6 +13,7 @@ ) where +import Control.Monad.IO.Class ( MonadIO(liftIO) ) import Control.Concurrent ( MVar , modifyMVar , modifyMVar_ @@ -50,7 +51,7 @@ initGQLState :: IO (GQLState m e) initGQLState = newMVar [] -connectClient :: Connection -> GQLState m e -> IO (GQLClient m e) +connectClient :: MonadIO m => Connection -> GQLState m e -> IO (GQLClient m e) connectClient clientConnection varState' = do client' <- newClient modifyMVar_ varState' (addClient client') @@ -70,11 +71,12 @@ removeClient = filter ((/= clientID client) . fst) updateClientByID - :: ClientID + :: MonadIO m => + ClientID -> (GQLClient m e -> GQLClient m e) -> MVar (ClientRegister m e) - -> IO () -updateClientByID id' updateFunc state = modifyMVar_ + -> m () +updateClientByID id' updateFunc state = liftIO $ modifyMVar_ state (return . map updateClient) where @@ -82,9 +84,9 @@ updateClient state' = state' publishUpdates - :: (Eq (StreamChannel e), GQLChannel e) => GQLState IO e -> e -> IO () + :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) => GQLState m e -> e -> m () publishUpdates state event = do - state' <- readMVar state + state' <- liftIO $ readMVar state traverse_ sendMessage state' where sendMessage (_, GQLClient { clientSessions = [] } ) = return () @@ -92,10 +94,10 @@ __send (filterByChannels clientSessions) where - __send ClientSession { sessionId, sessionSubscription = Event { content = subscriptionRes } } - = subscriptionRes event - >>= sendTextData clientConnection - . toApolloResponse sessionId + __send ClientSession { sessionId, sessionSubscription = Event { content = subscriptionRes } } = do + res <- subscriptionRes event + let apolloRes = toApolloResponse sessionId res + liftIO $ sendTextData clientConnection apolloRes --------------------------- filterByChannels = filter ( not @@ -105,7 +107,7 @@ . sessionSubscription ) -removeClientSubscription :: ClientID -> Text -> GQLState m e -> IO () +removeClientSubscription :: MonadIO m => ClientID -> Text -> GQLState m e -> m () removeClientSubscription id' sid' = updateClientByID id' stopSubscription where stopSubscription client' = client' @@ -113,7 +115,7 @@ } addClientSubscription - :: ClientID -> SubEvent m e -> Text -> GQLState m e -> IO () + :: MonadIO m => ClientID -> SubEvent m e -> Text -> GQLState m e -> m () addClientSubscription id' sessionSubscription sessionId = updateClientByID id' startSubscription diff --git a/src/Data/Morpheus/Kind.hs b/src/Data/Morpheus/Kind.hs --- a/src/Data/Morpheus/Kind.hs +++ b/src/Data/Morpheus/Kind.hs @@ -11,11 +11,12 @@ , WRAPPER , UNION , INPUT_OBJECT - , INPUT_UNION , GQL_KIND , Context(..) , VContext(..) , ResContext(..) + , OUTPUT + , INPUT ) where @@ -24,14 +25,11 @@ data GQL_KIND = SCALAR - | OBJECT | ENUM - | INPUT_OBJECT - | UNION - | INPUT_UNION + | INPUT + | OUTPUT | WRAPPER - data ResContext (kind :: GQL_KIND) (operation:: OperationType) event (m :: * -> * ) value = ResContext --type ObjectConstraint a = @@ -48,20 +46,26 @@ -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type type SCALAR = 'SCALAR --- | GraphQL Object -type OBJECT = 'OBJECT - -- | GraphQL Enum type ENUM = 'ENUM +-- | GraphQL Arrays , Resolvers and NonNull fields +type WRAPPER = 'WRAPPER + +-- | GraphQL Object and union +type OUTPUT = 'OUTPUT + +-- | GraphQL input Object and input union +type INPUT = 'INPUT + +{-# DEPRECATED INPUT_OBJECT "use more generalised kind: INPUT" #-} -- | GraphQL input Object -type INPUT_OBJECT = 'INPUT_OBJECT +type INPUT_OBJECT = 'INPUT +{-# DEPRECATED UNION "use: deriving(GQLType), INPORTANT: only types with will sustain their form, other union constructors will be wrapped inside an new object" #-} -- | GraphQL Union -type UNION = 'UNION - --- | extension for graphQL -type INPUT_UNION = 'INPUT_UNION +type UNION = 'OUTPUT --- | GraphQL Arrays , Resolvers and NonNull fields -type WRAPPER = 'WRAPPER +{-# DEPRECATED OBJECT "use: deriving(GQLType), will be automatically inferred" #-} +-- | GraphQL Object +type OBJECT = 'OUTPUT diff --git a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs --- a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs +++ b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs @@ -34,7 +34,7 @@ import Data.Morpheus.Types.Internal.AST ( DataField , DataFingerprint(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataValidator(..) , Key @@ -54,12 +54,11 @@ metaDirectives <- optionalDirectives pure ( typeName - , DataScalar DataTyCon - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = SystemFingerprint typeName - , typeData = DataValidator pure - } + , DataType { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataScalar $ DataValidator pure + } ) -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects @@ -79,18 +78,18 @@ -- objectTypeDefinition :: Maybe Text -> Parser (Text, RawDataType) objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do - name <- typDeclaration "type" - interfaces <- optionalImplementsInterfaces - metaDirectives <- optionalDirectives - fields <- fieldsDefinition + implementsName <- typDeclaration "type" + implementsInterfaces <- optionalImplementsInterfaces + metaDirectives <- optionalDirectives + fields <- fieldsDefinition -------------------------- pure - ( name - , Implements interfaces $ DataTyCon - { typeName = name - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = SystemFingerprint name - , typeData = fields + ( implementsName + , Implements + { implementsName + , implementsInterfaces + , implementsMeta = Just Meta { metaDescription, metaDirectives } + , implementsContent = fields } ) @@ -107,20 +106,17 @@ -- interfaceTypeDefinition :: Maybe Text -> Parser (Text, RawDataType) interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do - typeName <- typDeclaration "interface" + interfaceName <- typDeclaration "interface" metaDirectives <- optionalDirectives fields <- fieldsDefinition pure - ( typeName - , Interface DataTyCon - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = SystemFingerprint typeName - , typeData = fields - } + ( interfaceName + , Interface { interfaceName + , interfaceMeta = Just Meta { metaDescription, metaDirectives } + , interfaceContent = fields + } ) - -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions -- -- UnionTypeDefinition: @@ -137,12 +133,11 @@ memberTypes <- unionMemberTypes pure ( typeName - , DataUnion DataTyCon - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = SystemFingerprint typeName - , typeData = memberTypes - } + , DataType { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataUnion memberTypes + } ) where unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral @@ -164,12 +159,11 @@ enumValuesDefinitions <- setOf enumValueDefinition pure ( typeName - , DataEnum DataTyCon - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = SystemFingerprint typeName - , typeData = enumValuesDefinitions - } + , DataType { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataEnum enumValuesDefinitions + } ) @@ -189,12 +183,11 @@ fields <- inputFieldsDefinition pure ( typeName - , DataInputObject DataTyCon - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = SystemFingerprint typeName - , typeData = fields - } + , DataType { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataInputObject fields + } ) where inputFieldsDefinition :: Parser [(Key, DataField)] diff --git a/src/Data/Morpheus/Parsing/Internal/Pattern.hs b/src/Data/Morpheus/Parsing/Internal/Pattern.hs --- a/src/Data/Morpheus/Parsing/Internal/Pattern.hs +++ b/src/Data/Morpheus/Parsing/Internal/Pattern.hs @@ -39,7 +39,6 @@ , Meta(..) , DataEnumValue(..) , Name - , TypeAlias(..) ) @@ -68,21 +67,17 @@ metaDescription <- optDescription fieldName <- parseName litAssignment -- ':' - (aliasWrappers, aliasTyCon) <- parseType - _ <- parseDefaultValue - metaDirectives <- optionalDirectives + fieldType <- parseType + _ <- parseDefaultValue + metaDirectives <- optionalDirectives pure ( fieldName - , DataField - { fieldArgs = [] - , fieldArgsType = Nothing - , fieldName - , fieldType = TypeAlias { aliasTyCon - , aliasWrappers - , aliasArgs = Nothing - } - , fieldMeta = Just Meta { metaDescription, metaDirectives } - } + , DataField { fieldArgs = [] + , fieldArgsType = Nothing + , fieldName + , fieldType + , fieldMeta = Just Meta { metaDescription, metaDirectives } + } ) -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments @@ -113,20 +108,16 @@ fieldName <- parseName fieldArgs <- argumentsDefinition litAssignment -- ':' - (aliasWrappers, aliasTyCon) <- parseType - metaDirectives <- optionalDirectives + fieldType <- parseType + metaDirectives <- optionalDirectives pure ( fieldName - , DataField - { fieldName - , fieldArgs - , fieldArgsType = Nothing - , fieldType = TypeAlias { aliasTyCon - , aliasWrappers - , aliasArgs = Nothing - } - , fieldMeta = Just Meta { metaDescription, metaDirectives } - } + , DataField { fieldName + , fieldArgs + , fieldArgsType = Nothing + , fieldType + , fieldMeta = Just Meta { metaDescription, metaDirectives } + } ) -- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives diff --git a/src/Data/Morpheus/Parsing/Internal/Terms.hs b/src/Data/Morpheus/Parsing/Internal/Terms.hs --- a/src/Data/Morpheus/Parsing/Internal/Terms.hs +++ b/src/Data/Morpheus/Parsing/Internal/Terms.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -26,6 +27,7 @@ , keyword , operator , optDescription + , parseNegativeSign ) where @@ -69,15 +71,21 @@ , Key , Description , Name - , TypeWrapper(..) , toHSWrappers - , convertToHaskellName ) + , convertToHaskellName + , Ref(..) + , TypeRef(..) + ) -- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names -- -- Name :: /[_A-Za-z][_0-9A-Za-z]*/ -- + +parseNegativeSign :: Parser Bool +parseNegativeSign = (char '-' $> True <* spaceAndComments) <|> pure False + parseName :: Parser Name parseName = token @@ -121,12 +129,13 @@ -- -- Variable : $Name -- -variable :: Parser (Text, Position) +variable :: Parser Ref variable = label "variable" $ do - position' <- getLocation - _ <- char '$' - varName' <- token - return (varName', position') + refPosition <- getLocation + _ <- char '$' + refName <- token + spaceAndComments + pure $ Ref { refName, refPosition } spaceAndComments1 :: Parser () spaceAndComments1 = space1 *> spaceAndComments @@ -244,8 +253,11 @@ where alias = label "alias" $ token <* char ':' <* spaceAndComments -parseType :: Parser ([TypeWrapper], Key) +parseType :: Parser TypeRef parseType = do - (wrappers, fieldType) <- parseWrappedType - nonNull <- parseNonNull - pure (toHSWrappers $ nonNull ++ wrappers, fieldType) + (wrappers, typeConName) <- parseWrappedType + nonNull <- parseNonNull + pure TypeRef { typeConName + , typeArgs = Nothing + , typeWrappers = toHSWrappers $ nonNull ++ wrappers + } diff --git a/src/Data/Morpheus/Parsing/Internal/Value.hs b/src/Data/Morpheus/Parsing/Internal/Value.hs --- a/src/Data/Morpheus/Parsing/Internal/Value.hs +++ b/src/Data/Morpheus/Parsing/Internal/Value.hs @@ -5,6 +5,7 @@ ( parseValue , enumValue , parseDefaultValue + , parseRawValue ) where @@ -34,44 +35,38 @@ , setOf , spaceAndComments , token + , parseNegativeSign + , variable ) import Data.Morpheus.Types.Internal.AST ( ScalarValue(..) , Value(..) + , RawValue + , ValidValue , decodeScientific + , Name + , Value(..) + , ResolvedValue ) -parseDefaultValue :: Parser (Maybe Value) -parseDefaultValue = optional $ do - litEquals - parseValue - -parseValue :: Parser Value -parseValue = label "value" $ do - value <- - valueNull - <|> booleanValue - <|> valueNumber - <|> enumValue - <|> stringValue - <|> objectValue - <|> listValue - spaceAndComments - return value - -valueNull :: Parser Value +valueNull :: Parser (Value a) valueNull = string "null" $> Null -booleanValue :: Parser Value +booleanValue :: Parser (Value a) booleanValue = boolTrue <|> boolFalse where boolTrue = string "true" $> Scalar (Boolean True) boolFalse = string "false" $> Scalar (Boolean False) -valueNumber :: Parser Value -valueNumber = Scalar . decodeScientific <$> scientific +valueNumber :: Parser (Value a) +valueNumber = do + isNegative <- parseNegativeSign + Scalar . decodeScientific . signedNumber isNegative <$> scientific + where + signedNumber isNegative number | isNegative = -number + | otherwise = number -enumValue :: Parser Value +enumValue :: Parser (Value a) enumValue = do enum <- Enum <$> token spaceAndComments @@ -86,18 +81,47 @@ codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/'] escapeChar code replacement = char code >> return replacement -stringValue :: Parser Value +stringValue :: Parser (Value a) stringValue = label "stringValue" $ Scalar . String . pack <$> between (char '"') (char '"') (many escaped) -listValue :: Parser Value -listValue = label "listValue" $ List <$> between + +listValue :: Parser a -> Parser [a] +listValue parser = label "listValue" $ between (char '[' *> spaceAndComments) (char ']' *> spaceAndComments) - (parseValue `sepBy` (char ',' *> spaceAndComments)) + (parser `sepBy` (char ',' *> spaceAndComments)) -objectValue :: Parser Value -objectValue = label "objectValue" $ Object <$> setOf entry - where entry = parseAssignment token parseValue +objectValue :: Show a => Parser a -> Parser [(Name, a)] +objectValue parser = label "objectValue" $ setOf entry + where entry = parseAssignment token parser + +structValue :: Parser (Value a) -> Parser (Value a) +structValue parser = + label "Value" + $ ( parsePrimitives + <|> (Object <$> objectValue parser) + <|> (List <$> listValue parser) + ) + <* spaceAndComments + +parsePrimitives :: Parser (Value a) +parsePrimitives = + valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue + +parseDefaultValue :: Parser (Maybe ResolvedValue) +parseDefaultValue = optional $ do + litEquals + parseV + where + parseV :: Parser ResolvedValue + parseV = structValue parseV + + +parseValue :: Parser ValidValue +parseValue = structValue parseValue + +parseRawValue :: Parser RawValue +parseRawValue = (VariableValue <$> variable) <|> structValue parseRawValue diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs --- a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +++ b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs @@ -24,6 +24,7 @@ import Data.Morpheus.Types.Internal.AST ( DataField , DataType(..) + , DataTypeContent(..) , DataTypeLib , DataTypeWrapper(..) , Key @@ -70,11 +71,11 @@ parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields } = do fields <- traverse parse iFields - pure [(typeName, DataInputObject $ createType typeName fields)] + pure [(typeName, createType typeName $ DataInputObject fields)] parse Type { name = Just typeName, kind = OBJECT, fields = Just oFields } = do fields <- traverse parse oFields - pure [(typeName, DataObject $ createType typeName fields)] + pure [(typeName, createType typeName $ DataObject fields)] parse _ = pure [] instance ParseJSONSchema Field (Key,DataField) where diff --git a/src/Data/Morpheus/Parsing/Request/Arguments.hs b/src/Data/Morpheus/Parsing/Request/Arguments.hs --- a/src/Data/Morpheus/Parsing/Request/Arguments.hs +++ b/src/Data/Morpheus/Parsing/Request/Arguments.hs @@ -5,9 +5,7 @@ ) where -import Text.Megaparsec ( label - , (<|>) - ) +import Text.Megaparsec ( label) -- MORPHEUS import Data.Morpheus.Parsing.Internal.Internal @@ -18,18 +16,13 @@ ( parseAssignment , parseMaybeTuple , token - , variable ) import Data.Morpheus.Parsing.Internal.Value - ( enumValue - , parseValue - ) + ( parseRawValue ) import Data.Morpheus.Types.Internal.AST - ( ValueOrigin(..) - , Argument(..) - , RawArgument(..) + ( Argument(..) + , RawArgument , RawArguments - , Ref(..) ) @@ -42,19 +35,11 @@ -- Name : Value[Const] -- TODO: move variable to Value valueArgument :: Parser RawArgument -valueArgument = label "valueArgument" $ do +valueArgument = label "Argument" $ do argumentPosition <- getLocation - argumentValue <- parseValue <|> enumValue - pure $ RawArgument $ Argument { argumentValue - , argumentOrigin = INLINE - , argumentPosition - } - -variableArgument :: Parser RawArgument -variableArgument = label "variableArgument" $ do - (refName, refPosition) <- variable - pure $ VariableRef $ Ref { refName, refPosition } + argumentValue <- parseRawValue + pure $ Argument { argumentValue, argumentPosition } maybeArguments :: Parser RawArguments -maybeArguments = label "maybeArguments" $ parseMaybeTuple argument - where argument = parseAssignment token (valueArgument <|> variableArgument) +maybeArguments = + label "Arguments" $ parseMaybeTuple (parseAssignment token valueArgument) diff --git a/src/Data/Morpheus/Parsing/Request/Operation.hs b/src/Data/Morpheus/Parsing/Request/Operation.hs --- a/src/Data/Morpheus/Parsing/Request/Operation.hs +++ b/src/Data/Morpheus/Parsing/Request/Operation.hs @@ -36,12 +36,13 @@ import Data.Morpheus.Parsing.Request.Selection ( parseSelectionSet ) import Data.Morpheus.Types.Internal.AST - ( DefaultValue - , Operation(..) + ( Operation(..) , RawOperation , Variable(..) , OperationType(..) - , isNullable + , Ref(..) + , VariableContent(..) + , RAW ) @@ -50,19 +51,17 @@ -- VariableDefinition -- Variable : Type DefaultValue(opt) -- -variableDefinition :: Parser (Text, Variable DefaultValue) +variableDefinition :: Parser (Text, Variable RAW) variableDefinition = label "VariableDefinition" $ do - (name, variablePosition) <- variable + (Ref name variablePosition) <- variable operator ':' - (variableTypeWrappers, variableType) <- parseType - defaultValue <- parseDefaultValue + variableType <- parseType + defaultValue <- parseDefaultValue pure ( name , Variable { variableType - , isVariableRequired = not (isNullable variableTypeWrappers) - , variableTypeWrappers , variablePosition - , variableValue = defaultValue + , variableValue = DefaultValue defaultValue } ) @@ -78,14 +77,14 @@ operationPosition <- getLocation operationType <- parseOperationType operationName <- optional parseName - operationArgs <- parseMaybeTuple variableDefinition + operationArguments <- parseMaybeTuple variableDefinition -- TODO: handle directives _directives <- optionalDirectives operationSelection <- parseSelectionSet pure (Operation { operationName , operationType - , operationArgs + , operationArguments , operationSelection , operationPosition } @@ -107,7 +106,7 @@ pure (Operation { operationName = Nothing , operationType = Query - , operationArgs = [] + , operationArguments = [] , operationSelection , operationPosition } diff --git a/src/Data/Morpheus/Parsing/Request/Parser.hs b/src/Data/Morpheus/Parsing/Request/Parser.hs --- a/src/Data/Morpheus/Parsing/Request/Parser.hs +++ b/src/Data/Morpheus/Parsing/Request/Parser.hs @@ -35,9 +35,9 @@ , Failure(..) ) import Data.Morpheus.Types.Internal.AST - ( Value(..) - , replaceValue + ( replaceValue , GQLQuery(..) + , ResolvedValue ) import Data.Morpheus.Types.IO ( GQLRequest(..) ) @@ -57,7 +57,7 @@ Right root -> pure $ root { inputVariables = toVariableMap variables } Left parseError -> failure $ processErrorBundle parseError where - toVariableMap :: Maybe Aeson.Value -> [(Text, Value)] + toVariableMap :: Maybe Aeson.Value -> [(Text, ResolvedValue)] toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x) where toMorpheusValue (key, value) = (key, replaceValue value) toVariableMap _ = [] diff --git a/src/Data/Morpheus/Parsing/Request/Selection.hs b/src/Data/Morpheus/Parsing/Request/Selection.hs --- a/src/Data/Morpheus/Parsing/Request/Selection.hs +++ b/src/Data/Morpheus/Parsing/Request/Selection.hs @@ -34,11 +34,12 @@ ( maybeArguments ) import Data.Morpheus.Types.Internal.AST ( Selection(..) + , SelectionContent(..) + , Ref(..) , Fragment(..) , RawArguments - , RawSelection(..) + , RawSelection , RawSelectionSet - , Ref(..) ) @@ -80,23 +81,23 @@ where ---------------------------------------- buildField selectionAlias selectionArguments selectionPosition = pure - (RawSelectionField $ Selection { selectionAlias - , selectionArguments - , selectionRec = () - , selectionPosition - } + (Selection { selectionAlias + , selectionArguments + , selectionContent = SelectionField + , selectionPosition + } ) ----------------------------------------- selSet :: Maybe Text -> RawArguments -> Parser RawSelection selSet selectionAlias selectionArguments = label "body" $ do selectionPosition <- getLocation - selectionRec <- parseSelectionSet + selectionSet <- parseSelectionSet return - (RawSelectionSet $ Selection { selectionAlias - , selectionArguments - , selectionRec - , selectionPosition - } + (Selection { selectionAlias + , selectionArguments + , selectionContent = SelectionSet selectionSet + , selectionPosition + } ) diff --git a/src/Data/Morpheus/Rendering/RenderGQL.hs b/src/Data/Morpheus/Rendering/RenderGQL.hs --- a/src/Data/Morpheus/Rendering/RenderGQL.hs +++ b/src/Data/Morpheus/Rendering/RenderGQL.hs @@ -21,12 +21,12 @@ -- MORPHEUS import Data.Morpheus.Types.Internal.AST ( DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeLib , DataTypeWrapper(..) , Key - , TypeAlias(..) + , TypeRef(..) , TypeWrapper(..) , allDataTypes , createInputUnionFields @@ -34,7 +34,8 @@ , isDefaultTypeName , toGQLWrapper , DataEnumValue(..) - , convertToJSONName ) + , convertToJSONName + ) renderGraphQLDocument :: DataTypeLib -> ByteString @@ -53,42 +54,34 @@ showGQLWrapper (ListType:xs) = "[" <> showGQLWrapper xs <> "]" showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!" + instance RenderGQL Key where render = id -instance RenderGQL TypeAlias where - render TypeAlias { aliasTyCon, aliasWrappers } = - renderWrapped aliasTyCon aliasWrappers +instance RenderGQL TypeRef where + render TypeRef { typeConName, typeWrappers } = + renderWrapped typeConName typeWrappers instance RenderGQL DataType where - render (DataScalar x) = typeName x - render (DataEnum x) = typeName x - render (DataUnion x) = typeName x - render (DataInputObject x) = typeName x - render (DataInputUnion x) = typeName x - render (DataObject x) = typeName x + render = typeName instance RenderGQL DataEnumValue where render DataEnumValue { enumName } = enumName instance RenderGQL (Key, DataType) where - render (name, DataScalar{}) = "scalar " <> name - render (name, DataEnum DataTyCon { typeData }) = - "enum " <> name <> renderObject render typeData - render (name, DataUnion DataTyCon { typeData }) = - "union " - <> name - <> " =\n " - <> intercalate ("\n" <> renderIndent <> "| ") typeData - render (name, DataInputObject DataTyCon { typeData }) = - "input " <> name <> render typeData - render (name, DataInputUnion DataTyCon { typeData }) = - "input " <> name <> render fields - where fields = createInputUnionFields name typeData - render (name, DataObject DataTyCon { typeData }) = - "type " <> name <> render typeData - - + render (name, DataType { typeContent }) = __render typeContent + where + __render DataScalar{} = "scalar " <> name + __render (DataEnum tags) = "enum " <> name <> renderObject render tags + __render (DataUnion members) = + "union " + <> name + <> " =\n " + <> intercalate ("\n" <> renderIndent <> "| ") members + __render (DataInputObject fields ) = "input " <> name <> render fields + __render (DataInputUnion members) = "input " <> name <> render fields + where fields = createInputUnionFields name (map fst members) + __render (DataObject fields) = "type " <> name <> render fields -- OBJECT instance RenderGQL [(Text, DataField)] where diff --git a/src/Data/Morpheus/Rendering/RenderIntrospection.hs b/src/Data/Morpheus/Rendering/RenderIntrospection.hs --- a/src/Data/Morpheus/Rendering/RenderIntrospection.hs +++ b/src/Data/Morpheus/Rendering/RenderIntrospection.hs @@ -19,15 +19,16 @@ import Data.Morpheus.Schema.Schema import Data.Morpheus.Schema.TypeKind ( TypeKind(..) ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) - , DataTyCon(..) + ( DataInputUnion + , DataField(..) + , DataTypeContent(..) , DataType(..) , DataTypeKind(..) , DataTypeLib , DataTypeWrapper(..) , DataUnion , Meta(..) - , TypeAlias(..) + , TypeRef(..) , createInputUnionFields , fieldVisibility , kindOf @@ -35,8 +36,10 @@ , toGQLWrapper , DataEnumValue(..) , lookupDeprecated + , DataInputUnion , lookupDeprecatedReason - , convertToJSONName ) + , convertToJSONName + ) import Data.Morpheus.Types.Internal.Resolving ( Failure(..) ) @@ -49,24 +52,22 @@ render :: (Monad m, Failure Text m) => (Text, a) -> DataTypeLib -> m (b m) instance RenderSchema DataType S__Type where - render (key, DataScalar DataTyCon { typeMeta }) = - constRes $ createLeafType SCALAR key typeMeta Nothing - render (key, DataEnum DataTyCon { typeMeta, typeData }) = - constRes - $ createLeafType ENUM key typeMeta (Just $ map createEnumValue typeData) - render (name, DataInputObject DataTyCon { typeData, typeMeta }) = - renderInputObject - where - renderInputObject lib = do - fields <- traverse (`renderinputValue` lib) typeData - pure $ createInputObject name typeMeta fields - render (name, DataObject object') = typeFromObject (name, object') + render (name, DataType { typeMeta, typeContent }) = __render typeContent where - typeFromObject (key, DataTyCon { typeData, typeMeta }) lib = - createObjectType key (typeMeta >>= metaDescription) - <$> (Just <$> traverse (`render` lib) (filter fieldVisibility typeData)) - render (name, DataUnion union) = constRes $ typeFromUnion (name, union) - render (name, DataInputUnion inpUnion') = renderInputUnion (name, inpUnion') + __render DataScalar{} = + constRes $ createLeafType SCALAR name typeMeta Nothing + __render (DataEnum enums) = constRes + $ createLeafType ENUM name typeMeta (Just $ map createEnumValue enums) + __render (DataInputObject fields) = \lib -> + createInputObject name typeMeta + <$> traverse (`renderinputValue` lib) fields + __render (DataObject fields) = \lib -> + createObjectType name (typeMeta >>= metaDescription) + <$> (Just <$> traverse (`render` lib) (filter fieldVisibility fields)) + __render (DataUnion union) = + constRes $ typeFromUnion (name, typeMeta, union) + __render (DataInputUnion members) = + renderInputUnion (name, typeMeta, members) createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue @@ -79,16 +80,16 @@ where deprecated = enumMeta >>= lookupDeprecated instance RenderSchema DataField S__Field where - render (name, field@DataField { fieldType = TypeAlias { aliasTyCon }, fieldArgs, fieldMeta }) lib + render (name, field@DataField { fieldType = TypeRef { typeConName }, fieldArgs, fieldMeta }) lib = do - kind <- renderTypeKind <$> lookupKind aliasTyCon lib + kind <- renderTypeKind <$> lookupKind typeConName lib args <- traverse (`renderinputValue` lib) fieldArgs pure S__Field { s__FieldName = constRes (convertToJSONName name) , s__FieldDescription = constRes (fieldMeta >>= metaDescription) , s__FieldArgs = constRes args , s__FieldType' = - constRes (wrap field $ createType kind aliasTyCon Nothing $ Just []) + constRes (wrap field $ createType kind typeConName Nothing $ Just []) , s__FieldIsDeprecated = constRes (isJust deprecated) , s__FieldDeprecationReason = constRes (deprecated >>= lookupDeprecatedReason) @@ -106,8 +107,8 @@ renderTypeKind KindNonNull = NON_NULL wrap :: Monad m => DataField -> S__Type m -> S__Type m -wrap DataField { fieldType = TypeAlias { aliasWrappers } } typ = - foldr wrapByTypeWrapper typ (toGQLWrapper aliasWrappers) +wrap DataField { fieldType = TypeRef { typeWrappers } } typ = + foldr wrapByTypeWrapper typ (toGQLWrapper typeWrappers) wrapByTypeWrapper :: Monad m => DataTypeWrapper -> S__Type m -> S__Type m wrapByTypeWrapper ListType = wrapAs LIST @@ -128,17 +129,20 @@ createInputObjectType :: (Monad m, Failure Text m) => DataField -> Result m (S__Type m) -createInputObjectType field@DataField { fieldType = TypeAlias { aliasTyCon } } lib +createInputObjectType field@DataField { fieldType = TypeRef { typeConName } } lib = do - kind <- renderTypeKind <$> lookupKind aliasTyCon lib - pure $ wrap field $ createType kind aliasTyCon Nothing $ Just [] + kind <- renderTypeKind <$> lookupKind typeConName lib + pure $ wrap field $ createType kind typeConName Nothing $ Just [] renderInputUnion - :: (Monad m, Failure Text m) => (Text, DataUnion) -> Result m (S__Type m) -renderInputUnion (key, DataTyCon { typeData, typeMeta }) lib = - createInputObject key typeMeta - <$> traverse createField (createInputUnionFields key typeData) + :: (Monad m, Failure Text m) + => (Text, Maybe Meta, DataInputUnion) + -> Result m (S__Type m) +renderInputUnion (key, meta, fields) lib = + createInputObject key meta <$> traverse + createField + (createInputUnionFields key $ map fst $ filter snd fields) where createField (name, field) = createInputValueWith name Nothing <$> createInputObjectType field lib @@ -162,8 +166,8 @@ , s__TypeInputFields = constRes Nothing } -typeFromUnion :: Monad m => (Text, DataUnion) -> S__Type m -typeFromUnion (name, DataTyCon { typeData, typeMeta }) = S__Type +typeFromUnion :: Monad m => (Text, Maybe Meta, DataUnion) -> S__Type m +typeFromUnion (name, typeMeta, typeContent) = S__Type { s__TypeKind = constRes UNION , s__TypeName = constRes $ Just name , s__TypeDescription = constRes (typeMeta >>= metaDescription) @@ -171,7 +175,8 @@ , s__TypeOfType = constRes Nothing , s__TypeInterfaces = constRes Nothing , s__TypePossibleTypes = - constRes $ Just (map (\x -> createObjectType x Nothing $ Just []) typeData) + constRes + $ Just (map (\x -> createObjectType x Nothing $ Just []) typeContent) , s__TypeEnumValues = constRes Nothing , s__TypeInputFields = constRes Nothing } diff --git a/src/Data/Morpheus/Schema/SchemaAPI.hs b/src/Data/Morpheus/Schema/SchemaAPI.hs --- a/src/Data/Morpheus/Schema/SchemaAPI.hs +++ b/src/Data/Morpheus/Schema/SchemaAPI.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Schema.SchemaAPI ( hiddenRootFields @@ -15,9 +16,10 @@ -- MORPHEUS import Data.Morpheus.Execution.Server.Introspect - ( ObjectFields(..) + ( objectFields , TypeUpdater , introspect + , TypeScope(..) ) import Data.Morpheus.Rendering.RenderIntrospection ( createObjectType @@ -33,9 +35,9 @@ import Data.Morpheus.Types.ID ( ID ) import Data.Morpheus.Types.Internal.AST ( DataField(..) - , DataObject , DataTypeLib(..) , QUERY + , DataType , allDataTypes , lookupDataType ) @@ -50,7 +52,7 @@ convertTypes lib = traverse (`render` lib) (allDataTypes lib) buildSchemaLinkType - :: Monad m => (Text, DataObject) -> S__Type (Resolver QUERY e m) + :: Monad m => (Text, DataType) -> S__Type (Resolver QUERY e m) buildSchemaLinkType (key', _) = createObjectType key' Nothing $ Just [] findType @@ -78,8 +80,9 @@ } hiddenRootFields :: [(Text, DataField)] -hiddenRootFields = fst - $ objectFields (Proxy :: Proxy (CUSTOM (Root Maybe))) (Proxy @(Root Maybe)) +hiddenRootFields = fst $ objectFields + (Proxy :: Proxy (CUSTOM (Root Maybe))) + ("Root", OutputType, Proxy @(Root Maybe)) defaultTypes :: TypeUpdater defaultTypes = flip diff --git a/src/Data/Morpheus/Server.hs b/src/Data/Morpheus/Server.hs --- a/src/Data/Morpheus/Server.hs +++ b/src/Data/Morpheus/Server.hs @@ -7,6 +7,7 @@ -- | GraphQL Wai Server Applications module Data.Morpheus.Server ( gqlSocketApp + , gqlSocketMonadIOApp , initGQLState , GQLState ) @@ -14,6 +15,7 @@ import Control.Exception ( finally ) import Control.Monad ( forever ) +import Control.Monad.IO.Class ( MonadIO(liftIO) ) import Data.Text ( Text ) import Network.WebSockets ( ServerApp , acceptRequestWith @@ -55,21 +57,21 @@ ( GQLClient(..) ) import Data.Morpheus.Types.IO ( GQLResponse(..) ) import Data.Morpheus.Types.Internal.AST - ( Value ) + ( ValidValue ) handleSubscription - :: (Eq (StreamChannel e), GQLChannel e) - => GQLClient IO e - -> GQLState IO e + :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) + => GQLClient m e + -> GQLState m e -> Text - -> ResponseStream e IO Value - -> IO () + -> ResponseStream e m ValidValue + -> m () handleSubscription GQLClient { clientConnection, clientID } state sessionId stream = do response <- runResultT stream case response of Success { events } -> mapM_ execute events - Failure errors -> sendTextData + Failure errors -> liftIO $ sendTextData clientConnection (toApolloResponse sessionId $ Errors errors) where @@ -77,25 +79,35 @@ execute (Subscribe sub) = addClientSubscription clientID sub sessionId state -- | Wai WebSocket Server App for GraphQL subscriptions -gqlSocketApp - :: RootResCon IO e que mut sub - => GQLRootResolver IO e que mut sub - -> GQLState IO e +gqlSocketMonadIOApp + :: (RootResCon m e que mut sub, MonadIO m) + => GQLRootResolver m e que mut sub + -> GQLState m e + -> (m () -> IO ()) -> ServerApp -gqlSocketApp gqlRoot state pending = do +gqlSocketMonadIOApp gqlRoot state f pending = do connection <- acceptRequestWith pending $ acceptApolloSubProtocol (pendingRequest pending) forkPingThread connection 30 client <- connectClient connection state - finally (queryHandler client) (disconnectClient client state) + finally (f $ queryHandler client) (disconnectClient client state) where queryHandler client = forever handleRequest where - handleRequest = - receiveData (clientConnection client) >>= resolveMessage . apolloFormat + handleRequest = do + d <- liftIO $ receiveData (clientConnection client) + resolveMessage (apolloFormat d) where - resolveMessage (SubError x) = print x + resolveMessage (SubError x) = liftIO $ print x resolveMessage (AddSub sessionId request) = handleSubscription client state sessionId (coreResolver gqlRoot request) resolveMessage (RemoveSub sessionId) = removeClientSubscription (clientID client) sessionId state + +-- | Same as above but specific to IO +gqlSocketApp + :: (RootResCon IO e que mut sub) + => GQLRootResolver IO e que mut sub + -> GQLState IO e + -> ServerApp +gqlSocketApp gqlRoot state = gqlSocketMonadIOApp gqlRoot state id diff --git a/src/Data/Morpheus/Types.hs b/src/Data/Morpheus/Types.hs --- a/src/Data/Morpheus/Types.hs +++ b/src/Data/Morpheus/Types.hs @@ -29,9 +29,11 @@ , ResolveQ , ResolveM , ResolveS + , failRes ) where +import Data.Text ( pack ) import Data.Morpheus.Types.GQLScalar ( GQLScalar ( parseValue , serialize @@ -51,6 +53,7 @@ , Resolver(..) , LiftEither(..) , lift + , failure ) import Data.Morpheus.Types.IO ( GQLRequest(..) , GQLResponse(..) @@ -76,3 +79,6 @@ constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a constMutRes events value = const $ MutResolver $ pure (events, value) + +failRes :: (LiftEither o Resolver, Monad m) => String -> Resolver o e m a +failRes = failure . pack diff --git a/src/Data/Morpheus/Types/GQLScalar.hs b/src/Data/Morpheus/Types/GQLScalar.hs --- a/src/Data/Morpheus/Types/GQLScalar.hs +++ b/src/Data/Morpheus/Types/GQLScalar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,14 +11,15 @@ import Data.Morpheus.Types.Internal.AST.Data ( DataValidator(..) ) -import Data.Morpheus.Types.Internal.AST.Value +import Data.Morpheus.Types.Internal.AST ( ScalarValue(..) + , ValidValue , Value(..) ) import Data.Proxy ( Proxy(..) ) import Data.Text ( Text ) -toScalar :: Value -> Either Text ScalarValue +toScalar :: ValidValue -> Either Text ScalarValue toScalar (Scalar x) = pure x toScalar _ = Left "" @@ -65,5 +67,6 @@ instance GQLScalar Float where parseValue (Float x) = pure x + parseValue (Int x) = pure $ fromInteger $ toInteger x parseValue _ = Left "" serialize = Float diff --git a/src/Data/Morpheus/Types/GQLType.hs b/src/Data/Morpheus/Types/GQLType.hs --- a/src/Data/Morpheus/Types/GQLType.hs +++ b/src/Data/Morpheus/Types/GQLType.hs @@ -80,13 +80,34 @@ -- instance GQLType ... where -- description = const "your description ..." -- @ -class GQLType a where + +class IsObject (a :: GQL_KIND) where + isObject :: Proxy a -> Bool + +instance IsObject SCALAR where + isObject _ = False + +instance IsObject ENUM where + isObject _ = False + +instance IsObject WRAPPER where + isObject _ = False + +instance IsObject INPUT where + isObject _ = True + +instance IsObject OUTPUT where + isObject _ = True + +class IsObject (KIND a) => GQLType a where type KIND a :: GQL_KIND - type KIND a = OBJECT + type KIND a = OUTPUT type CUSTOM a :: Bool type CUSTOM a = FALSE description :: Proxy a -> Maybe Text description _ = Nothing + isObjectKind :: Proxy a -> Bool + isObjectKind _ = isObject (Proxy @(KIND a)) __typeName :: Proxy a -> Text default __typeName :: (Typeable a) => Proxy a -> Text @@ -96,7 +117,7 @@ __typeFingerprint :: Proxy a -> DataFingerprint default __typeFingerprint :: (Typeable a) => Proxy a -> DataFingerprint - __typeFingerprint _ = TypeableFingerprint $ map show $ conFingerprints (Proxy @a) + __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a) where conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep) @@ -143,10 +164,10 @@ __typeFingerprint _ = __typeFingerprint (Proxy @a) instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where - type KIND (Pair a b) = OBJECT + type KIND (Pair a b) = OUTPUT instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where - type KIND (MapKind a b m) = OBJECT + type KIND (MapKind a b m) = OUTPUT __typeName _ = __typeName (Proxy @(Map a b)) __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b)) diff --git a/src/Data/Morpheus/Types/ID.hs b/src/Data/Morpheus/Types/ID.hs --- a/src/Data/Morpheus/Types/ID.hs +++ b/src/Data/Morpheus/Types/ID.hs @@ -10,7 +10,7 @@ import Data.Morpheus.Kind ( SCALAR ) import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) ) import Data.Morpheus.Types.GQLType ( GQLType(KIND) ) -import Data.Morpheus.Types.Internal.AST.Value +import Data.Morpheus.Types.Internal.AST ( ScalarValue(..) ) import Data.Text ( Text , pack diff --git a/src/Data/Morpheus/Types/IO.hs b/src/Data/Morpheus/Types/IO.hs --- a/src/Data/Morpheus/Types/IO.hs +++ b/src/Data/Morpheus/Types/IO.hs @@ -32,10 +32,10 @@ , Result(..) ) import Data.Morpheus.Types.Internal.AST.Value - ( Value ) + ( ValidValue ) -renderResponse :: Result e GQLError con Value -> GQLResponse +renderResponse :: Result e GQLError con ValidValue -> GQLResponse renderResponse (Failure errors) = Errors errors renderResponse Success { result } = Data result @@ -57,7 +57,7 @@ -- | GraphQL Response data GQLResponse - = Data Value + = Data ValidValue | Errors [GQLError] deriving (Show, Generic) diff --git a/src/Data/Morpheus/Types/Internal/AST.hs b/src/Data/Morpheus/Types/Internal/AST.hs --- a/src/Data/Morpheus/Types/Internal/AST.hs +++ b/src/Data/Morpheus/Types/Internal/AST.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Types.Internal.AST ( @@ -11,6 +13,10 @@ , anonymousRef , Name , Description + , Stage + , RESOLVED + , VALID + , RAW -- VALUE , Value(..) @@ -21,22 +27,32 @@ , decodeScientific , convertToJSONName , convertToHaskellName + , RawValue + , ValidValue + , RawObject + , ValidObject + , ResolvedObject + , ResolvedValue + , unpackInputUnion -- Selection , Argument(..) , Arguments , SelectionSet - , SelectionRec(..) - , ValueOrigin(..) + , SelectionContent(..) , ValidSelection , Selection(..) - , RawSelection' + , RawSelection , FragmentLib , RawArguments , RawSelectionSet , Fragment(..) - , RawArgument(..) - , RawSelection(..) + , RawArgument + , ValidSelectionSet + , ValidArgument + , ValidArguments + , RawSelectionRec + , ValidSelectionRec -- OPERATION , Operation(..) @@ -48,6 +64,7 @@ , DefaultValue , getOperationName , getOperationDataType + , getOperationObject -- DSL @@ -58,7 +75,7 @@ , DataUnion , DataArguments , DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeLib(..) , DataTypeWrapper(..) @@ -68,7 +85,7 @@ , RawDataType(..) , ResolverKind(..) , TypeWrapper(..) - , TypeAlias(..) + , TypeRef(..) , ArgsType(..) , DataEnumValue(..) , isTypeDefined @@ -120,7 +137,6 @@ , Meta(..) , Directive(..) , createEnumValue - , fromDataType , insertType , TypeUpdater , lookupDeprecated @@ -130,33 +146,64 @@ , ClientQuery(..) , GQLTypeD(..) , ClientType(..) + , DataInputUnion + , VariableContent(..) -- LOCAL , GQLQuery(..) , Variables + , isNullableWrapper ) where import Data.Map ( Map ) import Language.Haskell.TH.Syntax ( Lift ) -import Instances.TH.Lift ( ) +import Data.Semigroup ( (<>) ) -- Morpheus import Data.Morpheus.Types.Internal.AST.Data - -import Data.Morpheus.Types.Internal.AST.Operation - import Data.Morpheus.Types.Internal.AST.Selection import Data.Morpheus.Types.Internal.AST.Base import Data.Morpheus.Types.Internal.AST.Value +import Data.Morpheus.Types.Internal.Resolving.Core + ( Failure(..) ) -type Variables = Map Key Value +type Variables = Map Key ResolvedValue data GQLQuery = GQLQuery { fragments :: FragmentLib , operation :: RawOperation - , inputVariables :: [(Key, Value)] + , inputVariables :: [(Key, ResolvedValue)] } deriving (Show,Lift) + +unpackInputUnion + :: [(Name, Bool)] + -> Object stage + -> Either Message (Name, Maybe (Value stage)) +unpackInputUnion tags [("__typename", enum)] = do + tyName <- isPosibeUnion tags enum + pure (tyName, Nothing) +unpackInputUnion tags [("__typename", enum), (name, value)] = do + tyName <- isPosibeUnion tags enum + inputtypeName tyName name value +unpackInputUnion tags [(name, value), ("__typename", enum)] = do + tyName <- isPosibeUnion tags enum + inputtypeName tyName name value +unpackInputUnion _ _ = failure + ("valid input union should contain __typename and actual value" :: Message) + +isPosibeUnion :: [(Name, Bool)] -> Value stage -> Either Message Name +isPosibeUnion tags (Enum name) = case lookup name tags of + Nothing -> failure (name <> " is not posible union type" :: Message) + _ -> pure name +isPosibeUnion _ _ = failure ("__typename must be Enum" :: Message) + + +inputtypeName + :: Name -> Name -> Value stage -> Either Message (Name, Maybe (Value stage)) +inputtypeName name fName fieldValue + | fName == name = pure (name, Just fieldValue) + | otherwise = failure ("field \"" <> name <> "\" was not provided" :: Message) diff --git a/src/Data/Morpheus/Types/Internal/AST/Base.hs b/src/Data/Morpheus/Types/Internal/AST/Base.hs --- a/src/Data/Morpheus/Types/Internal/AST/Base.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Base.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} module Data.Morpheus.Types.Internal.AST.Base ( Key @@ -12,6 +13,12 @@ , anonymousRef , Name , Description + , VALID + , RAW + , TypeWrapper(..) + , Stage(..) + , RESOLVED + , TypeRef(..) ) where @@ -31,6 +38,15 @@ type Collection a = [(Key, a)] + +data Stage = RAW | RESOLVED | VALID + +type VALID = 'RAW + +type RESOLVED = 'RESOLVED + +type RAW = 'VALID + data Position = Position { line :: Int , column :: Int @@ -53,3 +69,14 @@ anonymousRef :: Key -> Ref anonymousRef refName = Ref { refName, refPosition = Position 0 0 } + +data TypeWrapper + = TypeList + | TypeMaybe + deriving (Show, Lift) + +data TypeRef = TypeRef + { typeConName :: Name + , typeArgs :: Maybe Name + , typeWrappers :: [TypeWrapper] + } deriving (Show,Lift) diff --git a/src/Data/Morpheus/Types/Internal/AST/Data.hs b/src/Data/Morpheus/Types/Internal/AST/Data.hs --- a/src/Data/Morpheus/Types/Internal/AST/Data.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Data.hs @@ -10,15 +10,14 @@ {-# LANGUAGE RankNTypes #-} module Data.Morpheus.Types.Internal.AST.Data - ( - DataScalar + ( DataScalar , DataEnum , DataObject , DataArgument , DataUnion , DataArguments , DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeLib(..) , DataTypeWrapper(..) @@ -28,7 +27,7 @@ , RawDataType(..) , ResolverKind(..) , TypeWrapper(..) - , TypeAlias(..) + , TypeRef(..) , ArgsType(..) , DataEnumValue(..) , isTypeDefined @@ -80,7 +79,6 @@ , Meta(..) , Directive(..) , createEnumValue - , fromDataType , insertType , TypeUpdater , lookupDeprecated @@ -90,6 +88,8 @@ , ClientQuery(..) , GQLTypeD(..) , ClientType(..) + , DataInputUnion + , isNullableWrapper ) where @@ -117,6 +117,8 @@ , Position , Name , Description + , TypeWrapper(..) + , TypeRef(..) ) import Data.Morpheus.Types.Internal.Resolving.Core ( Validation @@ -126,7 +128,8 @@ , resolveUpdates ) import Data.Morpheus.Types.Internal.AST.Value - ( Value(..) + ( Value(..) + , ValidValue , ScalarValue(..) ) import Data.Morpheus.Error.Schema ( nameCollisionError ) @@ -196,18 +199,19 @@ | ExternalResolver deriving (Show, Eq, Lift) -data TypeWrapper - = TypeList - | TypeMaybe - deriving (Show, Lift) + isFieldNullable :: DataField -> Bool -isFieldNullable = isNullable . aliasWrappers . fieldType +isFieldNullable = isNullable . fieldType -isNullable :: [TypeWrapper] -> Bool -isNullable (TypeMaybe : _) = True -isNullable _ = False +isNullable :: TypeRef -> Bool +isNullable TypeRef { typeWrappers = typeWrappers } = isNullableWrapper typeWrappers +isNullableWrapper :: [TypeWrapper] -> Bool +isNullableWrapper (TypeMaybe : _ ) = True +isNullableWrapper _ = False + + isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2 isWeaker (TypeMaybe : _ ) _ = True @@ -229,27 +233,21 @@ toHSWrappers [] = [TypeMaybe] toHSWrappers [NonNullType] = [] -data DataFingerprint = SystemFingerprint Key | TypeableFingerprint [String] - deriving (Show, Eq, Ord, Lift) - +data DataFingerprint = DataFingerprint Name [String] deriving (Show, Eq, Ord, Lift) newtype DataValidator = DataValidator - { validateValue :: Value -> Either Key Value + { validateValue :: ValidValue -> Either Key ValidValue } instance Show DataValidator where show _ = "DataValidator" -type DataScalar = DataTyCon DataValidator - -type DataEnum = DataTyCon [DataEnumValue] - -type DataObject = DataTyCon [(Key, DataField)] - +type DataScalar = DataValidator +type DataEnum = [DataEnumValue] +type DataObject = [(Key, DataField)] type DataArgument = DataField - -type DataUnion = DataTyCon [Key] - +type DataUnion = [Key] +type DataInputUnion = [(Key, Bool)] type DataArguments = [(Key, DataArgument)] data DataTypeWrapper @@ -257,12 +255,6 @@ | NonNullType deriving (Show, Lift) -data TypeAlias = TypeAlias - { aliasTyCon :: Key - , aliasArgs :: Maybe Key - , aliasWrappers :: [TypeWrapper] - } deriving (Show,Lift) - data ArgsType = ArgsType { argsTypeName :: Key , resKind :: ResolverKind @@ -270,7 +262,7 @@ data Directive = Directive { directiveName :: Name, - directiveArgs :: [(Name,Value)] + directiveArgs :: [(Name, ValidValue)] } deriving (Show,Lift) -- META @@ -289,6 +281,7 @@ lookupDeprecatedReason Directive { directiveArgs } = maybeString . snd <$> find isReason directiveArgs where + maybeString :: ValidValue -> Name maybeString (Scalar (String x)) = x maybeString _ = "can't read deprecated Reason Value" isReason ("reason", _) = True @@ -305,7 +298,7 @@ { fieldName :: Key , fieldArgs :: [(Key, DataArgument)] , fieldArgsType :: Maybe ArgsType - , fieldType :: TypeAlias + , fieldType :: TypeRef , fieldMeta :: Maybe Meta } deriving (Show,Lift) @@ -316,11 +309,11 @@ fieldVisibility _ = True createField :: DataArguments -> Key -> ([TypeWrapper], Key) -> DataField -createField fieldArgs fieldName (aliasWrappers, aliasTyCon) = DataField +createField fieldArgs fieldName (typeWrappers, typeConName) = DataField { fieldArgs , fieldArgsType = Nothing , fieldName - , fieldType = TypeAlias { aliasTyCon, aliasWrappers, aliasArgs = Nothing } + , fieldType = TypeRef { typeConName, typeWrappers, typeArgs = Nothing } , fieldMeta = Nothing } @@ -330,17 +323,17 @@ toNullableField :: DataField -> DataField toNullableField dataField - | isNullable (aliasWrappers $ fieldType dataField) = dataField + | isNullable (fieldType dataField) = dataField | otherwise = dataField { fieldType = nullable (fieldType dataField) } where - nullable alias@TypeAlias { aliasWrappers } = - alias { aliasWrappers = TypeMaybe : aliasWrappers } + nullable alias@TypeRef { typeWrappers } = + alias { typeWrappers = TypeMaybe : typeWrappers } toListField :: DataField -> DataField toListField dataField = dataField { fieldType = listW (fieldType dataField) } where - listW alias@TypeAlias { aliasWrappers } = - alias { aliasWrappers = TypeList : aliasWrappers } + listW alias@TypeRef { typeWrappers } = + alias { typeWrappers = TypeList : typeWrappers } lookupField :: Failure error m => Key -> [(Key, field)] -> error -> m field lookupField key fields gqlError = case lookup key fields of @@ -350,58 +343,69 @@ lookupSelectionField :: Failure GQLErrors Validation => Position - -> Key + -> Name + -> Name -> DataObject -> Validation DataField -lookupSelectionField position fieldName DataTyCon { typeData, typeName } = - lookupField fieldName typeData gqlError +lookupSelectionField position fieldName typeName fields = lookupField + fieldName + fields + gqlError where gqlError = cannotQueryField fieldName typeName position -- -- TYPE CONSTRUCTOR -------------------------------------------------------------------------------------------------- -data DataTyCon a = DataTyCon - { typeName :: Key - , typeFingerprint :: DataFingerprint - , typeMeta :: Maybe Meta - , typeData :: a - } deriving (Show, Lift) - data RawDataType = FinalDataType DataType - | Interface DataObject - | Implements { implementsInterfaces :: [Key] - , unImplements :: DataObject } + | Interface { + interfaceName :: Key + , interfaceMeta :: Maybe Meta + , interfaceContent :: DataObject + } + | Implements { + implementsName :: Key + , implementsInterfaces :: [Key] + , implementsMeta :: Maybe Meta + , implementsContent :: DataObject + } deriving (Show) -- -- DATA TYPE -------------------------------------------------------------------------------------------------- -data DataType +data DataTypeContent = DataScalar DataScalar | DataEnum DataEnum | DataInputObject DataObject | DataObject DataObject | DataUnion DataUnion - | DataInputUnion DataUnion + | DataInputUnion [(Key,Bool)] deriving (Show) -createType :: Key -> a -> DataTyCon a -createType typeName typeData = DataTyCon +data DataType = DataType + { typeName :: Key + , typeFingerprint :: DataFingerprint + , typeMeta :: Maybe Meta + , typeContent :: DataTypeContent + } deriving (Show) + +createType :: Key -> DataTypeContent -> DataType +createType typeName typeContent = DataType { typeName , typeMeta = Nothing - , typeFingerprint = SystemFingerprint "" - , typeData + , typeFingerprint = DataFingerprint typeName [] + , typeContent } createScalarType :: Key -> (Key, DataType) createScalarType typeName = - (typeName, DataScalar $ createType typeName (DataValidator pure)) + (typeName, createType typeName $ DataScalar (DataValidator pure)) createEnumType :: Key -> [Key] -> (Key, DataType) createEnumType typeName typeData = - (typeName, DataEnum $ createType typeName enumValues) + (typeName, createType typeName $ DataEnum enumValues) where enumValues = map createEnumValue typeData createEnumValue :: Key -> DataEnumValue @@ -409,58 +413,54 @@ createUnionType :: Key -> [Key] -> (Key, DataType) createUnionType typeName typeData = - (typeName, DataUnion $ createType typeName typeData) - + (typeName, createType typeName $ DataUnion typeData) -isEntNode :: DataType -> Bool -isEntNode DataScalar{} = True -isEntNode DataEnum{} = True -isEntNode _ = False +isEntNode :: DataTypeContent -> Bool +isEntNode DataScalar{} = True +isEntNode DataEnum{} = True +isEntNode _ = False isInputDataType :: DataType -> Bool -isInputDataType DataScalar{} = True -isInputDataType DataEnum{} = True -isInputDataType DataInputObject{} = True -isInputDataType DataInputUnion{} = True -isInputDataType _ = False +isInputDataType DataType { typeContent } = __isInput typeContent + where + __isInput DataScalar{} = True + __isInput DataEnum{} = True + __isInput DataInputObject{} = True + __isInput DataInputUnion{} = True + __isInput _ = False -coerceDataObject :: Failure error m => error -> DataType -> m DataObject -coerceDataObject _ (DataObject object) = pure object -coerceDataObject gqlError _ = failure gqlError +coerceDataObject :: Failure error m => error -> DataType -> m (Name,DataObject) +coerceDataObject _ DataType { typeContent = DataObject object , typeName } = pure (typeName,object) +coerceDataObject gqlError _ = failure gqlError coerceDataUnion :: Failure error m => error -> DataType -> m DataUnion -coerceDataUnion _ (DataUnion object) = pure object -coerceDataUnion gqlError _ = failure gqlError +coerceDataUnion _ DataType { typeContent = DataUnion members } = pure members +coerceDataUnion gqlError _ = failure gqlError kindOf :: DataType -> DataTypeKind -kindOf (DataScalar _) = KindScalar -kindOf (DataEnum _) = KindEnum -kindOf (DataInputObject _) = KindInputObject -kindOf (DataObject _) = KindObject Nothing -kindOf (DataUnion _) = KindUnion -kindOf (DataInputUnion _) = KindInputUnion +kindOf DataType { typeContent } = __kind typeContent + where + __kind (DataScalar _) = KindScalar + __kind (DataEnum _) = KindEnum + __kind (DataInputObject _) = KindInputObject + __kind (DataObject _) = KindObject Nothing + __kind (DataUnion _) = KindUnion + __kind (DataInputUnion _) = KindInputUnion -fromDataType :: (DataTyCon () -> v) -> DataType -> v -fromDataType f (DataScalar dt) = f dt { typeData = () } -fromDataType f (DataEnum dt) = f dt { typeData = () } -fromDataType f (DataUnion dt) = f dt { typeData = () } -fromDataType f (DataInputObject dt) = f dt { typeData = () } -fromDataType f (DataInputUnion dt) = f dt { typeData = () } -fromDataType f (DataObject dt) = f dt { typeData = () } -- -- Type Register -------------------------------------------------------------------------------------------------- data DataTypeLib = DataTypeLib { types :: HashMap Key DataType - , query :: (Key, DataObject) - , mutation :: Maybe (Key, DataObject) - , subscription :: Maybe (Key, DataObject) + , query :: (Name,DataType) + , mutation :: Maybe (Name, DataType) + , subscription :: Maybe (Name, DataType) } deriving (Show) type TypeRegister = HashMap Key DataType -initTypeLib :: (Key, DataObject) -> DataTypeLib +initTypeLib :: (Key, DataType) -> DataTypeLib initTypeLib query = DataTypeLib { types = empty , query = query , mutation = Nothing @@ -476,9 +476,9 @@ types `union` fromList (concatMap fromOperation [Just query, mutation, subscription]) -fromOperation :: Maybe (Key, DataObject) -> [(Key, DataType)] -fromOperation (Just (key', dataType')) = [(key', DataObject dataType')] -fromOperation Nothing = [] +fromOperation :: Maybe (Key, DataType) -> [(Key, DataType)] +fromOperation (Just (key, datatype)) = [(key, datatype)] +fromOperation Nothing = [] lookupDataType :: Key -> DataTypeLib -> Maybe DataType lookupDataType name lib = name `HM.lookup` typeRegister lib @@ -489,7 +489,7 @@ _ -> failure gqlError lookupDataObject - :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m DataObject + :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m (Name,DataObject) lookupDataObject validationError name lib = getDataType name lib validationError >>= coerceDataObject validationError @@ -504,11 +504,10 @@ -> Key -> DataTypeLib -> DataField - -> m [DataObject] -lookupUnionTypes position key lib DataField { fieldType = TypeAlias { aliasTyCon = typeName } } + -> m [(Name,DataObject)] +lookupUnionTypes position key lib DataField { fieldType = TypeRef { typeConName = typeName } } = lookupDataUnion gqlError typeName lib >>= mapM (flip (lookupDataObject gqlError) lib) - . typeData where gqlError = hasNoSubfields key typeName position lookupFieldAsSelectionSet @@ -517,10 +516,10 @@ -> Key -> DataTypeLib -> DataField - -> m DataObject -lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeAlias { aliasTyCon } } - = lookupDataObject gqlError aliasTyCon lib - where gqlError = hasNoSubfields key aliasTyCon position + -> m (Name,DataObject) +lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeRef { typeConName } } + = lookupDataObject gqlError typeConName lib + where gqlError = hasNoSubfields key typeConName position lookupInputType :: Failure e m => Key -> DataTypeLib -> e -> m DataType lookupInputType name lib errors = case lookupDataType name lib of @@ -528,19 +527,19 @@ _ -> failure errors isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint -isTypeDefined name lib = - fromDataType typeFingerprint <$> lookupDataType name lib +isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib defineType :: (Key, DataType) -> DataTypeLib -> DataTypeLib -defineType (key, datatype@(DataInputUnion DataTyCon { typeName, typeData = enumKeys, typeFingerprint })) lib +defineType (key, datatype@DataType { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint }) lib = lib { types = insert name unionTags (insert key datatype (types lib)) } where name = typeName <> "Tags" - unionTags = DataEnum DataTyCon { typeName = name - , typeFingerprint - , typeMeta = Nothing - , typeData = map createEnumValue enumKeys - } + unionTags = DataType + { typeName = name + , typeFingerprint + , typeMeta = Nothing + , typeContent = DataEnum $ map (createEnumValue . fst) enumKeys + } defineType (key, datatype) lib = lib { types = insert key datatype (types lib) } @@ -560,33 +559,19 @@ } ) _ -> internalError "Query Not Defined" - ---------------------------------------------------------------------------- - - - - - - - - - - - - - - where takeByKey key lib = case lookup key lib of - Just (DataObject value) -> (Just (key, value), filter ((/= key) . fst) lib) - _ -> (Nothing, lib) + Just dt@DataType { typeContent = DataObject {} } -> + (Just (key, dt), filter ((/= key) . fst) lib) + _ -> (Nothing, lib) createInputUnionFields :: Key -> [Key] -> [(Key, DataField)] createInputUnionFields name members = fieldTag : map unionField members where fieldTag = - ( "tag" - , DataField { fieldName = "tag" + ( "__typename" + , DataField { fieldName = "__typename" , fieldArgs = [] , fieldArgsType = Nothing , fieldType = createAlias (name <> "Tags") @@ -599,17 +584,17 @@ { fieldArgs = [] , fieldArgsType = Nothing , fieldName = memberName - , fieldType = TypeAlias { aliasTyCon = memberName - , aliasWrappers = [TypeMaybe] - , aliasArgs = Nothing + , fieldType = TypeRef { typeConName = memberName + , typeWrappers = [TypeMaybe] + , typeArgs = Nothing } , fieldMeta = Nothing } ) -createAlias :: Key -> TypeAlias -createAlias aliasTyCon = - TypeAlias { aliasTyCon, aliasWrappers = [], aliasArgs = Nothing } +createAlias :: Key -> TypeRef +createAlias typeConName = + TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing } type TypeUpdater = LibUpdater DataTypeLib @@ -617,11 +602,10 @@ insertType :: (Key, DataType) -> TypeUpdater insertType nextType@(name, datatype) lib = case isTypeDefined name lib of Nothing -> resolveUpdates (defineType nextType lib) [] - Just fingerprint - | fingerprint == fromDataType typeFingerprint datatype -> return lib - | + Just fingerprint | fingerprint == typeFingerprint datatype -> return lib + | -- throw error if 2 different types has same name - otherwise -> failure $ nameCollisionError name + otherwise -> failure $ nameCollisionError name -- TEMPLATE HASKELL DATA TYPES diff --git a/src/Data/Morpheus/Types/Internal/AST/Operation.hs b/src/Data/Morpheus/Types/Internal/AST/Operation.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/Operation.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Types.Internal.AST.Operation - ( Operation(..) - , Variable(..) - , ValidOperation - , RawOperation - , VariableDefinitions - , ValidVariables - , DefaultValue - , getOperationName - , getOperationDataType - ) -where - -import Data.Maybe ( fromMaybe ) -import Language.Haskell.TH.Syntax ( Lift(..) ) - --- MORPHEUS -import Data.Morpheus.Error.Mutation ( mutationIsNotDefined ) -import Data.Morpheus.Error.Subscription - ( subscriptionIsNotDefined ) -import Data.Morpheus.Types.Internal.AST.Selection - ( Arguments - , SelectionSet - , RawSelectionSet - ) - -import Data.Morpheus.Types.Internal.Resolving.Core - ( Validation ,Failure(..) ) -import Data.Morpheus.Types.Internal.AST.Base - ( Collection - , Key - , Position - ) -import Data.Morpheus.Types.Internal.AST.Data - ( OperationType(..) - , TypeWrapper - , DataTypeLib(..) - , DataObject - ) -import Data.Morpheus.Types.Internal.AST.Value - ( Value ) - -type DefaultValue = Maybe Value - -type VariableDefinitions = Collection (Variable DefaultValue) - -type ValidVariables = Collection (Variable Value) - -type ValidOperation = Operation Arguments SelectionSet - -type RawOperation = Operation VariableDefinitions RawSelectionSet - -getOperationName :: Maybe Key -> Key -getOperationName = fromMaybe "AnonymousOperation" - -data Operation args sel = Operation - { operationName :: Maybe Key - , operationType :: OperationType - , operationArgs :: args - , operationSelection :: sel - , operationPosition :: Position - } deriving (Show,Lift) - -data Variable a = Variable - { variableType :: Key - , isVariableRequired :: Bool - , variableTypeWrappers :: [TypeWrapper] - , variablePosition :: Position - , variableValue :: a - } deriving (Show,Lift) - -getOperationDataType :: Operation a b -> DataTypeLib -> Validation DataObject -getOperationDataType Operation { operationType = Query } lib = - pure $ snd $ query lib -getOperationDataType Operation { operationType = Mutation, operationPosition } lib - = case mutation lib of - Just (_, mutation') -> pure mutation' - Nothing -> failure $ mutationIsNotDefined operationPosition -getOperationDataType Operation { operationType = Subscription, operationPosition } lib - = case subscription lib of - Just (_, subscription') -> pure subscription' - Nothing -> failure $ subscriptionIsNotDefined operationPosition - diff --git a/src/Data/Morpheus/Types/Internal/AST/Selection.hs b/src/Data/Morpheus/Types/Internal/AST/Selection.hs --- a/src/Data/Morpheus/Types/Internal/AST/Selection.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Selection.hs @@ -1,95 +1,179 @@ -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + module Data.Morpheus.Types.Internal.AST.Selection ( Argument(..) , Arguments , SelectionSet - , SelectionRec(..) - , ValueOrigin(..) + , SelectionContent(..) , ValidSelection , Selection(..) - , RawSelection' + , RawSelection , FragmentLib , RawArguments , RawSelectionSet , Fragment(..) - , RawArgument(..) - , RawSelection(..) + , RawArgument + , ValidSelectionSet + , ValidArgument + , ValidArguments + , RawSelectionRec + , ValidSelectionRec + , Operation(..) + , Variable(..) + , ValidOperation + , RawOperation + , VariableDefinitions + , ValidVariables + , DefaultValue + , getOperationName + , getOperationDataType + , getOperationObject ) where -import Language.Haskell.TH.Syntax ( Lift ) +import Data.Maybe ( fromMaybe ) +import Data.Semigroup ( (<>) ) +import Language.Haskell.TH.Syntax ( Lift(..) ) -- MORPHEUS +import Data.Morpheus.Error.Mutation ( mutationIsNotDefined ) +import Data.Morpheus.Error.Subscription + ( subscriptionIsNotDefined ) import Data.Morpheus.Types.Internal.AST.Base ( Collection , Key , Position , Ref(..) + , Name + , VALID + , RAW + , Stage ) - +import Data.Morpheus.Types.Internal.Resolving.Core + ( Validation + , Failure(..) + ) +import Data.Morpheus.Types.Internal.AST.Data + ( OperationType(..) + , DataTypeLib(..) + , DataType(..) + , DataTypeContent(..) + , DataObject + ) import Data.Morpheus.Types.Internal.AST.Value - ( Value ) + ( Value + , Variable(..) + , ResolvedValue + ) --- RAW SELECTION - -type RawSelection' a = Selection RawArguments a +data Fragment = Fragment + { fragmentType :: Key + , fragmentPosition :: Position + , fragmentSelection :: RawSelectionSet + } deriving (Show,Lift) type FragmentLib = [(Key, Fragment)] -type RawArguments = Collection RawArgument +data Argument (valid :: Stage) = Argument { + argumentValue :: Value valid + , argumentPosition :: Position + } deriving (Show,Lift) -type RawSelectionSet = Collection RawSelection +type RawArgument = Argument RAW -data Fragment = Fragment - { fragmentType :: Key - , fragmentPosition :: Position - , fragmentSelection :: RawSelectionSet - } deriving (Show, Lift) +type ValidArgument = Argument VALID -data RawArgument - = VariableRef Ref - | RawArgument Argument - deriving (Show, Lift) +type Arguments a = Collection (Argument a) -data RawSelection - = RawSelectionSet (RawSelection' RawSelectionSet) - | RawSelectionField (RawSelection' ()) - | InlineFragment Fragment - | Spread Ref - deriving (Show,Lift) +type RawArguments = Arguments RAW --- VALID SELECTION -type Arguments = Collection Argument +type ValidArguments = Collection ValidArgument -type SelectionSet = Collection ValidSelection +data SelectionContent (valid :: Stage) where + SelectionField ::SelectionContent valid + SelectionSet ::SelectionSet valid -> SelectionContent valid + UnionSelection ::UnionSelection -> SelectionContent VALID -type ValidSelection = Selection Arguments SelectionRec +deriving instance Show (SelectionContent a) +deriving instance Lift (SelectionContent a) -type UnionSelection = Collection SelectionSet +type RawSelectionRec = SelectionContent RAW +type ValidSelectionRec = SelectionContent VALID +type UnionSelection = Collection (SelectionSet VALID) +type SelectionSet a = Collection (Selection a) +type RawSelectionSet = Collection RawSelection +type ValidSelectionSet = Collection ValidSelection -data ValueOrigin - = VARIABLE - | INLINE - deriving (Show, Lift) -data Argument = Argument - { argumentValue :: Value - , argumentOrigin :: ValueOrigin - , argumentPosition :: Position - } deriving (Show, Lift) +data Selection (valid:: Stage) where + Selection ::{ + selectionArguments :: Arguments valid + , selectionPosition :: Position + , selectionAlias :: Maybe Key + , selectionContent :: SelectionContent valid + } -> Selection valid + InlineFragment ::Fragment -> Selection RAW + Spread ::Ref -> Selection RAW -data Selection args rec = Selection - { selectionArguments :: args - , selectionPosition :: Position - , selectionAlias :: Maybe Key - , selectionRec :: rec +deriving instance Show (Selection a) +deriving instance Lift (Selection a) + +type RawSelection = Selection RAW +type ValidSelection = Selection VALID + +type DefaultValue = Maybe ResolvedValue + +type VariableDefinitions = Collection (Variable RAW) + +type ValidVariables = Collection (Variable VALID) + +data Operation (stage:: Stage) = Operation + { operationName :: Maybe Key + , operationType :: OperationType + , operationArguments :: Collection (Variable stage) + , operationSelection :: SelectionSet stage + , operationPosition :: Position } deriving (Show,Lift) -data SelectionRec - = SelectionSet SelectionSet - | UnionSelection UnionSelection - | SelectionField - deriving (Show) +type RawOperation = Operation RAW + +type ValidOperation = Operation VALID + + +getOperationName :: Maybe Key -> Key +getOperationName = fromMaybe "AnonymousOperation" + +getOperationObject + :: Operation a -> DataTypeLib -> Validation (Name, DataObject) +getOperationObject op lib = do + dt <- getOperationDataType op lib + case dt of + DataType { typeContent = DataObject x, typeName } -> pure (typeName, x) + DataType { typeName } -> + failure + $ "Type Mismatch: operation \"" + <> typeName + <> "\" must be an Object" + +getOperationDataType :: Operation a -> DataTypeLib -> Validation DataType +getOperationDataType Operation { operationType = Query } lib = + pure $ snd $ query lib +getOperationDataType Operation { operationType = Mutation, operationPosition } lib + = case mutation lib of + Just (_, mutation') -> pure mutation' + Nothing -> failure $ mutationIsNotDefined operationPosition +getOperationDataType Operation { operationType = Subscription, operationPosition } lib + = case subscription lib of + Just (_, subscription') -> pure subscription' + Nothing -> failure $ subscriptionIsNotDefined operationPosition + diff --git a/src/Data/Morpheus/Types/Internal/AST/Value.hs b/src/Data/Morpheus/Types/Internal/AST/Value.hs --- a/src/Data/Morpheus/Types/Internal/AST/Value.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Value.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Morpheus.Types.Internal.AST.Value ( Value(..) @@ -13,6 +19,14 @@ , decodeScientific , convertToJSONName , convertToHaskellName + , RawValue + , ValidValue + , RawObject + , ValidObject + , Variable(..) + , ResolvedValue + , ResolvedObject + , VariableContent(..) ) where @@ -30,16 +44,31 @@ , floatingOrInteger ) import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) +import Data.Text ( Text + , unpack + ) import qualified Data.Text as T import qualified Data.Vector as V ( toList ) import GHC.Generics ( Generic ) import Instances.TH.Lift ( ) -import Language.Haskell.TH.Syntax ( Lift ) +import Language.Haskell.TH.Syntax ( Lift(..) ) +-- MORPHEUS +import Data.Morpheus.Types.Internal.AST.Base + ( Collection + , Ref(..) + , Name + , RAW + , VALID + , Position + , Stage + , RESOLVED + , TypeRef + ) -isReserved :: Text -> Bool + +isReserved :: Name -> Bool isReserved "case" = True isReserved "class" = True isReserved "data" = True @@ -85,7 +114,6 @@ | Boolean Bool deriving (Show, Generic,Lift) - instance A.ToJSON ScalarValue where toJSON (Float x) = A.toJSON x toJSON (Int x) = A.toJSON x @@ -98,22 +126,85 @@ parseJSON (A.String v) = pure $ String v parseJSON notScalar = fail $ "Expected Scalar got :" <> show notScalar +type family VAR (a:: Stage) :: Stage +type instance VAR RAW = RESOLVED +type instance VAR RESOLVED = RESOLVED +type instance VAR VALID = VALID -type Object = [(Text, Value)] +data VariableContent (stage:: Stage) where + DefaultValue ::Maybe ResolvedValue -> VariableContent RESOLVED + ValidVariableValue ::{ validVarContent::ValidValue }-> VariableContent VALID -data Value - = Object Object - | List [Value] - | Enum Text - | Scalar ScalarValue - | Null - deriving (Show, Generic,Lift) +instance Lift (VariableContent a) where + lift (DefaultValue x) = [| DefaultValue x |] + lift (ValidVariableValue x) = [| ValidVariableValue x |] -instance A.ToJSON Value where +deriving instance Show (VariableContent a) + +data Variable (stage :: Stage) = Variable + { variableType :: TypeRef + , variablePosition :: Position + , variableValue :: VariableContent (VAR stage) + } deriving (Show,Lift) + +data Value (valid :: Stage) where + ResolvedVariable::Ref -> Variable VALID -> Value RESOLVED + VariableValue ::Ref -> Value RAW + Object ::Object a -> Value a + List ::[Value a] -> Value a + Enum ::Name -> Value a + Scalar ::ScalarValue -> Value a + Null ::Value a + + +type Object a = Collection (Value a) +type ValidObject = Object VALID +type RawObject = Object RAW +type ResolvedObject = Object RESOLVED +type RawValue = Value RAW +type ValidValue = Value VALID +type ResolvedValue = Value RESOLVED + +deriving instance Lift (Value a) + +instance Show (Value a) where + show Null = "null" + show (Enum x) = "" <> unpack x + show (Scalar x) = show x + show (ResolvedVariable Ref { refName } Variable { variableValue }) = + "($" <> unpack refName <> ": " <> show variableValue <> ") " + show (VariableValue Ref { refName }) = "$" <> unpack refName <> " " + show (Object keys ) = "{" <> foldl toEntry "" keys <> "}" + where + toEntry :: String -> (Name, Value a) -> String + toEntry "" (key, value) = unpack key <> ":" <> show value + toEntry txt (key, value) = txt <> ", " <> unpack key <> ":" <> show value + show (List list) = "[" <> foldl toEntry "" list <> "]" + where + toEntry :: String -> Value a -> String + toEntry "" value = show value + toEntry txt value = txt <> ", " <> show value + +instance A.ToJSON (Value a) where + toJSON (ResolvedVariable _ Variable { variableValue = ValidVariableValue x }) + = A.toJSON x + toJSON (VariableValue Ref { refName }) = + A.String $ "($ref:" <> refName <> ")" + toJSON Null = A.Null + toJSON (Enum x ) = A.String x + toJSON (Scalar x ) = A.toJSON x + toJSON (List x ) = A.toJSON x + toJSON (Object fields) = A.object $ map toEntry fields + where toEntry (name, value) = name A..= A.toJSON value + ------------------------------------------- + toEncoding (ResolvedVariable _ Variable { variableValue = ValidVariableValue x }) + = A.toEncoding x + toEncoding (VariableValue Ref { refName }) = + A.toEncoding $ "($ref:" <> refName <> ")" toEncoding Null = A.toEncoding A.Null toEncoding (Enum x ) = A.toEncoding x - toEncoding (List x ) = A.toEncoding x toEncoding (Scalar x ) = A.toEncoding x + toEncoding (List x ) = A.toEncoding x toEncoding (Object []) = A.toEncoding $ A.object [] toEncoding (Object x ) = A.pairs $ foldl1 (<>) $ map encodeField x where encodeField (key, value) = convertToJSONName key A..= value @@ -123,18 +214,18 @@ Left float -> Float float Right int -> Int int -replaceValue :: A.Value -> Value +replaceValue :: A.Value -> Value a replaceValue (A.Bool v) = gqlBoolean v replaceValue (A.Number v) = Scalar $ decodeScientific v replaceValue (A.String v) = gqlString v replaceValue (A.Object v) = gqlObject $ map replace (M.toList v) - where - replace :: (a, A.Value) -> (a, Value) - replace (key, val) = (key, replaceValue val) + where + --replace :: (a, A.Value) -> (a, Value a) + replace (key, val) = (key, replaceValue val) replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li)) replaceValue A.Null = gqlNull -instance A.FromJSON Value where +instance A.FromJSON (Value a) where parseJSON = pure . replaceValue -- DEFAULT VALUES @@ -144,10 +235,10 @@ gqlBoolean :: Bool -> a gqlString :: Text -> a gqlList :: [a] -> a - gqlObject :: [(Text, a)] -> a + gqlObject :: [(Name, a)] -> a -- build GQL Values for Subscription Resolver -instance GQLValue Value where +instance GQLValue (Value a) where gqlNull = Null gqlScalar = Scalar gqlBoolean = Scalar . Boolean diff --git a/src/Data/Morpheus/Types/Internal/Resolving.hs b/src/Data/Morpheus/Types/Internal/Resolving.hs --- a/src/Data/Morpheus/Types/Internal/Resolving.hs +++ b/src/Data/Morpheus/Types/Internal/Resolving.hs @@ -27,6 +27,10 @@ , GQLErrors , GQLError(..) , Position + , resolveEnum + , resolve__typename + , DataResolver(..) + , FieldRes ) where diff --git a/src/Data/Morpheus/Types/Internal/Resolving/Core.hs b/src/Data/Morpheus/Types/Internal/Resolving/Core.hs --- a/src/Data/Morpheus/Types/Internal/Resolving/Core.hs +++ b/src/Data/Morpheus/Types/Internal/Resolving/Core.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Types.Internal.Resolving.Core ( GQLError(..) @@ -84,6 +85,10 @@ instance Failure [error] (Result ev error con) where failure = Failure +instance Failure Text Validation where + failure text = + Failure [GQLError { message = "INTERNAL ERROR: " <> text, locations = [] }] + unpackEvents :: Result event c e a -> [event] unpackEvents Success { events } = events unpackEvents _ = [] @@ -137,20 +142,21 @@ => (ea -> eb) -> ResultT ea er con m value -> ResultT eb er con m value -mapEvent func (ResultT ma) = ResultT $ do - state <- ma - return $ state { events = map func (events state) } +mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma + where + mapEv Success { result, warnings, events } = + Success { result, warnings, events = map func events } + mapEv (Failure err) = Failure err mapFailure :: Monad m => (er1 -> er2) -> ResultT ev er1 con m value -> ResultT ev er2 con m value -mapFailure f (ResultT ma) = ResultT $ do - state <- ma - case state of - Failure x -> pure $ Failure (map f x) - Success x w e -> pure $ Success x (map f w) e +mapFailure f (ResultT ma) = ResultT $ mapF <$> ma + where + mapF (Failure x ) = Failure (map f x) + mapF (Success x w e) = Success x (map f w) e -- Helper Functions diff --git a/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs b/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs --- a/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +++ b/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs @@ -14,8 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Resolving.Resolver - ( - Event(..) + ( Event(..) , GQLRootResolver(..) , UnSubResolver , Resolver(..) @@ -23,6 +22,7 @@ , MapStrategy(..) , LiftEither(..) , resolveObject + , resolveEnum , toResponseRes , withObject , resolving @@ -32,31 +32,41 @@ , GQLChannel(..) , ResponseEvent(..) , ResponseStream + , resolve__typename + , DataResolver(..) + , FieldRes ) where import Control.Monad.Trans.Class ( MonadTrans(..) ) import Data.Maybe ( fromMaybe ) -import Data.Semigroup ( (<>) ) +import Data.Semigroup ( (<>) + , Semigroup(..) + ) import Data.Text ( unpack , pack ) -- MORPHEUS +import Data.Morpheus.Error.Internal ( internalResolvingError ) import Data.Morpheus.Error.Selection ( resolvingFailedError , subfieldsNotSelected ) import Data.Morpheus.Types.Internal.AST.Selection ( Selection(..) - , SelectionRec(..) - , SelectionSet + , SelectionContent(..) , ValidSelection + , ValidSelectionRec + , ValidSelectionSet + , ValidSelection ) import Data.Morpheus.Types.Internal.AST.Base - ( Message , Key ) + ( Message + , Key + , Name + ) import Data.Morpheus.Types.Internal.AST.Data - ( - MUTATION + ( MUTATION , OperationType , QUERY , SUBSCRIPTION @@ -77,9 +87,11 @@ ) import Data.Morpheus.Types.Internal.AST.Value ( GQLValue(..) - , Value + , ValidValue ) -import Data.Morpheus.Types.IO (renderResponse, GQLResponse) +import Data.Morpheus.Types.IO ( renderResponse + , GQLResponse + ) -- MORPHEUS class LiftEither (o::OperationType) res where @@ -152,35 +164,75 @@ instance (LiftEither o ResolvingStrategy, Monad m) => Failure GQLErrors (ResolvingStrategy o e m) where failure = liftEither . pure . Left --- helper functins +-- DataResolver +data DataResolver o e m = + EnumRes Name + | UnionRes (Name,[FieldRes o e m]) + | ObjectRes [FieldRes o e m ] + | UnionRef (FieldRes o e m) + | InvalidRes Name + +instance Semigroup (DataResolver o e m) where + ObjectRes x <> ObjectRes y = ObjectRes (x <> y) + _ <> _ = InvalidRes "can't merge: incompatible resolvers" + withObject :: (LiftEither o ResolvingStrategy, Monad m) - => (SelectionSet -> ResolvingStrategy o e m value) + => (ValidSelectionSet -> ResolvingStrategy o e m value) -> (Key, ValidSelection) -> ResolvingStrategy o e m value -withObject f (_, Selection { selectionRec = SelectionSet selection }) = +withObject f (_, Selection { selectionContent = SelectionSet selection }) = f selection withObject _ (key, Selection { selectionPosition }) = failure (subfieldsNotSelected key "" selectionPosition) resolveObject :: (Monad m, LiftEither o ResolvingStrategy) - => SelectionSet - -> [FieldRes o e m] - -> ResolvingStrategy o e m Value -resolveObject selectionSet fieldResolvers = + => ValidSelectionSet + -> DataResolver o e m + -> ResolvingStrategy o e m ValidValue +resolveObject selectionSet (ObjectRes resolvers) = gqlObject <$> traverse selectResolver selectionSet where selectResolver (key, selection@Selection { selectionAlias }) = (fromMaybe key selectionAlias, ) <$> lookupRes selection where lookupRes sel = - (fromMaybe (const $ pure gqlNull) $ lookup key fieldResolvers) (key, sel) + (fromMaybe (const $ pure gqlNull) $ lookup key resolvers) (key, sel) +resolveObject _ _ = + failure $ internalResolvingError "expected object as resolver" +resolveEnum + :: (Monad m, LiftEither o ResolvingStrategy) + => Name + -> Name + -> ValidSelectionRec + -> ResolvingStrategy o e m ValidValue +resolveEnum _ enum SelectionField = pure $ gqlString enum +resolveEnum typeName enum (UnionSelection selections) = resolveObject + currentSelection + resolvers + where + enumObjectTypeName = typeName <> "EnumObject" + currentSelection = fromMaybe [] $ lookup enumObjectTypeName selections + resolvers = ObjectRes + [ ("enum", const $ pure $ gqlString enum) + , resolve__typename enumObjectTypeName + ] +resolveEnum _ _ _ = + failure $ internalResolvingError "wrong selection on enum value" + + +resolve__typename + :: (Monad m, LiftEither o ResolvingStrategy) + => Name + -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue) +resolve__typename name = ("__typename", const $ pure $ gqlString name) + toResponseRes :: Monad m - => ResolvingStrategy o event m Value - -> ResponseStream event m Value + => ResolvingStrategy o event m ValidValue + -> ResponseStream event m ValidValue toResponseRes (ResolveQ resT) = cleanEvents resT toResponseRes (ResolveM resT) = mapEvent Publish resT toResponseRes (ResolveS resT) = ResultT $ handleActions <$> runResultT resT @@ -192,7 +244,8 @@ , events = [Subscribe $ Event channels eventResolver] } where - eventResolver event = renderResponse <$> runResultT (unRecResolver subRes event) + eventResolver event = + renderResponse <$> runResultT (unRecResolver subRes event) -- -- @@ -276,7 +329,7 @@ -- RESOLVING type FieldRes o e m - = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value) + = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue) toResolver :: (LiftEither o Resolver, Monad m) @@ -290,10 +343,10 @@ resolving :: forall o e m value . Monad m - => (value -> (Key, ValidSelection) -> ResolvingStrategy o e m Value) + => (value -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue) -> Resolver o e m value -> (Key, ValidSelection) - -> ResolvingStrategy o e m Value + -> ResolvingStrategy o e m ValidValue resolving encode gResolver selection@(fieldName, Selection { selectionPosition }) = _resolve gResolver where @@ -322,17 +375,16 @@ , warnings = [] } where - eventResolver :: e -> StatelessResT m Value + eventResolver :: e -> StatelessResT m ValidValue eventResolver event = convert (unQueryResolver $ res event) >>= unPureSub . _encode where unPureSub :: Monad m - => ResolvingStrategy SUBSCRIPTION e m Value - -> StatelessResT m Value + => ResolvingStrategy SUBSCRIPTION e m ValidValue + -> StatelessResT m ValidValue unPureSub (ResolveS x) = cleanEvents x >>= passEvent - where - passEvent (RecResolver f) = f event + where passEvent (RecResolver f) = f event -- map Resolving strategies class MapStrategy (from :: OperationType) (to :: OperationType) where @@ -360,7 +412,7 @@ -- Channel newtype Channel event = Channel { - unChannel :: StreamChannel event + _unChannel :: StreamChannel event } instance (Eq (StreamChannel event)) => Eq (Channel event) where diff --git a/src/Data/Morpheus/Validation/Document/Validation.hs b/src/Data/Morpheus/Validation/Document/Validation.hs --- a/src/Data/Morpheus/Validation/Document/Validation.hs +++ b/src/Data/Morpheus/Validation/Document/Validation.hs @@ -20,10 +20,13 @@ ( DataField(..) , DataType(..) , DataObject - , DataTyCon(..) + , DataTypeContent(..) + , Name , Key , RawDataType(..) - , TypeAlias(..) + , TypeRef(..) + , DataFingerprint(..) + , Meta , isWeaker , isWeaker ) @@ -37,29 +40,37 @@ where validateType :: (Key, RawDataType) -> Validation (Maybe (Key, DataType)) validateType (name, FinalDataType x) = pure $ Just (name, x) - validateType (name, Implements interfaces object) = - asTuple name <$> object `mustImplement` interfaces + validateType (name, Implements { implementsName, implementsInterfaces, implementsMeta, implementsContent }) + = asTuple name + <$> (implementsName, implementsMeta, implementsContent) + `mustImplement` implementsInterfaces validateType _ = pure Nothing ----------------------------------- asTuple name x = Just (name, x) ----------------------------------- - mustImplement :: DataObject -> [Key] -> Validation DataType - mustImplement object interfaceKey = do + mustImplement :: (Name, Maybe Meta, DataObject) -> [Key] -> Validation DataType + mustImplement (typeName, typeMeta, object) interfaceKey = do interface <- traverse getInterfaceByKey interfaceKey case concatMap (mustBeSubset object) interface of - [] -> pure $ DataObject object - errors -> failure $ partialImplements (typeName object) errors + [] -> pure $ DataType { typeName + , typeFingerprint = DataFingerprint typeName [] + , typeMeta + , typeContent = DataObject object + } + errors -> failure $ partialImplements typeName errors ------------------------------- - mustBeSubset :: DataObject -> DataObject -> [(Key, Key, ImplementsError)] - mustBeSubset DataTyCon { typeData = objFields } DataTyCon { typeName, typeData = interfaceFields } - = concatMap checkField interfaceFields + mustBeSubset + :: DataObject -> (Name, DataObject) -> [(Key, Key, ImplementsError)] + mustBeSubset objFields (typeName, interfaceFields) = concatMap + checkField + interfaceFields where checkField :: (Key, DataField) -> [(Key, Key, ImplementsError)] - checkField (key, DataField { fieldType = interfaceT@TypeAlias { aliasTyCon = interfaceTypeName, aliasWrappers = interfaceWrappers } }) + checkField (key, DataField { fieldType = interfaceT@TypeRef { typeConName = interfaceTypeName, typeWrappers = interfaceWrappers } }) = case lookup key objFields of - Just DataField { fieldType = objT@TypeAlias { aliasTyCon, aliasWrappers } } - | aliasTyCon == interfaceTypeName && not - (isWeaker aliasWrappers interfaceWrappers) + Just DataField { fieldType = objT@TypeRef { typeConName, typeWrappers } } + | typeConName == interfaceTypeName && not + (isWeaker typeWrappers interfaceWrappers) -> [] | otherwise -> [ ( typeName @@ -71,7 +82,7 @@ ] Nothing -> [(typeName, key, UndefinedField)] ------------------------------- - getInterfaceByKey :: Key -> Validation DataObject + getInterfaceByKey :: Key -> Validation (Name,DataObject) getInterfaceByKey key = case lookup key lib of - Just (Interface x) -> pure x - _ -> failure $ unknownInterface key + Just Interface { interfaceContent } -> pure (key,interfaceContent) + _ -> failure $ unknownInterface key diff --git a/src/Data/Morpheus/Validation/Internal/Value.hs b/src/Data/Morpheus/Validation/Internal/Value.hs --- a/src/Data/Morpheus/Validation/Internal/Value.hs +++ b/src/Data/Morpheus/Validation/Internal/Value.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,104 +11,190 @@ import Data.List ( elem ) -- MORPHEUS +import Data.Morpheus.Error.Variable ( incompatibleVariableType ) import Data.Morpheus.Error.Input ( InputError(..) , InputValidation , Prop(..) ) -import Data.Morpheus.Rendering.RenderGQL - ( renderWrapped ) import Data.Morpheus.Types.Internal.AST ( DataField(..) - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeLib(..) , DataValidator(..) , Key - , TypeAlias(..) + , TypeRef(..) , TypeWrapper(..) , DataEnumValue(..) - , isNullable , lookupField , lookupInputType , Value(..) + , ValidValue + , Variable(..) + , Ref(..) + , isWeaker + , DataScalar + , Message + , Name + , ResolvedValue + , VALID + , VariableContent(..) + , unpackInputUnion + , isFieldNullable + , TypeRef(..) + , isNullableWrapper ) import Data.Morpheus.Types.Internal.Resolving ( Failure(..) ) +import Data.Morpheus.Rendering.RenderGQL + ( RenderGQL(..) ) +checkTypeEquality + :: (Name, [TypeWrapper]) + -> Ref + -> Variable VALID + -> InputValidation ValidValue +checkTypeEquality (tyConName, tyWrappers) Ref { refName, refPosition } Variable { variableValue = ValidVariableValue value, variableType } + | typeConName variableType == tyConName && not + (isWeaker (typeWrappers variableType) tyWrappers) + = pure value + | otherwise + = failure $ GlobalInputError $ incompatibleVariableType refName + varSignature + fieldSignature + refPosition + where + varSignature = render variableType + fieldSignature = render TypeRef { typeConName = tyConName + , typeWrappers = tyWrappers + , typeArgs = Nothing + } + + + -- Validate Variable Argument or all Possible input Values validateInputValue :: DataTypeLib -> [Prop] -> [TypeWrapper] -> DataType - -> (Key, Value) - -> InputValidation Value -validateInputValue lib prop' = validate + -> (Key, ResolvedValue) + -> InputValidation ValidValue +validateInputValue lib props rw datatype@DataType { typeContent, typeName } = + validateWrapped rw typeContent where - throwError :: [TypeWrapper] -> DataType -> Value -> InputValidation Value - throwError wrappers datatype value = - Left $ UnexpectedType prop' (renderWrapped datatype wrappers) value Nothing + throwError :: [TypeWrapper] -> ResolvedValue -> InputValidation ValidValue + throwError wrappers value = + Left $ UnexpectedType props (renderWrapped datatype wrappers) value Nothing -- VALIDATION - validate :: [TypeWrapper] -> DataType -> (Key, Value) -> InputValidation Value + validateWrapped + :: [TypeWrapper] + -> DataTypeContent + -> (Key, ResolvedValue) + -> InputValidation ValidValue -- Validate Null. value = null ? - validate wrappers tName (_, Null) | isNullable wrappers = return Null - | otherwise = throwError wrappers tName Null + validateWrapped wrappers _ (_, ResolvedVariable ref variable) = + checkTypeEquality (typeName, wrappers) ref variable + validateWrapped wrappers _ (_, Null) + | isNullableWrapper wrappers = return Null + | otherwise = throwError wrappers Null -- Validate LIST - validate (TypeMaybe : wrappers) type' value' = - validateInputValue lib prop' wrappers type' value' - validate (TypeList : wrappers) type' (key', List list') = - List <$> mapM validateElement list' + validateWrapped (TypeMaybe : wrappers) _ value = + validateInputValue lib props wrappers datatype value + validateWrapped (TypeList : wrappers) _ (key, List list) = + List <$> mapM validateElement list where - validateElement element' = - validateInputValue lib prop' wrappers type' (key', element') + validateElement element = + validateInputValue lib props wrappers datatype (key, element) {-- 2. VALIDATE TYPES, all wrappers are already Processed --} {-- VALIDATE OBJECT--} - validate [] (DataInputObject DataTyCon { typeData = parentFields' }) (_, Object fields) - = Object <$> mapM validateField fields + validateWrapped [] dt v = validate dt v where - validateField (_name, value) = do - (type', currentProp') <- validationData value - wrappers' <- aliasWrappers . fieldType <$> getField - value'' <- validateInputValue lib - currentProp' - wrappers' - type' - (_name, value) - return (_name, value'') + validate + :: DataTypeContent -> (Key, ResolvedValue) -> InputValidation ValidValue + validate (DataInputObject parentFields) (_, Object fields) = + traverse requiredFieldsDefined parentFields + >> Object + <$> traverse validateField fields where - validationData x = do - fieldTypeName' <- aliasTyCon . fieldType <$> getField - let currentProp = prop' ++ [Prop _name fieldTypeName'] - type' <- lookupInputType fieldTypeName' - lib - (typeMismatch x fieldTypeName' currentProp) - return (type', currentProp) - getField = lookupField _name parentFields' (UnknownField prop' _name) - -- VALIDATE INPUT UNION - -- TODO: Validate Union - validate [] (DataInputUnion DataTyCon { typeData }) (_, Object fields) = - return (Object fields) - {-- VALIDATE SCALAR --} - validate [] (DataEnum DataTyCon { typeData = tags, typeName = name' }) (_, value') - = validateEnum (UnexpectedType prop' name' value' Nothing) tags value' - {-- VALIDATE ENUM --} - validate [] (DataScalar DataTyCon { typeName = name', typeData = DataValidator { validateValue = validator' } }) (_, value') - = case validator' value' of - Right _ -> return value' - Left "" -> failure (UnexpectedType prop' name' value' Nothing) - Left errorMessage -> - Left $ UnexpectedType prop' name' value' (Just errorMessage) - {-- 3. THROW ERROR: on invalid values --} - validate wrappers datatype (_, value) = throwError wrappers datatype value + requiredFieldsDefined (fName, datafield) + | fName `elem` map fst fields || isFieldNullable datafield = pure () + | otherwise = failure (UndefinedField props fName) + validateField + :: (Name, ResolvedValue) -> InputValidation (Name, ValidValue) + validateField (_name, value) = do + (type', currentProp') <- validationData value + wrappers' <- typeWrappers . fieldType <$> getField + value'' <- validateInputValue lib + currentProp' + wrappers' + type' + (_name, value) + return (_name, value'') + where + validationData :: ResolvedValue -> InputValidation (DataType, [Prop]) + validationData x = do + fieldTypeName' <- typeConName . fieldType <$> getField + let currentProp = props ++ [Prop _name fieldTypeName'] + type' <- lookupInputType fieldTypeName' + lib + (typeMismatch x fieldTypeName' currentProp) + return (type', currentProp) + getField = lookupField _name parentFields (UnknownField props _name) + -- VALIDATE INPUT UNION + validate (DataInputUnion inputUnion) (_, Object rawFields) = + case unpackInputUnion inputUnion rawFields of + Left message -> failure + $ UnexpectedType props typeName (Object rawFields) (Just message) + Right (name, Nothing ) -> return (Object [("__typename", Enum name)]) + Right (name, Just value) -> do + currentUnionDatatype <- lookupInputType + name + lib + (typeMismatch value name props) + validValue <- validateInputValue lib + props + [TypeMaybe] + currentUnionDatatype + (name, value) + return (Object [("__typename", Enum name), (name, validValue)]) -validateEnum :: error -> [DataEnumValue] -> Value -> Either error Value + {-- VALIDATE ENUM --} + validate (DataEnum tags) (_, value) = + validateEnum (UnexpectedType props typeName value Nothing) tags value + {-- VALIDATE SCALAR --} + validate (DataScalar dataScalar) (_, value) = + validateScalar dataScalar value (UnexpectedType props typeName) + validate _ (_, value) = throwError [] value + {-- 3. THROW ERROR: on invalid values --} + validateWrapped wrappers _ (_, value) = throwError wrappers value + + +validateScalar + :: DataScalar + -> ResolvedValue + -> (ResolvedValue -> Maybe Message -> InputError) + -> InputValidation ValidValue +validateScalar DataValidator { validateValue } value err = do + scalarValue <- toScalar value + case validateValue scalarValue of + Right _ -> return scalarValue + Left "" -> failure (err value Nothing) + Left errorMessage -> failure $ err value (Just errorMessage) + where + toScalar :: ResolvedValue -> InputValidation ValidValue + toScalar (Scalar x) = pure (Scalar x) + toScalar scValue = Left (err scValue Nothing) + +validateEnum + :: error -> [DataEnumValue] -> ResolvedValue -> Either error ValidValue validateEnum gqlError enumValues (Enum enumValue) | enumValue `elem` tags = pure (Enum enumValue) | otherwise = Left gqlError where tags = map enumName enumValues validateEnum gqlError _ _ = Left gqlError -typeMismatch :: Value -> Key -> [Prop] -> InputError +typeMismatch :: ResolvedValue -> Key -> [Prop] -> InputError typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing diff --git a/src/Data/Morpheus/Validation/Query/Arguments.hs b/src/Data/Morpheus/Validation/Query/Arguments.hs --- a/src/Data/Morpheus/Validation/Query/Arguments.hs +++ b/src/Data/Morpheus/Validation/Query/Arguments.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} module Data.Morpheus.Validation.Query.Arguments ( validateArguments ) where +import Data.Maybe ( maybe ) import Data.Morpheus.Error.Arguments ( argumentGotInvalidValue , argumentNameCollision , undefinedArgument @@ -15,29 +17,30 @@ , inputErrorMessage ) import Data.Morpheus.Error.Internal ( internalUnknownTypeMessage ) -import Data.Morpheus.Error.Variable ( incompatibleVariableType - , undefinedVariable - ) -import Data.Morpheus.Rendering.RenderGQL - ( RenderGQL(..) ) +import Data.Morpheus.Error.Variable ( undefinedVariable ) import Data.Morpheus.Types.Internal.AST ( ValidVariables , Variable(..) , Argument(..) - , ValueOrigin(..) - , Arguments - , RawArgument(..) + , RawArgument , RawArguments + , ValidArgument + , ValidArguments + , Arguments , Ref(..) , Position , DataArgument , DataField(..) , DataTypeLib - , TypeAlias(..) + , TypeRef(..) , isFieldNullable - , isWeaker , lookupInputType - , Value(Null) + , Value(..) + , Name + , RawValue + , ResolvedValue + , RESOLVED + , VALID ) import Data.Morpheus.Types.Internal.Resolving ( Validation @@ -51,74 +54,86 @@ ( validateInputValue ) import Data.Text ( Text ) +-- only Resolves , doesnot checks the types +resolveObject :: Name -> ValidVariables -> RawValue -> Validation ResolvedValue +resolveObject operationName variables = resolve + where + resolve :: RawValue -> Validation ResolvedValue + resolve Null = pure Null + resolve (Scalar x ) = pure $ Scalar x + resolve (Enum x ) = pure $ Enum x + resolve (List x ) = List <$> traverse resolve x + resolve (Object obj) = Object <$> traverse mapSecond obj + where mapSecond (fName, y) = (fName, ) <$> resolve y + resolve (VariableValue ref) = + ResolvedVariable ref <$> variableByRef operationName variables ref + -- >>= checkTypeEquality ref fieldType + -- RAW | RESOLVED | Valid + +variableByRef :: Name -> ValidVariables -> Ref -> Validation (Variable VALID) +variableByRef operationName variables Ref { refName, refPosition } = maybe + variableError + pure + (lookup refName variables) + where + variableError = failure $ undefinedVariable operationName refPosition refName + + + resolveArgumentVariables - :: Text -> ValidVariables -> DataField -> RawArguments -> Validation Arguments -resolveArgumentVariables operatorName variables DataField { fieldName, fieldArgs } + :: Name + -> ValidVariables + -> DataField + -> RawArguments + -> Validation (Arguments RESOLVED) +resolveArgumentVariables operationName variables DataField { fieldName, fieldArgs } = mapM resolveVariable where - resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument) - resolveVariable (key, RawArgument argument) = pure (key, argument) - resolveVariable (key, VariableRef Ref { refName, refPosition }) = - (key, ) . toArgument <$> lookupVar - where - toArgument argumentValue = Argument { argumentValue - , argumentOrigin = VARIABLE - , argumentPosition = refPosition - } - lookupVar = case lookup refName variables of - Nothing -> failure $ undefinedVariable operatorName refPosition refName - Just Variable { variableValue, variableType, variableTypeWrappers } -> - case lookup key fieldArgs of - Nothing -> failure $ unknownArguments fieldName [Ref key refPosition] - Just DataField { fieldType = fieldT@TypeAlias { aliasTyCon, aliasWrappers } } - -> if variableType == aliasTyCon && not - (isWeaker variableTypeWrappers aliasWrappers) - then return variableValue - else failure $ incompatibleVariableType refName - varSignature - fieldSignature - refPosition - where - varSignature = renderWrapped variableType variableTypeWrappers - fieldSignature = render fieldT + resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument RESOLVED) + resolveVariable (key, Argument val position) = case lookup key fieldArgs of + Nothing -> failure $ unknownArguments fieldName [Ref key position] + Just _ -> do + constValue <- resolveObject operationName variables val + pure (key, Argument constValue position) validateArgument :: DataTypeLib -> Position - -> Arguments + -> Arguments RESOLVED -> (Text, DataArgument) - -> Validation (Text, Argument) -validateArgument lib fieldPosition requestArgs (key, argType@DataField { fieldType = TypeAlias { aliasTyCon, aliasWrappers } }) + -> Validation (Text, ValidArgument) +validateArgument lib fieldPosition requestArgs (key, argType@DataField { fieldType = TypeRef { typeConName, typeWrappers } }) = case lookup key requestArgs of Nothing -> handleNullable - Just argument@Argument { argumentOrigin = VARIABLE } -> - pure (key, argument) -- Variables are already checked in Variable Validation + -- TODO: move it in value validation + -- Just argument@Argument { argumentOrigin = VARIABLE } -> + -- pure (key, argument) -- Variables are already checked in Variable Validation Just Argument { argumentValue = Null } -> handleNullable - Just argument -> validateArgumentValue argument + Just argument -> validateArgumentValue argument where handleNullable - | isFieldNullable argType = pure - ( key - , Argument { argumentValue = Null - , argumentOrigin = INLINE - , argumentPosition = fieldPosition - } - ) - | otherwise = failure $ undefinedArgument (Ref key fieldPosition) + | isFieldNullable argType + = pure + (key, Argument { argumentValue = Null, argumentPosition = fieldPosition }) + | otherwise + = failure $ undefinedArgument (Ref key fieldPosition) ------------------------------------------------------------------------- - validateArgumentValue :: Argument -> Validation (Text, Argument) - validateArgumentValue arg@Argument { argumentValue, argumentPosition } = - lookupInputType aliasTyCon lib (internalUnknownTypeMessage aliasTyCon) - >>= checkType - >> pure (key, arg) + validateArgumentValue :: Argument RESOLVED -> Validation (Text, ValidArgument) + validateArgumentValue Argument { argumentValue = value, argumentPosition } = + do + datatype <- lookupInputType typeConName + lib + (internalUnknownTypeMessage typeConName) + argumentValue <- handleInputError + $ validateInputValue lib [] typeWrappers datatype (key, value) + pure (key, Argument { argumentValue, argumentPosition }) where - checkType type' = handleInputError - (validateInputValue lib [] aliasWrappers type' (key, argumentValue)) --------- - handleInputError :: InputValidation a -> Validation () - handleInputError (Left err) = failure - $ argumentGotInvalidValue key (inputErrorMessage err) argumentPosition - handleInputError _ = pure () + handleInputError :: InputValidation a -> Validation a + handleInputError (Left err) = failure $ case inputErrorMessage err of + Left errors -> errors + Right message -> argumentGotInvalidValue key message argumentPosition + handleInputError (Right x) = pure x validateArguments :: DataTypeLib @@ -127,14 +142,15 @@ -> (Text, DataField) -> Position -> RawArguments - -> Validation Arguments + -> Validation ValidArguments validateArguments typeLib operatorName variables (key, field@DataField { fieldArgs }) pos rawArgs = do args <- resolveArgumentVariables operatorName variables field rawArgs dataArgs <- checkForUnknownArguments args mapM (validateArgument typeLib pos args) dataArgs where - checkForUnknownArguments :: Arguments -> Validation [(Text, DataField)] + checkForUnknownArguments + :: Arguments RESOLVED -> Validation [(Text, DataField)] checkForUnknownArguments args = checkForUnknownKeys enhancedKeys fieldKeys argError >> checkNameCollision enhancedKeys argumentNameCollision @@ -142,5 +158,6 @@ where argError = unknownArguments key enhancedKeys = map argToKey args + argToKey :: (Name, Argument RESOLVED) -> Ref argToKey (key', Argument { argumentPosition }) = Ref key' argumentPosition fieldKeys = map fst fieldArgs diff --git a/src/Data/Morpheus/Validation/Query/Fragment.hs b/src/Data/Morpheus/Validation/Query/Fragment.hs --- a/src/Data/Morpheus/Validation/Query/Fragment.hs +++ b/src/Data/Morpheus/Validation/Query/Fragment.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -12,8 +13,6 @@ import Data.List ( (\\) ) import Data.Semigroup ( (<>) ) import Data.Text ( Text ) -import qualified Data.Text as T - ( concat ) -- MORPHEUS import Data.Morpheus.Error.Fragment ( cannotBeSpreadOnType @@ -26,7 +25,8 @@ import Data.Morpheus.Types.Internal.AST ( Fragment(..) , FragmentLib - , RawSelection(..) + , RawSelection + , SelectionContent(..) , Selection(..) , Ref(..) , Position @@ -69,11 +69,10 @@ castFragmentType :: Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment -castFragmentType key' position' targets' fragment@Fragment { fragmentType } = - if fragmentType `elem` targets' +castFragmentType key' position' typeMembers fragment@Fragment { fragmentType } + = if fragmentType `elem` typeMembers then pure fragment - else failure - $ cannotBeSpreadOnType key' fragmentType position' (T.concat targets') + else failure $ cannotBeSpreadOnType key' fragmentType position' typeMembers resolveSpread :: FragmentLib -> [Text] -> Ref -> Validation Fragment resolveSpread fragments allowedTargets reference@Ref { refName, refPosition } = @@ -81,27 +80,28 @@ >>= castFragmentType (Just refName) refPosition allowedTargets usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node] -usedFragments fragments = concatMap findAllUses +usedFragments fragments = concatMap (findAllUses . snd) where - findAllUses :: (Text, RawSelection) -> [Node] - findAllUses (_, RawSelectionSet Selection { selectionRec }) = - concatMap findAllUses selectionRec - findAllUses (_, InlineFragment Fragment { fragmentSelection }) = - concatMap findAllUses fragmentSelection - findAllUses (_, RawSelectionField{}) = [] - findAllUses (_, Spread Ref { refName, refPosition }) = + findAllUses :: RawSelection -> [Node] + findAllUses Selection { selectionContent = SelectionField } = [] + findAllUses Selection { selectionContent = SelectionSet selectionSet } = + concatMap (findAllUses . snd) selectionSet + findAllUses (InlineFragment Fragment { fragmentSelection }) = + concatMap (findAllUses . snd) fragmentSelection + findAllUses (Spread Ref { refName, refPosition }) = [Ref refName refPosition] <> searchInFragment where - searchInFragment = maybe [] - (concatMap findAllUses . fragmentSelection) - (lookup refName fragments) + searchInFragment = maybe + [] + (concatMap (findAllUses . snd) . fragmentSelection) + (lookup refName fragments) scanForSpread :: (Text, RawSelection) -> [Node] -scanForSpread (_, RawSelectionSet Selection { selectionRec }) = - concatMap scanForSpread selectionRec +scanForSpread (_, Selection { selectionContent = SelectionField }) = [] +scanForSpread (_, Selection { selectionContent = SelectionSet selectionSet }) = + concatMap scanForSpread selectionSet scanForSpread (_, InlineFragment Fragment { fragmentSelection = selection' }) = concatMap scanForSpread selection' -scanForSpread (_, RawSelectionField{}) = [] scanForSpread (_, Spread Ref { refName = name', refPosition = position' }) = [Ref name' position'] diff --git a/src/Data/Morpheus/Validation/Query/Selection.hs b/src/Data/Morpheus/Validation/Query/Selection.hs --- a/src/Data/Morpheus/Validation/Query/Selection.hs +++ b/src/Data/Morpheus/Validation/Query/Selection.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} @@ -22,21 +23,23 @@ ) import Data.Morpheus.Error.Variable ( unknownType ) import Data.Morpheus.Types.Internal.AST - ( ValidVariables + ( ValidVariables , Selection(..) - , SelectionRec(..) - , SelectionSet + , SelectionContent(..) + , ValidSelection + , ValidSelectionSet , Fragment(..) , FragmentLib - , RawSelection(..) + , RawSelection , RawSelectionSet , DataField(..) , Ref(..) , DataObject - , DataTyCon(..) + , DataTypeContent(..) , DataType(..) , DataTypeLib(..) - , TypeAlias(..) + , TypeRef(..) + , Name , allDataTypes , isEntNode , lookupFieldAsSelectionSet @@ -57,51 +60,52 @@ , resolveSpread ) -checkDuplicatesOn :: DataObject -> SelectionSet -> Validation SelectionSet -checkDuplicatesOn DataTyCon { typeName = name' } keys = - checkNameCollision enhancedKeys selError >> pure keys +checkDuplicatesOn :: Name -> ValidSelectionSet -> Validation ValidSelectionSet +checkDuplicatesOn typeName keys = checkNameCollision enhancedKeys selError + >> pure keys where - selError = duplicateQuerySelections name' + selError = duplicateQuerySelections typeName enhancedKeys = map selToKey keys + selToKey :: (Name, ValidSelection) -> Ref selToKey (key, Selection { selectionPosition = position', selectionAlias }) = Ref (fromMaybe key selectionAlias) position' clusterUnionSelection :: FragmentLib -> Text - -> [DataObject] + -> [Name] -> (Text, RawSelection) - -> Validation ([Fragment], SelectionSet) -clusterUnionSelection fragments type' possibleTypes' = splitFrag + -> Validation ([Fragment], ValidSelectionSet) +clusterUnionSelection fragments type' typeNames = splitFrag where packFragment fragment = return ([fragment], []) - typeNames = map typeName possibleTypes' - splitFrag :: (Text, RawSelection) -> Validation ([Fragment], SelectionSet) + splitFrag + :: (Text, RawSelection) -> Validation ([Fragment], ValidSelectionSet) splitFrag (_, Spread ref) = resolveSpread fragments typeNames ref >>= packFragment - splitFrag ("__typename", RawSelectionField selection) = pure - ( [] - , [ ( "__typename" - , selection { selectionArguments = [], selectionRec = SelectionField } - ) - ] - ) - splitFrag (key, RawSelectionSet Selection { selectionPosition }) = - failure $ cannotQueryField key type' selectionPosition - splitFrag (key, RawSelectionField Selection { selectionPosition }) = + splitFrag ("__typename", selection@Selection { selectionContent = SelectionField }) + = pure + ( [] + , [ ( "__typename" + , selection { selectionArguments = [], selectionContent = SelectionField } + ) + ] + ) + splitFrag (key, Selection { selectionPosition }) = failure $ cannotQueryField key type' selectionPosition -- splitFrag (key', RawAlias {rawAliasPosition = position'}) = failure $ cannotQueryField key' type' position' splitFrag (_, InlineFragment fragment') = castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>= packFragment -categorizeTypes :: [DataObject] -> [Fragment] -> [(DataObject, [Fragment])] +categorizeTypes + :: [(Name, DataObject)] -> [Fragment] -> [((Name, DataObject), [Fragment])] categorizeTypes types fragments = filter notEmpty $ map categorizeType types where notEmpty = (0 /=) . length . snd - categorizeType :: DataObject -> (DataObject, [Fragment]) + categorizeType :: (Name, DataObject) -> ((Name, DataObject), [Fragment]) categorizeType datatype = (datatype, filter matches fragments) - where matches fragment = fragmentType fragment == typeName datatype + where matches fragment = fragmentType fragment == fst datatype flatTuple :: [([a], [b])] -> ([a], [b]) flatTuple list' = (concatMap fst list', concatMap snd list') @@ -122,45 +126,51 @@ -> FragmentLib -> Text -> ValidVariables - -> DataObject + -> (Name, DataObject) -> RawSelectionSet - -> Validation SelectionSet + -> Validation ValidSelectionSet validateSelectionSet lib fragments' operatorName variables = __validate where - __validate dataType'@DataTyCon { typeName = typeName' } selectionSet' = + __validate + :: (Name, DataObject) -> RawSelectionSet -> Validation ValidSelectionSet + __validate dataType@(typeName, objectFields) selectionSet = concat - <$> mapM validateSelection selectionSet' - >>= checkDuplicatesOn dataType' + <$> mapM validateSelection selectionSet + >>= checkDuplicatesOn typeName where validateFragment Fragment { fragmentSelection = selection' } = - __validate dataType' selection' + __validate dataType selection' {- get dataField and validated arguments for RawSelection -} - getValidationData key Selection { selectionArguments, selectionPosition } = - do - selectionField <- lookupSelectionField selectionPosition key dataType' - -- validate field Argument ----- - arguments <- validateArguments lib - operatorName - variables - (key, selectionField) - selectionPosition - selectionArguments - -- check field Type existence ----- - fieldDataType <- lookupType - (unknownType (aliasTyCon $fieldType selectionField) selectionPosition) - (allDataTypes lib) - (aliasTyCon $ fieldType selectionField) - return (selectionField, fieldDataType, arguments) + -- getValidationData :: Name -> ValidSelection -> (DataField, DataTypeContent, ValidArguments) + getValidationData key (selectionArguments, selectionPosition) = do + selectionField <- lookupSelectionField selectionPosition + key + typeName + objectFields + -- validate field Argument ----- + arguments <- validateArguments lib + operatorName + variables + (key, selectionField) + selectionPosition + selectionArguments + -- check field Type existence ----- + fieldDataType <- lookupType + (unknownType (typeConName $fieldType selectionField) selectionPosition) + (allDataTypes lib) + (typeConName $ fieldType selectionField) + return (selectionField, fieldDataType, arguments) -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet -- - validateSelection :: (Text, RawSelection) -> Validation SelectionSet - validateSelection (key', RawSelectionSet fullRawSelection@Selection { selectionRec = rawSelection, selectionPosition }) + validateSelection :: (Text, RawSelection) -> Validation ValidSelectionSet + validateSelection (key', fullRawSelection@Selection { selectionArguments = selArgs, selectionContent = SelectionSet rawSelection, selectionPosition }) = do - (dataField, dataType, arguments) <- getValidationData key' - fullRawSelection - case dataType of + (dataField, datatype, arguments) <- getValidationData + key' + (selArgs, selectionPosition) + case typeContent datatype of DataUnion _ -> do (categories, __typename) <- clusterTypes mapM (validateCluster __typename) categories @@ -175,19 +185,22 @@ (spreads, __typename) <- flatTuple <$> mapM - (clusterUnionSelection fragments' typeName' unionTypes) + ( clusterUnionSelection fragments' typeName + $ fst + <$> unionTypes + ) rawSelection return (categorizeTypes unionTypes spreads, __typename) -- -- second arguments will be added to every selection cluster validateCluster - :: SelectionSet - -> (DataObject, [Fragment]) - -> Validation (Text, SelectionSet) + :: ValidSelectionSet + -> ((Name, DataObject), [Fragment]) + -> Validation (Text, ValidSelectionSet) validateCluster sysSelection' (type', frags') = do selection' <- __validate type' (concatMap fragmentSelection frags') - return (typeName type', sysSelection' ++ selection') + return (fst type', sysSelection' ++ selection') DataObject _ -> do fieldType' <- lookupFieldAsSelectionSet selectionPosition key' @@ -197,32 +210,29 @@ >>= returnSelection arguments . SelectionSet _ -> failure $ hasNoSubfields key' - (aliasTyCon $fieldType dataField) + (typeConName $fieldType dataField) selectionPosition where - returnSelection selectionArguments selectionRec = - pure [(key', fullRawSelection { selectionArguments, selectionRec })] - validateSelection (key, RawSelectionField rawSelection@Selection { selectionPosition }) + returnSelection selectionArguments selectionContent = + pure [(key', fullRawSelection { selectionArguments, selectionContent })] + validateSelection (key, rawSelection@Selection { selectionArguments = selArgs, selectionPosition, selectionContent = SelectionField }) = do (dataField, datatype, selectionArguments) <- getValidationData key - rawSelection - isLeaf datatype dataField + (selArgs, selectionPosition) + isLeaf (typeContent datatype) dataField pure [ ( key - , rawSelection { selectionArguments, selectionRec = SelectionField } + , rawSelection { selectionArguments, selectionContent = SelectionField } ) ] where - isLeaf dataType DataField { fieldType = TypeAlias { aliasTyCon } } - | isEntNode dataType = pure () + isLeaf datatype DataField { fieldType = TypeRef { typeConName } } + | isEntNode datatype = pure () | otherwise = failure - $ subfieldsNotSelected key aliasTyCon selectionPosition + $ subfieldsNotSelected key typeConName selectionPosition validateSelection (_, Spread reference') = - resolveSpread fragments' [typeName'] reference' >>= validateFragment + resolveSpread fragments' [typeName] reference' >>= validateFragment validateSelection (_, InlineFragment fragment') = - castFragmentType Nothing - (fragmentPosition fragment') - [typeName'] - fragment' + castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment' >>= validateFragment diff --git a/src/Data/Morpheus/Validation/Query/Validation.hs b/src/Data/Morpheus/Validation/Query/Validation.hs --- a/src/Data/Morpheus/Validation/Query/Validation.hs +++ b/src/Data/Morpheus/Validation/Query/Validation.hs @@ -13,7 +13,7 @@ ( Operation(..) , ValidOperation , getOperationName - , getOperationDataType + , getOperationObject , DataTypeLib(..) , GQLQuery(..) ) @@ -34,7 +34,7 @@ :: DataTypeLib -> VALIDATION_MODE -> GQLQuery -> Validation ValidOperation validateRequest lib validationMode GQLQuery { fragments, inputVariables, operation = rawOperation@Operation { operationName, operationType, operationSelection, operationPosition } } = do - operationDataType <- getOperationDataType rawOperation lib + operationDataType <- getOperationObject rawOperation lib variables <- resolveOperationVariables lib fragments (fromList inputVariables) @@ -49,7 +49,7 @@ operationSelection pure $ Operation { operationName , operationType - , operationArgs = [] + , operationArguments = [] , operationSelection = selection , operationPosition } diff --git a/src/Data/Morpheus/Validation/Query/Variable.hs b/src/Data/Morpheus/Validation/Query/Variable.hs --- a/src/Data/Morpheus/Validation/Query/Variable.hs +++ b/src/Data/Morpheus/Validation/Query/Variable.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -29,10 +31,12 @@ , getOperationName , Fragment(..) , FragmentLib - , RawArgument(..) - , RawSelection(..) - , RawSelectionSet + , Argument(..) + , RawArgument , Selection(..) + , SelectionContent(..) + , RawSelection + , RawSelectionSet , Ref(..) , Position , DataType @@ -40,6 +44,15 @@ , lookupInputType , Variables , Value(..) + , ValidValue + , RawValue + , ResolvedValue + , Name + , VALID + , RAW + , VariableContent(..) + , isNullable + , TypeRef(..) ) import Data.Morpheus.Types.Internal.Resolving ( Validation @@ -59,24 +72,34 @@ concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f + +class ExploreRefs a where + exploreRefs :: a -> [Ref] + +instance ExploreRefs RawValue where + exploreRefs (VariableValue ref ) = [ref] + exploreRefs (Object fields) = concatMap (exploreRefs . snd) fields + exploreRefs (List ls ) = concatMap exploreRefs ls + exploreRefs _ = [] + +instance ExploreRefs (Text, RawArgument) where + exploreRefs (_, Argument { argumentValue }) = exploreRefs argumentValue + allVariableRefs :: FragmentLib -> [RawSelectionSet] -> Validation [Ref] allVariableRefs fragmentLib = concatMapM (concatMapM searchRefs) where - referencesFromArgument :: (Text, RawArgument) -> [Ref] - referencesFromArgument (_, RawArgument{}) = [] - referencesFromArgument (_, VariableRef Ref { refName, refPosition }) = - [Ref refName refPosition] + -- | search used variables in every arguments searchRefs :: (Text, RawSelection) -> Validation [Ref] - searchRefs (_, RawSelectionSet Selection { selectionArguments, selectionRec }) - = getArgs <$> concatMapM searchRefs selectionRec + searchRefs (_, Selection { selectionArguments, selectionContent = SelectionField }) + = return $ concatMap exploreRefs selectionArguments + searchRefs (_, Selection { selectionArguments, selectionContent = SelectionSet selSet }) + = getArgs <$> concatMapM searchRefs selSet where getArgs :: [Ref] -> [Ref] - getArgs x = concatMap referencesFromArgument selectionArguments <> x + getArgs x = concatMap exploreRefs selectionArguments <> x searchRefs (_, InlineFragment Fragment { fragmentSelection }) = concatMapM searchRefs fragmentSelection - searchRefs (_, RawSelectionField Selection { selectionArguments }) = - return $ concatMap referencesFromArgument selectionArguments searchRefs (_, Spread reference) = getFragment reference fragmentLib >>= concatMapM searchRefs @@ -89,17 +112,17 @@ -> VALIDATION_MODE -> RawOperation -> Validation ValidVariables -resolveOperationVariables typeLib lib root validationMode Operation { operationName, operationSelection, operationArgs } +resolveOperationVariables typeLib lib root validationMode Operation { operationName, operationSelection, operationArguments } = do allVariableRefs lib [operationSelection] >>= checkUnusedVariables mapM (lookupAndValidateValueOnBody typeLib root validationMode) - operationArgs + operationArguments where varToKey :: (Text, Variable a) -> Ref varToKey (key', Variable { variablePosition }) = Ref key' variablePosition -- checkUnusedVariables :: [Ref] -> Validation () - checkUnusedVariables refs = case map varToKey operationArgs \\ refs of + checkUnusedVariables refs = case map varToKey operationArguments \\ refs of [] -> pure () unused' -> failure $ unusedVariables (getOperationName operationName) unused' @@ -108,40 +131,50 @@ :: DataTypeLib -> Variables -> VALIDATION_MODE - -> (Text, Variable DefaultValue) - -> Validation (Text, Variable Value) -lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType, variablePosition, isVariableRequired, variableTypeWrappers, variableValue = defaultValue }) + -> (Text, Variable RAW) + -> Validation (Text, Variable VALID) +lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType, variablePosition, variableValue = DefaultValue defaultValue }) = toVariable - <$> ( getVariableType variableType variablePosition typeLib + <$> ( getVariableType (typeConName variableType) variablePosition typeLib >>= checkType getVariable defaultValue ) where - toVariable (varKey, variableValue) = (varKey, var { variableValue }) + toVariable (varKey, x) = + (varKey, var { variableValue = ValidVariableValue x }) + getVariable :: Maybe ResolvedValue getVariable = M.lookup key bodyVariables ------------------------------------------------------------------ + -- checkType :: + checkType + :: Maybe ResolvedValue + -> DefaultValue + -> DataType + -> Validation (Name, ValidValue) checkType (Just variable) Nothing varType = validator varType variable checkType (Just variable) (Just defValue) varType = validator varType defValue >> validator varType variable checkType Nothing (Just defValue) varType = validator varType defValue checkType Nothing Nothing varType - | validationMode /= WITHOUT_VARIABLES && isVariableRequired - = failure $ uninitializedVariable variablePosition variableType key + | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) + = failure + $ uninitializedVariable variablePosition (typeConName variableType) key | otherwise = returnNull where returnNull = maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables) ----------------------------------------------------------------------------------------------- + validator :: DataType -> ResolvedValue -> Validation (Name, ValidValue) validator varType varValue = case validateInputValue typeLib [] - variableTypeWrappers + (typeWrappers variableType) varType (key, varValue) of - Left message -> failure $ variableGotInvalidValue - key - (inputErrorMessage message) - variablePosition + Left message -> failure $ case inputErrorMessage message of + Left errors -> errors + Right errMessage -> + variableGotInvalidValue key errMessage variablePosition Right value -> pure (key, value) diff --git a/test/Feature/Holistic/API.hs b/test/Feature/Holistic/API.hs --- a/test/Feature/Holistic/API.hs +++ b/test/Feature/Holistic/API.hs @@ -28,6 +28,8 @@ , ScalarValue(..) , Resolver(..) , constRes + , failRes + , liftEither ) import Data.Text ( Text ) import GHC.Generics ( Generic ) @@ -53,9 +55,19 @@ importGQLDocument "test/Feature/Holistic/schema.gql" + + +alwaysFail :: IO (Either String a) +alwaysFail = pure $ Left "fail with Either" + + rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver - { queryResolver = Query { user, testUnion = constRes Nothing } + { queryResolver = Query { user + , testUnion = constRes Nothing + , fail1 = const $ liftEither alwaysFail + , fail2 = const $ failRes "fail with failRes" + } , mutationResolver = Mutation { createUser = user } , subscriptionResolver = Subscription { newUser = const SubResolver diff --git a/test/Feature/Holistic/cases.json b/test/Feature/Holistic/cases.json --- a/test/Feature/Holistic/cases.json +++ b/test/Feature/Holistic/cases.json @@ -200,6 +200,10 @@ "description": "fail when: directive is used in Variable Definition" }, { + "path": "parsing/numbers", + "description": "parse signed numbers and numbers with expotential" + }, + { "path": "introspection/description/object", "description": "check object descriptions, type, field, args" }, @@ -222,5 +226,9 @@ { "path": "introspection/deprecated/field", "description": "check if deprecated works with object fields" + }, + { + "path": "failure/resolveFailure", + "description": "test failed resolvers" } ] diff --git a/test/Feature/Holistic/failure/resolveFailure/query.gql b/test/Feature/Holistic/failure/resolveFailure/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/failure/resolveFailure/query.gql @@ -0,0 +1,4 @@ +{ + fail1 + fail2 +} diff --git a/test/Feature/Holistic/failure/resolveFailure/response.json b/test/Feature/Holistic/failure/resolveFailure/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/failure/resolveFailure/response.json @@ -0,0 +1,12 @@ +{ + "errors": [ + { + "message": "Failure on Resolving Field \"fail1\": fail with Either", + "locations": [{ "line": 2, "column": 3 }] + }, + { + "message": "Failure on Resolving Field \"fail2\": fail with failRes", + "locations": [{ "line": 3, "column": 3 }] + } + ] +} diff --git a/test/Feature/Holistic/fragment/loopingFragment/response.json b/test/Feature/Holistic/fragment/loopingFragment/response.json --- a/test/Feature/Holistic/fragment/loopingFragment/response.json +++ b/test/Feature/Holistic/fragment/loopingFragment/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Cannot spread fragment \"A\" within itself via A,A,C.", + "message": "Cannot spread fragment \"A\" within itself via A, A, C.", "locations": [ { "line": 17, "column": 3 }, { "line": 7, "column": 10 }, diff --git a/test/Feature/Holistic/parsing/complex/response.json b/test/Feature/Holistic/parsing/complex/response.json --- a/test/Feature/Holistic/parsing/complex/response.json +++ b/test/Feature/Holistic/parsing/complex/response.json @@ -13,6 +13,10 @@ "locations": [{ "line": 15, "column": 21 }] }, { + "message": "Argument cityID got invalid value ; Expected type \"TestEnum\" found \"HH\".", + "locations": [{ "line": 15, "column": 33 }] + }, + { "message": "Cannot query field \"home\" on type \"User\".", "locations": [{ "line": 25, "column": 5 }] }, diff --git a/test/Feature/Holistic/parsing/invalidFields/response.json b/test/Feature/Holistic/parsing/invalidFields/response.json --- a/test/Feature/Holistic/parsing/invalidFields/response.json +++ b/test/Feature/Holistic/parsing/invalidFields/response.json @@ -1,13 +1,8 @@ { "errors": [ { - "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Directives, IgnoredTokens, Selection, body, digit, letter, maybeArguments, or white space\n", - "locations": [ - { - "line": 1, - "column": 27 - } - ] + "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, body, digit, letter, or white space\n", + "locations": [{ "line": 1, "column": 27 }] } ] } diff --git a/test/Feature/Holistic/parsing/numbers/query.gql b/test/Feature/Holistic/parsing/numbers/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/numbers/query.gql @@ -0,0 +1,7 @@ +{ + negative1(num: -1) + negative2(num: -20232) + negative3(num: -5.0) + exp1(num: 1.01e4) + exp2(num: 6.0221413e23) +} diff --git a/test/Feature/Holistic/parsing/numbers/response.json b/test/Feature/Holistic/parsing/numbers/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/numbers/response.json @@ -0,0 +1,24 @@ +{ + "errors": [ + { + "message": "Cannot query field \"negative1\" on type \"Query\".", + "locations": [{ "line": 2, "column": 3 }] + }, + { + "message": "Cannot query field \"negative2\" on type \"Query\".", + "locations": [{ "line": 3, "column": 3 }] + }, + { + "message": "Cannot query field \"negative3\" on type \"Query\".", + "locations": [{ "line": 4, "column": 3 }] + }, + { + "message": "Cannot query field \"exp1\" on type \"Query\".", + "locations": [{ "line": 5, "column": 3 }] + }, + { + "message": "Cannot query field \"exp2\" on type \"Query\".", + "locations": [{ "line": 6, "column": 3 }] + } + ] +} diff --git a/test/Feature/Holistic/schema.gql b/test/Feature/Holistic/schema.gql --- a/test/Feature/Holistic/schema.gql +++ b/test/Feature/Holistic/schema.gql @@ -92,6 +92,8 @@ type Query { user: User! testUnion: TestUnion + fail1: String! + fail2: Int! } type Mutation { diff --git a/test/Feature/Input/Object/API.hs b/test/Feature/Input/Object/API.hs new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/API.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Feature.Input.Object.API + ( api + ) +where + +import Data.Morpheus ( interpreter ) +import Data.Morpheus.Types ( GQLRequest + , GQLResponse + , GQLRootResolver(..) + , GQLType(..) + , Undefined(..) + ) +import GHC.Generics ( Generic ) +import Data.Morpheus.Kind ( INPUT ) +import Data.Text ( Text + , pack + ) + + +data InputObject = InputObject { + field :: Text, + nullableField :: Maybe Int +} deriving (Generic, Show) + +instance GQLType InputObject where + type KIND InputObject = INPUT + +-- types & args +newtype Arg a = Arg + { value :: a + } deriving (Generic, Show) + +-- query +testRes :: Show a => Applicative m => Arg a -> m Text +testRes Arg { value } = pure $ pack $ show value + +-- resolver +newtype Query m = Query + { input :: Arg InputObject -> m Text + } deriving (Generic, GQLType) + +rootResolver :: GQLRootResolver IO () Query Undefined Undefined +rootResolver = GQLRootResolver { queryResolver = Query { input = testRes } + , mutationResolver = Undefined + , subscriptionResolver = Undefined + } + +api :: GQLRequest -> IO GQLResponse +api = interpreter rootResolver diff --git a/test/Feature/Input/Object/cases.json b/test/Feature/Input/Object/cases.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/cases.json @@ -0,0 +1,30 @@ +[ + { + "path": "undefinedField", + "description": "fail when field was not provided" + }, + { + "path": "nullableUndefinedField", + "description": "dont fail when nullable field was not provided" + }, + { + "path": "unknownField", + "description": "fail on unknown field" + }, + { + "path": "unexpectedValue", + "description": "fail on value with unexpected type" + }, + { + "path": "unexpectedVariable", + "description": "fail on use of variable with unexpected type" + }, + { + "path": "resolveVariable", + "description": "resolve by variable" + }, + { + "path": "resolveObject", + "description": "resolve object" + } +] diff --git a/test/Feature/Input/Object/nullableUndefinedField/query.gql b/test/Feature/Input/Object/nullableUndefinedField/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/nullableUndefinedField/query.gql @@ -0,0 +1,3 @@ +query NullableUndefinedField { + input(value: { field: "value" }) +} diff --git a/test/Feature/Input/Object/nullableUndefinedField/response.json b/test/Feature/Input/Object/nullableUndefinedField/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/nullableUndefinedField/response.json @@ -0,0 +1,5 @@ +{ + "data": { + "input": "InputObject {field = \"value\", nullableField = Nothing}" + } +} diff --git a/test/Feature/Input/Object/resolveObject/query.gql b/test/Feature/Input/Object/resolveObject/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/resolveObject/query.gql @@ -0,0 +1,4 @@ +query ResolveObject { + i1: input(value: { field: "v1", nullableField: 123 }) + i2: input(value: { field: "v2" }) +} diff --git a/test/Feature/Input/Object/resolveObject/response.json b/test/Feature/Input/Object/resolveObject/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/resolveObject/response.json @@ -0,0 +1,6 @@ +{ + "data": { + "i1": "InputObject {field = \"v1\", nullableField = Just 123}", + "i2": "InputObject {field = \"v2\", nullableField = Nothing}" + } +} diff --git a/test/Feature/Input/Object/resolveVariable/query.gql b/test/Feature/Input/Object/resolveVariable/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/resolveVariable/query.gql @@ -0,0 +1,4 @@ +query ResolveVariable($v1: String!, $v2: Int!, $v3: Int) { + i1: input(value: { field: $v1, nullableField: $v2 }) + i2: input(value: { field: "", nullableField: $v3 }) +} diff --git a/test/Feature/Input/Object/resolveVariable/response.json b/test/Feature/Input/Object/resolveVariable/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/resolveVariable/response.json @@ -0,0 +1,6 @@ +{ + "data": { + "i1": "InputObject {field = \"string from variable\", nullableField = Just 123011}", + "i2": "InputObject {field = \"\", nullableField = Nothing}" + } +} diff --git a/test/Feature/Input/Object/resolveVariable/variables.json b/test/Feature/Input/Object/resolveVariable/variables.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/resolveVariable/variables.json @@ -0,0 +1,4 @@ +{ + "v1": "string from variable", + "v2": 123011 +} diff --git a/test/Feature/Input/Object/undefinedField/query.gql b/test/Feature/Input/Object/undefinedField/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/undefinedField/query.gql @@ -0,0 +1,4 @@ +query UndefinedField { + i1: input(value: { nullableField: 1 }) + i2: input(value: {}) +} diff --git a/test/Feature/Input/Object/undefinedField/response.json b/test/Feature/Input/Object/undefinedField/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/undefinedField/response.json @@ -0,0 +1,12 @@ +{ + "errors": [ + { + "message": "Argument value got invalid value ; Undefined Field \"field\".", + "locations": [{ "line": 2, "column": 20 }] + }, + { + "message": "Argument value got invalid value ; Undefined Field \"field\".", + "locations": [{ "line": 3, "column": 20 }] + } + ] +} diff --git a/test/Feature/Input/Object/unexpectedValue/query.gql b/test/Feature/Input/Object/unexpectedValue/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/unexpectedValue/query.gql @@ -0,0 +1,6 @@ +query UnexpectedValue { + i1: input(value: "some text") + i2: input(value: 1) + i3: input(value: { field: {} }) + i4: input(value: { field: 3 }) +} diff --git a/test/Feature/Input/Object/unexpectedValue/response.json b/test/Feature/Input/Object/unexpectedValue/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/unexpectedValue/response.json @@ -0,0 +1,20 @@ +{ + "errors": [ + { + "message": "Argument value got invalid value ; Expected type \"InputObject!\" found \"some text\".", + "locations": [{ "line": 2, "column": 20 }] + }, + { + "message": "Argument value got invalid value ; Expected type \"InputObject!\" found 1.", + "locations": [{ "line": 3, "column": 20 }] + }, + { + "message": "Argument value got invalid value ;on field Expected type \"String\" found {}.", + "locations": [{ "line": 4, "column": 20 }] + }, + { + "message": "Argument value got invalid value ;on field Expected type \"String\" found 3.", + "locations": [{ "line": 5, "column": 20 }] + } + ] +} diff --git a/test/Feature/Input/Object/unexpectedVariable/query.gql b/test/Feature/Input/Object/unexpectedVariable/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/unexpectedVariable/query.gql @@ -0,0 +1,4 @@ +query Unexpectedvariable($v1: String, $v2: String) { + i1: input(value: { field: $v1, nullableField: 1 }) + i2: input(value: { field: "", nullableField: $v2 }) +} diff --git a/test/Feature/Input/Object/unexpectedVariable/response.json b/test/Feature/Input/Object/unexpectedVariable/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/unexpectedVariable/response.json @@ -0,0 +1,12 @@ +{ + "errors": [ + { + "message": "Variable \"$v1\" of type \"String\" used in position expecting type \"String!\".", + "locations": [{ "line": 2, "column": 29 }] + }, + { + "message": "Variable \"$v2\" of type \"String\" used in position expecting type \"Int\".", + "locations": [{ "line": 3, "column": 48 }] + } + ] +} diff --git a/test/Feature/Input/Object/unknownField/query.gql b/test/Feature/Input/Object/unknownField/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/unknownField/query.gql @@ -0,0 +1,3 @@ +query UndefinedField { + input(value: { moo: 1, field: "some field" }) +} diff --git a/test/Feature/Input/Object/unknownField/response.json b/test/Feature/Input/Object/unknownField/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Object/unknownField/response.json @@ -0,0 +1,8 @@ +{ + "errors": [ + { + "message": "Argument value got invalid value ; Unknown Field \"moo\".", + "locations": [{ "line": 2, "column": 16 }] + } + ] +} diff --git a/test/Feature/Input/Scalar/API.hs b/test/Feature/Input/Scalar/API.hs new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Scalar/API.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Feature.Input.Scalar.API + ( api + ) +where + +import Data.Morpheus ( interpreter ) +import Data.Morpheus.Types ( GQLRequest + , GQLResponse + , GQLRootResolver(..) + , GQLType(..) + , Undefined(..) + ) +import GHC.Generics ( Generic ) + +-- types & args +newtype Arg a = Arg + { value :: a + } deriving (Generic, Show) + +-- query +testRes :: Applicative m => Arg a -> m a +testRes Arg { value } = pure value + +-- resolver +data Query m = Query + { testFloat :: Arg Float -> m Float + , testInt :: Arg Int -> m Int + } deriving (Generic, GQLType) + +rootResolver :: GQLRootResolver IO () Query Undefined Undefined +rootResolver = GQLRootResolver + { queryResolver = Query { testFloat = testRes, testInt = testRes } + , mutationResolver = Undefined + , subscriptionResolver = Undefined + } + +api :: GQLRequest -> IO GQLResponse +api = interpreter rootResolver diff --git a/test/Feature/Input/Scalar/cases.json b/test/Feature/Input/Scalar/cases.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Scalar/cases.json @@ -0,0 +1,10 @@ +[ + { + "path": "decodeFloat", + "description": "test signed float and float with expotential" + }, + { + "path": "decodeInt", + "description": "test signed int and int with expotential" + } +] diff --git a/test/Feature/Input/Scalar/decodeFloat/query.gql b/test/Feature/Input/Scalar/decodeFloat/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Scalar/decodeFloat/query.gql @@ -0,0 +1,7 @@ +query ValidDecoding { + one: testFloat(value: 1.00) + negOne: testFloat(value: -1) + negNummber: testFloat(value: -1.235) + expNumber: testFloat(value: 0.3e5) + negExpNumber: testFloat(value: - 0.12e-35) +} diff --git a/test/Feature/Input/Scalar/decodeFloat/response.json b/test/Feature/Input/Scalar/decodeFloat/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Scalar/decodeFloat/response.json @@ -0,0 +1,9 @@ +{ + "data": { + "one": 1, + "negOne": -1, + "negNummber": -1.235, + "expNumber": 30000, + "negExpNumber": -1.2e-36 + } +} diff --git a/test/Feature/Input/Scalar/decodeInt/query.gql b/test/Feature/Input/Scalar/decodeInt/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Scalar/decodeInt/query.gql @@ -0,0 +1,7 @@ +query ValidDecoding { + one: testInt(value: 1) + negOne: testInt(value: -1) + negNummber: testInt(value: -1235) + expNumber: testInt(value: 123e5) + negExpNumber: testInt(value: - 123e5) +} diff --git a/test/Feature/Input/Scalar/decodeInt/response.json b/test/Feature/Input/Scalar/decodeInt/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Input/Scalar/decodeInt/response.json @@ -0,0 +1,9 @@ +{ + "data": { + "one": 1, + "negOne": -1, + "negNummber": -1235, + "expNumber": 12300000, + "negExpNumber": -12300000 + } +} diff --git a/test/Feature/TypeInference/API.hs b/test/Feature/TypeInference/API.hs new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/API.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Feature.TypeInference.API + ( api + ) +where + +import Data.Morpheus ( interpreter ) +import Data.Morpheus.Kind ( INPUT ) +import Data.Morpheus.Types ( GQLRequest + , GQLResponse + , GQLRootResolver(..) + , GQLType(..) + , Undefined(..) + ) +import Data.Text ( Text + , pack + ) +import GHC.Generics ( Generic ) + +data Power = Thunderbolts | Shapeshift | Hurricanes + deriving (Generic,GQLType) + +data Deity = Deity { + name :: Text , + power :: Power +} deriving(Generic,GQLType) + +deityRes :: Deity +deityRes = Deity { name = "Morpheus", power = Shapeshift } + +data Hydra = Hydra { + name :: Text, + age :: Int +} deriving (Show,Generic) + +instance GQLType Hydra where + type KIND Hydra = INPUT + +data Monster = + MonsterHydra Hydra + | Cerberus { name :: Text } + | UnidentifiedMonster + deriving (Show, Generic) + +instance GQLType Monster where + type KIND Monster = INPUT + +data Character = + CharacterDeity Deity -- Only should generate direct link + -- RECORDS + | Creature { creatureName :: Text, creatureAge :: Int } + | BoxedDeity { boxedDeity :: Deity} + | ScalarRecord { scalarText :: Text } + --- Types + | CharacterInt Int -- all scalars mus be boxed + -- Types + | SomeDeity Deity + | SomeMutli Int Text + --- ENUMS + | Zeus + | Cronus deriving (Generic, GQLType) + + + +newtype MonsterArgs = MonsterArgs { + monster :: Monster +} deriving (Generic) + +data Query (m :: * -> *) = Query + { deity :: Deity, + character :: [Character], + showMonster :: MonsterArgs -> m Text + } deriving (Generic, GQLType) + +rootResolver :: GQLRootResolver IO () Query Undefined Undefined +rootResolver = GQLRootResolver + { queryResolver = Query { deity = deityRes, character, showMonster } + , mutationResolver = Undefined + , subscriptionResolver = Undefined + } + where + showMonster MonsterArgs { monster } = pure (pack $ show monster) + character :: [Character] + character = + [ CharacterDeity deityRes + , Creature { creatureName = "Lamia", creatureAge = 205 } + , BoxedDeity { boxedDeity = deityRes } + , ScalarRecord { scalarText = "Some Text" } + --- + , SomeDeity deityRes + , CharacterInt 12 + , SomeMutli 21 "some text" + , Zeus + , Cronus + ] + + +api :: GQLRequest -> IO GQLResponse +api = interpreter rootResolver diff --git a/test/Feature/TypeInference/cases.json b/test/Feature/TypeInference/cases.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/cases.json @@ -0,0 +1,50 @@ +[ + { + "path": "introspection/object", + "description": "derives simple gql object type" + }, + { + "path": "introspection/enum", + "description": "derive as gql enum, if type has only empty constructors" + }, + { + "path": "introspection/complexUnion", + "description": "derive complex union" + }, + { + "path": "introspection/complexUnionEnum", + "description": "complex union enum contains, actual enums with empty constructors and enum object wrapper" + }, + { + "path": "introspection/complexUnionRecord", + "description": "creates object type for every union records" + }, + { + "path": "introspection/complexUnionScalar", + "description": "all scalar unions must be boxed" + }, + { + "path": "introspection/complexUnionIndexedTypes", + "description": "all types without record syntax(indexed types), will be converted to gql object with fields _0,_1...." + }, + { + "path": "introspection/inputObject", + "description": "introspect input object" + }, + { + "path": "introspection/complexInput", + "description": "introspect complex input" + }, + { + "path": "resolving/object", + "description": "resolve regular object" + }, + { + "path": "resolving/complexUnion", + "description": "resolve regular object" + }, + { + "path": "resolving/input", + "description": "resolve input" + } +] diff --git a/test/Feature/TypeInference/introspection/complexInput/query.gql b/test/Feature/TypeInference/introspection/complexInput/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexInput/query.gql @@ -0,0 +1,79 @@ +query Get__Type { + __type(name: "Monster") { + ...FullType + } + tags: __type(name: "MonsterTags") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexInput/response.json b/test/Feature/TypeInference/introspection/complexInput/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexInput/response.json @@ -0,0 +1,58 @@ +{ + "data": { + "__type": { + "kind": "INPUT_OBJECT", + "name": "Monster", + "fields": null, + "inputFields": [ + { + "name": "__typename", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "ENUM", "name": "MonsterTags", "ofType": null } + }, + "defaultValue": null + }, + { + "name": "Hydra", + "type": { "kind": "INPUT_OBJECT", "name": "Hydra", "ofType": null }, + "defaultValue": null + }, + { + "name": "Cerberus", + "type": { + "kind": "INPUT_OBJECT", + "name": "Cerberus", + "ofType": null + }, + "defaultValue": null + } + ], + "interfaces": null, + "enumValues": null, + "possibleTypes": null + }, + "tags": { + "kind": "ENUM", + "name": "MonsterTags", + "fields": null, + "inputFields": null, + "interfaces": null, + "enumValues": [ + { "name": "Hydra", "isDeprecated": false, "deprecationReason": null }, + { + "name": "Cerberus", + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "UnidentifiedMonster", + "isDeprecated": false, + "deprecationReason": null + } + ], + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnion/query.gql b/test/Feature/TypeInference/introspection/complexUnion/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnion/query.gql @@ -0,0 +1,76 @@ +query Get__Type { + __type(name: "Character") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnion/response.json b/test/Feature/TypeInference/introspection/complexUnion/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnion/response.json @@ -0,0 +1,22 @@ +{ + "data": { + "__type": { + "kind": "UNION", + "name": "Character", + "fields": null, + "inputFields": null, + "interfaces": null, + "enumValues": null, + "possibleTypes": [ + { "kind": "OBJECT", "name": "Deity", "ofType": null }, + { "kind": "OBJECT", "name": "CharacterEnumObject", "ofType": null }, + { "kind": "OBJECT", "name": "Creature", "ofType": null }, + { "kind": "OBJECT", "name": "BoxedDeity", "ofType": null }, + { "kind": "OBJECT", "name": "ScalarRecord", "ofType": null }, + { "kind": "OBJECT", "name": "CharacterInt", "ofType": null }, + { "kind": "OBJECT", "name": "SomeDeity", "ofType": null }, + { "kind": "OBJECT", "name": "SomeMutli", "ofType": null } + ] + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionEnum/query.gql b/test/Feature/TypeInference/introspection/complexUnionEnum/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionEnum/query.gql @@ -0,0 +1,79 @@ +query Get__Type { + enumObject: __type(name: "CharacterEnumObject") { + ...FullType + } + enum: __type(name: "CharacterEnum") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionEnum/response.json b/test/Feature/TypeInference/introspection/complexUnionEnum/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionEnum/response.json @@ -0,0 +1,41 @@ +{ + "data": { + "enumObject": { + "kind": "OBJECT", + "name": "CharacterEnumObject", + "fields": [ + { + "name": "enum", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { + "kind": "ENUM", + "name": "CharacterEnum", + "ofType": null + } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + }, + "enum": { + "kind": "ENUM", + "name": "CharacterEnum", + "fields": null, + "inputFields": null, + "interfaces": null, + "enumValues": [ + { "name": "Zeus", "isDeprecated": false, "deprecationReason": null }, + { "name": "Cronus", "isDeprecated": false, "deprecationReason": null } + ], + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionIndexedTypes/query.gql b/test/Feature/TypeInference/introspection/complexUnionIndexedTypes/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionIndexedTypes/query.gql @@ -0,0 +1,79 @@ +query Get__Type { + someDeity: __type(name: "SomeDeity") { + ...FullType + } + someMutli: __type(name: "SomeMutli") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionIndexedTypes/response.json b/test/Feature/TypeInference/introspection/complexUnionIndexedTypes/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionIndexedTypes/response.json @@ -0,0 +1,57 @@ +{ + "data": { + "someDeity": { + "kind": "OBJECT", + "name": "SomeDeity", + "fields": [ + { + "name": "_0", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "OBJECT", "name": "Deity", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + }, + "someMutli": { + "kind": "OBJECT", + "name": "SomeMutli", + "fields": [ + { + "name": "_0", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "Int", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "_1", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionRecord/query.gql b/test/Feature/TypeInference/introspection/complexUnionRecord/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionRecord/query.gql @@ -0,0 +1,82 @@ +query Get__Type { + creature: __type(name: "Creature") { + ...FullType + } + boxedDeity: __type(name: "BoxedDeity") { + ...FullType + } + scalarRecord: __type(name: "ScalarRecord") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionRecord/response.json b/test/Feature/TypeInference/introspection/complexUnionRecord/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionRecord/response.json @@ -0,0 +1,78 @@ +{ + "data": { + "creature": { + "kind": "OBJECT", + "name": "Creature", + "fields": [ + { + "name": "creatureName", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "creatureAge", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "Int", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + }, + "boxedDeity": { + "kind": "OBJECT", + "name": "BoxedDeity", + "fields": [ + { + "name": "boxedDeity", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "OBJECT", "name": "Deity", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + }, + "scalarRecord": { + "kind": "OBJECT", + "name": "ScalarRecord", + "fields": [ + { + "name": "scalarText", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionScalar/query.gql b/test/Feature/TypeInference/introspection/complexUnionScalar/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionScalar/query.gql @@ -0,0 +1,76 @@ +query Get__Type { + __type(name: "CharacterInt") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/complexUnionScalar/response.json b/test/Feature/TypeInference/introspection/complexUnionScalar/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/complexUnionScalar/response.json @@ -0,0 +1,25 @@ +{ + "data": { + "__type": { + "kind": "OBJECT", + "name": "CharacterInt", + "fields": [ + { + "name": "_0", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "Int", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/enum/query.gql b/test/Feature/TypeInference/introspection/enum/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/enum/query.gql @@ -0,0 +1,76 @@ +query Get__Type { + __type(name: "Power") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/enum/response.json b/test/Feature/TypeInference/introspection/enum/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/enum/response.json @@ -0,0 +1,29 @@ +{ + "data": { + "__type": { + "kind": "ENUM", + "name": "Power", + "fields": null, + "inputFields": null, + "interfaces": null, + "enumValues": [ + { + "name": "Thunderbolts", + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "Shapeshift", + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "Hurricanes", + "isDeprecated": false, + "deprecationReason": null + } + ], + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/inputObject/query.gql b/test/Feature/TypeInference/introspection/inputObject/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/inputObject/query.gql @@ -0,0 +1,76 @@ +query Get__Type { + __type(name: "Hydra") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/inputObject/response.json b/test/Feature/TypeInference/introspection/inputObject/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/inputObject/response.json @@ -0,0 +1,32 @@ +{ + "data": { + "__type": { + "kind": "INPUT_OBJECT", + "name": "Hydra", + "fields": null, + "inputFields": [ + { + "name": "name", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "defaultValue": null + }, + { + "name": "age", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "Int", "ofType": null } + }, + "defaultValue": null + } + ], + "interfaces": null, + "enumValues": null, + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/introspection/object/query.gql b/test/Feature/TypeInference/introspection/object/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/object/query.gql @@ -0,0 +1,76 @@ +query Get__Type { + __type(name: "Deity") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/TypeInference/introspection/object/response.json b/test/Feature/TypeInference/introspection/object/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/introspection/object/response.json @@ -0,0 +1,36 @@ +{ + "data": { + "__type": { + "kind": "OBJECT", + "name": "Deity", + "fields": [ + { + "name": "name", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "power", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "ENUM", "name": "Power", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [], + "enumValues": null, + "possibleTypes": null + } + } +} diff --git a/test/Feature/TypeInference/resolving/complexUnion/query.gql b/test/Feature/TypeInference/resolving/complexUnion/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/resolving/complexUnion/query.gql @@ -0,0 +1,45 @@ +{ + character { + ## regular union + __typename + ... on Deity { + name + } + + ## union Enums + ... on CharacterEnumObject { + enum + } + + ... on Creature { + creatureName + creatureAge + } + + ... on BoxedDeity { + boxedDeity { + power + } + } + + ... on ScalarRecord { + scalarText + } + + ... on CharacterInt { + _0 + } + + ... on SomeDeity { + _0 { + name + power + } + } + + ... on SomeMutli { + _0 + _1 + } + } +} diff --git a/test/Feature/TypeInference/resolving/complexUnion/response.json b/test/Feature/TypeInference/resolving/complexUnion/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/resolving/complexUnion/response.json @@ -0,0 +1,18 @@ +{ + "data": { + "character": [ + { "__typename": "Deity", "name": "Morpheus" }, + { "__typename": "Creature", "creatureName": "Lamia", "creatureAge": 205 }, + { "__typename": "BoxedDeity", "boxedDeity": { "power": "Shapeshift" } }, + { "__typename": "ScalarRecord", "scalarText": "Some Text" }, + { + "__typename": "SomeDeity", + "_0": { "name": "Morpheus", "power": "Shapeshift" } + }, + { "__typename": "CharacterInt", "_0": 12 }, + { "__typename": "SomeMutli", "_0": 21, "_1": "some text" }, + { "__typename": "CharacterEnumObject", "enum": "Zeus" }, + { "__typename": "CharacterEnumObject", "enum": "Cronus" } + ] + } +} diff --git a/test/Feature/TypeInference/resolving/input/query.gql b/test/Feature/TypeInference/resolving/input/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/resolving/input/query.gql @@ -0,0 +1,9 @@ +{ + object: showMonster( + monster: { __typename: Hydra, Hydra: { name: "someName", age: 12 } } + ) + record: showMonster( + monster: { __typename: Cerberus, Cerberus: { name: "someName" } } + ) + enum: showMonster(monster: { __typename: UnidentifiedMonster }) +} diff --git a/test/Feature/TypeInference/resolving/input/response.json b/test/Feature/TypeInference/resolving/input/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/resolving/input/response.json @@ -0,0 +1,7 @@ +{ + "data": { + "object": "MonsterHydra (Hydra {name = \"someName\", age = 12})", + "record": "Cerberus {name = \"someName\"}", + "enum": "UnidentifiedMonster" + } +} diff --git a/test/Feature/TypeInference/resolving/object/query.gql b/test/Feature/TypeInference/resolving/object/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/resolving/object/query.gql @@ -0,0 +1,6 @@ +{ + deity { + name + power + } +} diff --git a/test/Feature/TypeInference/resolving/object/response.json b/test/Feature/TypeInference/resolving/object/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/TypeInference/resolving/object/response.json @@ -0,0 +1,1 @@ +{ "data": { "deity": { "name": "Morpheus", "power": "Shapeshift" } } } diff --git a/test/Feature/UnionType/API.hs b/test/Feature/UnionType/API.hs --- a/test/Feature/UnionType/API.hs +++ b/test/Feature/UnionType/API.hs @@ -6,14 +6,22 @@ module Feature.UnionType.API ( api - ) where + ) +where -import Data.Morpheus (interpreter) -import Data.Morpheus.Kind (OBJECT, UNION) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes, - Undefined (..)) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Morpheus ( interpreter ) +import Data.Morpheus.Kind ( OBJECT + , UNION + ) +import Data.Morpheus.Types ( GQLRequest + , GQLResponse + , GQLRootResolver(..) + , GQLType(..) + , IORes + , Undefined(..) + ) +import Data.Text ( Text ) +import GHC.Generics ( Generic ) instance GQLType A where type KIND A = OBJECT @@ -24,8 +32,8 @@ instance GQLType C where type KIND C = OBJECT -instance GQLType AOrB where - type KIND AOrB = UNION +instance GQLType Sum where + type KIND Sum = UNION data A = A { aText :: Text @@ -42,26 +50,28 @@ , cInt :: Int } deriving (Generic) -data AOrB - = A' A - | B' B +data Sum + = SumA A + | SumB B deriving (Generic) data Query m = Query - { union :: () -> m [AOrB] + { union :: () -> m [Sum] , fc :: C } deriving (Generic, GQLType) -resolveUnion :: () -> IORes () [AOrB] -resolveUnion _ = return [A' A {aText = "at", aInt = 1}, B' B {bText = "bt", bInt = 2}] +resolveUnion :: () -> IORes () [Sum] +resolveUnion _ = + return [SumA A { aText = "at", aInt = 1 }, SumB B { bText = "bt", bInt = 2 }] rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = - GQLRootResolver - { queryResolver = Query {union = resolveUnion, fc = C {cText = "", cInt = 3}} - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } +rootResolver = GQLRootResolver + { queryResolver = Query { union = resolveUnion + , fc = C { cText = "", cInt = 3 } + } + , mutationResolver = Undefined + , subscriptionResolver = Undefined + } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/UnionType/cannotBeSpreadOnType/response.json b/test/Feature/UnionType/cannotBeSpreadOnType/response.json --- a/test/Feature/UnionType/cannotBeSpreadOnType/response.json +++ b/test/Feature/UnionType/cannotBeSpreadOnType/response.json @@ -1,9 +1,13 @@ { - "errors": [{ - "message": "Fragment \"FC\" cannot be spread here as objects of type \"AB\" can never be of type \"C\".", - "locations": [{ - "line": 3, - "column": 5 - }] - }] + "errors": [ + { + "message": "Fragment \"FC\" cannot be spread here as objects of type \"A, B\" can never be of type \"C\".", + "locations": [ + { + "line": 3, + "column": 5 + } + ] + } + ] } diff --git a/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json --- a/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json +++ b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Fragment cannot be spread here as objects of type \"AB\" can never be of type \"C\".", + "message": "Fragment cannot be spread here as objects of type \"A, B\" can never be of type \"C\".", "locations": [ { "line": 3, diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,27 +2,56 @@ module Main ( main - ) where + ) +where -import qualified Feature.Holistic.API as Holistic (api) -import qualified Feature.Input.Enum.API as InputEnum (api) -import qualified Feature.InputType.API as InputType (api) -import qualified Feature.Schema.API as Schema (api) -import qualified Feature.UnionType.API as UnionType (api) -import qualified Feature.WrappedTypeName.API as TypeName (api) -import Rendering.TestSchemaRendering (testSchemaRendering) -import Test.Tasty (defaultMain, testGroup) -import TestFeature (testFeature) +import qualified Feature.Holistic.API as Holistic + ( api ) +import qualified Feature.Input.Enum.API as InputEnum + ( api ) +import qualified Feature.Input.Scalar.API as InputScalar + ( api ) +import qualified Feature.Input.Object.API as InputObject + ( api ) +import qualified Feature.InputType.API as InputType + ( api ) +import qualified Feature.Schema.API as Schema + ( api ) +import qualified Feature.UnionType.API as UnionType + ( api ) +import qualified Feature.WrappedTypeName.API as TypeName + ( api ) +import qualified Feature.TypeInference.API as Inference + ( api ) +import Rendering.TestSchemaRendering ( testSchemaRendering ) +import Test.Tasty ( defaultMain + , testGroup + ) +import TestFeature ( testFeature ) main :: IO () main = do - ioTests <- testFeature Holistic.api "Feature/Holistic" - unionTest <- testFeature UnionType.api "Feature/UnionType" - inputTest <- testFeature InputType.api "Feature/InputType" - schemaTest <- testFeature Schema.api "Feature/Schema" - typeName <- testFeature TypeName.api "Feature/WrappedTypeName" - inputEnum <- testFeature InputEnum.api "Feature/Input/Enum" + ioTests <- testFeature Holistic.api "Feature/Holistic" + unionTest <- testFeature UnionType.api "Feature/UnionType" + inputTest <- testFeature InputType.api "Feature/InputType" + schemaTest <- testFeature Schema.api "Feature/Schema" + typeName <- testFeature TypeName.api "Feature/WrappedTypeName" + inputEnum <- testFeature InputEnum.api "Feature/Input/Enum" + inputScalar <- testFeature InputScalar.api "Feature/Input/Scalar" + inputObject <- testFeature InputObject.api "Feature/Input/Object" + inference <- testFeature Inference.api "Feature/TypeInference" defaultMain (testGroup - "Morpheus Graphql Tests" - [ioTests, unionTest, inputTest, schemaTest, typeName, inputEnum, testSchemaRendering]) + "Morpheus Graphql Tests" + [ ioTests + , unionTest + , inputTest + , schemaTest + , typeName + , inputEnum + , inputScalar + , inputObject + , testSchemaRendering + , inference + ] + )