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.10.0 + - morpheus-graphql-0.11.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update` @@ -53,7 +53,7 @@ Description for name """ name: String! - power: String String! @deprecated(reason: "some reason for") + power: String @deprecated(reason: "some reason for") } ``` @@ -76,7 +76,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Document (importGQLDocumentWithNamespace) -import Data.Morpheus.Types (GQLRootResolver (..), IORes) +import Data.Morpheus.Types (GQLRootResolver (..), IORes, Undefined(..)) import Data.Text (Text) importGQLDocumentWithNamespace "schema.gql" @@ -253,12 +253,12 @@ ```gql union Character = - Deity # unwrapped union: becouse Character + Deity = CharacterDeity + Deity # unwrapped union: because "Character" <> "Deity" == "CharacterDeity" | Creature - | SomeDeity # wrapped union: becouse Character + Deity != SomeDeity + | SomeDeity # wrapped union: because "Character" <> "Deity" /= SomeDeity | CharacterInt | SomeMutli - | CharacterEnumObject # object wrapped for enums + | CharacterEnumObject # no-argument constructors all wrapped into an enum type Creature { creatureName: String! @@ -289,10 +289,60 @@ } ``` -- namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union - -- for all other unions will be generated new object type. for types without record syntaxt, fields will be automatally indexed. +By default, union members will be generated with wrapper objects. +There is one exception to this: if a constructor of a type is the type name concatinated with the name of the contained type, it will be referenced directly. +That is, given: +```haskell +data Song = { songName :: Text, songDuration :: Float } deriving (Generic, GQLType) + +data Skit = { skitName :: Text, skitDuration :: Float } deriving (Generic, GQLType) + +data WrappedNode + = WrappedSong Song + | WrappedSkit Skit + deriving (Generic, GQLType) + +data NonWrapped + = NonWrappedSong Song + | NonWrappedSkit Skit + deriving (Generic, GQLType) + +``` + +You will get the following schema: + + +```gql + +# has wrapper types +union WrappedNode = WrappedSong | WrappedSkit + +# is a direct union +union NonWrapped = Song | Skit + +type WrappedSong { + _0: Song! +} + +type WrappedSKit { + _0: Skit! +} + +type Song { + songDuration: Float! + songName: String! +} + +type Skit { + skitDuration: Float! + skitName: String! +} + +``` + +- for all other unions will be generated new object type. for types without record syntax, 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 @@ -361,7 +411,7 @@ ### Mutations -In addition to queries, Morpheus also supports mutations. The behave just like regular queries and are defined similarly: +In addition to queries, Morpheus also supports mutations. They behave just like regular queries and are defined similarly: ```haskell newtype Mutation m = Mutation @@ -386,7 +436,7 @@ ### Subscriptions -im morpheus subscription and mutation communicating with Events, +In morpheus subscription and mutation communicate with Events, `Event` consists with user defined `Channel` and `Content`. Every subscription has its own Channel by which it will be triggered @@ -467,7 +517,14 @@ type Deity { name: String! worships: Deity + power: Power! } + +enum Power { + Lightning + Teleportation + Omniscience +} ``` will validate query and Generate: @@ -484,6 +541,7 @@ data DeityDeity = DeityDeity { name: Text, worships: Maybe DeityWorshipsDeity + power: Power } -- from: {deity{worships @@ -491,6 +549,11 @@ name: Text, } +data Power = + PowerLightning + | PowerTeleportation + | PowerOmniscience + data GetHeroArgs = GetHeroArgs { getHeroArgsCharacter: Character } @@ -513,7 +576,7 @@ jsonRes = ``` -in this case, `jsonRes` is resolves a request into a response in some monad `m`. +in this case, `jsonRes` resolves a request into a response in some monad `m`. A `fetch` resolver implementation against [a real API](https://swapi.graph.cool) may look like the following: diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,55 @@ # Changelog +## 0.11.0 - 01.05.2020 + +### Breaking Changes + +- Client generated enum data constructors are now prefixed with with the type name to avoid name conflicts. +- for Variant selection inputUnion uses `inputname` insead of `__typename` + +- in `Data.Morpheus.Server` + - `gqlSocketApp` and `gqlSocketMonadIOApp` are replaced with `webSocketsApp` + - removed `initGQLState`, `GQLState` + +- for better control of subscriptions + - replaced instance `interpreter gqlRoot state` with + `interpreter gqlRoot`. + - added: `Input`, `Stream`, `httpPubApp` + + from now on you can define API that can be + used in websockets as well as in http servers + + ```hs + api :: Input api -> Stream api EVENT IO + api = interpreter gqlRoot + + server :: IO () + server = do + (wsApp, publish) <- webSocketsApp api + let httpApp = httpPubApp api publish + ... + runBoth wsApp httpApp + ``` + + where `publish :: e -> m ()` + + websockets and http app do not have to be on the same server. + e.g. you can pass events between servers with webhooks. + +- subscription can select only one top level field (based on the GraphQL specification). + +### New features + +- Instead of rejecting conflicting selections, they are merged (based on the GraphQL specification). +- Support for input lists separated by newlines. thanks @charlescrain +- conflicting variable , fragment ... validation +- issue #411: Aeson `FromJSON` `ToJSON` instances for `ID` + +### minor + +- changes to internal types +- fixed validation of apollo websockets requests + ## 0.10.0 - 07.01.2020 ### Breaking Changes @@ -23,7 +73,7 @@ resolveNewUser = subscribe [USER] $ do pure $ \(Event _ content) -> lift (getDBUserByContent content) ``` - + ### New features - exposed `publish` for mutation resolvers, now you can write @@ -49,9 +99,9 @@ - `type SubField` will convert your subscription monad to query monad. `SubField (Resolver Subscription Event IO) User` will generate same as `Resolver Subscription Event IO (User ((Resolver QUERY Event IO)))` - + now if you want define subscription as follows - + ```hs data Subscription m = Subscription { newUser :: SubField m User @@ -60,7 +110,7 @@ - `unsafeInternalContext` to get resolver context, use only if it really necessary. the code depending on it may break even on minor version changes. - + ```hs resolveUser :: ResolveQ EVENT IO User resolveUser = do @@ -68,10 +118,10 @@ lift (getDBUser currentSelection) ``` -### Minor +### minor -- MonadIO instance for resolvers. Thanks @dandoh -- Example using STM, authentication, monad transformers. Thanks @dandoh +- monadio instance for resolvers. thanks @dandoh +- example using stm, authentication, monad transformers. thanks @dandoh - added dependency `mtl` ## [0.9.1] - 02.01.2020 @@ -91,9 +141,9 @@ - auto inferece of external types in gql document (#343) th will generate field `m (Type m)` if type has an argument - + e.g for this types and DSL - + ```hs data Type1 = Type1 { ... } type Type2 m = SomeType m @@ -102,11 +152,11 @@ ```gql type Query { - field1 : Type1! - field2 : Type2! - field3 : Type3! + field1: Type1! + field2: Type2! + field3: Type3! } - ``` + ``` morpheus generates @@ -119,7 +169,7 @@ ``` now you can combine multiple gql documents: - + ```hs importDocumentWithNamespace `coreTypes.gql` importDocumentWithNamespace `operations.gql` @@ -139,7 +189,7 @@ } ``` -- template haskell generates `m type` insead of `() -> m type` for fields without argument (#334) +- template haskell generates `m type` insead of `() -> m type` for fields without argument (#334) ```hs data Diety m = Deity { @@ -162,10 +212,10 @@ - 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 : +- 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 @@ -177,11 +227,11 @@ will generate ```gql - union CHaracter = Deity | SomeDeity + union CHaracter = Deity | SomeDeity - type SomeDeity { - _0: Deity - } + type SomeDeity { + _0: Deity + } ``` ### Added @@ -322,7 +372,7 @@ - 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`) +- support of round floats (e.g `1.000`) - validation checks undefined fields on inputObject - variables are supported inside input values @@ -502,7 +552,7 @@ ```gql mutation { - name + name } ``` 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: acb4d101970b68e1e9b3790252120726595167c2154a4861772462f29501c7bb +-- hash: e10665dda7dcb75f84d447086dcbd786a36aea915278bd6bbf4285a01cf9d21a name: morpheus-graphql -version: 0.10.0 +version: 0.11.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -28,10 +28,12 @@ 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/conditionTypeViolation/query.gql test/Feature/Holistic/fragment/inlineFragment/query.gql test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql test/Feature/Holistic/fragment/loopingFragment/query.gql test/Feature/Holistic/fragment/nameCollision/query.gql + test/Feature/Holistic/fragment/unknownConditionType/query.gql test/Feature/Holistic/fragment/unknownTargetType/query.gql test/Feature/Holistic/fragment/unusedFragment/query.gql test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql @@ -69,6 +71,7 @@ test/Feature/Holistic/parsing/duplicatedFields/query.gql test/Feature/Holistic/parsing/extraCommas/query.gql test/Feature/Holistic/parsing/generousSpaces/query.gql + test/Feature/Holistic/parsing/inputListValues/query.gql test/Feature/Holistic/parsing/invalidFields/query.gql test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql test/Feature/Holistic/parsing/missingCloseBrace/query.gql @@ -77,12 +80,17 @@ test/Feature/Holistic/parsing/singleLineComments/query.gql test/Feature/Holistic/schema.gql test/Feature/Holistic/selection/__typename/query.gql - test/Feature/Holistic/selection/AliasNameConflict/query.gql test/Feature/Holistic/selection/AliasResolve/query.gql test/Feature/Holistic/selection/AliasUnknownField/query.gql test/Feature/Holistic/selection/hasNoSubFields/query.gql + test/Feature/Holistic/selection/mergeConflict/alias/query.gql + test/Feature/Holistic/selection/mergeConflict/arguments/query.gql + test/Feature/Holistic/selection/mergeConflict/union/query.gql + test/Feature/Holistic/selection/mergeSelection/query.gql + test/Feature/Holistic/selection/mergeUnionSelection/query.gql test/Feature/Holistic/selection/mustHaveSubFields/query.gql - test/Feature/Holistic/selection/nameConflict/query.gql + test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql + test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql test/Feature/Holistic/selection/unknownField/query.gql test/Feature/Input/Enum/decode2Con/query.gql test/Feature/Input/Enum/decode3Con/query.gql @@ -112,7 +120,9 @@ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/query.gql test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql + test/Feature/InputType/variables/nameCollision/query.gql test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql + test/Feature/InputType/variables/nonInputTypeViolation/query.gql test/Feature/InputType/variables/undefinedVariable/query.gql test/Feature/InputType/variables/unknownType/query.gql test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql @@ -153,10 +163,12 @@ test/Feature/Holistic/cases.json test/Feature/Holistic/failure/resolveFailure/response.json test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json + test/Feature/Holistic/fragment/conditionTypeViolation/response.json test/Feature/Holistic/fragment/inlineFragment/response.json test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json test/Feature/Holistic/fragment/loopingFragment/response.json test/Feature/Holistic/fragment/nameCollision/response.json + test/Feature/Holistic/fragment/unknownConditionType/response.json test/Feature/Holistic/fragment/unknownTargetType/response.json test/Feature/Holistic/fragment/unusedFragment/response.json test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json @@ -194,6 +206,8 @@ test/Feature/Holistic/parsing/duplicatedFields/response.json test/Feature/Holistic/parsing/extraCommas/response.json test/Feature/Holistic/parsing/generousSpaces/response.json + test/Feature/Holistic/parsing/inputListValues/response.json + test/Feature/Holistic/parsing/inputListValues/variables.json test/Feature/Holistic/parsing/invalidFields/response.json test/Feature/Holistic/parsing/invalidNotNullOperator/response.json test/Feature/Holistic/parsing/missingCloseBrace/response.json @@ -202,12 +216,17 @@ test/Feature/Holistic/parsing/numbers/response.json test/Feature/Holistic/parsing/singleLineComments/response.json test/Feature/Holistic/selection/__typename/response.json - test/Feature/Holistic/selection/AliasNameConflict/response.json test/Feature/Holistic/selection/AliasResolve/response.json test/Feature/Holistic/selection/AliasUnknownField/response.json test/Feature/Holistic/selection/hasNoSubFields/response.json + test/Feature/Holistic/selection/mergeConflict/alias/response.json + test/Feature/Holistic/selection/mergeConflict/arguments/response.json + test/Feature/Holistic/selection/mergeConflict/union/response.json + test/Feature/Holistic/selection/mergeSelection/response.json + test/Feature/Holistic/selection/mergeUnionSelection/response.json test/Feature/Holistic/selection/mustHaveSubFields/response.json - test/Feature/Holistic/selection/nameConflict/response.json + test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json + test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json test/Feature/Holistic/selection/unknownField/response.json test/Feature/Input/Enum/cases.json test/Feature/Input/Enum/decode2Con/response.json @@ -250,8 +269,11 @@ test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json + test/Feature/InputType/variables/nameCollision/response.json + test/Feature/InputType/variables/nameCollision/variables.json test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json + test/Feature/InputType/variables/nonInputTypeViolation/response.json test/Feature/InputType/variables/undefinedVariable/response.json test/Feature/InputType/variables/unknownType/response.json test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json @@ -308,16 +330,15 @@ Data.Morpheus.Client Data.Morpheus.Types.Internal.AST other-modules: - Data.Morpheus.Error.Arguments Data.Morpheus.Error.Client.Client Data.Morpheus.Error.Document.Interface Data.Morpheus.Error.Fragment Data.Morpheus.Error.Input Data.Morpheus.Error.Internal - Data.Morpheus.Error.Mutation + Data.Morpheus.Error.NameCollision + Data.Morpheus.Error.Operation Data.Morpheus.Error.Schema Data.Morpheus.Error.Selection - Data.Morpheus.Error.Subscription Data.Morpheus.Error.Utils Data.Morpheus.Error.Variable Data.Morpheus.Execution.Client.Aeson @@ -341,16 +362,14 @@ Data.Morpheus.Execution.Server.Interpreter Data.Morpheus.Execution.Server.Introspect Data.Morpheus.Execution.Server.Resolve - Data.Morpheus.Execution.Server.Subscription - Data.Morpheus.Parsing.Document.Parser Data.Morpheus.Parsing.Document.TypeSystem + Data.Morpheus.Parsing.Internal.Arguments Data.Morpheus.Parsing.Internal.Internal Data.Morpheus.Parsing.Internal.Pattern Data.Morpheus.Parsing.Internal.Terms Data.Morpheus.Parsing.Internal.Value Data.Morpheus.Parsing.JSONSchema.Parse Data.Morpheus.Parsing.JSONSchema.Types - Data.Morpheus.Parsing.Request.Arguments Data.Morpheus.Parsing.Request.Operation Data.Morpheus.Parsing.Request.Parser Data.Morpheus.Parsing.Request.Selection @@ -362,16 +381,24 @@ Data.Morpheus.Types.GQLScalar Data.Morpheus.Types.GQLType Data.Morpheus.Types.ID - Data.Morpheus.Types.Internal.Apollo Data.Morpheus.Types.Internal.AST.Base Data.Morpheus.Types.Internal.AST.Data + Data.Morpheus.Types.Internal.AST.MergeSet + Data.Morpheus.Types.Internal.AST.OrderedMap Data.Morpheus.Types.Internal.AST.Selection Data.Morpheus.Types.Internal.AST.Value + Data.Morpheus.Types.Internal.Operation Data.Morpheus.Types.Internal.Resolving Data.Morpheus.Types.Internal.Resolving.Core Data.Morpheus.Types.Internal.Resolving.Resolver + Data.Morpheus.Types.Internal.Subscription + Data.Morpheus.Types.Internal.Subscription.Apollo + Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore + Data.Morpheus.Types.Internal.Subscription.Stream Data.Morpheus.Types.Internal.TH - Data.Morpheus.Types.Internal.WebSocket + Data.Morpheus.Types.Internal.Validation + Data.Morpheus.Types.Internal.Validation.Error + Data.Morpheus.Types.Internal.Validation.Validator Data.Morpheus.Types.IO Data.Morpheus.Types.Types Data.Morpheus.Validation.Document.Validation @@ -379,6 +406,7 @@ Data.Morpheus.Validation.Query.Arguments Data.Morpheus.Validation.Query.Fragment Data.Morpheus.Validation.Query.Selection + Data.Morpheus.Validation.Query.UnionSelection Data.Morpheus.Validation.Query.Validation Data.Morpheus.Validation.Query.Variable Paths_morpheus_graphql @@ -397,6 +425,7 @@ , text >=1.2.3.0 && <1.3 , th-lift-instances >=0.1.1 && <=0.2.0 , transformers >=0.3.0.0 && <0.6 + , unliftio-core >=0.0.1 && <=0.3 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13 @@ -440,6 +469,7 @@ , text >=1.2.3.0 && <1.3 , th-lift-instances >=0.1.1 && <=0.2.0 , transformers >=0.3.0.0 && <0.6 + , unliftio-core >=0.0.1 && <=0.3 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13 diff --git a/src/Data/Morpheus/Client.hs b/src/Data/Morpheus/Client.hs --- a/src/Data/Morpheus/Client.hs +++ b/src/Data/Morpheus/Client.hs @@ -29,7 +29,7 @@ import Data.Morpheus.Parsing.JSONSchema.Parse ( decodeIntrospection ) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Eventless ) import Data.Morpheus.Types.Internal.AST ( GQLQuery , Schema @@ -59,7 +59,7 @@ defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec] defineByDocument doc = defineQuery (schemaByDocument doc) -schemaByDocument :: IO ByteString -> IO (Validation Schema) +schemaByDocument :: IO ByteString -> IO (Eventless Schema) schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec] diff --git a/src/Data/Morpheus/Document.hs b/src/Data/Morpheus/Document.hs --- a/src/Data/Morpheus/Document.hs +++ b/src/Data/Morpheus/Document.hs @@ -31,11 +31,12 @@ ( RootResCon , fullSchema ) -import Data.Morpheus.Parsing.Document.Parser - ( parseTypes ) - +import Data.Morpheus.Parsing.Document.TypeSystem + ( parseSchema + ) import Data.Morpheus.Rendering.RenderGQL - ( renderGraphQLDocument ) + ( renderGraphQLDocument + ) import Data.Morpheus.Schema.SchemaAPI ( defaultTypes ) import Data.Morpheus.Types ( GQLRootResolver ) import Data.Morpheus.Types.Internal.AST @@ -43,7 +44,7 @@ , createDataTypeLib ) import Data.Morpheus.Types.Internal.Resolving - ( Validation + ( Eventless , Result(..) ) import Data.Morpheus.Validation.Document.Validation @@ -56,14 +57,14 @@ Success { result } -> Right result -parseDocument :: Text -> Validation Schema +parseDocument :: Text -> Eventless Schema parseDocument doc = - parseTypes doc >>= validatePartialDocument >>= createDataTypeLib + parseSchema doc >>= validatePartialDocument >>= createDataTypeLib -parseGraphQLDocument :: ByteString -> Validation Schema +parseGraphQLDocument :: ByteString -> Eventless Schema parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x) -parseFullGQLDocument :: ByteString -> Validation Schema +parseFullGQLDocument :: ByteString -> Eventless Schema parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes -- | Generates schema.gql file from 'GQLRootResolver' diff --git a/src/Data/Morpheus/Error/Arguments.hs b/src/Data/Morpheus/Error/Arguments.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Arguments.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Arguments - ( undefinedArgument - , unknownArguments - , argumentGotInvalidValue - , argumentNameCollision - ) -where - -import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Ref(..) - , Position - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) - , GQLErrors - ) -import Data.Text ( Text ) -import qualified Data.Text as T - ( concat ) - -{- - ARGUMENTS: - type Experience { - experience ( lang: LANGUAGE ) : String , - date: String - } - - - required field !? - - experience( lang: "bal" ) -> "Expected type LANGUAGE, found \"a\"." - - experience( lang: Bla ) -> "Expected type LANGUAGE, found Bla." - - experience( lang: 1 ) -> "Expected type LANGUAGE, found 1." - - experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".", - - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"." --} -argumentGotInvalidValue :: Text -> Text -> Position -> GQLErrors -argumentGotInvalidValue key' inputMessage' position' = errorMessage position' - text - where - text = T.concat ["Argument ", key', " got invalid value ;", inputMessage'] - -unknownArguments :: Text -> [Ref] -> GQLErrors -unknownArguments fieldName = map keyToError - where - keyToError (Ref argName pos) = - GQLError { message = toMessage argName, locations = [pos] } - toMessage argName = T.concat - ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."] - -argumentNameCollision :: [Ref] -> GQLErrors -argumentNameCollision = map keyToError - where - keyToError (Ref argName pos) = - GQLError { message = toMessage argName, locations = [pos] } - toMessage argName = - T.concat ["There can Be only One Argument Named \"", argName, "\""] - -undefinedArgument :: Ref -> GQLErrors -undefinedArgument (Ref key' position') = errorMessage position' text - where text = T.concat ["Required Argument: \"", key', "\" was not Defined"] diff --git a/src/Data/Morpheus/Error/Client/Client.hs b/src/Data/Morpheus/Error/Client/Client.hs --- a/src/Data/Morpheus/Error/Client/Client.hs +++ b/src/Data/Morpheus/Error/Client/Client.hs @@ -9,21 +9,25 @@ ) where + import Data.Aeson ( encode ) import Data.ByteString.Lazy.Char8 ( unpack ) +import Language.Haskell.TH ( Q + , reportWarning + ) +import Data.Semigroup ( (<>) ) +import Data.Foldable ( traverse_ ) + +-- MORPHEUS import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLErrors ) import Data.Morpheus.Types.Internal.AST.Base ( Ref(..) , Description , Name - ) -import Language.Haskell.TH ( Q - , reportWarning + , GQLErrors ) -import Data.Semigroup ( (<>) ) + renderGQLErrors :: GQLErrors -> String renderGQLErrors = unpack . encode @@ -49,7 +53,7 @@ gqlWarnings :: GQLErrors -> Q () gqlWarnings [] = pure () -gqlWarnings warnings = mapM_ handleWarning warnings +gqlWarnings warnings = traverse_ handleWarning warnings where handleWarning warning = reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning) diff --git a/src/Data/Morpheus/Error/Document/Interface.hs b/src/Data/Morpheus/Error/Document/Interface.hs --- a/src/Data/Morpheus/Error/Document/Interface.hs +++ b/src/Data/Morpheus/Error/Document/Interface.hs @@ -10,9 +10,8 @@ import Data.Morpheus.Error.Utils ( globalErrorMessage ) import Data.Morpheus.Types.Internal.AST.Base - ( Key ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) + ( Key + , GQLError(..) , GQLErrors ) import Data.Semigroup ( (<>) ) 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 @@ -1,12 +1,8 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Error.Fragment ( cannotSpreadWithinItself - , unusedFragment - , unknownFragment , cannotBeSpreadOnType - , fragmentNameCollision ) where @@ -21,9 +17,7 @@ import Data.Morpheus.Types.Internal.AST.Base ( Ref(..) , Position - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) + , GQLError(..) , GQLErrors ) @@ -38,46 +32,23 @@ fragment H on D {...} -> "Unknown type \"D\"." {...H} -> "Unknown fragment \"H\"." -} -fragmentNameCollision :: [Ref] -> GQLErrors -fragmentNameCollision = map toError - where - toError Ref { refName, refPosition } = GQLError - { message = "There can be only one fragment named \"" <> refName <> "\"." - , locations = [refPosition] - } -unusedFragment :: [Ref] -> GQLErrors -unusedFragment = map toError - where - toError Ref { refName, refPosition } = GQLError - { message = "Fragment \"" <> refName <> "\" is never used." - , locations = [refPosition] - } - cannotSpreadWithinItself :: [Ref] -> GQLErrors -cannotSpreadWithinItself fragments = - [GQLError { message = text, locations = map refPosition fragments }] +cannotSpreadWithinItself fragments = [GQLError { message = text, locations = map refPosition fragments }] where - text = T.concat - [ "Cannot spread fragment \"" - , refName $ head fragments - , "\" within itself via " - , T.intercalate ", " (map refName fragments) - , "." - ] - --- {...H} -> "Unknown fragment \"H\"." -unknownFragment :: Text -> Position -> GQLErrors -unknownFragment key' position' = errorMessage position' text - where text = T.concat ["Unknown Fragment \"", key', "\"."] + text = "Cannot spread fragment \"" + <> refName (head fragments) + <> "\" within itself via " + <> T.intercalate ", " (map refName fragments) + <> "." -- 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 fragmentType position typeMembers = errorMessage position - message + msg where - message = + msg = "Fragment " <> getName key <> "cannot be spread here as objects of type \"" 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 @@ -1,81 +1,43 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} module Data.Morpheus.Error.Input - ( inputErrorMessage - , InputError(..) - , Prop(..) - , InputValidation + ( typeViolation ) where +import Data.Semigroup ( (<>) ) import Data.Aeson ( encode ) import Data.ByteString.Lazy.Char8 ( unpack ) -import Data.Morpheus.Types.Internal.AST.Value - ( ResolvedValue ) -import Data.Text ( Text ) -import qualified Data.Text as T - ( concat - , intercalate - , pack +import Data.Text ( pack ) + +-- MORPHEUS +import Data.Morpheus.Types.Internal.AST + ( Message + , ResolvedValue + , TypeRef(..) ) +import Data.Morpheus.Rendering.RenderGQL + ( RenderGQL(..) ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLErrors ) - -type InputValidation a = Either InputError a - -data InputError - = UnexpectedType [Prop] Text ResolvedValue (Maybe Text) - | UndefinedField [Prop] Text - | UnknownField [Prop] Text - | GlobalInputError GQLErrors +typeViolation :: TypeRef -> ResolvedValue -> Message +typeViolation expected found = "Expected type \"" + <> render expected + <> "\" found " + <> pack (unpack $ encode found) + <> "." -data Prop = - Prop - { propKey :: Text - , propType :: Text +{- + ARGUMENTS: + type Experience { + experience ( lang: LANGUAGE ) : String , + date: String } -inputErrorMessage :: InputError -> Either GQLErrors Text -inputErrorMessage (UnexpectedType path type' value errorMessage) = - 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 -> ResolvedValue -> Maybe Text -> Text -expectedTypeAFoundB path' expected found Nothing = T.concat - [ pathToText path' - , " Expected type \"" - , expected - , "\" found " - , T.pack (unpack $ encode found) - , "." - ] -expectedTypeAFoundB path' expected found (Just errorMessage) = T.concat - [ pathToText path' - , " Expected type \"" - , expected - , "\" found " - , T.pack (unpack $ encode found) - , "; " - , errorMessage - , "." - ] - -undefinedField :: [Prop] -> Text -> Text -undefinedField path' field' = - T.concat [pathToText path', " Undefined Field \"", field', "\"."] - -unknownField :: [Prop] -> Text -> Text -unknownField path' field' = - T.concat [pathToText path', " Unknown Field \"", field', "\"."] + - required field !? + - experience( lang: "bal" ) -> "Expected type LANGUAGE, found \"a\"." + - experience( lang: Bla ) -> "Expected type LANGUAGE, found Bla." + - experience( lang: 1 ) -> "Expected type LANGUAGE, found 1." + - experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".", + - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"." +-} 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 @@ -2,51 +2,36 @@ module Data.Morpheus.Error.Internal ( internalTypeMismatch - , internalArgumentError - , internalUnknownTypeMessage , internalError , internalResolvingError ) where -import Data.Text ( Text ) -import qualified Data.Text as T - ( concat - , pack - ) +import Data.Text ( pack ) import Data.Semigroup ( (<>) ) -- MORPHEUS import Data.Morpheus.Error.Utils ( globalErrorMessage ) import Data.Morpheus.Types.Internal.Resolving.Core - ( Validation - , GQLErrors + ( Eventless , Failure(..) ) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLErrors + , Message + ) import Data.Morpheus.Types.Internal.AST.Value ( ValidValue ) - -- GQL:: if no mutation defined -> "Schema is not configured for mutations." -- all kind internal error in development -internalError :: Text -> Validation b +internalError :: Message -> Eventless a 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] - --- if arguments is already validated but has not found required argument -internalArgumentError :: Text -> Validation b -internalArgumentError x = internalError $ "Argument " <> x +internalResolvingError :: Message -> GQLErrors +internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>) -- if value is already validated but value has different type -internalTypeMismatch :: Text -> ValidValue -> Validation b +internalTypeMismatch :: Message -> ValidValue -> Eventless a internalTypeMismatch text jsType = - internalError $ "Type mismatch " <> text <> T.pack (show jsType) + internalError $ "Type mismatch " <> text <> pack (show jsType) diff --git a/src/Data/Morpheus/Error/Mutation.hs b/src/Data/Morpheus/Error/Mutation.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Mutation.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Mutation - ( mutationIsNotDefined - ) -where - -import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Position ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLErrors ) - -mutationIsNotDefined :: Position -> GQLErrors -mutationIsNotDefined position' = - errorMessage position' "Schema is not configured for mutations." diff --git a/src/Data/Morpheus/Error/NameCollision.hs b/src/Data/Morpheus/Error/NameCollision.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/NameCollision.hs @@ -0,0 +1,12 @@ +module Data.Morpheus.Error.NameCollision + ( NameCollision(..) + ) +where + +import Data.Morpheus.Types.Internal.AST.Base + ( Name + , GQLError(..) + ) + +class NameCollision a where + nameCollision :: Name -> a -> GQLError diff --git a/src/Data/Morpheus/Error/Operation.hs b/src/Data/Morpheus/Error/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Operation.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Operation + ( mutationIsNotDefined + , subscriptionIsNotDefined + ) +where + +import Data.Morpheus.Error.Utils ( errorMessage ) +import Data.Morpheus.Types.Internal.AST.Base + ( Position + , GQLErrors + ) + +mutationIsNotDefined :: Position -> GQLErrors +mutationIsNotDefined position = + errorMessage position "Schema is not configured for mutations." + +subscriptionIsNotDefined :: Position -> GQLErrors +subscriptionIsNotDefined position = + errorMessage position "Schema is not configured for subscriptions." diff --git a/src/Data/Morpheus/Error/Schema.hs b/src/Data/Morpheus/Error/Schema.hs --- a/src/Data/Morpheus/Error/Schema.hs +++ b/src/Data/Morpheus/Error/Schema.hs @@ -7,7 +7,7 @@ where import Data.Morpheus.Error.Utils ( globalErrorMessage ) -import Data.Morpheus.Types.Internal.Resolving.Core +import Data.Morpheus.Types.Internal.AST.Base ( GQLErrors ) import Data.Semigroup ( (<>) ) import Data.Text ( Text ) diff --git a/src/Data/Morpheus/Error/Selection.hs b/src/Data/Morpheus/Error/Selection.hs --- a/src/Data/Morpheus/Error/Selection.hs +++ b/src/Data/Morpheus/Error/Selection.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module Data.Morpheus.Error.Selection - ( cannotQueryField + ( unknownSelectionField , subfieldsNotSelected - , duplicateQuerySelections , hasNoSubfields ) where @@ -11,52 +11,27 @@ import Data.Semigroup ( (<>) ) import Data.Morpheus.Error.Utils ( errorMessage ) import Data.Morpheus.Types.Internal.AST.Base - ( Ref(..) - , Position - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) + ( Position , GQLErrors + , Ref(..) + , Name ) import Data.Text ( Text ) -import qualified Data.Text as T - ( concat ) - -- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields." -hasNoSubfields :: Text -> Text -> Position -> GQLErrors -hasNoSubfields key typeName position = errorMessage position text - where - text = T.concat - [ "Field \"" - , key - , "\" must not have a selection since type \"" - , typeName - , "\" has no subfields." - ] - -cannotQueryField :: Text -> Text -> Position -> GQLErrors -cannotQueryField key typeName position = errorMessage position text +hasNoSubfields :: Ref -> Name -> GQLErrors +hasNoSubfields (Ref selectionName position) typeName = errorMessage position text where - text = - T.concat ["Cannot query field \"", key, "\" on type \"", typeName, "\"."] + text = "Field \"" <> selectionName <> "\" must not have a selection since type \"" <> typeName <> "\" has no subfields." -duplicateQuerySelections :: Text -> [Ref] -> GQLErrors -duplicateQuerySelections parentType = map keyToError +unknownSelectionField :: Name -> Ref -> GQLErrors +unknownSelectionField typeName Ref { refName , refPosition } = errorMessage refPosition text where - keyToError (Ref key' pos) = - GQLError { message = toMessage key', locations = [pos] } - toMessage key' = T.concat - ["duplicate selection of key \"", key', "\" on type \"", parentType, "\"."] + text = "Cannot query field \"" <> refName <> "\" on type \"" <> typeName <> "\"." -- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"? subfieldsNotSelected :: Text -> Text -> Position -> GQLErrors subfieldsNotSelected key typeName position = errorMessage position text where - text = T.concat - [ "Field \"" - , key - , "\" of type \"" - , typeName - , "\" must have a selection of subfields" - ] + text = "Field \"" <> key <> "\" of type \"" + <> typeName <> "\" must have a selection of subfields" diff --git a/src/Data/Morpheus/Error/Subscription.hs b/src/Data/Morpheus/Error/Subscription.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Subscription.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Subscription - ( subscriptionIsNotDefined - ) -where - -import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Position ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLErrors ) - -subscriptionIsNotDefined :: Position -> GQLErrors -subscriptionIsNotDefined position' = - errorMessage position' "Schema is not configured for subscriptions." diff --git a/src/Data/Morpheus/Error/Utils.hs b/src/Data/Morpheus/Error/Utils.hs --- a/src/Data/Morpheus/Error/Utils.hs +++ b/src/Data/Morpheus/Error/Utils.hs @@ -1,41 +1,30 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Error.Utils ( errorMessage , globalErrorMessage , badRequestError - , toLocation ) where +import Data.Semigroup ((<>)) import Data.ByteString.Lazy.Char8 ( ByteString , pack ) import Data.Morpheus.Types.Internal.AST.Base - ( Position ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) - , GQLErrors + ( Position(..) , GQLError(..) - , Position(..) + , GQLErrors ) import Data.Text ( Text ) -import Text.Megaparsec ( SourcePos(SourcePos) - , sourceColumn - , sourceLine - , unPos - ) + errorMessage :: Position -> Text -> GQLErrors errorMessage position message = [GQLError { message, locations = [position] }] globalErrorMessage :: Text -> GQLErrors globalErrorMessage message = [GQLError { message, locations = [] }] -toLocation :: SourcePos -> Position -toLocation SourcePos { sourceLine, sourceColumn } = - Position { line = unPos sourceLine, column = unPos sourceColumn } - badRequestError :: String -> ByteString -badRequestError aesonError' = - pack $ "Bad Request. Could not decode Request body: " ++ aesonError' +badRequestError = ("Bad Request. Could not decode Request body: " <>) . pack diff --git a/src/Data/Morpheus/Error/Variable.hs b/src/Data/Morpheus/Error/Variable.hs --- a/src/Data/Morpheus/Error/Variable.hs +++ b/src/Data/Morpheus/Error/Variable.hs @@ -1,84 +1,44 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module Data.Morpheus.Error.Variable - ( undefinedVariable - , unknownType - , variableGotInvalidValue - , uninitializedVariable - , unusedVariables + ( uninitializedVariable , incompatibleVariableType ) where import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Ref(..) - , Position - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) - , GQLErrors +import Data.Morpheus.Types.Internal.AST + ( GQLErrors + , Ref(..) + , Variable(..) + , TypeRef ) import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) -import qualified Data.Text as T - ( concat ) +import Data.Morpheus.Rendering.RenderGQL + ( RenderGQL(..) ) -- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"." -incompatibleVariableType :: Text -> Text -> Text -> Position -> GQLErrors -incompatibleVariableType variableName variableType argType argPosition = +incompatibleVariableType :: Ref -> Variable s -> TypeRef -> GQLErrors +incompatibleVariableType + (Ref variableName argPosition) + Variable { variableType } + argumentType = errorMessage argPosition text where text = "Variable \"$" <> variableName <> "\" of type \"" - <> variableType + <> render variableType <> "\" used in position expecting type \"" - <> argType + <> render argumentType <> "\"." --- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".", -unusedVariables :: Text -> [Ref] -> GQLErrors -unusedVariables operator' = map keyToError - where - keyToError (Ref key' position') = - GQLError { message = text key', locations = [position'] } - text key' = T.concat - ["Variable \"$", key', "\" is never used in operation \"", operator', "\"."] - --- type mismatch --- { "v": 1 } "Variable \"$v\" got invalid value 1; Expected type LANGUAGE." -variableGotInvalidValue :: Text -> Text -> Position -> GQLErrors -variableGotInvalidValue name' inputMessage' position' = errorMessage - position' - text - where - text = - T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage'] - -unknownType :: Text -> Position -> GQLErrors -unknownType type' position' = errorMessage position' text - where text = T.concat ["Unknown type \"", type', "\"."] - -undefinedVariable :: Text -> Position -> Text -> GQLErrors -undefinedVariable operation' position' key' = errorMessage position' text - where - text = T.concat - [ "Variable \"" - , key' - , "\" is not defined by operation \"" - , operation' - , "\"." - ] - -uninitializedVariable :: Position -> Text -> Text -> GQLErrors -uninitializedVariable position' type' key' = errorMessage position' text - where - text = T.concat - [ "Variable \"$" - , key' - , "\" of required type \"" - , type' - , "!\" was not provided." - ] +uninitializedVariable :: Variable s -> GQLErrors +uninitializedVariable Variable { variableName, variableType, variablePosition} = + errorMessage + variablePosition + $ "Variable \"$" <> variableName + <> "\" of required type \"" + <> render variableType <> "\" was not provided." diff --git a/src/Data/Morpheus/Execution/Client/Aeson.hs b/src/Data/Morpheus/Execution/Client/Aeson.hs --- a/src/Data/Morpheus/Execution/Client/Aeson.hs +++ b/src/Data/Morpheus/Execution/Client/Aeson.hs @@ -20,7 +20,10 @@ import qualified Data.HashMap.Lazy as H ( lookup ) import Data.Semigroup ( (<>) ) -import Data.Text ( unpack ) +import Data.Text ( append + , Text + , unpack + ) import Language.Haskell.TH import Data.Morpheus.Execution.Internal.Utils @@ -28,8 +31,10 @@ -- -- MORPHEUS +import Data.Morpheus.Execution.Internal.Declare + ( isEnum ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) + ( FieldDefinition(..) , isFieldNullable , ConsD(..) , TypeD(..) @@ -43,15 +48,15 @@ -- FromJSON deriveFromJSON :: TypeD -> Q Dec -deriveFromJSON TypeD { tCons = [] } = - fail "Type Should Have at least one Constructor" +deriveFromJSON TypeD { tCons = [] , tName } = + fail $ "Type " <> unpack tName <> " Should Have at least one Constructor" deriveFromJSON TypeD { tName, tNamespace, tCons = [cons] } = defineFromJSON name (aesonObject tNamespace) cons where name = nameSpaceType tNamespace tName deriveFromJSON typeD@TypeD { tName, tCons, tNamespace } - | isEnum tCons = defineFromJSON name aesonEnum tCons + | isEnum tCons = defineFromJSON name (aesonFromJSONEnumBody tName) tCons | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD where name = nameSpaceType tNamespace tName @@ -65,16 +70,16 @@ aesonObjectBody namespace ConsD { cName, cFields } = handleFields cFields where consName = mkName $ unpack $ nameSpaceType namespace cName - ------------------------------------------ - handleFields [] = fail "No Empty Object" + ---------------------------------------------------------- + handleFields [] = fail $ "Type \""<>unpack cName <>"\" is Empty Object" handleFields fields = startExp fields - ---------------------------------------------------------------------------------- + ---------------------------------------------------------- where - defField field@DataField { fieldName } + defField field@FieldDefinition { fieldName } | isFieldNullable field = [|o .:? fName|] | otherwise = [|o .: fName|] where fName = unpack fieldName - ------------------------------------------------------------------- + -------------------------------------------------------- startExp fNames = uInfixE (conE consName) (varE '(<$>)) (applyFields fNames) @@ -109,19 +114,15 @@ ----------------------------------------- method = instanceFunD 'parseJSON [] (parseJ cFields) -isEnum :: [ConsD] -> Bool -isEnum = not . isEmpty . filter (isEmpty . cFields) - where isEmpty = (0 ==) . length - -aesonEnum :: [ConsD] -> ExpQ -aesonEnum cons = lamCaseE handlers +aesonFromJSONEnumBody :: Text -> [ConsD] -> ExpQ +aesonFromJSONEnumBody tName cons = lamCaseE handlers where handlers = map buildMatch cons <> [elseCaseEXP] where buildMatch ConsD { cName } = match enumPat body [] where enumPat = litP $ stringL $ unpack cName - body = normalB $ appE (varE 'pure) (conE $ mkName $ unpack cName) + body = normalB $ appE (varE 'pure) (conE $ mkName $ unpack $ append tName cName) elseCaseEXP :: MatchQ elseCaseEXP = match (varP varName) body [] @@ -134,6 +135,16 @@ (stringE " is Not Valid Union Constructor") ) +aesonToJSONEnumBody :: Text -> [ConsD] -> ExpQ +aesonToJSONEnumBody tName cons = lamCaseE handlers + where + handlers = map buildMatch cons + where + buildMatch ConsD { cName } = match enumPat body [] + where + enumPat = conP (mkName $ unpack $ append tName cName) [] + body = normalB $ litE (stringL $ unpack cName) + -- ToJSON deriveToJSON :: TypeD -> Q [Dec] deriveToJSON TypeD { tCons = [] } = @@ -152,8 +163,9 @@ varNames = map fieldName cFields deriveToJSON TypeD { tName, tCons } | isEnum tCons - = pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) [] + = let methods = [funD 'toJSON clauses] + clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []] + in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) methods | - -- enum: uses default aeson instance derivation methods otherwise = fail "Input Unions are not yet supported" diff --git a/src/Data/Morpheus/Execution/Client/Build.hs b/src/Data/Morpheus/Execution/Client/Build.hs --- a/src/Data/Morpheus/Execution/Client/Build.hs +++ b/src/Data/Morpheus/Execution/Client/Build.hs @@ -28,7 +28,9 @@ import Data.Morpheus.Execution.Client.Fetch ( deriveFetch ) import Data.Morpheus.Execution.Internal.Declare - ( declareType ) + ( declareType + , Scope(..) + ) import Data.Morpheus.Types.Internal.AST ( GQLQuery(..) @@ -40,20 +42,17 @@ , TypeD(..) ) import Data.Morpheus.Types.Internal.Resolving - ( Validation + ( Eventless , Result(..) ) - - -defineQuery :: IO (Validation Schema) -> (GQLQuery, String) -> Q [Dec] +defineQuery :: IO (Eventless Schema) -> (GQLQuery, String) -> Q [Dec] defineQuery ioSchema queryRoot = do schema <- runIO ioSchema case schema >>= (`validateWith` queryRoot) of Failure errors -> fail (renderGQLErrors errors) Success { result, warnings } -> gqlWarnings warnings >> defineQueryD result - defineQueryD :: ClientQuery -> Q [Dec] defineQueryD ClientQuery { queryTypes = rootType : subTypes, queryText, queryArgsType } = do @@ -72,12 +71,12 @@ defineQueryD ClientQuery { queryTypes = [] } = return [] declareOutputType :: TypeD -> Q [Dec] -declareOutputType typeD = pure [declareType False Nothing [''Show] typeD] +declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD] declareInputType :: TypeD -> Q [Dec] declareInputType typeD = do toJSONDec <- deriveToJSON typeD - pure $ declareType True Nothing [''Show] typeD : toJSONDec + pure $ declareType CLIENT True Nothing [''Show] typeD : toJSONDec withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec] withToJSON f datatype = do 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 @@ -37,7 +37,7 @@ , VALIDATION_MODE(..) ) import Data.Morpheus.Types.Internal.Resolving - ( Validation + ( Eventless , Result(..) ) import Data.Morpheus.Validation.Query.Validation @@ -54,7 +54,7 @@ , variables = Nothing } -validateWith :: Schema -> (GQLQuery, String) -> Validation ClientQuery +validateWith :: Schema -> (GQLQuery, String) -> Eventless ClientQuery validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest (queryArgsType, queryTypes) <- operationTypes diff --git a/src/Data/Morpheus/Execution/Client/Fetch.hs b/src/Data/Morpheus/Execution/Client/Fetch.hs --- a/src/Data/Morpheus/Execution/Client/Fetch.hs +++ b/src/Data/Morpheus/Execution/Client/Fetch.hs @@ -38,6 +38,7 @@ , JSONResponse(..) ) + fixVars :: A.Value -> Maybe A.Value fixVars x | x == A.emptyArray = Nothing | otherwise = Just x 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 @@ -10,7 +10,6 @@ ) where -import Data.Maybe ( fromMaybe ) import Data.Semigroup ( (<>) ) import Data.Text ( Text , pack @@ -24,48 +23,50 @@ ( nameSpaceType ) import Data.Morpheus.Types.Internal.AST ( Operation(..) - , ValidOperation + , Key + , Name + , RAW + , VALID , Variable(..) , VariableDefinitions - , getOperationName - , getOperationDataType , Selection(..) , SelectionContent(..) - , ValidSelectionSet - , ValidSelection + , SelectionSet , Ref(..) - , DataField(..) - , DataTypeContent(..) - , DataType(..) + , FieldDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , DataTypeKind(..) , Schema(..) - , Key , TypeRef(..) , DataEnumValue(..) - , DataLookup(..) , ConsD(..) , ClientType(..) , TypeD(..) + , ArgumentsDefinition(..) + , getOperationName + , getOperationDataType , lookupDeprecated , lookupDeprecatedReason - , RAW - , Name + , typeFromScalar + , removeDuplicates + , Position + , GQLErrors + , UnionTag(..) ) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + , selectBy + , keyOf + ) import Data.Morpheus.Types.Internal.Resolving - ( GQLErrors - , Validation + ( Eventless , Failure(..) , Result(..) - , Position , LibUpdater , resolveUpdates ) -import Data.Set ( fromList - , toList - ) -removeDuplicates :: [Text] -> [Text] -removeDuplicates = toList . fromList compileError :: Text -> GQLErrors compileError x = @@ -73,9 +74,9 @@ operationTypes :: Schema - -> VariableDefinitions - -> ValidOperation - -> Validation (Maybe TypeD, [ClientType]) + -> VariableDefinitions RAW + -> Operation VALID + -> Eventless (Maybe TypeD, [ClientType]) operationTypes lib variables = genOperation where genOperation operation@Operation { operationName, operationSelection } = do @@ -85,7 +86,7 @@ datatype operationSelection inputTypeRequests <- resolveUpdates [] - $ map (scanInputTypes lib . typeConName . variableType . snd) variables + $ map (scanInputTypes lib . typeConName . variableType) (toList variables) inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums) pure ( rootArguments (getOperationName operationName <> "Args") @@ -105,15 +106,14 @@ rootArgumentsType = TypeD { tName = argsName , tNamespace = [] - , tCons = [ConsD { cName = argsName, cFields = map fieldD variables }] + , tCons = [ConsD { cName = argsName, cFields = map fieldD (toList variables) }] , tMeta = Nothing } where - fieldD :: (Text, Variable RAW) -> DataField - fieldD (key, Variable { variableType }) = DataField - { fieldName = key - , fieldArgs = [] - , fieldArgsType = Nothing + fieldD :: Variable RAW -> FieldDefinition + fieldD Variable { variableName, variableType } = FieldDefinition + { fieldName = variableName + , fieldArgs = NoArguments , fieldType = variableType , fieldMeta = Nothing } @@ -122,9 +122,9 @@ genRecordType :: [Name] -> Name - -> DataType - -> ValidSelectionSet - -> Validation ([ClientType], [Name]) + -> TypeDefinition + -> SelectionSet VALID + -> Eventless ([ClientType], [Name]) genRecordType path tName dataType recordSelSet = do (con, subTypes, requests) <- genConsD tName dataType recordSelSet pure @@ -142,41 +142,45 @@ where genConsD :: Name - -> DataType - -> ValidSelectionSet - -> Validation (ConsD, [ClientType], [Text]) + -> TypeDefinition + -> SelectionSet VALID + -> Eventless (ConsD, [ClientType], [Text]) genConsD cName datatype selSet = do - (cFields, subTypes, requests) <- unzip3 <$> traverse genField selSet + (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet) pure (ConsD { cName, cFields }, concat subTypes, concat requests) where genField - :: (Text, ValidSelection) - -> Validation (DataField, [ClientType], [Text]) - genField (fName, sel@Selection { selectionAlias, selectionPosition }) = + :: Selection VALID + -> Eventless (FieldDefinition, [ClientType], [Text]) + genField + sel@Selection + { selectionName + , selectionPosition + } = do (fieldDataType, fieldType) <- lookupFieldType lib fieldPath datatype selectionPosition - fName + selectionName (subTypes, requests) <- subTypesBySelection fieldDataType sel pure - ( DataField { fieldName - , fieldArgs = [] - , fieldArgsType = Nothing - , fieldType - , fieldMeta = Nothing - } + ( FieldDefinition + { fieldName + , fieldType + , fieldArgs = NoArguments + , fieldMeta = Nothing + } , subTypes , requests ) where fieldPath = path <> [fieldName] ------------------------------- - fieldName = fromMaybe fName selectionAlias + fieldName = keyOf sel ------------------------------------------ subTypesBySelection - :: DataType -> ValidSelection -> Validation ([ClientType], [Text]) + :: TypeDefinition -> Selection VALID -> Eventless ([ClientType], [Text]) subTypesBySelection dType Selection { selectionContent = SelectionField } = leafType dType --withLeaf buildLeaf dType @@ -186,7 +190,7 @@ subTypesBySelection dType Selection { selectionContent = UnionSelection unionSelections } = do (tCons, subTypes, requests) <- - unzip3 <$> mapM getUnionType unionSelections + unzip3 <$> traverse getUnionType (toList unionSelections) pure ( ClientType { clientType = TypeD { tNamespace = fieldPath @@ -200,7 +204,7 @@ , concat requests ) where - getUnionType (selectedTyName, selectionVariant) = do + getUnionType (UnionTag selectedTyName selectionVariant) = do conDatatype <- getType lib selectedTyName genConsD selectedTyName conDatatype selectionVariant @@ -208,25 +212,24 @@ scanInputTypes lib name collected | name `elem` collected = pure collected | otherwise = getType lib name >>= scanInpType where - scanInpType DataType { typeContent, typeName } = scanType typeContent + scanInpType TypeDefinition { typeContent, typeName } = scanType typeContent where scanType (DataInputObject fields) = resolveUpdates - (name : collected) - (map toInputTypeD fields) + (name : collected) (map toInputTypeD $ toList fields) where - toInputTypeD :: (Text, DataField) -> LibUpdater [Key] - toInputTypeD (_, DataField { fieldType = TypeRef { typeConName } }) = + toInputTypeD :: FieldDefinition -> LibUpdater [Key] + toInputTypeD FieldDefinition { fieldType = TypeRef { typeConName } } = scanInputTypes lib typeConName scanType (DataEnum _) = pure (collected <> [typeName]) scanType _ = pure collected -buildInputType :: Schema -> Text -> Validation [ClientType] +buildInputType :: Schema -> Text -> Eventless [ClientType] buildInputType lib name = getType lib name >>= generateTypes where - generateTypes DataType { typeName, typeContent } = subTypes typeContent + generateTypes TypeDefinition { typeName, typeContent } = subTypes typeContent where subTypes (DataInputObject inputFields) = do - fields <- traverse toFieldD inputFields + fields <- traverse toFieldD (toList inputFields) pure [ ClientType { clientType = TypeD @@ -242,10 +245,10 @@ } ] where - toFieldD :: (Text, DataField) -> Validation DataField - toFieldD (_, field@DataField { fieldType }) = do + toFieldD :: FieldDefinition -> Eventless FieldDefinition + toFieldD field@FieldDefinition { fieldType } = do typeConName <- typeFrom [] <$> getType lib (typeConName fieldType) - pure $ field { fieldType = fieldType { typeConName } } + pure $ field { fieldType = fieldType { typeConName } } subTypes (DataEnum enumTags) = pure [ ClientType { clientType = TypeD { tName = typeName @@ -261,23 +264,24 @@ ConsD { cName = enumName, cFields = [] } subTypes _ = pure [] - lookupFieldType :: Schema -> [Key] - -> DataType + -> TypeDefinition -> Position -> Text - -> Validation (DataType, TypeRef) -lookupFieldType lib path DataType { typeContent = DataObject { objectFields }, typeName } refPosition key - = case lookup key objectFields of - Just DataField { fieldType = alias@TypeRef { typeConName }, fieldMeta } -> + -> Eventless (TypeDefinition, TypeRef) +lookupFieldType lib path TypeDefinition { typeContent = DataObject { objectFields }, typeName } refPosition key + = selectBy selError key objectFields >>= processDeprecation + where + selError = compileError $ "cant find field \"" <> pack (show objectFields) <> "\"" + processDeprecation FieldDefinition { fieldType = alias@TypeRef { typeConName }, fieldMeta } = checkDeprecated >> (trans <$> getType lib typeConName) where trans x = (x, alias { typeConName = typeFrom path x, typeArgs = Nothing }) ------------------------------------------------------------------ - checkDeprecated :: Validation () + checkDeprecated :: Eventless () checkDeprecated = case fieldMeta >>= lookupDeprecated of Just deprecation -> Success { result = (), warnings, events = [] } where @@ -285,35 +289,23 @@ Ref { refName = key, refPosition } (lookupDeprecatedReason deprecation) Nothing -> pure () - ------------------ - Nothing -> - failure - (compileError $ "cant find field \"" <> pack (show objectFields) <> "\"") lookupFieldType _ _ dt _ _ = failure (compileError $ "Type should be output Object \"" <> pack (show dt)) -leafType :: DataType -> Validation ([ClientType], [Text]) -leafType DataType { typeName, typeContent } = fromKind typeContent +leafType :: TypeDefinition -> Eventless ([ClientType], [Text]) +leafType TypeDefinition { typeName, typeContent } = fromKind typeContent where - fromKind :: DataTypeContent -> Validation ([ClientType], [Text]) + fromKind :: TypeContent -> Eventless ([ClientType], [Text]) fromKind DataEnum{} = pure ([], [typeName]) fromKind DataScalar{} = pure ([], []) fromKind _ = failure $ compileError "Invalid schema Expected scalar" -getType :: Schema -> Text -> Validation DataType -getType lib typename = lookupResult (compileError typename) typename lib - -typeFromScalar :: Name -> Name -typeFromScalar "Boolean" = "Bool" -typeFromScalar "Int" = "Int" -typeFromScalar "Float" = "Float" -typeFromScalar "String" = "Text" -typeFromScalar "ID" = "ID" -typeFromScalar _ = "ScalarValue" +getType :: Schema -> Text -> Eventless TypeDefinition +getType lib typename = selectBy (compileError typename) typename lib -typeFrom :: [Name] -> DataType -> Name -typeFrom path DataType { typeName, typeContent } = __typeFrom typeContent +typeFrom :: [Name] -> TypeDefinition -> Name +typeFrom path TypeDefinition { typeName, typeContent } = __typeFrom typeContent where __typeFrom DataScalar{} = typeFromScalar typeName __typeFrom DataObject{} = nameSpaceType path typeName diff --git a/src/Data/Morpheus/Execution/Document/Compile.hs b/src/Data/Morpheus/Execution/Document/Compile.hs --- a/src/Data/Morpheus/Execution/Document/Compile.hs +++ b/src/Data/Morpheus/Execution/Document/Compile.hs @@ -22,8 +22,8 @@ ( toTHDefinitions ) import Data.Morpheus.Execution.Document.Declare ( declareTypes ) -import Data.Morpheus.Parsing.Document.Parser - ( parseTypes ) +import Data.Morpheus.Parsing.Document.TypeSystem + ( parseSchema ) import Data.Morpheus.Validation.Document.Validation import Data.Morpheus.Types.Internal.Resolving ( Result(..) ) @@ -52,7 +52,7 @@ compileDocument :: Bool -> String -> Q [Dec] compileDocument namespace documentTXT = case - parseTypes (T.pack documentTXT) + parseSchema (T.pack documentTXT) >>= validatePartialDocument of Failure errors -> fail (renderGQLErrors errors) 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 @@ -3,7 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} +-- {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Execution.Document.Convert ( toTHDefinitions @@ -19,84 +20,101 @@ import Data.Morpheus.Execution.Internal.Utils ( capital ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) - , DataTypeContent(..) - , DataType(..) - , DataTypeKind(..) - , OperationType(..) + ( FieldDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , TypeRef(..) , DataEnumValue(..) - , sysTypes , ConsD(..) , GQLTypeD(..) , TypeD(..) , Key - , DataObject + , InputFieldsDefinition(..) + , ArgumentsDefinition(..) + , hasArguments + , lookupWith + , toHSFieldDefinition + , hsTypeName + , kindOf ) - +import Data.Morpheus.Types.Internal.Operation + (Listable(..)) m_ :: Key m_ = "m" -getTypeArgs :: Key -> [(Key, DataType)] -> Q (Maybe Key) +getTypeArgs :: Key -> [TypeDefinition] -> Q (Maybe Key) getTypeArgs "__TypeKind" _ = pure Nothing getTypeArgs "Boolean" _ = pure Nothing getTypeArgs "String" _ = pure Nothing getTypeArgs "Int" _ = pure Nothing getTypeArgs "Float" _ = pure Nothing -getTypeArgs key lib = case typeContent <$> lookup key lib of +getTypeArgs key lib = case typeContent <$> lookupWith typeName key lib of Just x -> pure (kindToTyArgs x) Nothing -> getTyArgs <$> reify (mkName $ unpack key) getTyArgs :: Info -> Maybe Key getTyArgs x - | length (infoTyVars x) > 0 = Just m_ - | otherwise = Nothing - + | null (infoTyVars x) = Nothing + | otherwise = Just m_ -kindToTyArgs :: DataTypeContent -> Maybe Key +kindToTyArgs :: TypeContent -> Maybe Key kindToTyArgs DataObject{} = Just m_ kindToTyArgs DataUnion{} = Just m_ kindToTyArgs _ = Nothing -toTHDefinitions :: Bool -> [(Key, DataType)] -> Q [GQLTypeD] +toTHDefinitions :: Bool -> [TypeDefinition] -> Q [GQLTypeD] toTHDefinitions namespace lib = traverse renderTHType lib where - renderTHType :: (Key, DataType) -> Q GQLTypeD - renderTHType (tyConName, x) = generateType x + renderTHType :: TypeDefinition -> Q GQLTypeD + renderTHType x = generateType x where genArgsTypeName :: Key -> Key - genArgsTypeName fieldName | namespace = hsTypeName tyConName <> argTName + genArgsTypeName fieldName | namespace = hsTypeName (typeName x) <> argTName | otherwise = argTName where argTName = capital fieldName <> "Args" --------------------------------------------------------------------------------------------- - genResField :: (Key, DataField) -> Q DataField - genResField (_, field@DataField { fieldName, fieldArgs, fieldType = typeRef@TypeRef { typeConName } }) + genResField :: FieldDefinition -> Q FieldDefinition + genResField field@FieldDefinition { fieldName, fieldArgs, fieldType = typeRef@TypeRef { typeConName } } = do typeArgs <- getTypeArgs typeConName lib - pure $ field { - fieldType = typeRef { typeConName = hsTypeName typeConName, typeArgs } - , fieldArgsType - } + pure $ field + { fieldType = typeRef { typeConName = hsTypeName typeConName, typeArgs } + , fieldArgs = fieldArguments + } where - fieldArgsType - | null fieldArgs = Nothing - | otherwise = Just (genArgsTypeName fieldName) + fieldArguments + | hasArguments fieldArgs = fieldArgs { argumentsTypename = Just $ genArgsTypeName fieldName } + | otherwise = fieldArgs -------------------------------------------- - generateType :: DataType -> Q GQLTypeD - generateType dt@DataType { typeName, typeContent, typeMeta } = genType + generateType :: TypeDefinition -> Q GQLTypeD + generateType typeOriginal@TypeDefinition { typeName, typeContent, typeMeta } = genType typeContent where - genType :: DataTypeContent -> Q GQLTypeD + buildType :: [ConsD] -> TypeD + buildType tCons = TypeD + { tName = hsTypeName typeName + , tMeta = typeMeta + , tNamespace = [] + , tCons + } + buildObjectCons :: [FieldDefinition] -> [ConsD] + buildObjectCons cFields = + [ ConsD + { cName = hsTypeName typeName + , cFields + } + ] + typeKindD = kindOf typeOriginal + genType :: TypeContent -> Q GQLTypeD genType (DataEnum tags) = pure GQLTypeD { typeD = TypeD { tName = hsTypeName typeName , tNamespace = [] , tCons = map enumOption tags , tMeta = typeMeta } - , typeKindD = KindEnum , typeArgD = [] - , typeOriginal = (typeName, dt) + , .. } where enumOption DataEnumValue { enumName } = @@ -105,63 +123,35 @@ genType DataInputUnion {} = fail "Input Unions not Supported" genType DataInterface {} = fail "interfaces must be eliminated in Validation" genType (DataInputObject fields) = pure GQLTypeD - { typeD = - TypeD - { tName = hsTypeName typeName - , tNamespace = [] - , tCons = [ ConsD { cName = hsTypeName typeName - , cFields = genInputFields fields - } - ] - , tMeta = typeMeta - } - , typeKindD = KindInputObject - , typeArgD = [] - , typeOriginal = (typeName, dt) + { typeD = buildType $ buildObjectCons $ genInputFields fields + , typeArgD = [] + , .. } genType DataObject {objectFields} = do - typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) objectFields - cFields <- traverse genResField objectFields + typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (toList objectFields) + objCons <- buildObjectCons <$> traverse genResField (toList objectFields) pure GQLTypeD - { typeD = TypeD - { tName = hsTypeName typeName - , tNamespace = [] - , tCons = [ ConsD { cName = hsTypeName typeName - , cFields - } - ] - , tMeta = typeMeta - } - , typeKindD = if typeName == "Subscription" - then KindObject (Just Subscription) - else KindObject Nothing + { typeD = buildType objCons , typeArgD - , typeOriginal = (typeName, dt) + , .. } - genType (DataUnion members) = do - let tCons = map unionCon members + genType (DataUnion members) = pure GQLTypeD - { typeD = TypeD { tName = typeName - , tNamespace = [] - , tCons - , tMeta = typeMeta - } - , typeKindD = KindUnion + { typeD = buildType (map unionCon members) , typeArgD = [] - , typeOriginal = (typeName, dt) + , .. } where unionCon memberName = ConsD { cName - , cFields = [ DataField + , cFields = [ FieldDefinition { fieldName = "un" <> cName , fieldType = TypeRef { typeConName = utName , typeArgs = Just m_ , typeWrappers = [] } , fieldMeta = Nothing - , fieldArgs = [] - , fieldArgsType = Nothing + , fieldArgs = NoArguments } ] } @@ -170,21 +160,14 @@ utName = hsTypeName memberName - -hsTypeName :: Key -> Key -hsTypeName "String" = "Text" -hsTypeName "Boolean" = "Bool" -hsTypeName name | name `elem` sysTypes = "S" <> name -hsTypeName name = name - -genArgumentType :: (Key -> Key) -> (Key, DataField) -> Q [TypeD] -genArgumentType _ (_, DataField { fieldArgs = [] }) = pure [] -genArgumentType namespaceWith (fieldName, DataField { fieldArgs }) = pure +genArgumentType :: (Key -> Key) -> FieldDefinition -> Q [TypeD] +genArgumentType _ FieldDefinition { fieldArgs = NoArguments } = pure [] +genArgumentType namespaceWith FieldDefinition { fieldName, fieldArgs } = pure [ TypeD { tName , tNamespace = [] , tCons = [ ConsD { cName = hsTypeName tName - , cFields = genInputFields fieldArgs + , cFields = genArguments fieldArgs } ] , tMeta = Nothing @@ -192,10 +175,8 @@ ] where tName = namespaceWith (hsTypeName fieldName) +genArguments :: ArgumentsDefinition -> [FieldDefinition] +genArguments = genInputFields . InputFieldsDefinition . arguments -genInputFields :: DataObject -> [DataField] -genInputFields = map (genField . snd) - where - genField :: DataField -> DataField - genField field@DataField { fieldType = tyRef@TypeRef { typeConName } } = - field { fieldType = tyRef { typeConName = hsTypeName typeConName } } +genInputFields :: InputFieldsDefinition -> [FieldDefinition] +genInputFields = map toHSFieldDefinition . toList 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 @@ -23,7 +23,9 @@ , instanceIntrospect ) import Data.Morpheus.Execution.Internal.Declare - ( declareType ) + ( declareType + , Scope(..) + ) import Data.Morpheus.Types.Internal.AST ( isInput , isObject @@ -36,11 +38,11 @@ declareGQLType :: Bool -> GQLTypeD -> Q [Dec] declareGQLType namespace gqlType@GQLTypeD { typeD, typeKindD, typeArgD, typeOriginal } = do - mainType <- declareMainType - argTypes <- declareArgTypes - gqlInstances <- deriveGQLInstances - typeClasses <- deriveGQLType gqlType - introspectEnum <- instanceIntrospect typeOriginal + mainType <- declareMainType + argTypes <- declareArgTypes + gqlInstances <- deriveGQLInstances + typeClasses <- deriveGQLType gqlType + introspectEnum <- instanceIntrospect typeOriginal pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum where deriveGQLInstances = concat <$> sequence gqlInstances @@ -60,11 +62,11 @@ where deriveArgsRep args = deriveObjectRep (args, Nothing) ---------------------------------------------------- - argsTypeDecs = map (declareType namespace Nothing []) typeArgD + argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD -------------------------------------------------- declareMainType = declareT where declareT = - pure [declareType namespace (Just typeKindD) derivingClasses typeD] + pure [declareType SERVER namespace (Just typeKindD) derivingClasses typeD] derivingClasses | isInput typeKindD = [''Show] | 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 @@ -31,9 +31,9 @@ import Data.Morpheus.Types.Internal.TH ( instanceHeadT ) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Eventless ) -(.:) :: Decode a => ValidValue -> Text -> Validation a +(.:) :: Decode a => ValidValue -> Text -> Eventless a value .: selectorName = withObject (decodeFieldWith decode selectorName) value deriveDecode :: TypeD -> Q [Dec] 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 @@ -21,7 +21,7 @@ ) import Data.Morpheus.Types.GQLType ( TRUE ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) + ( FieldDefinition(..) , QUERY , SUBSCRIPTION , isSubscription @@ -34,7 +34,8 @@ ( Resolver , MapStrategy(..) , LiftOperation - , DataResolver(..) + , Deriving(..) + , ObjectDeriving(..) ) import Data.Morpheus.Types.Internal.TH ( applyT @@ -79,7 +80,8 @@ | isSubscription typeKindD = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]] | otherwise - = [ iLiftOp fo_ + = [ iLiftOp po_ + , iLiftOp fo_ , typeT ''MapStrategy [fo_, po_] , iTypeable fo_ , iTypeable po_ @@ -107,7 +109,14 @@ methods = [funD 'exploreResolvers [clause argsE (normalB body) []]] where argsE = [varP (mkName "_"), destructRecord tName varNames] - body = appE (conE 'ObjectRes) (listE $ map (decodeVar . unpack) varNames) + body = appE (varE 'pure) + $ appE + (conE 'DerivingObject ) + $ appE + (appE (conE 'ObjectDeriving) + (stringE (unpack tName)) + ) + (listE $ map (decodeVar . unpack) varNames) decodeVar name = [| (name, encode $(varName))|] where varName = varE $ mkName name varNames = map fieldName cFields 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 @@ -44,48 +44,49 @@ ) import Data.Typeable ( Typeable ) -genTypeName :: Key -> Key -genTypeName = pack . __genTypeName . unpack - where - __genTypeName ('S' : name) | isSchemaTypeName (pack name) = name - __genTypeName name = name - deriveGQLType :: GQLTypeD -> Q [Dec] deriveGQLType GQLTypeD { typeD = TypeD { tName, tMeta }, typeKindD } = pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies) where functions = map instanceProxyFunD - [('__typeName, [|genTypeName tName|]), ('description, descriptionValue)] + [('__typeName, [|toHSTypename tName|]), ('description, descriptionValue)] where descriptionValue = case tMeta >>= metaDescription of Nothing -> [| Nothing |] Just desc -> [| Just desc |] - ------------------------------------------------- + -------------------------------- typeArgs = tyConArgs typeKindD - ---------------------------------------------- + -------------------------------- iHead = instanceHeadT ''GQLType tName typeArgs headSig = typeT (mkName $ unpack tName) typeArgs - ----------------------------------------------- + --------------------------------------------------- constrains = map conTypeable typeArgs - where conTypeable name = typeT ''Typeable [name] - ----------------------------------------------- - typeFamilies | isObject typeKindD = [deriveCUSTOM, deriveKind] - | otherwise = [deriveKind] + where conTypeable name = typeT ''Typeable [name] + ------------------------------------------------- + typeFamilies | isObject typeKindD = [deriveKIND, deriveCUSTOM] + | otherwise = [deriveKIND] where - deriveCUSTOM = do - typeN <- headSig - pure $ typeInstanceDec ''CUSTOM typeN (ConT ''TRUE) - --------------------------------------------------------------- - deriveKind = do + deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE + deriveKIND = deriveInstance ''KIND (kindName typeKindD) + ------------------------------------------------------- + deriveInstance :: Name -> Name -> Q Dec + deriveInstance insName tyName = do typeN <- headSig - pure $ typeInstanceDec ''KIND typeN (ConT $ toKIND typeKindD) - --------------------------------- - toKIND KindScalar = ''SCALAR - toKIND KindEnum = ''ENUM - toKIND (KindObject _) = ''OUTPUT - toKIND KindUnion = ''OUTPUT - toKIND KindInputObject = ''INPUT - toKIND KindList = ''WRAPPER - toKIND KindNonNull = ''WRAPPER - toKIND KindInputUnion = ''INPUT + pure $ typeInstanceDec insName typeN (ConT tyName) + +kindName :: DataTypeKind -> Name +kindName KindObject {} = ''OUTPUT +kindName KindScalar = ''SCALAR +kindName KindEnum = ''ENUM +kindName KindUnion = ''OUTPUT +kindName KindInputObject = ''INPUT +kindName KindList = ''WRAPPER +kindName KindNonNull = ''WRAPPER +kindName KindInputUnion = ''INPUT + +toHSTypename :: Key -> Key +toHSTypename = pack . hsTypename . unpack + where + hsTypename ('S' : name) | isSchemaTypeName (pack name) = name + hsTypename name = name 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 @@ -1,7 +1,9 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Execution.Document.Introspect ( deriveObjectRep , instanceIntrospect @@ -17,34 +19,34 @@ import Data.Morpheus.Execution.Internal.Declare (tyConArgs) import Data.Morpheus.Execution.Server.Introspect (Introspect (..), introspectObjectFields, IntrospectRep (..),TypeScope(..)) import Data.Morpheus.Types.GQLType (GQLType (__typeName), TRUE) -import Data.Morpheus.Types.Internal.AST (ConsD (..), TypeD (..), Key, DataType(..), DataTypeContent(..), DataField (..),insertType,DataTypeKind(..), TypeRef (..)) +import Data.Morpheus.Types.Internal.AST ( ConsD (..) + , TypeD (..) + , TypeDefinition(..) + , TypeContent(..) + , ArgumentsDefinition(..) + , FieldDefinition (..) + , insertType + , DataTypeKind(..) + , TypeRef (..) + , unsafeFromFields + , unsafeFromInputFields + ) import Data.Morpheus.Types.Internal.TH (instanceFunD, instanceProxyFunD,instanceHeadT, instanceHeadMultiT, typeT) - -instanceIntrospect :: (Key,DataType) -> Q [Dec] --- FIXME: dirty fix for introspection -instanceIntrospect ("__DirectiveLocation",_) = pure [] -instanceIntrospect ("__TypeKind",_) = pure [] -instanceIntrospect (name, DataType { - typeContent = DataEnum enumType, - typeName - , typeMeta - , typeFingerprint - }) = pure <$> instanceD (cxt []) iHead [defineIntrospect] +instanceIntrospect :: TypeDefinition -> Q [Dec] +instanceIntrospect TypeDefinition { typeName, typeContent = DataEnum enumType , .. } + -- FIXME: dirty fix for introspection + | typeName `elem` ["__DirectiveLocation","__TypeKind"] = pure [] + | otherwise = pure <$> instanceD (cxt []) iHead [defineIntrospect] where ----------------------------------------------- - iHead = instanceHeadT ''Introspect name [] + iHead = instanceHeadT ''Introspect typeName [] defineIntrospect = instanceProxyFunD ('introspect,body) where - body =[| insertType (name,DataType { - typeName - ,typeMeta - , typeFingerprint - ,typeContent = DataEnum enumType - }) |] + body =[| insertType TypeDefinition { typeContent = DataEnum enumType, .. } |] instanceIntrospect _ = pure [] --- [((Text, DataField), TypeUpdater)] +-- [(FieldDefinition, TypeUpdater)] deriveObjectRep :: (TypeD, Maybe DataTypeKind) -> Q [Dec] deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) = pure <$> instanceD (cxt constrains) iHead methods @@ -59,18 +61,18 @@ methods = [instanceFunD 'introspectRep ["_proxy1", "_proxy2"] body] where body - | tKind == Just KindInputObject || null tKind = [| (DataInputObject $(buildFields cFields), concat $(buildTypes cFields))|] - | otherwise = [| (DataObject [] $(buildFields cFields), concat $(buildTypes cFields))|] + | tKind == Just KindInputObject || null tKind = [| (DataInputObject $ unsafeFromInputFields $(buildFields cFields), concat $(buildTypes cFields))|] + | otherwise = [| (DataObject [] $ unsafeFromFields $(buildFields cFields), concat $(buildTypes cFields))|] deriveObjectRep _ = pure [] -buildTypes :: [DataField] -> ExpQ +buildTypes :: [FieldDefinition] -> ExpQ buildTypes = listE . concatMap introspectField where - introspectField DataField {fieldType, fieldArgsType} = - [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgsType + introspectField FieldDefinition {fieldType, fieldArgs } = + [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgs where - inputTypes (Just argsTypeName) - | argsTypeName /= "()" = [[|snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]] + inputTypes ArgumentsDefinition { argumentsTypename = Just argsTypeName } + | argsTypeName /= "()" = [[| snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]] where tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing} inputTypes _ = [] @@ -87,18 +89,7 @@ genSig (Just m) = appT (conTX typeConName) (varTX m) genSig _ = conTX typeConName -buildFields :: [DataField] -> ExpQ +buildFields :: [FieldDefinition] -> ExpQ buildFields = listE . map buildField where - buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeRef {typeArgs, typeWrappers}, fieldMeta} = - [|( fieldName - , DataField - { fieldName - , fieldArgs = fArgs - , fieldArgsType = Nothing - , fieldType = TypeRef {typeConName = __typeName $(proxyT alias), typeArgs = aArgs, typeWrappers} - , fieldMeta - })|] - where - fArgs = map (\(k, v) -> (unpack k, v)) fieldArgs - aArgs = unpack <$> typeArgs + buildField f@FieldDefinition {fieldType } = [| f { fieldType = fieldType {typeConName = __typeName $(proxyT fieldType) } } |] 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 @@ -6,14 +6,18 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} module Data.Morpheus.Execution.Internal.Declare ( declareType + , isEnum , tyConArgs + , Scope(..) ) where import Data.Maybe ( maybe ) +import Data.Semigroup ( (<>) ) import Data.Text ( unpack ) import GHC.Generics ( Generic ) import Language.Haskell.TH @@ -24,7 +28,7 @@ , nameSpaceWith ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) + ( FieldDefinition(..) , DataTypeKind(..) , DataTypeKind(..) , TypeRef(..) @@ -35,6 +39,7 @@ , TypeD(..) , Key , isOutputObject + , ArgumentsDefinition(..) ) import Data.Morpheus.Types.Internal.Resolving ( UnSubResolver ) @@ -65,10 +70,13 @@ tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = [m_] | otherwise = [] +data Scope = CLIENT | SERVER + deriving Eq + -- declareType -declareType :: Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec -declareType namespace kindD derivingList TypeD { tName, tCons, tNamespace } = - DataD [] (genName tName) tVars Nothing (map cons tCons) +declareType :: Scope -> Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec +declareType scope namespace kindD derivingList TypeD { tName, tCons, tNamespace } = + DataD [] (genName tName) tVars Nothing cons $ map derive (''Generic : derivingList) where genName = mkName . unpack . nameSpaceType tNamespace @@ -76,26 +84,34 @@ where declareTyVar = map (PlainTV . mkName . unpack) defBang = Bang NoSourceUnpackedness NoSourceStrictness derive className = DerivClause Nothing [ConT className] - cons ConsD { cName, cFields } = RecC (genName cName) - (map declareField cFields) + cons + | scope == CLIENT && isEnum tCons = map consE tCons + | otherwise = map consR tCons + consE ConsD { cName } = NormalC (genName $ tName <> cName) [] + consR ConsD { cName, cFields } = RecC (genName cName) + (map declareField cFields) + where - declareField DataField { fieldName, fieldArgsType, fieldType } = + declareField FieldDefinition { fieldName, fieldArgs, fieldType } = (fName, defBang, fiType) where fName | namespace = mkName $ unpack (nameSpaceWith tName fieldName) | otherwise = mkName (unpack fieldName) - fiType = genFieldT fieldArgsType + fiType = genFieldT fieldArgs where monadVar = VarT $ mkName $ unpack m_ --------------------------- - genFieldT Nothing - | (isOutputObject <$> kindD) == Just True = AppT monadVar result - | otherwise = result - genFieldT (Just argsTypeName) = AppT + genFieldT ArgumentsDefinition { argumentsTypename = Just argsTypename } = AppT (AppT arrowType argType) (AppT monadVar result) where - argType = ConT $ mkName (unpack argsTypeName) + argType = ConT $ mkName (unpack argsTypename) arrowType = ConT ''Arrow + genFieldT _ + | (isOutputObject <$> kindD) == Just True = AppT monadVar result + | otherwise = result ------------------------------------------------ result = declareTypeRef (maybe False isSubscription kindD) fieldType + +isEnum :: [ConsD] -> Bool +isEnum = all (null . cFields) 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 @@ -1,6 +1,7 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Morpheus.Execution.Internal.Decode ( withObject @@ -26,17 +27,24 @@ internalTypeMismatch ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) + ( FieldDefinition(..) , Key , ConsD(..) , ValidObject , Value(..) , ValidValue , Message + , ObjectEntry(..) ) import Data.Morpheus.Types.Internal.Resolving - ( Validation, Failure(..) ) - + ( Eventless + , Failure(..) + ) +import Data.Morpheus.Types.Internal.Operation + ( selectBy + , selectOr + , empty + ) decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ decodeObjectExpQ fieldDecoder ConsD { cName, cFields } = handleFields cFields @@ -49,12 +57,12 @@ applyFields [x ] = defField x applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs) ------------------------------------------------------------------------ - defField DataField { fieldName } = uInfixE (varE (mkName "o")) + defField FieldDefinition { fieldName } = uInfixE (varE (mkName "o")) fieldDecoder [|fName|] where fName = unpack fieldName -withObject :: (ValidObject -> Validation a) -> ValidValue -> Validation a +withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a withObject f (Object object) = f object withObject _ isType = internalTypeMismatch "Object" isType @@ -62,23 +70,23 @@ withMaybe _ Null = pure Nothing withMaybe decode x = Just <$> decode x -withList :: (ValidValue -> Validation a) -> ValidValue -> Validation [a] -withList decode (List li) = mapM decode li +withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a] +withList decode (List li) = traverse decode li withList _ isType = internalTypeMismatch "List" isType -withEnum :: (Key -> Validation a) -> ValidValue -> Validation a +withEnum :: (Key -> Eventless a) -> ValidValue -> Eventless a withEnum decode (Enum value) = decode value withEnum _ isType = internalTypeMismatch "Enum" isType -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 -> withObject (decoder key unions) (Object []) - Just value -> withObject (decoder key unions) value - Just _ -> failure ("__typename must be Enum" :: Message) - Nothing -> failure ("__typename not found on Input Union" :: Message) +withUnion :: (Key -> ValidObject -> ValidObject -> Eventless a) -> ValidObject -> Eventless a +withUnion decoder unions = do + (enum :: ValidValue) <- entryValue <$> selectBy ("__typename not found on Input Union" :: Message) "__typename" unions + case enum of + (Enum key) -> selectOr notfound onFound key unions + where + notfound = withObject (decoder key unions) (Object empty) + onFound = withObject (decoder key unions) . entryValue + _ -> failure ("__typename must be Enum" :: Message) -decodeFieldWith :: (ValidValue -> Validation a) -> Key -> ValidObject -> Validation a -decodeFieldWith decoder name object = case lookup name object of - Nothing -> decoder Null - Just value -> decoder value +decodeFieldWith :: (ValidValue -> Eventless a) -> Key -> ValidObject -> Eventless a +decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue) 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 @@ -48,29 +48,31 @@ import Data.Morpheus.Types.Internal.AST ( Name , Argument(..) - , ValidArguments - , ValidArgument + , ObjectEntry(..) , ValidObject , Value(..) , ValidValue + , Arguments + , VALID ) import Data.Morpheus.Types.Internal.Resolving - ( Validation + ( Eventless , Failure(..) ) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + ) -- GENERIC -decodeArguments :: DecodeType a => ValidArguments -> Validation a -decodeArguments = decodeType . Object . map toObject - where - toObject :: (Name, ValidArgument) -> (Name, ValidValue) - toObject (x, Argument { argumentValue }) = (x, argumentValue) - +decodeArguments :: DecodeType a => Arguments VALID -> Eventless a +decodeArguments = decodeType . Object . fmap toEntry + where + toEntry (Argument name value _) = ObjectEntry name value -- | Decode GraphQL query arguments and input values class Decode a where - decode :: ValidValue -> Validation a + decode :: ValidValue -> Eventless a instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where decode = decodeKind (Proxy @(KIND a)) @@ -83,7 +85,7 @@ -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: GQL_KIND) a where - decodeKind :: Proxy kind -> ValidValue -> Validation a + decodeKind :: Proxy kind -> ValidValue -> Eventless a -- SCALAR instance (GQLScalar a) => DecodeKind SCALAR a where @@ -105,7 +107,7 @@ class DecodeType a where - decodeType :: ValidValue -> Validation a + decodeType :: ValidValue -> Eventless a instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a))=> DecodeType a where decodeType = fmap to . decodeRep . (, Cont D_CONS "") @@ -118,11 +120,11 @@ -- deriving (Generic, GQLType) decideUnion - :: ([Name], value -> Validation (f1 a)) - -> ([Name], value -> Validation (f2 a)) + :: ([Name], value -> Eventless (f1 a)) + -> ([Name], value -> Eventless (f2 a)) -> Name -> value - -> Validation ((:+:) f1 f2 a) + -> Eventless ((:+:) f1 f2 a) decideUnion (left, f1) (right, f2) name value | name `elem` left = L1 <$> f1 value @@ -153,16 +155,17 @@ -- class DecodeRep f where tags :: Proxy f -> Name -> Info - decodeRep :: (ValidValue,Cont) -> Validation (f a) + decodeRep :: (ValidValue,Cont) -> Eventless (f a) 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)) }) -getEnumTag :: ValidObject -> Validation Name -getEnumTag [("enum", Enum value)] = pure value -getEnumTag _ = internalError "bad union enum object" +getEnumTag :: ValidObject -> Eventless Name +getEnumTag x = case toList x of + [ObjectEntry "enum" (Enum value)] -> pure value + _ -> internalError "bad union enum object" instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where tags _ = tags (Proxy @a) <> tags (Proxy @b) @@ -210,7 +213,7 @@ class DecodeFields f where refType :: Proxy f -> Maybe Name - decodeFields :: (ValidValue,Cont) -> Validation (f a) + decodeFields :: (ValidValue,Cont) -> Eventless (f a) instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where refType _ = Nothing 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 @@ -10,21 +10,19 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} module Data.Morpheus.Execution.Server.Encode ( EncodeCon , Encode(..) - , encodeQuery - , encodeSubscription - , encodeMutation , ExploreResolvers(..) + , deriveModel ) where import Data.Map ( Map ) import qualified Data.Map as M ( toList ) -import Data.Maybe ( fromMaybe ) import Data.Proxy ( Proxy(..) ) import Data.Semigroup ( (<>) ) import Data.Set ( Set ) @@ -38,8 +36,6 @@ ( DecodeType , decodeArguments ) -import Data.Morpheus.Execution.Server.Generics.EnumRep - ( EnumRep(..) ) import Data.Morpheus.Kind ( ENUM , GQL_KIND , ResContext(..) @@ -55,43 +51,43 @@ import Data.Morpheus.Types.GQLType ( GQLType(..) ) import Data.Morpheus.Types.Internal.AST ( Name - , Operation(..) - , MUTATION - , OperationType + , OperationType(..) , QUERY , SUBSCRIPTION - , GQLValue(..) - , ValidValue + , MUTATION + , Message ) +import Data.Morpheus.Types.Internal.Operation + (Merge(..)) import Data.Morpheus.Types.Internal.Resolving ( MapStrategy(..) , LiftOperation , Resolver - , unsafeBind , toResolver - , DataResolver(..) - , resolveObject - , resolve__typename + , Deriving(..) , FieldRes - , ResponseStream - , runResolver - , runDataResolver - , Context(..) + , GQLRootResolver(..) + , ResolverModel(..) + , unsafeBind + , failure + , ObjectDeriving(..) + , Eventless + , liftStateless ) class Encode resolver o e (m :: * -> *) where - encode :: resolver -> Resolver o e m ValidValue + encode :: resolver -> Resolver o e m (Deriving o e m) instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftOperation o) => Encode a o e m where encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a) -- MAYBE instance (Monad m , LiftOperation o,Encode a o e m) => Encode (Maybe a) o e m where - encode = maybe (pure gqlNull) encode + encode = maybe (pure DerivingNull) encode -- LIST [] instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where - encode = fmap gqlList . (traverse encode) + encode = fmap DerivingList . traverse encode -- Tuple (a,b) instance Encode (Pair k v) o e m => Encode (k, v) o e m where @@ -107,46 +103,68 @@ encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m)) -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY -instance (DecodeType a,Generic a, Monad m,LiftOperation fo, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where - encode resolver = mapStrategy $ (toResolver decodeArguments resolver) `unsafeBind` encode +instance + ( DecodeType a + , Generic a + , Monad m + , LiftOperation fo + , Encode b fo e m + , MapStrategy fo o + ) + => Encode (a -> Resolver fo e m b) o e m where + encode x + = mapStrategy + $ toResolver decodeArguments x `unsafeBind` encode -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY -instance (Monad m,LiftOperation fo, MapStrategy fo o, Encode b fo e m) => Encode (Resolver fo e m b) o e m where - encode = mapStrategy . (`unsafeBind` encode) +instance + ( Monad m + , LiftOperation o + , Encode b fo e m + , MapStrategy fo o + ) + => Encode (Resolver fo e m b) o e m where + encode = mapStrategy . (`unsafeBind` encode) -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where - encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m ValidValue + encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m (Deriving o e m) -- SCALAR instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where - encodeKind = pure . gqlScalar . serialize . unVContext + encodeKind = pure . DerivingScalar . serialize . unVContext -- ENUM -instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o e m where - encodeKind = pure . gqlString . encodeRep . from . unVContext +instance (Generic a, ExploreResolvers (CUSTOM a) a o e m, Monad m) => EncodeKind ENUM a o e m where + encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value -instance (Monad m,Generic a, GQLType a,ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where - encodeKind (VContext value) = runDataResolver (__typeName (Proxy @a)) (exploreResolvers (Proxy @(CUSTOM a)) value) +instance (Monad m,Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where + encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value convertNode :: (Monad m, LiftOperation o) => ResNode o e m - -> DataResolver o e m -convertNode ResNode { resKind = REP_OBJECT, resFields } = - ObjectRes $ map toFieldRes resFields + -> Deriving o e m +convertNode ResNode { resDatatypeName, resKind = REP_OBJECT, resFields } = + DerivingObject (ObjectDeriving resDatatypeName $ map toFieldRes resFields) convertNode ResNode { resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord } = encodeUnion resFields where -- ENUM - encodeUnion [] = EnumRes resTypeName + encodeUnion [] = DerivingEnum resDatatypeName 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) + = DerivingUnion fieldTypeName fieldResolver + -- Inline Union Types ---------------------------------------------------------------------------- + encodeUnion fields + = DerivingUnion + resTypeName + $ pure + $ DerivingObject + $ ObjectDeriving + resTypeName + (map toFieldRes resolvers) where resolvers | isResRecord = fields | otherwise = setFieldNames fields @@ -154,75 +172,79 @@ -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a) -type EncodeOperation e m a = a -> Context -> ResponseStream e m ValidValue - type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) - -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" - - --- GENERICS ------------------------------------------------ class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where - exploreResolvers :: Proxy custom -> a -> DataResolver o e m + exploreResolvers :: Proxy custom -> a -> Eventless (Deriving o e m) instance (Generic a,Monad m,LiftOperation o,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) + exploreResolvers _ value = + pure + $ convertNode + $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value) ----- HELPERS ---------------------------- -encodeQuery - :: forall m event query (schema :: (* -> *) -> *) - . ( Monad m - , EncodeCon QUERY event m (schema (Resolver QUERY event m)) - , EncodeCon QUERY event m query +objectResolvers + :: forall a o e m + . ( ExploreResolvers (CUSTOM a) a o e m + , Monad m + , LiftOperation o ) - => schema (Resolver QUERY event m) - -> EncodeOperation event m query -encodeQuery schema = encodeOperationWith - (Proxy @QUERY) - (Just $ objectResolvers - (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m)))) - schema - ) - -encodeMutation - :: forall event m mut - . (Monad m, EncodeCon MUTATION event m mut) - => EncodeOperation event m mut -encodeMutation = encodeOperationWith (Proxy @MUTATION) Nothing + => a + -> Eventless (Deriving o e m) +objectResolvers value + = exploreResolvers (Proxy @(CUSTOM a)) value + >>= constraintOnject + where + constraintOnject obj@DerivingObject {} + = pure obj + constraintOnject _ + = failure ("resolver must be an object" :: Message) -encodeSubscription - :: forall m event mut - . (Monad m, EncodeCon SUBSCRIPTION event m mut) - => EncodeOperation event m mut -encodeSubscription = encodeOperationWith (Proxy @SUBSCRIPTION) Nothing +type Con o e m a + = ExploreResolvers + (CUSTOM + (a (Resolver o e m)) + ) + (a (Resolver o e m)) + o + e + m -encodeOperationWith - :: forall (o :: OperationType) e m a - . (Monad m, EncodeCon o e m a, LiftOperation o) - => Proxy o - -> Maybe (DataResolver o e m) - -> EncodeOperation e m a -encodeOperationWith _ externalRes rootResolver ctx@Context { operation = Operation { operationSelection } } = - runResolver (resolveObject operationSelection (rootDataRes <> extDataRes)) ctx - where - rootDataRes = objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver - extDataRes = fromMaybe (ObjectRes []) externalRes +deriveModel + :: forall e m query mut sub schema. + ( Con QUERY e m query + , Con QUERY e m schema + , Con MUTATION e m mut + , Con SUBSCRIPTION e m sub + , Applicative m + , Monad m + ) + => GQLRootResolver m e query mut sub + -> schema (Resolver QUERY e m) + -> ResolverModel e m +deriveModel + GQLRootResolver + { queryResolver + , mutationResolver + , subscriptionResolver + } + schema + = ResolverModel + { query + = do + schema' <- objectResolvers schema + root' <- objectResolvers queryResolver + root' <:> schema' + , mutation = objectResolvers mutationResolver + , subscription = objectResolvers subscriptionResolver + } toFieldRes :: FieldNode o e m -> FieldRes o e m toFieldRes FieldNode { fieldSelName, fieldResolver } = (fieldSelName, fieldResolver) - -- NEW AUTOMATIC DERIVATION SYSTEM data REP_KIND = REP_UNION | REP_OBJECT @@ -235,9 +257,9 @@ } data FieldNode o e m = FieldNode { - fieldTypeName :: Name, - fieldSelName :: Name, - fieldResolver :: Resolver o e m ValidValue, + fieldTypeName :: Name, + fieldSelName :: Name, + fieldResolver :: Resolver o e m (Deriving o e m), isFieldObject :: Bool } @@ -251,11 +273,9 @@ 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) - } - + { resDatatypeName = pack $ datatypeName (undefined :: M1 D d f a) } - --- UNION OR OBJECT +--- 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 } diff --git a/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs b/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs --- a/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs +++ b/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs @@ -19,11 +19,11 @@ -- MORPHEUS import Data.Morpheus.Error.Internal ( internalError ) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Eventless ) class EnumRep f where encodeRep :: f a -> Text - decodeEnum :: Text -> Validation (f a) + decodeEnum :: Text -> Eventless (f a) enumTags :: Proxy f -> [Text] instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where 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 @@ -8,41 +8,24 @@ ) where -import Data.Aeson ( encode ) -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy.Char8 as LB - ( ByteString - , fromStrict - , toStrict - ) -import Data.Text ( Text ) -import qualified Data.Text.Lazy as LT - ( Text - , fromStrict - , toStrict - ) -import Data.Text.Lazy.Encoding ( decodeUtf8 - , encodeUtf8 - ) -import Control.Monad.IO.Class ( MonadIO() ) -- MORPHEUS +import Data.Morpheus.Types.Internal.Subscription + ( Stream + , Input + , toOutStream + ) import Data.Morpheus.Execution.Server.Resolve ( RootResCon - , byteStringIO - , statefulResolver - , statelessResolver - , streamResolver , coreResolver + , statelessResolver ) -import Data.Morpheus.Execution.Server.Subscription - ( GQLState ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..) - , ResponseStream ) import Data.Morpheus.Types.IO ( GQLRequest , GQLResponse + , MapAPI(..) ) -- | main query processor and resolver @@ -62,76 +45,20 @@ -- -- or -- k :: GQLRequest -> IO GQLResponse -- @ -class Interpreter k m e where +class Interpreter e m a b where interpreter :: Monad m - => (RootResCon m e query mut sub) => - GQLRootResolver m e query mut sub -> k - -{- - simple HTTP stateless Interpreter without side effects --} -type StateLess m a = a -> m a + => (RootResCon m e query mut sub) + => GQLRootResolver m e query mut sub + -> a + -> b -instance Interpreter (GQLRequest -> m GQLResponse) m e where +instance Interpreter e m GQLRequest (m GQLResponse) where interpreter = statelessResolver -instance Interpreter (StateLess m LB.ByteString) m e where - interpreter root = byteStringIO (statelessResolver root) - -instance Interpreter (StateLess m LT.Text) m e where - interpreter root request = - decodeUtf8 <$> interpreter root (encodeUtf8 request) - -instance Interpreter (StateLess m ByteString) m e where - interpreter root request = - LB.toStrict <$> interpreter root (LB.fromStrict request) - -instance Interpreter (StateLess m Text) m e where - interpreter root request = - LT.toStrict <$> interpreter root (LT.fromStrict request) - -{- - HTTP Interpreter with state and side effects, every mutation will - trigger subscriptions in shared `GQLState` --} -type WSPub m e a = GQLState m e -> a -> m a - -instance MonadIO m => Interpreter (WSPub m e LB.ByteString) m e where - interpreter root state = statefulResolver state (coreResolver root) - -instance MonadIO m => Interpreter (WSPub m e LT.Text) m e where - interpreter root state request = - decodeUtf8 <$> interpreter root state (encodeUtf8 request) - -instance MonadIO m => Interpreter (WSPub m e ByteString) m e where - interpreter root state request = - LB.toStrict <$> interpreter root state (LB.fromStrict request) - -instance MonadIO m => Interpreter (WSPub m e Text) m e where - interpreter root state request = - LT.toStrict <$> interpreter root state (LT.fromStrict request) - -{- - WebSocket Interpreter without state and side effects, mutations and subscription will return Actions - that will be executed in WebSocket server --} -type WSSub m e a = a -> ResponseStream e m a - -instance Interpreter (GQLRequest -> ResponseStream e m LB.ByteString) m e where - interpreter root request = encode <$> streamResolver root request - -instance Interpreter (WSSub m e LB.ByteString) m e where - interpreter root = byteStringIO (streamResolver root) - -instance Interpreter (WSSub m e LT.Text) m e where - interpreter root request = - decodeUtf8 <$> interpreter root (encodeUtf8 request) - -instance Interpreter (WSSub m e ByteString) m e where - interpreter root request = - LB.toStrict <$> interpreter root (LB.fromStrict request) +instance Interpreter e m (Input api) (Stream api e m) where + interpreter root = toOutStream (coreResolver root) -instance Interpreter (WSSub m e Text) m e where - interpreter root request = - LT.toStrict <$> interpreter root (LT.fromStrict request) +instance ( MapAPI a ) => + Interpreter e m a (m a) where + interpreter root = mapAPI (interpreter root) 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,19 +1,20 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Execution.Server.Introspect ( TypeUpdater @@ -61,11 +62,11 @@ ) import Data.Morpheus.Types.Internal.AST ( Name - , DataArguments + , ArgumentsDefinition(..) , Meta(..) - , DataField(..) - , DataTypeContent(..) - , DataType(..) + , FieldDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , Key , createAlias , defineType @@ -76,10 +77,16 @@ , TypeUpdater , DataFingerprint(..) , DataUnion - , DataObject + , FieldsDefinition(..) + , InputFieldsDefinition(..) , TypeRef(..) + , Message + , unsafeFromFields ) - +import Data.Morpheus.Types.Internal.Operation + ( Empty(..) + , Singleton(..) + ) type IntroCon a = (GQLType a, IntrospectRep (CUSTOM a) a) @@ -89,12 +96,12 @@ isObject :: proxy a -> Bool default isObject :: GQLType a => proxy a -> Bool isObject _ = isObjectKind (Proxy @a) - field :: proxy a -> Text -> DataField + field :: proxy a -> Text -> FieldDefinition introspect :: proxy a -> TypeUpdater ----------------------------------------------- default field :: GQLType a => - proxy a -> Text -> DataField - field _ = buildField (Proxy @a) [] + proxy a -> Text -> FieldDefinition + field _ = buildField (Proxy @a) NoArguments instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect a where introspect _ = introspectKind (Context :: Context (KIND a) a) @@ -135,7 +142,7 @@ field _ name = fieldObj { fieldArgs } where fieldObj = field (Proxy @b) name - fieldArgs = fst $ introspectObjectFields + fieldArgs = ArgumentsDefinition Nothing $ unFieldsDefinition $ fst $ introspectObjectFields (Proxy :: Proxy 'False) (__typeName (Proxy @b), OutputType, Proxy @a) introspect _ typeLib = resolveUpdates typeLib @@ -191,46 +198,44 @@ type GQL_TYPE a = (Generic a, GQLType a) +fromInput :: InputFieldsDefinition -> FieldsDefinition +fromInput = FieldsDefinition . unInputFieldsDefinition + +toInput :: FieldsDefinition -> InputFieldsDefinition +toInput = InputFieldsDefinition . unFieldsDefinition + introspectObjectFields :: IntrospectRep custom a => proxy1 (custom :: Bool) -> (Name, TypeScope, proxy2 a) - -> ([(Name, DataField)], [TypeUpdater]) + -> (FieldsDefinition, [TypeUpdater]) introspectObjectFields p1 (name, scope, proxy) = withObject (introspectRep p1 (proxy, scope, "", DataFingerprint "" [])) where withObject (DataObject {objectFields}, ts) = (objectFields, ts) - withObject (DataInputObject x, ts) = (x, ts) - withObject _ = - ( [] - , [ const - $ failure - $ globalErrorMessage - $ "invalid schema: " - <> name - <> " should have only one nonempty constructor" - ] - ) + withObject (DataInputObject x, ts) = (fromInput x, ts) + withObject _ = (empty, [introspectFailure (name <> " should have only one nonempty constructor")]) +introspectFailure :: Message -> TypeUpdater +introspectFailure = const . failure . globalErrorMessage . ("invalid schema: " <>) + -- Object Fields class IntrospectRep (custom :: Bool) a where - introspectRep :: proxy1 custom -> ( proxy2 a,TypeScope,Name,DataFingerprint) -> (DataTypeContent, [TypeUpdater]) + introspectRep :: proxy1 custom -> ( proxy2 a,TypeScope,Name,DataFingerprint) -> (TypeContent, [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 - { fieldName - , fieldArgs - , fieldArgsType = Nothing - , fieldType = createAlias $ __typeName proxy +buildField :: GQLType a => Proxy a -> ArgumentsDefinition -> Text -> FieldDefinition +buildField proxy fieldArgs fieldName = FieldDefinition + { fieldType = createAlias $ __typeName proxy , fieldMeta = Nothing + , .. } -buildType :: GQLType a => DataTypeContent -> Proxy a -> DataType -buildType typeContent proxy = DataType +buildType :: GQLType a => TypeContent -> Proxy a -> TypeDefinition +buildType typeContent proxy = TypeDefinition { typeName = __typeName proxy , typeFingerprint = __typeFingerprint proxy , typeMeta = Just Meta { metaDescription = description proxy @@ -241,23 +246,23 @@ updateLib :: GQLType a - => (Proxy a -> DataType) + => (Proxy a -> TypeDefinition) -> [TypeUpdater] -> Proxy a -> TypeUpdater -updateLib typeBuilder stack proxy lib' = - case isTypeDefined (__typeName proxy) lib' of +updateLib typeBuilder stack proxy lib = + case isTypeDefined (__typeName proxy) lib of Nothing -> resolveUpdates - (defineType (__typeName proxy, typeBuilder proxy) lib') + (defineType (typeBuilder proxy) lib) stack - Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib' + 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 { +data ConsRep = ConsRep { consName :: Key, consIsRecord :: Bool, consFields :: [FieldRep] @@ -265,7 +270,7 @@ data FieldRep = FieldRep { fieldTypeName :: Name, - fieldData :: (Name, DataField), + fieldData :: FieldDefinition, fieldTypeUpdater :: TypeUpdater, fieldIsObject :: Bool } @@ -273,17 +278,14 @@ data ResRep = ResRep { enumCons :: [Name], unionRef :: [Name], - unionRecordRep :: [ConsRep] + unionRecordRep :: [ConsRep ] } isEmpty :: ConsRep -> Bool isEmpty ConsRep { consFields = [] } = True isEmpty _ = False -isUnionRecord :: ConsRep -> Bool -isUnionRecord ConsRep { consIsRecord } = consIsRecord - -isUnionRef :: Name -> ConsRep -> Bool +isUnionRef :: Name -> ConsRep -> Bool isUnionRef baseName ConsRep { consName, consFields = [FieldRep { fieldIsObject = True, fieldTypeName }] } = consName == baseName <> fieldTypeName isUnionRef _ _ = False @@ -293,9 +295,7 @@ { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields } where - setFieldName i fieldR@FieldRep { fieldData = (_, fieldD) } = fieldR - { fieldData = (fieldName, fieldD { fieldName }) - } + setFieldName i fieldR@FieldRep { fieldData = fieldD } = fieldR { fieldData = fieldD { fieldName } } where fieldName = "_" <> pack (show i) analyseRep :: Name -> [ConsRep] -> ResRep @@ -307,7 +307,7 @@ where (enumRep , left1 ) = partition isEmpty cons (unionRefRep , left2 ) = partition (isUnionRef baseName) left1 - (unionRecordRep, anyonimousUnionRep) = partition isUnionRecord left2 + (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2 derivingDataContent :: forall a @@ -315,7 +315,7 @@ => Proxy a -> (Name, DataFingerprint) -> TypeScope - -> (DataTypeContent, [TypeUpdater]) + -> (TypeContent, [TypeUpdater]) derivingDataContent _ (baseName, baseFingerprint) scope = builder $ typeRep $ Proxy @(Rep a) where @@ -328,7 +328,7 @@ buildInputUnion - :: (Name, DataFingerprint) -> [ConsRep] -> (DataTypeContent, [TypeUpdater]) + :: (Name, DataFingerprint) -> [ConsRep ] -> (TypeContent, [TypeUpdater]) buildInputUnion (baseName, baseFingerprint) cons = datatype (analyseRep baseName cons) where @@ -340,15 +340,15 @@ typeMembers = map (, True) (unionRef <> unionMembers) <> map (, False) enumCons (unionMembers, unionTypes) = - buildUnions DataInputObject baseFingerprint unionRecordRep + buildUnions (DataInputObject . toInput) baseFingerprint unionRecordRep types = map fieldTypeUpdater $ concatMap consFields cons buildUnionType :: (Name, DataFingerprint) - -> (DataUnion -> DataTypeContent) - -> (DataObject -> DataTypeContent) + -> (DataUnion -> TypeContent) + -> (FieldsDefinition -> TypeContent) -> [ConsRep] - -> (DataTypeContent, [TypeUpdater]) + -> (TypeContent, [TypeUpdater]) buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype (analyseRep baseName cons) where @@ -365,48 +365,41 @@ types = map fieldTypeUpdater $ concatMap consFields cons -buildObject :: TypeScope -> [FieldRep] -> (DataTypeContent, [TypeUpdater]) -buildObject isOutput consFields = (wrap fields, types) +buildObject :: TypeScope -> [FieldRep] -> (TypeContent, [TypeUpdater]) +buildObject isOutput consFields = (wrapWith fields, types) where (fields, types) = buildDataObject consFields - wrap | isOutput == OutputType = DataObject [] - | otherwise = DataInputObject + wrapWith | isOutput == OutputType = DataObject [] + | otherwise = DataInputObject . toInput -buildDataObject :: [FieldRep] -> (DataObject, [TypeUpdater]) +buildDataObject :: [FieldRep] -> (FieldsDefinition , [TypeUpdater]) buildDataObject consFields = (fields, types) where - fields = map fieldData consFields + fields = unsafeFromFields $ map fieldData consFields types = map fieldTypeUpdater consFields buildUnions - :: (DataObject -> DataTypeContent) + :: (FieldsDefinition -> TypeContent) -> DataFingerprint -> [ConsRep] -> ([Name], [TypeUpdater]) buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons) where buildURecType consRep = pure . defineType - (consName consRep, buildUnionRecord wrapObject baseFingerprint 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) - + :: (FieldsDefinition -> TypeContent) -> DataFingerprint -> ConsRep -> TypeDefinition +buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } = TypeDefinition + { typeName = consName + , typeFingerprint + , typeMeta = Nothing + , typeContent = wrapObject $ unsafeFromFields $ map fieldData consFields + } buildUnionEnum - :: (DataObject -> DataTypeContent) + :: (FieldsDefinition -> TypeContent) -> Name -> DataFingerprint -> [Name] @@ -432,39 +425,32 @@ buildEnum :: Name -> DataFingerprint -> [Name] -> TypeUpdater buildEnum typeName typeFingerprint tags = pure . defineType - ( typeName - , DataType { typeName - , typeFingerprint - , typeMeta = Nothing - , typeContent = DataEnum $ map createEnumValue tags - } - ) + TypeDefinition + { typeMeta = Nothing + , typeContent = DataEnum $ map createEnumValue tags + , .. + } buildEnumObject - :: (DataObject -> DataTypeContent) + :: (FieldsDefinition -> TypeContent) -> Name -> DataFingerprint -> Name -> TypeUpdater buildEnumObject wrapObject typeName typeFingerprint enumTypeName = pure . defineType - ( typeName - , DataType + TypeDefinition { typeName , typeFingerprint , typeMeta = Nothing - , typeContent = wrapObject - [ ( "enum" - , DataField { fieldName = "enum" - , fieldArgs = [] - , fieldArgsType = Nothing - , fieldType = createAlias enumTypeName - , fieldMeta = Nothing - } - ) - ] + , typeContent = wrapObject $ singleton + FieldDefinition + { fieldName = "enum" + , fieldArgs = NoArguments + , fieldType = createAlias enumTypeName + , fieldMeta = Nothing + } } - ) data TypeScope = InputType | OutputType deriving (Show,Eq,Ord) @@ -497,7 +483,7 @@ instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where conRep _ = [ FieldRep { fieldTypeName = typeConName $ fieldType fieldData - , fieldData = (name, fieldData) + , fieldData = fieldData , fieldTypeUpdater = introspect (Proxy @a) , fieldIsObject = isObject (Proxy @a) } 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 @@ -7,48 +7,32 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + module Data.Morpheus.Execution.Server.Resolve ( statelessResolver - , byteStringIO - , streamResolver - , statefulResolver , RootResCon , fullSchema , coreResolver + , EventCon ) where -import Data.Aeson ( encode ) -import Data.Aeson.Internal ( formatError - , ifromJSON - ) -import Data.Aeson.Parser ( eitherDecodeWith - , jsonNoDup - ) -import qualified Data.ByteString.Lazy.Char8 as L + import Data.Functor.Identity ( Identity(..) ) import Data.Proxy ( Proxy(..) ) -- MORPHEUS -import Data.Morpheus.Error.Utils ( badRequestError ) import Data.Morpheus.Execution.Server.Encode ( EncodeCon - , encodeMutation - , encodeQuery - , encodeSubscription + , deriveModel ) import Data.Morpheus.Execution.Server.Introspect ( IntroCon , introspectObjectFields , TypeScope(..) ) -import Data.Morpheus.Execution.Server.Subscription - ( GQLState - , publishEvent - ) import Data.Morpheus.Parsing.Request.Parser ( parseGQL ) ---import Data.Morpheus.Schema.Schema (Root) import Data.Morpheus.Schema.SchemaAPI ( defaultTypes , hiddenRootFields , schemaAPI @@ -57,34 +41,35 @@ import Data.Morpheus.Types.Internal.AST ( Operation(..) , DataFingerprint(..) - , DataTypeContent(..) + , TypeContent(..) , Schema(..) - , DataType(..) + , TypeDefinition(..) , MUTATION - , OperationType(..) , QUERY , SUBSCRIPTION , initTypeLib , ValidValue , Name - , DataField , VALIDATION_MODE(..) , Selection(..) , SelectionContent(..) + , FieldsDefinition(..) ) +import Data.Morpheus.Types.Internal.Operation + ( Merge(..) + , empty + ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..) , Resolver , GQLChannel(..) - , ResponseEvent(..) , ResponseStream - , Validation + , Eventless , cleanEvents , ResultT(..) - , unpackEvents - , Failure(..) , resolveUpdates , Context(..) + , runResolverModel ) import Data.Morpheus.Types.IO ( GQLRequest(..) , GQLResponse(..) @@ -93,8 +78,8 @@ 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) @@ -117,18 +102,6 @@ (subscription (Resolver SUBSCRIPTION event m)) ) -decodeNoDup :: Failure String m => L.ByteString -> m GQLRequest -decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of - Left (path, x) -> failure $ formatError path x - Right value -> pure value - - -byteStringIO - :: Monad m => (GQLRequest -> m GQLResponse) -> L.ByteString -> m L.ByteString -byteStringIO resolver request = case decodeNoDup request of - Left aesonError' -> return $ badRequestError aesonError' - Right req -> encode <$> resolver req - statelessResolver :: (Monad m, RootResCon m event query mut sub) => GQLRootResolver m event query mut sub @@ -137,24 +110,14 @@ statelessResolver root req = renderResponse <$> runResultT (coreResolver root req) -streamResolver - :: forall event m query mut sub - . (Monad m, RootResCon m event query mut sub) - => GQLRootResolver m event query mut sub - -> GQLRequest - -> ResponseStream event m GQLResponse -streamResolver root req = - ResultT $ pure . renderResponse <$> runResultT (coreResolver root req) - - coreResolver :: forall event m query mut sub . (Monad m, RootResCon m event query mut sub) => GQLRootResolver m event query mut sub -> GQLRequest -> ResponseStream event m ValidValue -coreResolver root@GQLRootResolver { queryResolver, mutationResolver, subscriptionResolver } request - = validRequest >>= execOperator +coreResolver root request + = validRequest >>= execOperator where validRequest :: Monad m => ResponseStream event m Context @@ -164,47 +127,28 @@ pure $ Context { schema , operation - , currentSelection = ( - "Root" - , Selection { - selectionArguments = [] - , selectionPosition = (operationPosition operation) + , currentTypeName = "Root" + , currentSelection = Selection + { selectionName = "Root" + , selectionArguments = empty + , selectionPosition = operationPosition operation , selectionAlias = Nothing , selectionContent = SelectionSet (operationSelection operation) - } - ) + } } ---------------------------------------------------------- - execOperator ctx@Context {schema ,operation = Operation{ operationType} } = execOperationBy operationType ctx - where - execOperationBy Query = encodeQuery (schemaAPI schema) queryResolver - execOperationBy Mutation = encodeMutation mutationResolver - execOperationBy Subscription = encodeSubscription subscriptionResolver - -statefulResolver - :: (EventCon event, MonadIO m) - => GQLState m event - -> (GQLRequest -> ResponseStream event m ValidValue) - -> L.ByteString - -> m L.ByteString -statefulResolver state streamApi requestText = do - res <- runResultT (decodeNoDup requestText >>= streamApi) - mapM_ execute (unpackEvents res) - pure $ encode $ renderResponse res - where - execute (Publish events) = publishEvent state events - execute Subscribe{} = pure () + execOperator ctx@Context {schema } = runResolverModel (deriveModel root (schemaAPI schema)) ctx fullSchema :: forall proxy m event query mutation subscription . (IntrospectConstraint m event query mutation subscription) => proxy (GQLRootResolver m event query mutation subscription) - -> Validation Schema + -> Eventless Schema fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema where - querySchema = resolveUpdates - (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) - (defaultTypes : types) + querySchema = do + fs <- hiddenRootFields <:> fields + resolveUpdates (initTypeLib (operatorType fs "Query")) (defaultTypes : types) where (fields, types) = introspectObjectFields (Proxy @(CUSTOM (query (Resolver QUERY event m)))) @@ -231,16 +175,14 @@ , OutputType , Proxy @(subscription (Resolver SUBSCRIPTION event m)) ) - maybeOperator :: [(Name, DataField)] -> Name -> Maybe (Name, DataType) - maybeOperator [] = const Nothing + maybeOperator :: FieldsDefinition -> Name -> Maybe TypeDefinition + maybeOperator (FieldsDefinition x) | null x = const Nothing maybeOperator fields = Just . operatorType fields ------------------------------------------------- - operatorType :: [(Name, DataField)] -> Name -> (Name, DataType) - operatorType fields typeName = - ( typeName - , DataType { typeContent = DataObject [] fields - , typeName - , typeFingerprint = DataFingerprint typeName [] - , typeMeta = Nothing - } - ) + operatorType :: FieldsDefinition -> Name -> TypeDefinition + operatorType fields typeName = TypeDefinition + { typeContent = DataObject [] fields + , typeName + , typeFingerprint = DataFingerprint typeName [] + , typeMeta = Nothing + } diff --git a/src/Data/Morpheus/Execution/Server/Subscription.hs b/src/Data/Morpheus/Execution/Server/Subscription.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Subscription.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE NamedFieldPuns , FlexibleContexts #-} - -module Data.Morpheus.Execution.Server.Subscription - ( ClientDB - , GQLState - , initGQLState - , connectClient - , disconnectClient - , startSubscription - , endSubscription - , publishEvent - ) -where - -import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import Control.Concurrent ( MVar - , modifyMVar - , modifyMVar_ - , newMVar - , readMVar - ) -import Data.Foldable ( traverse_ ) -import Data.List ( intersect ) -import Data.UUID.V4 ( nextRandom ) -import Network.WebSockets ( Connection - , sendTextData - ) -import Data.HashMap.Lazy ( empty - , insert - , delete - , adjust - , toList - ) - --- MORPHEUS -import Data.Morpheus.Types.Internal.Apollo - ( toApolloResponse ) -import Data.Morpheus.Types.Internal.Resolving - ( Event(..) - , GQLChannel(..) - , SubEvent - ) -import Data.Morpheus.Types.Internal.WebSocket - ( ClientID - , GQLClient(..) - , ClientDB - , GQLState - , SesionID - ) - --- | initializes empty GraphQL state -initGQLState :: IO (GQLState m e) -initGQLState = newMVar empty - -connectClient :: MonadIO m => Connection -> GQLState m e -> IO (GQLClient m e) -connectClient clientConnection gqlState = do - clientID <- nextRandom - let client = GQLClient { clientID , clientConnection, clientSessions = empty } - modifyMVar_ gqlState (pure . insert clientID client) - return client - -disconnectClient :: GQLClient m e -> GQLState m e -> IO (ClientDB m e) -disconnectClient GQLClient { clientID } state = modifyMVar state removeUser - where - removeUser db = let s' = delete clientID db in return (s', s') - -updateClientByID - :: MonadIO m => - ClientID - -> (GQLClient m e -> GQLClient m e) - -> MVar (ClientDB m e) - -> m () -updateClientByID key f state = liftIO $ modifyMVar_ state (return . adjust f key) - -publishEvent - :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) => GQLState m e -> e -> m () -publishEvent gqlState event = liftIO (readMVar gqlState) >>= traverse_ sendMessage - where - sendMessage GQLClient { clientSessions, clientConnection } - | null clientSessions = return () - | otherwise = mapM_ send (filterByChannels clientSessions) - where - send (sid, Event { content = subscriptionRes }) = do - res <- subscriptionRes event - let apolloRes = toApolloResponse sid res - liftIO $ sendTextData clientConnection apolloRes - --------------------------- - filterByChannels = filter - ( not - . null - . intersect (streamChannels event) - . channels - . snd - ) . toList - -endSubscription :: MonadIO m => ClientID -> SesionID -> GQLState m e -> m () -endSubscription cid sid = updateClientByID cid stopSubscription - where - stopSubscription client = client { clientSessions = delete sid (clientSessions client) } - -startSubscription :: MonadIO m => ClientID -> SubEvent m e -> SesionID -> GQLState m e -> m () -startSubscription cid subscriptions sid = updateClientByID cid startSubscription - where - startSubscription client = client - { clientSessions = insert sid subscriptions (clientSessions client) } diff --git a/src/Data/Morpheus/Parsing/Document/Parser.hs b/src/Data/Morpheus/Parsing/Document/Parser.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Document/Parser.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Parsing.Document.Parser - ( parseTypes - ) -where - -import Data.Text ( Text ) -import Text.Megaparsec ( eof - , label - , manyTill - , runParser - ) - --- MORPHEUS -import Data.Morpheus.Parsing.Document.TypeSystem - ( parseDataType ) -import Data.Morpheus.Parsing.Internal.Internal - ( processErrorBundle ) -import Data.Morpheus.Parsing.Internal.Terms - ( spaceAndComments ) -import Data.Morpheus.Types.Internal.AST - ( DataType ) -import Data.Morpheus.Types.Internal.Resolving - ( Validation - , Failure(..) - ) - -parseTypes :: Text -> Validation [(Text, DataType)] -parseTypes doc = case parseDoc of - Right root -> pure root - Left parseError -> failure (processErrorBundle parseError) - where - parseDoc = runParser request "" doc - request = label "DocumentTypes" $ do - spaceAndComments - manyTill parseDataType eof 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 @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Parsing.Document.TypeSystem - ( parseDataType + ( parseSchema ) where @@ -10,17 +10,21 @@ import Text.Megaparsec ( label , sepBy1 , (<|>) + , eof + , manyTill ) -- MORPHEUS import Data.Morpheus.Parsing.Internal.Internal - ( Parser ) + ( Parser + , processParser + ) import Data.Morpheus.Parsing.Internal.Pattern ( fieldsDefinition - , inputValueDefinition , optionalDirectives , typDeclaration , enumValueDefinition + , inputFieldsDefinition ) import Data.Morpheus.Parsing.Internal.Terms ( keyword @@ -29,36 +33,36 @@ , parseName , pipeLiteral , sepByAnd - , setOf + , collection + , spaceAndComments ) import Data.Morpheus.Types.Internal.AST - ( DataField - , DataFingerprint(..) - , DataTypeContent(..) - , DataType(..) - , DataValidator(..) - , Key + ( DataFingerprint(..) + , TypeContent(..) + , TypeDefinition(..) + , Name + , Description , Meta(..) + , ScalarDefinition(..) ) - +import Data.Morpheus.Types.Internal.Resolving + ( Eventless ) -- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars -- -- ScalarTypeDefinition: -- Description(opt) scalar Name Directives(Const)(opt) -- -scalarTypeDefinition :: Maybe Text -> Parser (Text, DataType) +scalarTypeDefinition :: Maybe Description -> Parser TypeDefinition scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do typeName <- typDeclaration "scalar" metaDirectives <- optionalDirectives - pure - ( typeName - , DataType { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataScalar $ DataValidator pure - } - ) + pure TypeDefinition + { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataScalar $ ScalarDefinition pure + } -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects -- @@ -75,24 +79,21 @@ -- FieldDefinition -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- -objectTypeDefinition :: Maybe Text -> Parser (Text, DataType) +objectTypeDefinition :: Maybe Description -> Parser TypeDefinition objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do typeName <- typDeclaration "type" objectImplements <- optionalImplementsInterfaces metaDirectives <- optionalDirectives objectFields <- fieldsDefinition - -------------------------- - pure - ( typeName - , DataType - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataObject { objectImplements, objectFields } - } - ) + -- build object + pure TypeDefinition + { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataObject { objectImplements, objectFields } + } -optionalImplementsInterfaces :: Parser [Text] +optionalImplementsInterfaces :: Parser [Name] optionalImplementsInterfaces = implements <|> pure [] where implements = @@ -103,20 +104,18 @@ -- InterfaceTypeDefinition -- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) -- -interfaceTypeDefinition :: Maybe Text -> Parser (Text, DataType) +interfaceTypeDefinition :: Maybe Description -> Parser TypeDefinition interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do typeName <- typDeclaration "interface" metaDirectives <- optionalDirectives fields <- fieldsDefinition - pure - ( typeName - , DataType { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataInterface fields - } - ) - + -- build interface + pure TypeDefinition + { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataInterface fields + } -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions -- @@ -127,19 +126,18 @@ -- = |(opt) NamedType -- UnionMemberTypes | NamedType -- -unionTypeDefinition :: Maybe Text -> Parser (Text, DataType) +unionTypeDefinition :: Maybe Description -> Parser TypeDefinition unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do typeName <- typDeclaration "union" metaDirectives <- optionalDirectives memberTypes <- unionMemberTypes - pure - ( typeName - , DataType { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataUnion memberTypes - } - ) + -- build union + pure TypeDefinition + { typeName + , typeMeta = Just Meta { metaDescription, metaDirectives } + , typeFingerprint = DataFingerprint typeName [] + , typeContent = DataUnion memberTypes + } where unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums @@ -153,20 +151,18 @@ -- EnumValueDefinition -- Description(opt) EnumValue Directives(Const)(opt) -- -enumTypeDefinition :: Maybe Text -> Parser (Text, DataType) +enumTypeDefinition :: Maybe Description -> Parser TypeDefinition enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do typeName <- typDeclaration "enum" metaDirectives <- optionalDirectives - enumValuesDefinitions <- setOf enumValueDefinition - pure - ( typeName - , DataType { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataEnum enumValuesDefinitions - } - ) - + enumValuesDefinitions <- collection enumValueDefinition + -- build enum + pure TypeDefinition + { typeName + , typeContent = DataEnum enumValuesDefinitions + , typeFingerprint = DataFingerprint typeName [] + , typeMeta = Just Meta { metaDescription, metaDirectives } + } -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects -- @@ -176,37 +172,34 @@ -- InputFieldsDefinition: -- { InputValueDefinition(list) } -- -inputObjectTypeDefinition :: Maybe Text -> Parser (Text, DataType) +inputObjectTypeDefinition :: Maybe Description -> Parser TypeDefinition inputObjectTypeDefinition metaDescription = label "InputObjectTypeDefinition" $ do typeName <- typDeclaration "input" metaDirectives <- optionalDirectives fields <- inputFieldsDefinition - pure - ( typeName - , DataType { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataInputObject fields - } - ) - where - inputFieldsDefinition :: Parser [(Key, DataField)] - inputFieldsDefinition = - label "InputFieldsDefinition" $ setOf inputValueDefinition - - -parseFinalDataType :: Maybe Text -> Parser (Text, DataType) -parseFinalDataType description = - label "TypeDefinition" - $ inputObjectTypeDefinition description - <|> unionTypeDefinition description - <|> enumTypeDefinition description - <|> scalarTypeDefinition description - <|> objectTypeDefinition description - <|> interfaceTypeDefinition description + -- build input + pure TypeDefinition + { typeName + , typeContent = DataInputObject fields + , typeFingerprint = DataFingerprint typeName [] + , typeMeta = Just Meta { metaDescription, metaDirectives } + } -parseDataType :: Parser (Text, DataType) -parseDataType = label "TypeDefinition" $ do +parseDataType :: Parser TypeDefinition +parseDataType = label "TypeDefinition" $ do description <- optDescription - parseFinalDataType description + -- scalar | enum | input | object | union | interface + inputObjectTypeDefinition description + <|> unionTypeDefinition description + <|> enumTypeDefinition description + <|> scalarTypeDefinition description + <|> objectTypeDefinition description + <|> interfaceTypeDefinition description + +parseSchema :: Text -> Eventless [TypeDefinition] +parseSchema = processParser request + where + request = label "DocumentTypes" $ do + spaceAndComments + manyTill parseDataType eof diff --git a/src/Data/Morpheus/Parsing/Internal/Arguments.hs b/src/Data/Morpheus/Parsing/Internal/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Arguments.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Parsing.Internal.Arguments + ( maybeArguments, + parseArgumentsOpt + ) +where + +import Text.Megaparsec ( label) + +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Internal + ( Parser + , getLocation + ) +import Data.Morpheus.Parsing.Internal.Terms + ( parseAssignment + , uniqTupleOpt + , token + ) +import Data.Morpheus.Parsing.Internal.Value + ( parseRawValue + , parseValue + ) +import Data.Morpheus.Types.Internal.AST + ( Argument(..) + , Arguments + , RAW + , VALID + ) + + +-- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments +-- +-- Arguments[Const] +-- ( Argument[Const](list) ) +-- +-- Argument[Const] +-- Name : Value[Const] +valueArgument :: Parser (Argument RAW) +valueArgument = + label "Argument" $ do + argumentPosition <- getLocation + (argumentName, argumentValue )<- parseAssignment token parseRawValue + pure $ Argument { argumentName, argumentValue, argumentPosition } + +parseArgument :: Parser (Argument VALID) +parseArgument = + label "Argument" $ do + argumentPosition <- getLocation + (argumentName, argumentValue )<- parseAssignment token parseValue + pure $ Argument { argumentName, argumentValue, argumentPosition } + +parseArgumentsOpt :: Parser (Arguments VALID) +parseArgumentsOpt = + label "Arguments" + $ uniqTupleOpt parseArgument + +maybeArguments :: Parser (Arguments RAW) +maybeArguments = + label "Arguments" + $ uniqTupleOpt valueArgument diff --git a/src/Data/Morpheus/Parsing/Internal/Internal.hs b/src/Data/Morpheus/Parsing/Internal/Internal.hs --- a/src/Data/Morpheus/Parsing/Internal/Internal.hs +++ b/src/Data/Morpheus/Parsing/Internal/Internal.hs @@ -1,30 +1,32 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} module Data.Morpheus.Parsing.Internal.Internal ( Parser , Position - , processErrorBundle , getLocation + , processParser ) where import qualified Data.List.NonEmpty as NonEmpty -import Data.Morpheus.Error.Utils ( toLocation ) import Data.Morpheus.Types.Internal.AST - ( Position ) -import Data.Morpheus.Types.Internal.Resolving - ( GQLError(..) + ( Position(..) + , GQLError(..) , GQLErrors ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless + , failure + , Result(..) + ) import Data.Text ( Text , pack ) -import Data.Void ( Void ) import Text.Megaparsec ( ParseError , ParseErrorBundle ( ParseErrorBundle ) - , Parsec + , ParsecT , SourcePos , attachSourcePos , bundleErrors @@ -32,24 +34,40 @@ , errorOffset , getSourcePos , parseErrorPretty + , runParserT + , SourcePos(..) + , unPos ) - +import Data.Void (Void) getLocation :: Parser Position getLocation = fmap toLocation getSourcePos -type Parser = Parsec Void Text +toLocation :: SourcePos -> Position +toLocation SourcePos { sourceLine, sourceColumn } = + Position { line = unPos sourceLine, column = unPos sourceColumn } -processErrorBundle :: ParseErrorBundle Text Void -> GQLErrors -processErrorBundle = fmap parseErrorToGQLError . bundleToErrors +type MyError = Void +type Parser = ParsecT MyError Text Eventless +type ErrorBundle = ParseErrorBundle Text MyError + +processParser :: Parser a -> Text -> Eventless a +processParser parser txt = case runParserT parser [] txt of + Success { result } -> case result of + Right root -> pure root + Left parseError -> failure (processErrorBundle parseError) + Failure { errors } -> failure errors + +processErrorBundle :: ErrorBundle -> GQLErrors +processErrorBundle = map parseErrorToGQLError . bundleToErrors where - parseErrorToGQLError :: (ParseError Text Void, SourcePos) -> GQLError + parseErrorToGQLError :: (ParseError Text MyError, SourcePos) -> GQLError parseErrorToGQLError (err, position) = GQLError { message = pack (parseErrorPretty err) - , locations = [toLocation position] + , locations = [toLocation position] } bundleToErrors - :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)] + :: ErrorBundle -> [(ParseError Text MyError, SourcePos)] bundleToErrors ParseErrorBundle { bundleErrors, bundlePosState } = NonEmpty.toList $ fst $ attachSourcePos errorOffset bundleErrors 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 @@ -6,12 +6,13 @@ , typDeclaration , optionalDirectives , enumValueDefinition + , inputFieldsDefinition ) where - import Text.Megaparsec ( label , many + , (<|>) ) -- MORPHEUS @@ -22,26 +23,26 @@ , litAssignment , operator , optDescription - , parseAssignment - , parseMaybeTuple , parseName , parseType , setOf + , uniqTuple ) +import Data.Morpheus.Parsing.Internal.Arguments + ( parseArgumentsOpt ) import Data.Morpheus.Parsing.Internal.Value - ( parseDefaultValue - , parseValue - ) + ( parseDefaultValue ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) + ( FieldDefinition(..) , Directive(..) - , Key , Meta(..) , DataEnumValue(..) , Name + , ArgumentsDefinition(..) + , FieldsDefinition(..) + , InputFieldsDefinition(..) ) - -- EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition -- -- EnumValueDefinition @@ -62,7 +63,7 @@ -- InputValueDefinition -- Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) -- -inputValueDefinition :: Parser (Key, DataField) +inputValueDefinition :: Parser FieldDefinition inputValueDefinition = label "InputValueDefinition" $ do metaDescription <- optDescription fieldName <- parseName @@ -70,39 +71,35 @@ fieldType <- parseType _ <- parseDefaultValue metaDirectives <- optionalDirectives - pure - ( fieldName - , DataField { fieldArgs = [] - , fieldArgsType = Nothing - , fieldName - , fieldType - , fieldMeta = Just Meta { metaDescription, metaDirectives } - } - ) + pure FieldDefinition + { fieldArgs = NoArguments + , fieldName + , fieldType + , fieldMeta = Just Meta { metaDescription, metaDirectives } + } -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments -- -- ArgumentsDefinition: -- ( InputValueDefinition(list) ) -- -argumentsDefinition :: Parser [(Key, DataField)] -argumentsDefinition = - label "ArgumentsDefinition" $ parseMaybeTuple inputValueDefinition - +argumentsDefinition :: Parser ArgumentsDefinition +argumentsDefinition = label "ArgumentsDefinition" + $ uniqTuple inputValueDefinition + <|> pure NoArguments -- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition -- -- FieldsDefinition : -- { FieldDefinition(list) } -- -fieldsDefinition :: Parser [(Key, DataField)] +fieldsDefinition :: Parser FieldsDefinition fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition - -- FieldDefinition -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- -fieldDefinition :: Parser (Key, DataField) +fieldDefinition :: Parser FieldDefinition fieldDefinition = label "FieldDefinition" $ do metaDescription <- optDescription fieldName <- parseName @@ -110,15 +107,19 @@ litAssignment -- ':' fieldType <- parseType metaDirectives <- optionalDirectives - pure - ( fieldName - , DataField { fieldName - , fieldArgs - , fieldArgsType = Nothing - , fieldType - , fieldMeta = Just Meta { metaDescription, metaDirectives } - } - ) + pure FieldDefinition + { fieldName + , fieldArgs + , fieldType + , fieldMeta = Just Meta { metaDescription, metaDirectives } + } + +-- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives +-- InputFieldsDefinition: +-- { InputValueDefinition(list) } +-- +inputFieldsDefinition :: Parser InputFieldsDefinition +inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition -- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives -- @@ -137,9 +138,8 @@ directive = label "Directive" $ do operator '@' directiveName <- parseName - directiveArgs <- parseMaybeTuple (parseAssignment parseName parseValue) + directiveArgs <- parseArgumentsOpt pure Directive { directiveName, directiveArgs } - -- typDeclaration : Not in spec ,start part of type definitions -- 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 @@ -10,11 +10,13 @@ , spaceAndComments1 , pipeLiteral ------------- + , collection , setOf + , uniqTuple + , uniqTupleOpt , parseTypeCondition , spreadLiteral , parseNonNull - , parseMaybeTuple , parseAssignment , parseWrappedType , litEquals @@ -27,10 +29,12 @@ , keyword , operator , optDescription + , optionalList , parseNegativeSign ) where +import Control.Monad ((>=>)) import Data.Functor ( ($>) ) import Data.Text ( Text , pack @@ -61,6 +65,10 @@ ) -- MORPHEUS +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + , KeyOf + ) import Data.Morpheus.Parsing.Internal.Internal ( Parser , Position @@ -96,9 +104,11 @@ operator x = char x *> spaceAndComments -- LITERALS -setLiteral :: Parser [a] -> Parser [a] -setLiteral = - between (char '{' *> spaceAndComments) (char '}' *> spaceAndComments) +braces :: Parser [a] -> Parser [a] +braces = + between + (char '{' *> spaceAndComments) + (char '}' *> spaceAndComments) pipeLiteral :: Parser () pipeLiteral = char '|' *> spaceAndComments @@ -185,17 +195,20 @@ sepByAnd entry = entry `sepBy` (char '&' *> spaceAndComments) ----------------------------- -setOf :: Parser a -> Parser [a] -setOf entry = setLiteral (entry `sepEndBy` many (char ',' *> spaceAndComments)) +collection :: Parser a -> Parser [a] +collection entry = braces (entry `sepEndBy` many (char ',' *> spaceAndComments)) +setOf :: (Listable c a , KeyOf a) => Parser a -> Parser c +setOf = collection >=> fromList + parseNonNull :: Parser [DataTypeWrapper] parseNonNull = do wrapper <- (char '!' $> [NonNullType]) <|> pure [] spaceAndComments return wrapper -parseMaybeTuple :: Parser a -> Parser [a] -parseMaybeTuple parser = parseTuple parser <|> pure [] +optionalList :: Parser [a] -> Parser [a] +optionalList x = x <|> pure [] parseTuple :: Parser a -> Parser [a] parseTuple parser = label "Tuple" $ between @@ -203,6 +216,12 @@ (char ')' *> spaceAndComments) (parser `sepBy` (many (char ',') *> spaceAndComments) "empty Tuple value!" ) + +uniqTuple :: (Listable c a , KeyOf a) => Parser a -> Parser c +uniqTuple = parseTuple >=> fromList + +uniqTupleOpt :: (Listable c a , KeyOf a) => Parser a -> Parser c +uniqTupleOpt = optionalList . parseTuple >=> fromList parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b) parseAssignment nameParser valueParser = label "assignment" $ do 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 @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} module Data.Morpheus.Parsing.Internal.Value ( parseValue @@ -32,11 +33,11 @@ import Data.Morpheus.Parsing.Internal.Terms ( litEquals , parseAssignment - , setOf , spaceAndComments , token , parseNegativeSign , variable + , setOf ) import Data.Morpheus.Types.Internal.AST ( ScalarValue(..) @@ -44,9 +45,10 @@ , RawValue , ValidValue , decodeScientific - , Name , Value(..) , ResolvedValue + , OrderedMap + , ObjectEntry(..) ) valueNull :: Parser (Value a) @@ -87,16 +89,19 @@ (char '"') (many escaped) - listValue :: Parser a -> Parser [a] -listValue parser = label "listValue" $ between +listValue parser = label "ListValue" $ between (char '[' *> spaceAndComments) (char ']' *> spaceAndComments) - (parser `sepBy` (char ',' *> spaceAndComments)) + (parser `sepBy` (many (char ',') *> spaceAndComments)) -objectValue :: Show a => Parser a -> Parser [(Name, a)] -objectValue parser = label "objectValue" $ setOf entry - where entry = parseAssignment token parser +objectEntry :: Parser (Value a) -> Parser (ObjectEntry a) +objectEntry parser = label "ObjectEntry" $ do + (entryName,entryValue) <- parseAssignment token parser + pure ObjectEntry { entryName, entryValue } + +objectValue :: Parser (Value a) -> Parser (OrderedMap (ObjectEntry a)) +objectValue = label "ObjectValue" . setOf . objectEntry structValue :: Parser (Value a) -> Parser (Value a) structValue parser = 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 @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Morpheus.Parsing.JSONSchema.Parse ( decodeIntrospection @@ -24,11 +25,10 @@ import qualified Data.Morpheus.Types.Internal.AST as AST ( Schema) import Data.Morpheus.Types.Internal.AST - ( DataField - , DataType(..) - , DataTypeContent(..) + ( FieldDefinition + , TypeDefinition(..) + , TypeContent(..) , DataTypeWrapper(..) - , Key , TypeWrapper , createArgument , createDataTypeLib @@ -38,16 +38,19 @@ , createType , createUnionType , toHSWrappers + , ArgumentsDefinition(..) ) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..)) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Eventless ) import Data.Morpheus.Types.IO ( JSONResponse(..) ) import Data.Semigroup ( (<>) ) import Data.Text ( Text , pack ) -decodeIntrospection :: ByteString -> Validation AST.Schema +decodeIntrospection :: ByteString -> Eventless AST.Schema decodeIntrospection jsonDoc = case jsonSchema of Left errors -> internalError $ pack errors Right JSONResponse { responseData = Just Introspection { __schema = Schema { types } } } @@ -58,9 +61,9 @@ jsonSchema = eitherDecode jsonDoc class ParseJSONSchema a b where - parse :: a -> Validation b + parse :: a -> Eventless b -instance ParseJSONSchema Type [(Key,DataType)] where +instance ParseJSONSchema Type [TypeDefinition] where parse Type { name = Just typeName, kind = SCALAR } = pure [createScalarType typeName] parse Type { name = Just typeName, kind = ENUM, enumValues = Just enums } = @@ -71,34 +74,34 @@ Just uni -> pure [createUnionType typeName uni] parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields } = do - fields <- traverse parse iFields - pure [(typeName, createType typeName $ DataInputObject fields)] + (fields :: [FieldDefinition]) <- traverse parse iFields + fs <- fromList fields + pure [createType typeName $ DataInputObject fs] parse Type { name = Just typeName, kind = OBJECT, fields = Just oFields } = do - fields <- traverse parse oFields - pure [(typeName, createType typeName $ DataObject [] fields)] + (fields :: [FieldDefinition]) <- traverse parse oFields + fs <- fromList fields + pure [createType typeName $ DataObject [] fs] parse _ = pure [] -instance ParseJSONSchema Field (Key,DataField) where +instance ParseJSONSchema Field FieldDefinition where parse Field { fieldName, fieldArgs, fieldType } = do fType <- fieldTypeFromJSON fieldType - args <- traverse genArg fieldArgs - pure (fieldName, createField args fieldName fType) + args <- traverse genArg fieldArgs >>= fromList + pure $ createField (ArgumentsDefinition Nothing args) fieldName fType where genArg InputValue { inputName = argName, inputType = argType } = createArgument argName <$> fieldTypeFromJSON argType -instance ParseJSONSchema InputValue (Key,DataField) where - parse InputValue { inputName, inputType } = do - fieldType <- fieldTypeFromJSON inputType - pure (inputName, createField [] inputName fieldType) +instance ParseJSONSchema InputValue FieldDefinition where + parse InputValue { inputName, inputType } = createField NoArguments inputName <$> fieldTypeFromJSON inputType -fieldTypeFromJSON :: Type -> Validation ([TypeWrapper], Text) +fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], Text) fieldTypeFromJSON = fmap toHs . fieldTypeRec [] where toHs (w, t) = (toHSWrappers w, t) fieldTypeRec - :: [DataTypeWrapper] -> Type -> Validation ([DataTypeWrapper], Text) + :: [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], Text) fieldTypeRec acc Type { kind = LIST, ofType = Just ofType } = fieldTypeRec (ListType : acc) ofType fieldTypeRec acc Type { kind = NON_NULL, ofType = Just ofType } = diff --git a/src/Data/Morpheus/Parsing/Request/Arguments.hs b/src/Data/Morpheus/Parsing/Request/Arguments.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Request/Arguments.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Parsing.Request.Arguments - ( maybeArguments - ) -where - -import Text.Megaparsec ( label) - --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser - , getLocation - ) -import Data.Morpheus.Parsing.Internal.Terms - ( parseAssignment - , parseMaybeTuple - , token - ) -import Data.Morpheus.Parsing.Internal.Value - ( parseRawValue ) -import Data.Morpheus.Types.Internal.AST - ( Argument(..) - , RawArgument - , RawArguments - ) - - --- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments --- --- Arguments[Const] --- ( Argument[Const](list) ) --- --- Argument[Const] --- Name : Value[Const] --- TODO: move variable to Value -valueArgument :: Parser RawArgument -valueArgument = label "Argument" $ do - argumentPosition <- getLocation - argumentValue <- parseRawValue - pure $ Argument { argumentValue, argumentPosition } - -maybeArguments :: Parser RawArguments -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 @@ -1,5 +1,5 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Parsing.Request.Operation ( parseOperation @@ -7,7 +7,6 @@ where import Data.Functor ( ($>) ) -import Data.Text ( Text ) import Text.Megaparsec ( label , optional , () @@ -25,7 +24,7 @@ ( optionalDirectives ) import Data.Morpheus.Parsing.Internal.Terms ( operator - , parseMaybeTuple + , uniqTupleOpt , parseName , parseType , spaceAndComments1 @@ -35,9 +34,10 @@ ( parseDefaultValue ) import Data.Morpheus.Parsing.Request.Selection ( parseSelectionSet ) +import Data.Morpheus.Types.Internal.Operation + (empty) import Data.Morpheus.Types.Internal.AST ( Operation(..) - , RawOperation , Variable(..) , OperationType(..) , Ref(..) @@ -51,19 +51,13 @@ -- VariableDefinition -- Variable : Type DefaultValue(opt) -- -variableDefinition :: Parser (Text, Variable RAW) +variableDefinition :: Parser (Variable RAW) variableDefinition = label "VariableDefinition" $ do - (Ref name variablePosition) <- variable + (Ref variableName variablePosition) <- variable operator ':' variableType <- parseType - defaultValue <- parseDefaultValue - pure - ( name - , Variable { variableType - , variablePosition - , variableValue = DefaultValue defaultValue - } - ) + variableValue <- DefaultValue <$> parseDefaultValue + pure Variable{..} -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations -- @@ -72,23 +66,16 @@ -- -- OperationType: one of -- query, mutation, subscription -parseOperationDefinition :: Parser RawOperation +parseOperationDefinition :: Parser (Operation RAW) parseOperationDefinition = label "OperationDefinition" $ do operationPosition <- getLocation operationType <- parseOperationType operationName <- optional parseName - operationArguments <- parseMaybeTuple variableDefinition + operationArguments <- uniqTupleOpt variableDefinition -- TODO: handle directives _directives <- optionalDirectives operationSelection <- parseSelectionSet - pure - (Operation { operationName - , operationType - , operationArguments - , operationSelection - , operationPosition - } - ) + pure Operation {..} parseOperationType :: Parser OperationType parseOperationType = label "OperationType" $ do @@ -99,19 +86,18 @@ spaceAndComments1 return kind -parseAnonymousQuery :: Parser RawOperation +parseAnonymousQuery :: Parser (Operation RAW) parseAnonymousQuery = label "AnonymousQuery" $ do operationPosition <- getLocation operationSelection <- parseSelectionSet pure (Operation { operationName = Nothing , operationType = Query - , operationArguments = [] - , operationSelection - , operationPosition + , operationArguments = empty + , .. } ) "can't parse AnonymousQuery" -parseOperation :: Parser RawOperation +parseOperation :: Parser (Operation RAW) parseOperation = parseAnonymousQuery <|> parseOperationDefinition 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 @@ -3,6 +3,7 @@ module Data.Morpheus.Parsing.Request.Parser ( parseGQL + , processParser ) where @@ -10,19 +11,16 @@ ( Value(..) ) import Data.HashMap.Lazy ( toList ) import Data.Text ( Text ) -import Data.Void ( Void ) -import Text.Megaparsec ( ParseErrorBundle - , eof +import Text.Megaparsec ( eof , label , manyTill - , runParser ) -- -- MORPHEUS import Data.Morpheus.Parsing.Internal.Internal ( Parser - , processErrorBundle + , processParser ) import Data.Morpheus.Parsing.Internal.Terms ( spaceAndComments ) @@ -31,32 +29,27 @@ import Data.Morpheus.Parsing.Request.Selection ( parseFragmentDefinition ) import Data.Morpheus.Types.Internal.Resolving - ( Validation - , Failure(..) - ) + ( Eventless ) import Data.Morpheus.Types.Internal.AST ( replaceValue , GQLQuery(..) , ResolvedValue ) import Data.Morpheus.Types.IO ( GQLRequest(..) ) - +import Data.Morpheus.Types.Internal.Operation + (fromList) -parseGQLSyntax :: Text -> Either (ParseErrorBundle Text Void) GQLQuery -parseGQLSyntax = runParser request "" - where - request :: Parser GQLQuery - request = label "GQLQuery" $ do +request :: Parser GQLQuery +request = label "GQLQuery" $ do spaceAndComments operation <- parseOperation - fragments <- manyTill parseFragmentDefinition eof + fragments <- manyTill parseFragmentDefinition eof >>= fromList pure GQLQuery { operation, fragments, inputVariables = [] } -parseGQL :: GQLRequest -> Validation GQLQuery -parseGQL GQLRequest { query, variables } = case parseGQLSyntax query of - Right root -> pure $ root { inputVariables = toVariableMap variables } - Left parseError -> failure $ processErrorBundle parseError +parseGQL :: GQLRequest -> Eventless GQLQuery +parseGQL GQLRequest { query, variables } = setVariables <$> processParser request query where + setVariables root = root { inputVariables = toVariableMap variables } toVariableMap :: Maybe Aeson.Value -> [(Text, ResolvedValue)] toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x) where toMorpheusValue (key, value) = (key, replaceValue value) 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 @@ -1,5 +1,5 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Parsing.Request.Selection ( parseSelectionSet @@ -7,7 +7,6 @@ ) where -import Data.Text ( Text ) import Text.Megaparsec ( label , try , (<|>) @@ -30,16 +29,18 @@ , spreadLiteral , token ) -import Data.Morpheus.Parsing.Request.Arguments +import Data.Morpheus.Parsing.Internal.Arguments ( maybeArguments ) import Data.Morpheus.Types.Internal.AST ( Selection(..) , SelectionContent(..) , Ref(..) , Fragment(..) - , RawArguments - , RawSelection - , RawSelectionSet + , Arguments + , RAW + , SelectionSet + , Name + , Position ) @@ -53,7 +54,7 @@ -- FragmentSpread -- InlineFragment -- -parseSelectionSet :: Parser RawSelectionSet +parseSelectionSet :: Parser (SelectionSet RAW) parseSelectionSet = label "SelectionSet" $ setOf parseSelection where parseSelection = @@ -67,39 +68,22 @@ -- Field -- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt) -- -parseSelectionField :: Parser (Text, RawSelection) +parseSelectionField :: Parser (Selection RAW) parseSelectionField = label "SelectionField" $ do - position <- getLocation - aliasName <- parseAlias - name <- parseName - arguments <- maybeArguments + selectionPosition <- getLocation + selectionAlias <- parseAlias + selectionName <- parseName + selectionArguments <- maybeArguments -- TODO: handle Directives - _directives <- optionalDirectives - value <- - selSet aliasName arguments <|> buildField aliasName arguments position - return (name, value) + _directives <- optionalDirectives + selSet selectionName selectionAlias selectionArguments <|> pure Selection { selectionContent = SelectionField, ..} where - ---------------------------------------- - buildField selectionAlias selectionArguments selectionPosition = pure - (Selection { selectionAlias - , selectionArguments - , selectionContent = SelectionField - , selectionPosition - } - ) ----------------------------------------- - selSet :: Maybe Text -> RawArguments -> Parser RawSelection - selSet selectionAlias selectionArguments = label "body" $ do + selSet :: Name -> Maybe Name -> Arguments RAW -> Parser (Selection RAW) + selSet selectionName selectionAlias selectionArguments = label "body" $ do selectionPosition <- getLocation selectionSet <- parseSelectionSet - return - (Selection { selectionAlias - , selectionArguments - , selectionContent = SelectionSet selectionSet - , selectionPosition - } - ) - + pure Selection { selectionContent = SelectionSet selectionSet, ..} -- -- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments @@ -110,45 +94,40 @@ -- FragmentSpread -- ...FragmentName Directives(opt) -- -spread :: Parser (Text, RawSelection) +spread :: Parser (Selection RAW) spread = label "FragmentSpread" $ do refPosition <- spreadLiteral refName <- token -- TODO: handle Directives _directives <- optionalDirectives - return (refName, Spread $ Ref { refName, refPosition }) + pure $ Spread Ref { .. } -- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition -- -- FragmentDefinition: -- fragment FragmentName TypeCondition Directives(opt) SelectionSet -- -parseFragmentDefinition :: Parser (Text, Fragment) +parseFragmentDefinition :: Parser Fragment parseFragmentDefinition = label "FragmentDefinition" $ do keyword "fragment" fragmentPosition <- getLocation - name <- parseName - fragmentType <- parseTypeCondition - -- TODO: handle Directives - _directives <- optionalDirectives - fragmentSelection <- parseSelectionSet - pure (name, Fragment { fragmentType, fragmentSelection, fragmentPosition }) + fragmentName <- parseName + fragmentBody fragmentName fragmentPosition -- Inline Fragments : https://graphql.github.io/graphql-spec/June2018/#sec-Inline-Fragments -- -- InlineFragment: -- ... TypeCondition(opt) Directives(opt) SelectionSet -- -inlineFragment :: Parser (Text, RawSelection) +inlineFragment :: Parser (Selection RAW) inlineFragment = label "InlineFragment" $ do fragmentPosition <- spreadLiteral - -- TODO: optional + InlineFragment <$> fragmentBody "INLINE_FRAGMENT" fragmentPosition + +fragmentBody :: Name -> Position -> Parser Fragment +fragmentBody fragmentName fragmentPosition = label "FragmentBody" $ do fragmentType <- parseTypeCondition -- TODO: handle Directives _directives <- optionalDirectives fragmentSelection <- parseSelectionSet - pure - ( "INLINE_FRAGMENT" - , InlineFragment - $ Fragment { fragmentType, fragmentSelection, fragmentPosition } - ) + pure $ Fragment { .. } 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 @@ -1,11 +1,12 @@ -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} module Data.Morpheus.Rendering.RenderGQL ( RenderGQL(..) , renderGraphQLDocument + , renderWrapped ) where @@ -20,9 +21,10 @@ -- MORPHEUS import Data.Morpheus.Types.Internal.AST - ( DataField(..) - , DataTypeContent(..) - , DataType(..) + ( FieldDefinition(..) + , InputFieldsDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , Schema , DataTypeWrapper(..) , Key @@ -35,68 +37,76 @@ , toGQLWrapper , DataEnumValue(..) , convertToJSONName + , ArgumentsDefinition(..) + , Name + , FieldsDefinition(..) + , unsafeFromFields ) - +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + ) renderGraphQLDocument :: Schema -> ByteString renderGraphQLDocument lib = encodeUtf8 $ LT.fromStrict $ intercalate "\n\n" $ map render visibleTypes where - visibleTypes = filter (not . isDefaultTypeName . fst) (allDataTypes lib) + visibleTypes = filter (not . isDefaultTypeName . typeName) (allDataTypes lib) class RenderGQL a where render :: a -> Key - renderWrapped :: a -> [TypeWrapper] -> Key - default renderWrapped :: a -> [TypeWrapper] -> Key - renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers) - where - showGQLWrapper [] = render x - showGQLWrapper (ListType:xs) = "[" <> showGQLWrapper xs <> "]" - showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!" +instance RenderGQL TypeDefinition where + render TypeDefinition { typeName, typeContent } = __render typeContent + where + __render DataInterface { interfaceFields } = "interface " <> typeName <> render interfaceFields + __render DataScalar{} = "scalar " <> typeName + __render (DataEnum tags) = "enum " <> typeName <> renderObject render tags + __render (DataUnion members) = + "union " + <> typeName + <> " =\n " + <> intercalate ("\n" <> renderIndent <> "| ") members + __render (DataInputObject fields ) = "input " <> typeName <> render fields + __render (DataInputUnion members) = "input " <> typeName <> render fieldsDef + where + fieldsDef = unsafeFromFields fields + fields = createInputUnionFields typeName (fmap fst members) + __render DataObject {objectFields} = "type " <> typeName <> render objectFields -instance RenderGQL Key where - render = id -instance RenderGQL TypeRef where - render TypeRef { typeConName, typeWrappers } = - renderWrapped typeConName typeWrappers +ignoreHidden :: [FieldDefinition] -> [FieldDefinition] +ignoreHidden = filter fieldVisibility -instance RenderGQL DataType where - render = typeName +-- OBJECT +instance RenderGQL FieldsDefinition where + render = renderObject render . ignoreHidden . toList + +instance RenderGQL InputFieldsDefinition where + render = renderObject render . ignoreHidden . toList +instance RenderGQL FieldDefinition where + render FieldDefinition { fieldName, fieldType, fieldArgs } = + convertToJSONName fieldName <> render fieldArgs <> ": " <> render fieldType + +instance RenderGQL ArgumentsDefinition where + render NoArguments = "" + render arguments = "(" <> intercalate ", " (map render $ toList arguments) <> ")" + instance RenderGQL DataEnumValue where render DataEnumValue { enumName } = enumName -instance RenderGQL (Key, DataType) where - render (name, DataType { typeContent }) = __render typeContent - where - __render DataInterface { interfaceFields } = "interface " <> name <> render interfaceFields - __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 {objectFields}) = "type " <> name <> render objectFields +instance RenderGQL TypeRef where + render TypeRef { typeConName, typeWrappers } = renderWrapped typeConName typeWrappers --- OBJECT -instance RenderGQL [(Text, DataField)] where - render = renderObject renderField . ignoreHidden - where - renderField :: (Text, DataField) -> Text - renderField (key, DataField { fieldType, fieldArgs }) = - convertToJSONName key <> renderArgs fieldArgs <> ": " <> render fieldType - where - renderArgs [] = "" - renderArgs list = "(" <> intercalate ", " (map renderField list) <> ")" - ----------------------------------------------------------- - ignoreHidden :: [(Text, DataField)] -> [(Text, DataField)] - ignoreHidden = filter fieldVisibility +instance RenderGQL Key where + render = id + +renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Name +renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers) + where + showGQLWrapper [] = render x + showGQLWrapper (ListType:xs) = "[" <> showGQLWrapper xs <> "]" + showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!" renderIndent :: Text renderIndent = " " 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 @@ -2,7 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts , FlexibleInstances #-} module Data.Morpheus.Rendering.RenderIntrospection ( render @@ -20,9 +20,9 @@ import Data.Morpheus.Schema.TypeKind ( TypeKind(..) ) import Data.Morpheus.Types.Internal.AST ( DataInputUnion - , DataField(..) - , DataTypeContent(..) - , DataType(..) + , FieldDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , DataTypeKind(..) , Schema , DataTypeWrapper(..) @@ -39,7 +39,11 @@ , DataInputUnion , lookupDeprecatedReason , convertToJSONName + , ArgumentsDefinition(..) ) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + ) import Data.Morpheus.Types.Internal.Resolving ( Failure(..) ) @@ -49,27 +53,27 @@ type Result m a = Schema -> m a class RenderSchema a b where - render :: (Monad m, Failure Text m) => (Text, a) -> Schema -> m (b m) + render :: (Monad m, Failure Text m) => a -> Schema -> m (b m) -instance RenderSchema DataType S__Type where - render (name, DataType { typeMeta, typeContent }) = __render typeContent +instance RenderSchema TypeDefinition S__Type where + render TypeDefinition { typeName , typeMeta, typeContent } = __render typeContent where __render - :: (Monad m, Failure Text m) => DataTypeContent -> Schema -> m (S__Type m) + :: (Monad m, Failure Text m) => TypeContent -> Schema -> m (S__Type m) __render DataScalar{} = - constRes $ createLeafType SCALAR name typeMeta Nothing + constRes $ createLeafType SCALAR typeName typeMeta Nothing __render (DataEnum enums) = constRes - $ createLeafType ENUM name typeMeta (Just $ map createEnumValue enums) + $ createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums) __render (DataInputObject fields) = \lib -> - createInputObject name typeMeta - <$> traverse (`renderinputValue` lib) fields - __render (DataObject {objectFields}) = \lib -> - createObjectType name (typeMeta >>= metaDescription) - <$> (Just <$> traverse (`render` lib) (filter fieldVisibility objectFields)) + createInputObject typeName typeMeta + <$> traverse (`renderinputValue` lib) (toList fields) + __render DataObject {objectFields} = \lib -> + createObjectType typeName (typeMeta >>= metaDescription) + <$> (Just <$> traverse (`render` lib) (filter fieldVisibility $ toList objectFields)) __render (DataUnion union) = - constRes $ typeFromUnion (name, typeMeta, union) + constRes $ typeFromUnion (typeName, typeMeta, union) __render (DataInputUnion members) = - renderInputUnion (name, typeMeta, members) + renderInputUnion (typeName, typeMeta, members) createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue @@ -80,17 +84,20 @@ } where deprecated = enumMeta >>= lookupDeprecated -instance RenderSchema DataField S__Field where - render (name, field@DataField { fieldType = TypeRef { typeConName }, fieldArgs, fieldMeta }) lib +renderArguments :: (Monad m, Failure Text m) => ArgumentsDefinition -> Schema -> m [S__InputValue m] +renderArguments ArgumentsDefinition { arguments} lib = traverse (`renderinputValue` lib) $ toList arguments +renderArguments NoArguments _ = pure [] + +instance RenderSchema FieldDefinition S__Field where + render field@FieldDefinition { fieldName ,fieldType = TypeRef { typeConName }, fieldArgs, fieldMeta } lib = do kind <- renderTypeKind <$> lookupKind typeConName lib - args <- traverse (`renderinputValue` lib) fieldArgs pure S__Field - { s__FieldName = pure (convertToJSONName name) + { s__FieldName = pure (convertToJSONName fieldName) , s__FieldDescription = pure (fieldMeta >>= metaDescription) - , s__FieldArgs = pure args + , s__FieldArgs = renderArguments fieldArgs lib , s__FieldType' = - pure (wrap field $ createType kind typeConName Nothing $ Just []) + pure (applyTypeWrapper field $ createType kind typeConName Nothing $ Just []) , s__FieldIsDeprecated = pure (isJust deprecated) , s__FieldDeprecationReason = pure (deprecated >>= lookupDeprecatedReason) @@ -107,8 +114,8 @@ renderTypeKind KindList = LIST renderTypeKind KindNonNull = NON_NULL -wrap :: Monad m => DataField -> S__Type m -> S__Type m -wrap DataField { fieldType = TypeRef { typeWrappers } } typ = +applyTypeWrapper :: Monad m => FieldDefinition -> S__Type m -> S__Type m +applyTypeWrapper FieldDefinition { fieldType = TypeRef { typeWrappers } } typ = foldr wrapByTypeWrapper typ (toGQLWrapper typeWrappers) wrapByTypeWrapper :: Monad m => DataTypeWrapper -> S__Type m -> S__Type m @@ -122,18 +129,16 @@ renderinputValue :: (Monad m, Failure Text m) - => (Text, DataField) + => FieldDefinition -> Result m (S__InputValue m) -renderinputValue (key, input) = - fmap (createInputValueWith key (fieldMeta input)) - . createInputObjectType input +renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input createInputObjectType - :: (Monad m, Failure Text m) => DataField -> Result m (S__Type m) -createInputObjectType field@DataField { fieldType = TypeRef { typeConName } } lib + :: (Monad m, Failure Text m) => FieldDefinition -> Result m (S__Type m) +createInputObjectType field@FieldDefinition { fieldType = TypeRef { typeConName } } lib = do kind <- renderTypeKind <$> lookupKind typeConName lib - pure $ wrap field $ createType kind typeConName Nothing $ Just [] + pure $ applyTypeWrapper field $ createType kind typeConName Nothing $ Just [] renderInputUnion @@ -145,8 +150,8 @@ createField (createInputUnionFields key $ map fst $ filter snd fields) where - createField (name, field) = - createInputValueWith name Nothing <$> createInputObjectType field lib + createField field = + createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib createLeafType :: Monad m 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 @@ -33,12 +33,12 @@ import Data.Morpheus.Types.GQLType ( CUSTOM ) import Data.Morpheus.Types.ID ( ID ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) - , Schema(..) + ( Schema(..) , QUERY - , DataType + , TypeDefinition(..) , allDataTypes , lookupDataType + , FieldsDefinition ) import Data.Morpheus.Types.Internal.Resolving ( Resolver @@ -51,8 +51,8 @@ convertTypes lib = traverse (`render` lib) (allDataTypes lib) buildSchemaLinkType - :: Monad m => (Text, DataType) -> S__Type (Resolver QUERY e m) -buildSchemaLinkType (key', _) = createObjectType key' Nothing $ Just [] + :: Monad m => TypeDefinition -> S__Type (Resolver QUERY e m) +buildSchemaLinkType TypeDefinition { typeName } = createObjectType typeName Nothing $ Just [] findType :: Monad m @@ -61,7 +61,7 @@ -> Resolver QUERY e m (Maybe (S__Type (Resolver QUERY e m))) findType name lib = renderT (lookupDataType name lib) where - renderT (Just datatype) = Just <$> render (name, datatype) lib + renderT (Just datatype) = Just <$> render datatype lib renderT Nothing = pure Nothing initSchema @@ -76,7 +76,7 @@ , s__SchemaDirectives = pure [] } -hiddenRootFields :: [(Text, DataField)] +hiddenRootFields :: FieldsDefinition hiddenRootFields = fst $ introspectObjectFields (Proxy :: Proxy (CUSTOM (Root Maybe))) ("Root", OutputType, Proxy @(Root Maybe)) 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 @@ -1,113 +1,101 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} -- | GraphQL Wai Server Applications module Data.Morpheus.Server - ( gqlSocketApp - , gqlSocketMonadIOApp - , initGQLState - , GQLState + ( webSocketsApp + , httpPubApp ) where -import Control.Exception ( finally ) -import Control.Monad ( forever ) -import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import Data.Text ( Text ) -import Network.WebSockets ( ServerApp - , acceptRequestWith - , forkPingThread - , pendingRequest - , receiveData + +import Control.Monad.IO.Unlift ( MonadUnliftIO + , withRunInIO + ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Network.WebSockets ( Connection , sendTextData + , receiveData + , ServerApp ) +import qualified Network.WebSockets as WS -- MORPHEUS -import Data.Morpheus.Execution.Server.Resolve - ( RootResCon - , coreResolver - ) -import Data.Morpheus.Types.Internal.Apollo - ( SubAction(..) - , acceptApolloSubProtocol - , apolloFormat - , toApolloResponse - ) -import Data.Morpheus.Execution.Server.Subscription - ( GQLState - , connectClient - , disconnectClient - , initGQLState - , publishEvent - , startSubscription - , endSubscription - ) -import Data.Morpheus.Types.Internal.Resolving - ( GQLRootResolver(..) - , GQLChannel(..) - , ResponseEvent(..) - , ResponseStream - , runResultT - , Result(..) +import Data.Morpheus.Types.Internal.Resolving + ( GQLChannel(..) ) +import Data.Morpheus.Types.IO ( MapAPI(..) ) +import Data.Morpheus.Types.Internal.Subscription + ( connectionThread + , Input(..) + , Stream + , Store(..) + , Scope(..) + , HTTP + , WS + , runStreamHTTP + , acceptApolloRequest + , initDefaultStore + , publishEventWith ) -import Data.Morpheus.Types.Internal.WebSocket - ( GQLClient(..) ) -import Data.Morpheus.Types.IO ( GQLResponse(..) ) -import Data.Morpheus.Types.Internal.AST - ( ValidValue ) -handleSubscription - :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) - => GQLClient m e - -> GQLState m e - -> Text - -> 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 -> liftIO $ sendTextData - clientConnection - (toApolloResponse sessionId $ Errors errors) - where - execute (Publish pub) = publishEvent state pub - execute (Subscribe sub) = startSubscription clientID sub sessionId state +-- support old version of Websockets +pingThread :: Connection -> IO () -> IO () +#if MIN_VERSION_websockets(0,12,6) +pingThread connection = WS.withPingThread connection 30 (return ()) +#else +pingThread connection = (WS.forkPingThread connection 30 >>) +#endif + +defaultWSScope :: MonadIO m => Store e m -> Connection -> Scope WS e m +defaultWSScope Store { writeStore } connection = ScopeWS + { listener = liftIO (receiveData connection) + , callback = liftIO . sendTextData connection + , update = writeStore + } + +httpPubApp + :: + ( MonadIO m, + MapAPI a + ) + => (Input HTTP -> Stream HTTP e m) + -> (e -> m ()) + -> a + -> m a +httpPubApp api httpCallback + = mapAPI + ( runStreamHTTP ScopeHTTP { httpCallback } + . api + . Request + ) + -- | Wai WebSocket Server App for GraphQL subscriptions -gqlSocketMonadIOApp - :: (RootResCon m e que mut sub, MonadIO m) - => GQLRootResolver m e que mut sub - -> GQLState m e - -> (m () -> IO ()) - -> ServerApp -gqlSocketMonadIOApp gqlRoot state f pending = do - connection <- acceptRequestWith pending - $ acceptApolloSubProtocol (pendingRequest pending) - forkPingThread connection 30 - client <- connectClient connection state - finally (f $ queryHandler client) (disconnectClient client state) - where - queryHandler client = forever handleRequest - where - handleRequest = do - d <- liftIO $ receiveData (clientConnection client) - resolveMessage (apolloFormat d) +webSocketsApp + :: ( MonadIO m + , MonadUnliftIO m + , (Eq (StreamChannel e)) + , (GQLChannel e) + ) + => (Input WS -> Stream WS e m) + -> m (ServerApp , e -> m ()) +webSocketsApp api = withRunInIO handle + where + handle runIO = do + store <- initDefaultStore + pure (wsApp store, publishEventWith store) where - resolveMessage (SubError x) = liftIO $ print x - resolveMessage (AddSub sessionId request) = - handleSubscription client state sessionId (coreResolver gqlRoot request) - resolveMessage (RemoveSub sessionId) = - endSubscription (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 + wsApp store pending = do + connection <- acceptApolloRequest pending + let scope = defaultWSScope store connection + pingThread + connection + $ runIO (connectionThread api scope) 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 @@ -36,6 +36,8 @@ , subscribe , unsafeInternalContext , SubField + , Input + , Stream ) where @@ -76,6 +78,10 @@ , GQLResponse(..) ) import Data.Morpheus.Types.Types ( Undefined(..) ) +import Data.Morpheus.Types.Internal.Subscription + ( Stream + , Input + ) type Res = Resolver QUERY type MutRes = Resolver MUTATION 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 @@ -10,7 +10,7 @@ where import Data.Morpheus.Types.Internal.AST.Data - ( DataValidator(..) ) + ( ScalarDefinition(..) ) import Data.Morpheus.Types.Internal.AST ( ScalarValue(..) , ValidValue @@ -42,8 +42,8 @@ parseValue :: ScalarValue -> Either Text a -- | serialization of haskell type into scalar value serialize :: a -> ScalarValue - scalarValidator :: Proxy a -> DataValidator - scalarValidator _ = DataValidator {validateValue = validator} + scalarValidator :: Proxy a -> ScalarDefinition + scalarValidator _ = ScalarDefinition {validateValue = validator} where validator value = do scalarValue' <- toScalar value 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 @@ -38,7 +38,7 @@ , Pair , Undefined(..) ) -import Data.Morpheus.Types.Internal.AST.Data +import Data.Morpheus.Types.Internal.AST ( DataFingerprint(..) , QUERY ) 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 @@ -7,6 +7,7 @@ ) where +import qualified Data.Aeson as A import Data.Morpheus.Kind ( SCALAR ) import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) ) import Data.Morpheus.Types.GQLType ( GQLType(KIND) ) @@ -26,6 +27,12 @@ instance GQLType ID where type KIND ID = SCALAR + +instance A.ToJSON ID where + toJSON = A.toJSON . unpackID + +instance A.FromJSON ID where + parseJSON = fmap ID . A.parseJSON instance GQLScalar ID where parseValue (Int x) = return (ID $ pack $ show x) 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 @@ -2,40 +2,90 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Data.Morpheus.Types.IO ( GQLRequest(..) , GQLResponse(..) , JSONResponse(..) , renderResponse + , MapAPI(..) ) where + import Data.Aeson ( FromJSON(..) , ToJSON(..) , pairs , withObject , (.:?) , (.=) + , object + , encode ) +import Data.Aeson.Parser ( eitherDecodeWith + , jsonNoDup + ) import qualified Data.Aeson as Aeson ( Value(..) ) import qualified Data.HashMap.Lazy as LH ( toList ) import GHC.Generics ( Generic ) +import Data.Text ( Text ) +import qualified Data.Text.Lazy as LT + ( Text + , fromStrict + , toStrict + ) +import Data.Text.Lazy.Encoding ( decodeUtf8 + , encodeUtf8 + ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy.Char8 as LB + ( ByteString + , fromStrict + , toStrict + ) +import Data.Aeson.Internal ( formatError + , ifromJSON + ) -- MORPHEUS -import Data.Morpheus.Types.Internal.AST.Base - ( Key ) +import Data.Morpheus.Error.Utils ( badRequestError ) +import Data.Morpheus.Types.Internal.AST + ( Key + , GQLError(..) + , ValidValue + ) import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) - , Result(..) + ( Result(..) + , Failure(..) ) -import Data.Morpheus.Types.Internal.AST.Value - ( ValidValue ) -renderResponse :: Result e GQLError con ValidValue -> GQLResponse +decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest +decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of + Left (path, x) -> failure $ formatError path x + Right value -> pure value + +class MapAPI a where + mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m a + +instance MapAPI LB.ByteString where + mapAPI api request = case decodeNoDup request of + Left aesonError -> pure $ badRequestError aesonError + Right req -> encode <$> api req + +instance MapAPI LT.Text where + mapAPI api = fmap decodeUtf8 . mapAPI api . encodeUtf8 + +instance MapAPI ByteString where + mapAPI api = fmap LB.toStrict . mapAPI api . LB.fromStrict + +instance MapAPI Text where + mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict + +renderResponse :: Result e ValidValue -> GQLResponse renderResponse (Failure errors) = Errors errors renderResponse Success { result } = Data result @@ -69,5 +119,8 @@ parseJSON _ = fail "Invalid GraphQL Response" instance ToJSON GQLResponse where + toJSON (Data gqlData) = object ["data" .= toJSON gqlData] + toJSON (Errors errors) = object ["errors" .= toJSON errors] + ---------------------------------------------------------- toEncoding (Data _data ) = pairs $ "data" .= _data toEncoding (Errors _errors) = pairs $ "errors" .= _errors 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,12 +1,14 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} module Data.Morpheus.Types.Internal.AST ( -- BASE Key - , Collection , Ref(..) , Position(..) , Message @@ -34,58 +36,58 @@ , ValidObject , ResolvedObject , ResolvedValue - , unpackInputUnion - + , Named + , splitDuplicates + , removeDuplicates -- Selection , Argument(..) , Arguments , SelectionSet , SelectionContent(..) - , ValidSelection , Selection(..) - , RawSelection - , FragmentLib - , RawArguments - , RawSelectionSet + , Fragments , Fragment(..) - , RawArgument - , ValidSelectionSet - , ValidArgument - , ValidArguments - , RawSelectionRec - , ValidSelectionRec , isOutputType -- OPERATION , Operation(..) , Variable(..) - , ValidOperation - , RawOperation , VariableDefinitions - , ValidVariables , DefaultValue , getOperationName , getOperationDataType - , getOperationObject - - -- DSL - , DataScalar + , ScalarDefinition(..) , DataEnum - , DataObject - , DataArgument + , FieldsDefinition(..) + , ArgumentDefinition , DataUnion - , DataArguments - , DataField(..) - , DataTypeContent(..) - , DataType(..) + , ArgumentsDefinition(..) + , FieldDefinition(..) + , InputFieldsDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , Schema(..) , DataTypeWrapper(..) - , DataValidator(..) , DataTypeKind(..) , DataFingerprint(..) , TypeWrapper(..) , TypeRef(..) , DataEnumValue(..) + , OperationType(..) + , QUERY + , MUTATION + , SUBSCRIPTION + , Meta(..) + , Directive(..) + , TypeUpdater + , TypeD(..) + , ConsD(..) + , ClientQuery(..) + , GQLTypeD(..) + , ClientType(..) + , DataInputUnion + , VariableContent(..) + , TypeLib , isTypeDefined , initTypeLib , defineType @@ -107,18 +109,7 @@ , isDefaultTypeName , isSchemaTypeName , isPrimitiveTypeName - , OperationType(..) - , QUERY - , MUTATION - , SUBSCRIPTION , isEntNode - , lookupInputType - , coerceDataObject - , lookupDataUnion - , lookupField - , lookupUnionTypes - , lookupSelectionField - , lookupFieldAsSelectionSet , createField , createArgument , createDataTypeLib @@ -129,79 +120,46 @@ , createAlias , createInputUnionFields , fieldVisibility - , Meta(..) - , Directive(..) , createEnumValue , insertType - , TypeUpdater , lookupDeprecated , lookupDeprecatedReason - , TypeD(..) - , ConsD(..) - , ClientQuery(..) - , GQLTypeD(..) - , ClientType(..) - , DataInputUnion - , VariableContent(..) - , checkForUnknownKeys - , checkNameCollision - , DataLookup(..) + , hasArguments + , lookupWith + , typeFromScalar + -- Temaplate Haskell + , toHSFieldDefinition + , hsTypeName -- LOCAL , GQLQuery(..) , Variables , isNullableWrapper + , unsafeFromFields + , unsafeFromInputFields + , OrderedMap + , GQLError(..) + , GQLErrors + , ObjectEntry(..) + , UnionTag(..) + , isInputDataType + , __inputname ) where import Data.Map ( Map ) import Language.Haskell.TH.Syntax ( Lift ) -import Data.Semigroup ( (<>) ) -- Morpheus -import Data.Morpheus.Types.Internal.AST.Data - -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(..) ) +import Data.Morpheus.Types.Internal.AST.Selection +import Data.Morpheus.Types.Internal.AST.Data +import Data.Morpheus.Types.Internal.AST.OrderedMap type Variables = Map Key ResolvedValue data GQLQuery = GQLQuery - { fragments :: FragmentLib - , operation :: RawOperation + { fragments :: Fragments + , operation :: Operation RAW , 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 @@ -1,17 +1,19 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Data.Morpheus.Types.Internal.AST.Base ( Key - , Collection , Ref(..) , Position(..) , Message - , anonymousRef , Name + , Named , Description , VALID , RAW @@ -19,43 +21,97 @@ , Stage(..) , RESOLVED , TypeRef(..) - , removeDuplicates - , elementOfKeys , VALIDATION_MODE(..) + , OperationType(..) + , QUERY + , MUTATION + , SUBSCRIPTION + , DataTypeKind(..) + , DataFingerprint(..) + , DataTypeWrapper(..) + , anonymousRef + , toHSWrappers + , toGQLWrapper + , sysTypes + , isNullable + , isWeaker + , isSubscription + , isOutputObject + , isDefaultTypeName + , isSchemaTypeName + , isPrimitiveTypeName + , isObject + , isInput + , isNullableWrapper + , isOutputType + , sysFields + , typeFromScalar + , hsTypeName + , toOperationType + , splitDuplicates + , removeDuplicates + , GQLError(..) + , GQLErrors ) where +import Data.Semigroup ((<>)) import Data.Aeson ( FromJSON , ToJSON ) import Data.Text ( Text ) import GHC.Generics ( Generic ) -import Language.Haskell.TH.Syntax ( Lift ) -import Instances.TH.Lift ( ) -import qualified Data.Set as S +import Language.Haskell.TH.Syntax ( Lift(..) ) +import Instances.TH.Lift () type Key = Text type Message = Text type Name = Key type Description = Key +data Stage = RAW | RESOLVED | VALID -type Collection a = [(Key, a)] +data Position = Position + { line :: Int + , column :: Int + } deriving ( Show, Generic, FromJSON, ToJSON, Lift) +-- Positions 2 Value withs same structire +-- but different Positions should be Equal +instance Eq Position where + _ == _ = True -data Stage = RAW | RESOLVED | VALID +data GQLError = GQLError + { message :: Message + , locations :: [Position] + } deriving ( Show, Generic, FromJSON, ToJSON) -type RAW = 'RAW +type GQLErrors = [GQLError] -type RESOLVED = 'RESOLVED +type RAW = 'RAW +type RESOLVED = 'RESOLVED type VALID = 'VALID -data Position = Position - { line :: Int - , column :: Int - } deriving (Show, Generic, FromJSON, ToJSON, Lift) +data VALIDATION_MODE + = WITHOUT_VARIABLES + | FULL_VALIDATION + deriving (Eq, Show) +data DataFingerprint = DataFingerprint Name [String] deriving (Show, Eq, Ord, Lift) + +data OperationType + = Query + | Subscription + | Mutation + deriving (Show, Eq, Lift) + +type QUERY = 'Query +type MUTATION = 'Mutation +type SUBSCRIPTION = 'Subscription + +type Named a = (Name, a) + -- Refference with Position information -- -- includes position for debugging, where Ref "a" 1 === Ref "a" 3 @@ -63,10 +119,7 @@ data Ref = Ref { refName :: Key , refPosition :: Position - } deriving (Show,Lift) - -instance Eq Ref where - (Ref id1 _) == (Ref id2 _) = id1 == id2 + } deriving (Show,Lift, Eq) instance Ord Ref where compare (Ref x _) (Ref y _) = compare x y @@ -74,27 +127,142 @@ anonymousRef :: Key -> Ref anonymousRef refName = Ref { refName, refPosition = Position 0 0 } +-- TypeRef +------------------------------------------------------------------- +data TypeRef = TypeRef + { typeConName :: Name + , typeArgs :: Maybe Name + , typeWrappers :: [TypeWrapper] + } deriving (Show, Eq, Lift) + +isNullable :: TypeRef -> Bool +isNullable TypeRef { typeWrappers = typeWrappers } = isNullableWrapper typeWrappers + +-- Kind +----------------------------------------------------------------------------------- +data DataTypeKind + = KindScalar + | KindObject (Maybe OperationType) + | KindUnion + | KindEnum + | KindInputObject + | KindList + | KindNonNull + | KindInputUnion + deriving (Eq, Show, Lift) + +isSubscription :: DataTypeKind -> Bool +isSubscription (KindObject (Just Subscription)) = True +isSubscription _ = False + +isOutputType :: DataTypeKind -> Bool +isOutputType (KindObject _) = True +isOutputType KindUnion = True +isOutputType _ = False + +isOutputObject :: DataTypeKind -> Bool +isOutputObject (KindObject _) = True +isOutputObject _ = False + +isObject :: DataTypeKind -> Bool +isObject (KindObject _) = True +isObject KindInputObject = True +isObject _ = False + +isInput :: DataTypeKind -> Bool +isInput KindInputObject = True +isInput _ = False + +-- TypeWrappers +----------------------------------------------------------------------------------- data TypeWrapper = TypeList | TypeMaybe + deriving (Show, Eq, Lift) + +data DataTypeWrapper + = ListType + | NonNullType deriving (Show, Lift) -data TypeRef = TypeRef - { typeConName :: Name - , typeArgs :: Maybe Name - , typeWrappers :: [TypeWrapper] - } deriving (Show,Lift) +isNullableWrapper :: [TypeWrapper] -> Bool +isNullableWrapper (TypeMaybe : _ ) = True +isNullableWrapper _ = False +isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool +isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2 +isWeaker (TypeMaybe : _ ) _ = True +isWeaker (_ : xs1) (_ : xs2) = isWeaker xs1 xs2 +isWeaker _ _ = False -data VALIDATION_MODE - = WITHOUT_VARIABLES - | FULL_VALIDATION - deriving (Eq, Show) +toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper] +toGQLWrapper (TypeMaybe : (TypeMaybe : tw)) = toGQLWrapper (TypeMaybe : tw) +toGQLWrapper (TypeMaybe : (TypeList : tw)) = ListType : toGQLWrapper tw +toGQLWrapper (TypeList : tw) = [NonNullType, ListType] <> toGQLWrapper tw +toGQLWrapper [TypeMaybe ] = [] +toGQLWrapper [] = [NonNullType] -removeDuplicates :: Ord a => [a] -> [a] -removeDuplicates = S.toList . S.fromList +toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper] +toHSWrappers (NonNullType : (NonNullType : xs)) = + toHSWrappers (NonNullType : xs) +toHSWrappers (NonNullType : (ListType : xs)) = TypeList : toHSWrappers xs +toHSWrappers (ListType : xs) = [TypeMaybe, TypeList] <> toHSWrappers xs +toHSWrappers [] = [TypeMaybe] +toHSWrappers [NonNullType] = [] -elementOfKeys :: [Name] -> Ref -> Bool -elementOfKeys keys Ref { refName } = refName `elem` keys +isDefaultTypeName :: Key -> Bool +isDefaultTypeName x = isSchemaTypeName x || isPrimitiveTypeName x +isSchemaTypeName :: Key -> Bool +isSchemaTypeName = (`elem` sysTypes) +isPrimitiveTypeName :: Key -> Bool +isPrimitiveTypeName = (`elem` ["String", "Float", "Int", "Boolean", "ID"]) + +sysTypes :: [Key] +sysTypes = + [ "__Schema" + , "__Type" + , "__Directive" + , "__TypeKind" + , "__Field" + , "__DirectiveLocation" + , "__InputValue" + , "__EnumValue" + ] + +sysFields :: [Key] +sysFields = ["__typename","__schema","__type"] + +typeFromScalar :: Name -> Name +typeFromScalar "Boolean" = "Bool" +typeFromScalar "Int" = "Int" +typeFromScalar "Float" = "Float" +typeFromScalar "String" = "Text" +typeFromScalar "ID" = "ID" +typeFromScalar _ = "ScalarValue" + +hsTypeName :: Key -> Key +hsTypeName "String" = "Text" +hsTypeName "Boolean" = "Bool" +hsTypeName name | name `elem` sysTypes = "S" <> name +hsTypeName name = name + +toOperationType :: Name -> Maybe OperationType +toOperationType "Subscription" = Just Subscription +toOperationType "Mutation" = Just Mutation +toOperationType "Query" = Just Query +toOperationType _ = Nothing + +removeDuplicates :: Eq a => [a] -> [a] +removeDuplicates = fst . splitDuplicates + +-- elems -> (unique elements, duplicate elems) +splitDuplicates :: Eq a => [a] -> ([a],[a]) +splitDuplicates = collectElems ([],[]) + where + collectElems :: Eq a => ([a],[a]) -> [a] -> ([a],[a]) + collectElems collected [] = collected + collectElems (collected,errors) (x:xs) + | x `elem` collected = collectElems (collected,errors <> [x]) xs + | otherwise = collectElems (collected <> [x],errors) xs 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 @@ -1,65 +1,42 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Data.Morpheus.Types.Internal.AST.Data - ( DataScalar + ( Arguments + , ScalarDefinition(..) , DataEnum - , DataObject - , DataArgument + , FieldsDefinition(..) + , ArgumentDefinition , DataUnion - , DataArguments - , DataField(..) - , DataTypeContent(..) - , DataType(..) + , ArgumentsDefinition(..) + , FieldDefinition(..) + , InputFieldsDefinition(..) + , TypeContent(..) + , TypeDefinition(..) , Schema(..) - , DataTypeWrapper(..) - , DataValidator(..) - , DataTypeKind(..) - , DataFingerprint(..) - , TypeWrapper(..) - , TypeRef(..) , DataEnumValue(..) - , isTypeDefined - , initTypeLib - , defineType - , isFieldNullable + , TypeLib + , Meta(..) + , Directive(..) + , TypeUpdater + , TypeD(..) + , ConsD(..) + , ClientQuery(..) + , GQLTypeD(..) + , ClientType(..) + , DataInputUnion + , Argument(..) , allDataTypes - , lookupDataType - , kindOf - , toNullableField - , toListField - , isObject - , isInput - , toHSWrappers - , isNullable - , toGQLWrapper - , isWeaker - , isSubscription - , isOutputObject - , sysTypes - , isDefaultTypeName - , isSchemaTypeName - , isPrimitiveTypeName - , OperationType(..) - , QUERY - , MUTATION - , SUBSCRIPTION - , isEntNode - , lookupInputType - , coerceDataObject - , lookupDataUnion - , lookupField - , lookupUnionTypes - , lookupSelectionField - , lookupFieldAsSelectionSet , createField , createArgument , createDataTypeLib @@ -69,62 +46,77 @@ , createUnionType , createAlias , createInputUnionFields - , fieldVisibility - , Meta(..) - , Directive(..) , createEnumValue + , defineType + , isTypeDefined + , initTypeLib + , isFieldNullable , insertType - , TypeUpdater + , fieldVisibility + , kindOf + , toNullableField + , toListField + , toHSFieldDefinition + , isEntNode + , lookupDataType , lookupDeprecated , lookupDeprecatedReason - , TypeD(..) - , ConsD(..) - , ClientQuery(..) - , GQLTypeD(..) - , ClientType(..) - , DataInputUnion - , isNullableWrapper - , isOutputType - , checkForUnknownKeys - , checkNameCollision - , DataLookup(..) + , lookupWith + , hasArguments + , unsafeFromFields + , isInputDataType + , unsafeFromInputFields + , __inputname ) where import Data.HashMap.Lazy ( HashMap - , empty - , fromList - , insert - , toList , union + , elems ) import qualified Data.HashMap.Lazy as HM - ( lookup ) -import Data.Semigroup ( (<>) ) -import Language.Haskell.TH.Syntax ( Lift ) +import Data.Semigroup ( Semigroup(..), (<>) ) +import Language.Haskell.TH.Syntax ( Lift(..) ) import Instances.TH.Lift ( ) -import Data.List ( find , (\\)) +import Data.List ( find) -- MORPHEUS -import Data.Morpheus.Error.Internal ( internalError ) -import Data.Morpheus.Error.Selection ( cannotQueryField - , hasNoSubfields +import Data.Morpheus.Error.NameCollision + ( NameCollision(..) ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap + , unsafeFromValues + ) import Data.Morpheus.Types.Internal.AST.Base ( Key , Position , Name + , Message , Description , TypeWrapper(..) , TypeRef(..) - , Ref(..) - , elementOfKeys - , removeDuplicates + , Stage + , VALID + , DataTypeKind(..) + , DataFingerprint(..) + , isNullable + , sysFields + , toOperationType + , hsTypeName + , GQLError(..) ) +import Data.Morpheus.Types.Internal.Operation + ( Empty(..) + , Selectable(..) + , Listable(..) + , Singleton(..) + , Listable(..) + , Merge(..) + , KeyOf(..) + ) import Data.Morpheus.Types.Internal.Resolving.Core - ( Validation - , Failure(..) - , GQLErrors + ( Failure(..) , LibUpdater , resolveUpdates ) @@ -135,147 +127,43 @@ ) import Data.Morpheus.Error.Schema ( nameCollisionError ) -type QUERY = 'Query -type MUTATION = 'Mutation -type SUBSCRIPTION = 'Subscription -isDefaultTypeName :: Key -> Bool -isDefaultTypeName x = isSchemaTypeName x || isPrimitiveTypeName x - -isSchemaTypeName :: Key -> Bool -isSchemaTypeName = (`elem` sysTypes) - -isPrimitiveTypeName :: Key -> Bool -isPrimitiveTypeName = (`elem` ["String", "Float", "Int", "Boolean", "ID"]) - - -checkNameCollision :: (Failure e m, Ord a) => [a] -> ([a] -> e) -> m [a] -checkNameCollision enhancedKeys errorGenerator = - case enhancedKeys \\ removeDuplicates enhancedKeys of - [] -> pure enhancedKeys - duplicates -> failure $ errorGenerator duplicates - -checkForUnknownKeys :: Failure e m => [Ref] -> [Name] -> ([Ref] -> e) -> m [Ref] -checkForUnknownKeys enhancedKeys' keys' errorGenerator' = - case filter (not . elementOfKeys keys') enhancedKeys' of - [] -> pure enhancedKeys' - unknownKeys' -> failure $ errorGenerator' unknownKeys' - - -sysTypes :: [Key] -sysTypes = - [ "__Schema" - , "__Type" - , "__Directive" - , "__TypeKind" - , "__Field" - , "__DirectiveLocation" - , "__InputValue" - , "__EnumValue" - ] - -data OperationType - = Query - | Subscription - | Mutation - deriving (Show, Eq, Lift) - -isSubscription :: DataTypeKind -> Bool -isSubscription (KindObject (Just Subscription)) = True -isSubscription _ = False - -isOutputType :: DataTypeKind -> Bool -isOutputType (KindObject _) = True -isOutputType KindUnion = True -isOutputType _ = False - -isOutputObject :: DataTypeKind -> Bool -isOutputObject (KindObject _) = True -isOutputObject _ = False - -isObject :: DataTypeKind -> Bool -isObject (KindObject _) = True -isObject KindInputObject = True -isObject _ = False - -isInput :: DataTypeKind -> Bool -isInput KindInputObject = True -isInput _ = False - -data DataTypeKind - = KindScalar - | KindObject (Maybe OperationType) - | KindUnion - | KindEnum - | KindInputObject - | KindList - | KindNonNull - | KindInputUnion - deriving (Eq, Show, Lift) +type DataEnum = [DataEnumValue] +type DataUnion = [Key] +type DataInputUnion = [(Key, Bool)] -isFieldNullable :: DataField -> Bool -isFieldNullable = isNullable . fieldType +-- scalar +------------------------------------------------------------------ +newtype ScalarDefinition = ScalarDefinition + { validateValue :: ValidValue -> Either Key ValidValue } -isNullable :: TypeRef -> Bool -isNullable TypeRef { typeWrappers = typeWrappers } = isNullableWrapper typeWrappers +instance Show ScalarDefinition where + show _ = "ScalarDefinition" -isNullableWrapper :: [TypeWrapper] -> Bool -isNullableWrapper (TypeMaybe : _ ) = True -isNullableWrapper _ = False +data Argument (valid :: Stage) = Argument + { argumentName :: Name + , argumentValue :: Value valid + , argumentPosition :: Position + } deriving ( Show, Eq, Lift ) -isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool -isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2 -isWeaker (TypeMaybe : _ ) _ = True -isWeaker (_ : xs1) (_ : xs2) = isWeaker xs1 xs2 -isWeaker _ _ = False - -toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper] -toGQLWrapper (TypeMaybe : (TypeMaybe : tw)) = toGQLWrapper (TypeMaybe : tw) -toGQLWrapper (TypeMaybe : (TypeList : tw)) = ListType : toGQLWrapper tw -toGQLWrapper (TypeList : tw) = [NonNullType, ListType] <> toGQLWrapper tw -toGQLWrapper [TypeMaybe ] = [] -toGQLWrapper [] = [NonNullType] - -toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper] -toHSWrappers (NonNullType : (NonNullType : xs)) = - toHSWrappers (NonNullType : xs) -toHSWrappers (NonNullType : (ListType : xs)) = TypeList : toHSWrappers xs -toHSWrappers (ListType : xs) = [TypeMaybe, TypeList] <> toHSWrappers xs -toHSWrappers [] = [TypeMaybe] -toHSWrappers [NonNullType] = [] - -data DataFingerprint = DataFingerprint Name [String] deriving (Show, Eq, Ord, Lift) - -newtype DataValidator = DataValidator - { validateValue :: ValidValue -> Either Key ValidValue - } - -instance Show DataValidator where - show _ = "DataValidator" +instance KeyOf (Argument stage) where + keyOf = argumentName -type DataScalar = DataValidator -type DataEnum = [DataEnumValue] -type DataObject = [(Key, DataField)] -type DataArgument = DataField -type DataUnion = [Key] -type DataInputUnion = [(Key, Bool)] -type DataArguments = [(Key, DataArgument)] +instance NameCollision (Argument s) where + nameCollision _ Argument { argumentName, argumentPosition } + = GQLError + { message = "There can Be only One Argument Named \"" <> argumentName <> "\"", + locations = [argumentPosition] + } -data DataTypeWrapper - = ListType - | NonNullType - deriving (Show, Lift) +type Arguments s = OrderedMap (Argument s) +-- directive +------------------------------------------------------------------ data Directive = Directive { directiveName :: Name, - directiveArgs :: [(Name, ValidValue)] -} deriving (Show,Lift) - --- META -data Meta = Meta { - metaDescription:: Maybe Description, - metaDirectives :: [Directive] + directiveArgs :: OrderedMap (Argument VALID) } deriving (Show,Lift) lookupDeprecated :: Meta -> Maybe Directive @@ -286,132 +174,133 @@ lookupDeprecatedReason :: Directive -> Maybe Key lookupDeprecatedReason Directive { directiveArgs } = - maybeString . snd <$> find isReason directiveArgs + selectOr Nothing (Just . maybeString) "reason" directiveArgs where - maybeString :: ValidValue -> Name - maybeString (Scalar (String x)) = x + maybeString :: Argument VALID -> Name + maybeString Argument { argumentValue = (Scalar (String x)) } = x maybeString _ = "can't read deprecated Reason Value" - isReason ("reason", _) = True - isReason _ = False +-- META +data Meta = Meta { + metaDescription:: Maybe Description, + metaDirectives :: [Directive] +} deriving (Show,Lift) + + -- ENUM VALUE data DataEnumValue = DataEnumValue{ enumName :: Name, enumMeta :: Maybe Meta } deriving (Show, Lift) --------------------------------------------------------------------------------------------------- -data DataField = DataField - { fieldName :: Key - , fieldArgs :: [(Key, DataArgument)] - , fieldArgsType :: Maybe Name - , fieldType :: TypeRef - , fieldMeta :: Maybe Meta - } deriving (Show,Lift) +-- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema +--------------------------------------------------------------------------- +-- SchemaDefinition : +-- schema Directives[Const](opt) { RootOperationTypeDefinition(list)} +-- +-- RootOperationTypeDefinition : +-- OperationType: NamedType -fieldVisibility :: (Key, DataField) -> Bool -fieldVisibility ("__typename", _) = False -fieldVisibility ("__schema" , _) = False -fieldVisibility ("__type" , _) = False -fieldVisibility _ = True +data Schema = Schema + { types :: TypeLib + , query :: TypeDefinition + , mutation :: Maybe TypeDefinition + , subscription :: Maybe TypeDefinition + } deriving (Show) -createField :: DataArguments -> Key -> ([TypeWrapper], Key) -> DataField -createField fieldArgs fieldName (typeWrappers, typeConName) = DataField - { fieldArgs - , fieldArgsType = Nothing - , fieldName - , fieldType = TypeRef { typeConName, typeWrappers, typeArgs = Nothing } - , fieldMeta = Nothing - } +type TypeLib = HashMap Key TypeDefinition -createArgument :: Key -> ([TypeWrapper], Key) -> (Key, DataField) -createArgument fieldName x = (fieldName, createField [] fieldName x) +instance Selectable Schema TypeDefinition where + selectOr fb f name lib = maybe fb f (lookupDataType name lib) +initTypeLib :: TypeDefinition -> Schema +initTypeLib query = Schema { types = empty + , query = query + , mutation = Nothing + , subscription = Nothing + } -toNullableField :: DataField -> DataField -toNullableField dataField - | isNullable (fieldType dataField) = dataField - | otherwise = dataField { fieldType = nullable (fieldType dataField) } - where - nullable alias@TypeRef { typeWrappers } = - alias { typeWrappers = TypeMaybe : typeWrappers } -toListField :: DataField -> DataField -toListField dataField = dataField { fieldType = listW (fieldType dataField) } - where - listW alias@TypeRef { typeWrappers } = - alias { typeWrappers = TypeList : typeWrappers } +allDataTypes :: Schema -> [TypeDefinition] +allDataTypes = elems . typeRegister -lookupField :: Failure error m => Key -> [(Key, field)] -> error -> m field -lookupField key fields gqlError = case lookup key fields of - Nothing -> failure gqlError - Just field -> pure field +typeRegister :: Schema -> TypeLib +typeRegister Schema { types, query, mutation, subscription } = + types `union` HM.fromList + (concatMap fromOperation [Just query, mutation, subscription]) -lookupSelectionField - :: Failure GQLErrors Validation - => Position - -> Name - -> Name - -> DataObject - -> Validation DataField -lookupSelectionField position fieldName typeName fields = lookupField - fieldName - fields - gqlError - where gqlError = cannotQueryField fieldName typeName position +createDataTypeLib :: Failure Message m => [TypeDefinition] -> m Schema +createDataTypeLib types = case popByKey "Query" types of + (Nothing ,_ ) -> failure ("INTERNAL: Query Not Defined" :: Message) + (Just query, lib1) -> do + let (mutation, lib2) = popByKey "Mutation" lib1 + let (subscription, lib3) = popByKey "Subscription" lib2 + pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription} --- DATA TYPE --------------------------------------------------------------------------------------------------- -data DataType = DataType +-- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types +------------------------------------------------------------------------- +-- TypeDefinition : +-- ScalarTypeDefinition +-- ObjectTypeDefinition +-- InterfaceTypeDefinition +-- UnionTypeDefinition +-- EnumTypeDefinition +-- InputObjectTypeDefinition + +data TypeDefinition = TypeDefinition { typeName :: Key , typeFingerprint :: DataFingerprint - , typeMeta :: Maybe Meta - , typeContent :: DataTypeContent + , typeMeta :: Maybe Meta + , typeContent :: TypeContent } deriving (Show) -data DataTypeContent - = DataScalar { dataScalar :: DataScalar } - | DataEnum { enumMembers :: DataEnum } - | DataInputObject { inputObjectFields :: DataObject } +data TypeContent + = DataScalar { dataScalar :: ScalarDefinition + } + | DataEnum { enumMembers :: DataEnum + } + | DataInputObject { inputObjectFields :: InputFieldsDefinition + } | DataObject { objectImplements :: [Name], - objectFields :: DataObject } - | DataUnion { unionMembers :: DataUnion } - | DataInputUnion { inputUnionMembers :: [(Key,Bool)] } - | DataInterface { interfaceFields :: DataObject } + objectFields :: FieldsDefinition + } + | DataUnion { unionMembers :: DataUnion + } + | DataInputUnion { inputUnionMembers :: [(Key,Bool)] + } + | DataInterface { interfaceFields :: FieldsDefinition + } deriving (Show) -createType :: Key -> DataTypeContent -> DataType -createType typeName typeContent = DataType +createType :: Key -> TypeContent -> TypeDefinition +createType typeName typeContent = TypeDefinition { typeName , typeMeta = Nothing , typeFingerprint = DataFingerprint typeName [] , typeContent } -createScalarType :: Key -> (Key, DataType) -createScalarType typeName = - (typeName, createType typeName $ DataScalar (DataValidator pure)) +createScalarType :: Name -> TypeDefinition +createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) -createEnumType :: Key -> [Key] -> (Key, DataType) -createEnumType typeName typeData = - (typeName, createType typeName $ DataEnum enumValues) +createEnumType :: Name -> [Key] -> TypeDefinition +createEnumType typeName typeData = createType typeName (DataEnum enumValues) where enumValues = map createEnumValue typeData -createEnumValue :: Key -> DataEnumValue +createEnumValue :: Name -> DataEnumValue createEnumValue enumName = DataEnumValue { enumName, enumMeta = Nothing } -createUnionType :: Key -> [Key] -> (Key, DataType) -createUnionType typeName typeData = - (typeName, createType typeName $ DataUnion typeData) +createUnionType :: Key -> [Key] -> TypeDefinition +createUnionType typeName typeData = createType typeName (DataUnion typeData) -isEntNode :: DataTypeContent -> Bool +isEntNode :: TypeContent -> Bool isEntNode DataScalar{} = True isEntNode DataEnum{} = True isEntNode _ = False -isInputDataType :: DataType -> Bool -isInputDataType DataType { typeContent } = __isInput typeContent +isInputDataType :: TypeDefinition -> Bool +isInputDataType TypeDefinition { typeContent } = __isInput typeContent where __isInput DataScalar{} = True __isInput DataEnum{} = True @@ -419,156 +308,240 @@ __isInput DataInputUnion{} = True __isInput _ = False -coerceDataObject :: Failure error m => error -> DataType -> m (Name,DataObject) -coerceDataObject _ DataType { typeContent = DataObject { objectFields } , typeName } = pure (typeName, objectFields) -coerceDataObject gqlError _ = failure gqlError - -coerceDataUnion :: Failure error m => error -> DataType -> m DataUnion -coerceDataUnion _ DataType { typeContent = DataUnion members } = pure members -coerceDataUnion gqlError _ = failure gqlError - -kindOf :: DataType -> DataTypeKind -kindOf DataType { typeContent } = __kind typeContent +kindOf :: TypeDefinition -> DataTypeKind +kindOf TypeDefinition { typeName, typeContent } = __kind typeContent where __kind DataScalar {} = KindScalar __kind DataEnum {} = KindEnum __kind DataInputObject {} = KindInputObject - __kind DataObject {} = KindObject Nothing + __kind DataObject {} = KindObject (toOperationType typeName) __kind DataUnion {} = KindUnion __kind DataInputUnion {} = KindInputUnion + -- TODO: + -- __kind DataInterface {} = KindInterface --- --- Type Register --------------------------------------------------------------------------------------------------- -data Schema = Schema - { types :: HashMap Name DataType - , query :: (Name,DataType) - , mutation :: Maybe (Name,DataType) - , subscription :: Maybe (Name,DataType) - } deriving (Show) +fromOperation :: Maybe TypeDefinition -> [(Name, TypeDefinition)] +fromOperation (Just datatype) = [(typeName datatype,datatype)] +fromOperation Nothing = [] -type TypeRegister = HashMap Key DataType +lookupDataType :: Key -> Schema -> Maybe TypeDefinition +lookupDataType name = HM.lookup name . typeRegister -initTypeLib :: (Key, DataType) -> Schema -initTypeLib query = Schema { types = empty - , query = query - , mutation = Nothing - , subscription = Nothing - } +isTypeDefined :: Key -> Schema -> Maybe DataFingerprint +isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib -allDataTypes :: Schema -> [(Key, DataType)] -allDataTypes = toList . typeRegister +defineType :: TypeDefinition -> Schema -> Schema +defineType dt@TypeDefinition { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint } lib + = lib { types = HM.insert name unionTags (HM.insert typeName dt (types lib)) } + where + name = typeName <> "Tags" + unionTags = TypeDefinition + { typeName = name + , typeFingerprint + , typeMeta = Nothing + , typeContent = DataEnum $ map (createEnumValue . fst) enumKeys + } +defineType datatype lib = + lib { types = HM.insert (typeName datatype) datatype (types lib) } -typeRegister :: Schema -> TypeRegister -typeRegister Schema { types, query, mutation, subscription } = - types `union` fromList - (concatMap fromOperation [Just query, mutation, subscription]) +insertType :: TypeDefinition -> TypeUpdater +insertType datatype@TypeDefinition { typeName } lib = case isTypeDefined typeName lib of + Nothing -> resolveUpdates (defineType datatype lib) [] + Just fingerprint | fingerprint == typeFingerprint datatype -> return lib + -- throw error if 2 different types has same name + | otherwise -> failure $ nameCollisionError typeName -fromOperation :: Maybe (Key, DataType) -> [(Key, DataType)] -fromOperation (Just (key, datatype)) = [(key, datatype)] -fromOperation Nothing = [] +lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a +lookupWith f key = find ((== key) . f) +-- lookups and removes TypeDefinition from hashmap +popByKey :: Name -> [TypeDefinition] -> (Maybe TypeDefinition,[TypeDefinition]) +popByKey name lib = case lookupWith typeName name lib of + Just dt@TypeDefinition { typeContent = DataObject {} } -> + (Just dt, filter ((/= name) . typeName) lib) + _ -> (Nothing, lib) -class DataLookup l a where - lookupResult :: (Failure e m, Monad m) => e -> Name -> l -> m a +-- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects +------------------------------------------------------------------------------ +-- ObjectTypeDefinition: +-- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) +-- +-- ImplementsInterfaces +-- implements &(opt) NamedType +-- ImplementsInterfaces & NamedType +-- +-- FieldsDefinition +-- { FieldDefinition(list) } +-- -instance DataLookup Schema DataType where - lookupResult err name lib = case lookupDataType name lib of - Nothing -> failure err - Just x -> pure x +newtype FieldsDefinition = FieldsDefinition + { unFieldsDefinition :: OrderedMap FieldDefinition } + deriving (Show, Empty) -instance DataLookup Schema (Name,DataObject) where - lookupResult validationError name lib = - lookupResult validationError name lib >>= coerceDataObject validationError +unsafeFromFields :: [FieldDefinition] -> FieldsDefinition +unsafeFromFields = FieldsDefinition . unsafeFromValues -lookupDataUnion - :: (Monad m, Failure e m) => e -> Key -> Schema -> m DataUnion -lookupDataUnion validationError name lib = - lookupResult validationError name lib >>= coerceDataUnion validationError +instance Merge FieldsDefinition where + merge path (FieldsDefinition x) (FieldsDefinition y) = FieldsDefinition <$> merge path x y -lookupDataType :: Key -> Schema -> Maybe DataType -lookupDataType name = HM.lookup name . typeRegister +instance Selectable FieldsDefinition FieldDefinition where + selectOr fb f name (FieldsDefinition lib) = selectOr fb f name lib -lookupUnionTypes - :: (Monad m, Failure GQLErrors m) - => Position - -> Key - -> Schema - -> DataField - -> m [(Name,DataObject)] -lookupUnionTypes position key lib DataField { fieldType = TypeRef { typeConName = typeName } } - = lookupDataUnion gqlError typeName lib - >>= mapM (flip (lookupResult gqlError) lib) - where gqlError = hasNoSubfields key typeName position +instance Singleton FieldsDefinition FieldDefinition where + singleton = FieldsDefinition . singleton -lookupFieldAsSelectionSet - :: (Monad m, Failure GQLErrors m) - => Position - -> Key - -> Schema - -> DataField - -> m (Name,DataObject) -lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeRef { typeConName } } - = lookupResult gqlError typeConName lib - where gqlError = hasNoSubfields key typeConName position +instance Listable FieldsDefinition FieldDefinition where + fromAssoc ls = FieldsDefinition <$> fromAssoc ls + toAssoc = toAssoc . unFieldsDefinition + +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +data FieldDefinition = FieldDefinition + { fieldName :: Key + , fieldArgs :: ArgumentsDefinition + , fieldType :: TypeRef + , fieldMeta :: Maybe Meta + } deriving (Show,Lift) -lookupInputType :: Failure e m => Key -> Schema -> e -> m DataType -lookupInputType name lib errors = case lookupDataType name lib of - Just x | isInputDataType x -> pure x - _ -> failure errors +instance KeyOf FieldDefinition where + keyOf = fieldName -isTypeDefined :: Key -> Schema -> Maybe DataFingerprint -isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib +instance Selectable FieldDefinition ArgumentDefinition where + selectOr fb f key FieldDefinition { fieldArgs } = selectOr fb f key fieldArgs -defineType :: (Key, DataType) -> Schema -> Schema -defineType (key, datatype@DataType { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint }) lib - = lib { types = insert name unionTags (insert key datatype (types lib)) } +instance NameCollision FieldDefinition where + nameCollision name _ = GQLError { + message = "There can Be only One field Named \"" <> name <> "\"", + locations = [] + } + +fieldVisibility :: FieldDefinition -> Bool +fieldVisibility FieldDefinition { fieldName } = fieldName `notElem` sysFields + +isFieldNullable :: FieldDefinition -> Bool +isFieldNullable = isNullable . fieldType + +createField :: ArgumentsDefinition -> Key -> ([TypeWrapper], Key) -> FieldDefinition +createField dataArguments fieldName (typeWrappers, typeConName) = FieldDefinition + { fieldArgs = dataArguments + , fieldName + , fieldType = TypeRef { typeConName, typeWrappers, typeArgs = Nothing } + , fieldMeta = Nothing + } + +toHSFieldDefinition :: FieldDefinition -> FieldDefinition +toHSFieldDefinition field@FieldDefinition { fieldType = tyRef@TypeRef { typeConName } } = field + { fieldType = tyRef { typeConName = hsTypeName typeConName } } + +toNullableField :: FieldDefinition -> FieldDefinition +toNullableField dataField + | isNullable (fieldType dataField) = dataField + | otherwise = dataField { fieldType = nullable (fieldType dataField) } where - name = typeName <> "Tags" - unionTags = DataType - { typeName = name - , typeFingerprint - , typeMeta = Nothing - , typeContent = DataEnum $ map (createEnumValue . fst) enumKeys + nullable alias@TypeRef { typeWrappers } = + alias { typeWrappers = TypeMaybe : typeWrappers } + +toListField :: FieldDefinition -> FieldDefinition +toListField dataField = dataField { fieldType = listW (fieldType dataField) } + where + listW alias@TypeRef { typeWrappers } = + alias { typeWrappers = TypeList : typeWrappers } + + + +-- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects +--------------------------------------------------------------------------- +-- InputObjectTypeDefinition +-- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt) +-- +--- InputFieldsDefinition +-- { InputValueDefinition(list) } + +newtype InputFieldsDefinition = InputFieldsDefinition + { unInputFieldsDefinition :: OrderedMap FieldDefinition } + deriving (Show, Empty) + +unsafeFromInputFields :: [FieldDefinition] -> InputFieldsDefinition +unsafeFromInputFields = InputFieldsDefinition . unsafeFromValues + +instance Merge InputFieldsDefinition where + merge path (InputFieldsDefinition x) (InputFieldsDefinition y) = InputFieldsDefinition <$> merge path x y + +instance Selectable InputFieldsDefinition FieldDefinition where + selectOr fb f name (InputFieldsDefinition lib) = selectOr fb f name lib + +instance Singleton InputFieldsDefinition FieldDefinition where + singleton = InputFieldsDefinition . singleton + +instance Listable InputFieldsDefinition FieldDefinition where + fromAssoc ls = InputFieldsDefinition <$> fromAssoc ls + toAssoc = toAssoc . unInputFieldsDefinition + + +-- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments +----------------------------------------------------------------------------------------------- +-- ArgumentsDefinition: +-- (InputValueDefinition(list)) + +data ArgumentsDefinition + = ArgumentsDefinition + { argumentsTypename :: Maybe Name + , arguments :: OrderedMap ArgumentDefinition } -defineType (key, datatype) lib = - lib { types = insert key datatype (types lib) } + | NoArguments + deriving (Show, Lift) +type ArgumentDefinition = FieldDefinition --- lookups and removes DataType from hashmap -popByKey :: Name -> [(Key, DataType)] -> (Maybe (Name,DataType), [(Key, DataType)]) -popByKey key lib = case lookup key lib of - Just dt@DataType { typeContent = DataObject {} } -> - (Just (key, dt), filter ((/= key) . fst) lib) - _ -> (Nothing, lib) +instance Selectable ArgumentsDefinition ArgumentDefinition where + selectOr fb _ _ NoArguments = fb + selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args -createDataTypeLib :: [(Key, DataType)] -> Validation Schema -createDataTypeLib types = case popByKey "Query" types of - (Nothing ,_ ) -> internalError "Query Not Defined" - (Just query, lib1) -> do - let (mutation, lib2) = popByKey "Mutation" lib1 - let (subscription, lib3) = popByKey "Subscription" lib2 - pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription} +instance Singleton ArgumentsDefinition ArgumentDefinition where + singleton = ArgumentsDefinition Nothing . singleton +instance Listable ArgumentsDefinition ArgumentDefinition where + toAssoc NoArguments = [] + toAssoc (ArgumentsDefinition _ args) = toAssoc args + fromAssoc [] = pure NoArguments + fromAssoc args = ArgumentsDefinition Nothing <$> fromAssoc args -createInputUnionFields :: Key -> [Key] -> [(Key, DataField)] +createArgument :: Key -> ([TypeWrapper], Key) -> FieldDefinition +createArgument = createField NoArguments + +hasArguments :: ArgumentsDefinition -> Bool +hasArguments NoArguments = False +hasArguments _ = True + + + +-- https://spec.graphql.org/June2018/#InputValueDefinition +-- InputValueDefinition +-- Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt) +-- TODO: implement inputValue + +-- data InputValueDefinition = InputValueDefinition +-- { inputValueName :: Key +-- , inputValueType :: TypeRef +-- , inputValueMeta :: Maybe Meta +-- } deriving (Show,Lift) + +__inputname :: Name +__inputname = "inputname" + +createInputUnionFields :: Key -> [Key] -> [FieldDefinition] createInputUnionFields name members = fieldTag : map unionField members where - fieldTag = - ( "__typename" - , DataField { fieldName = "__typename" - , fieldArgs = [] - , fieldArgsType = Nothing - , fieldType = createAlias (name <> "Tags") - , fieldMeta = Nothing - } - ) - unionField memberName = - ( memberName - , DataField - { fieldArgs = [] - , fieldArgsType = Nothing + fieldTag = FieldDefinition + { fieldName = __inputname + , fieldArgs = NoArguments + , fieldType = createAlias (name <> "Tags") + , fieldMeta = Nothing + } + unionField memberName = FieldDefinition + { fieldArgs = NoArguments , fieldName = memberName , fieldType = TypeRef { typeConName = memberName , typeWrappers = [TypeMaybe] @@ -576,27 +549,17 @@ } , fieldMeta = Nothing } - ) +-- +-- OTHER +-------------------------------------------------------------------------------------------------- createAlias :: Key -> TypeRef createAlias typeConName = TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing } - type TypeUpdater = LibUpdater Schema -insertType :: (Key, DataType) -> TypeUpdater -insertType nextType@(name, datatype) lib = case isTypeDefined name lib of - Nothing -> resolveUpdates (defineType nextType lib) [] - Just fingerprint | fingerprint == typeFingerprint datatype -> return lib - | - -- throw error if 2 different types has same name - otherwise -> failure $ nameCollisionError name - - -- TEMPLATE HASKELL DATA TYPES - --- CLIENT data ClientQuery = ClientQuery { queryText :: String , queryTypes :: [ClientType] @@ -613,7 +576,7 @@ { typeD :: TypeD , typeKindD :: DataTypeKind , typeArgD :: [TypeD] - , typeOriginal:: (Name,DataType) + , typeOriginal:: TypeDefinition } deriving (Show) data TypeD = TypeD @@ -625,5 +588,5 @@ data ConsD = ConsD { cName :: Name - , cFields :: [DataField] + , cFields :: [FieldDefinition] } deriving (Show) diff --git a/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs b/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.Internal.AST.MergeSet + ( MergeSet + , toOrderedMap + , concatTraverse + , join + ) +where + +import Data.Semigroup ((<>)) +import Data.List (find, (\\)) +import Data.Maybe (maybe) +import Language.Haskell.TH.Syntax ( Lift(..) ) + +-- MORPHEUS +import Data.Morpheus.Types.Internal.Operation ( Merge(..) + , Empty(..) + , Singleton(..) + , Selectable(..) + , Listable(..) + , Failure(..) + , KeyOf(..) + , toPair + ) +import Data.Morpheus.Types.Internal.AST.Base ( Named + , GQLErrors + , Ref + ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap(..) ) +import qualified Data.Morpheus.Types.Internal.AST.OrderedMap as OM + +-- set with mergeable components +newtype MergeSet a = MergeSet { + unpack :: [a] + } deriving ( Show, Eq, Functor, Foldable , Lift ) + +concatTraverse :: (KeyOf a, Eq a, Eq b, Merge a, Merge b, KeyOf b, Monad m, Failure GQLErrors m) => (a -> m (MergeSet b)) -> MergeSet a -> m (MergeSet b) +concatTraverse f smap = traverse f (toList smap) >>= join + +join :: (Eq a, KeyOf a , Merge a, Monad m, Failure GQLErrors m) => [MergeSet a] -> m (MergeSet a) +join = __join empty + where + __join :: (Eq a,KeyOf a, Merge a, Monad m, Failure GQLErrors m) => MergeSet a ->[MergeSet a] -> m (MergeSet a) + __join acc [] = pure acc + __join acc (x:xs) = acc <:> x >>= (`__join` xs) + +toOrderedMap :: KeyOf a => MergeSet a -> OrderedMap a +toOrderedMap = OM.unsafeFromValues . unpack + +instance Traversable MergeSet where + traverse f = fmap MergeSet . traverse f . unpack + +instance Empty (MergeSet a) where + empty = MergeSet [] + +instance (KeyOf a) => Singleton (MergeSet a) a where + singleton x = MergeSet [x] + +instance KeyOf a => Selectable (MergeSet a) a where + selectOr fb _ "" _ = fb + selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls) + +-- must merge files on collision +instance (KeyOf a, Merge a, Eq a) => Merge (MergeSet a) where + merge = safeJoin + +instance (KeyOf a, Merge a, Eq a) => Listable (MergeSet a) a where + fromAssoc = safeFromList + toAssoc = map toPair . unpack + +safeFromList :: (Monad m, KeyOf a, Eq a, Merge a ,Failure GQLErrors m) => [Named a] -> m (MergeSet a) +safeFromList = insertList [] empty . map snd + +safeJoin :: (Monad m, KeyOf a, Eq a, Merge a ,Failure GQLErrors m) => [Ref] -> MergeSet a -> MergeSet a -> m (MergeSet a) +safeJoin path hm1 hm2 = insertList path hm1 (toList hm2) + +insertList:: (Monad m, Eq a, KeyOf a, Merge a ,Failure GQLErrors m) => [Ref] -> MergeSet a -> [a] -> m (MergeSet a) +insertList _ smap [] = pure smap +insertList path smap (x:xs) = insert path smap x >>= flip (insertList path) xs + +insert :: (Monad m, Eq a, KeyOf a , Merge a ,Failure GQLErrors m) => [Ref] -> MergeSet a -> a -> m (MergeSet a) +insert path mSet@(MergeSet ls) currentValue = MergeSet <$> __insert + where + __insert = selectOr + (pure $ ls <> [currentValue]) + mergeWith + (keyOf currentValue) + mSet + ------------------ + mergeWith oldValue + | oldValue == currentValue = pure ls + | otherwise = do + mergedValue <- merge path oldValue currentValue + pure $ ( ls \\ [oldValue]) <> [mergedValue] + + + + diff --git a/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs b/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap(..) + , unsafeFromValues + , traverseWithKey + , foldWithKey + , update + ) +where + +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as HM +import Data.Semigroup ((<>)) +import Data.Maybe (isJust,fromMaybe) +import Language.Haskell.TH.Syntax ( Lift(..) ) + +-- MORPHEUS +import Data.Morpheus.Error.NameCollision (NameCollision(..)) +import Data.Morpheus.Types.Internal.Operation ( Merge(..) + , Empty(..) + , Singleton(..) + , Selectable(..) + , Listable(..) + , Failure(..) + , KeyOf(..) + , toPair + ) +import Data.Morpheus.Types.Internal.AST.Base ( Name + , Named + , GQLErrors + ) + + +-- OrderedMap +data OrderedMap a = OrderedMap { + mapKeys :: [Name], + mapEntries :: HashMap Name a + } deriving (Show, Eq, Functor) + +traverseWithKey :: Applicative t => (Name -> a -> t b) -> OrderedMap a -> t (OrderedMap b) +traverseWithKey f (OrderedMap names hmap) = OrderedMap names <$> HM.traverseWithKey f hmap + +foldWithKey :: NameCollision a => (Name -> a -> b -> b) -> b -> OrderedMap a -> b +foldWithKey f defValue om = foldr (uncurry f) defValue (toAssoc om) + +update :: KeyOf a => a -> OrderedMap a -> OrderedMap a +update x (OrderedMap names values) = OrderedMap newNames $ HM.insert name x values + where + name = keyOf x + newNames + | name `elem` names = names + | otherwise = names <> [name] + +instance Lift a => Lift (OrderedMap a) where + lift (OrderedMap names x) = [| OrderedMap names (HM.fromList ls) |] + where ls = HM.toList x + +instance Foldable OrderedMap where + foldMap f OrderedMap { mapEntries } = foldMap f mapEntries + +instance Traversable OrderedMap where + traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values + +instance Empty (OrderedMap a) where + empty = OrderedMap [] HM.empty + +instance (KeyOf a) => Singleton (OrderedMap a) a where + singleton x = OrderedMap [keyOf x] $ HM.singleton (keyOf x) x + +instance Selectable (OrderedMap a) a where + selectOr fb f key OrderedMap { mapEntries } = maybe fb f (HM.lookup key mapEntries) + +instance NameCollision a => Merge (OrderedMap a) where + merge _ (OrderedMap k1 x) (OrderedMap k2 y) = OrderedMap (k1 <> k2) <$> safeJoin x y + +instance NameCollision a => Listable (OrderedMap a) a where + fromAssoc = safeFromList + toAssoc OrderedMap { mapKeys, mapEntries } = map takeValue mapKeys + where + takeValue key = (key, fromMaybe (error "TODO:error") (key `HM.lookup` mapEntries )) + +safeFromList :: (Failure GQLErrors m, Applicative m, NameCollision a) => [Named a] -> m (OrderedMap a) +safeFromList values = OrderedMap (map fst values) <$> safeUnionWith HM.empty values + +unsafeFromValues :: KeyOf a => [a] -> OrderedMap a +unsafeFromValues x = OrderedMap (map keyOf x) $ HM.fromList $ map toPair x + +safeJoin :: (Failure GQLErrors m, Applicative m, NameCollision a) => HashMap Name a -> HashMap Name a -> m (HashMap Name a) +safeJoin hm newls = safeUnionWith hm (HM.toList newls) + +safeUnionWith :: (Failure GQLErrors m, Applicative m, NameCollision a) => HashMap Name a -> [Named a] -> m (HashMap Name a) +safeUnionWith hm names = case insertNoDups (hm,[]) names of + (res,dupps) | null dupps -> pure res + | otherwise -> failure $ map (uncurry nameCollision) dupps + +type NoDupHashMap a = (HashMap Name a,[Named a]) + +insertNoDups :: NoDupHashMap a -> [Named a] -> NoDupHashMap a +insertNoDups collected [] = collected +insertNoDups (coll,errors) (pair@(name,value):xs) + | isJust (name `HM.lookup` coll) = insertNoDups (coll,errors <> [pair]) xs + | otherwise = insertNoDups (HM.insert name value coll,errors) xs 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,179 +1,247 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveLift #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module Data.Morpheus.Types.Internal.AST.Selection - ( Argument(..) - , Arguments - , SelectionSet + ( Selection(..) , SelectionContent(..) - , ValidSelection - , Selection(..) - , RawSelection - , FragmentLib - , RawArguments - , RawSelectionSet + , SelectionSet + , UnionTag(..) + , UnionSelection , Fragment(..) - , RawArgument - , ValidSelectionSet - , ValidArgument - , ValidArguments - , RawSelectionRec - , ValidSelectionRec + , Fragments , Operation(..) , Variable(..) - , ValidOperation - , RawOperation , VariableDefinitions - , ValidVariables , DefaultValue , getOperationName , getOperationDataType - , getOperationObject ) where -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( fromMaybe , isJust ) import Data.Semigroup ( (<>) ) import Language.Haskell.TH.Syntax ( Lift(..) ) +import qualified Data.Text as T -- MORPHEUS -import Data.Morpheus.Error.Mutation ( mutationIsNotDefined ) -import Data.Morpheus.Error.Subscription - ( subscriptionIsNotDefined ) +import Data.Morpheus.Error.Operation ( mutationIsNotDefined + , subscriptionIsNotDefined + ) import Data.Morpheus.Types.Internal.AST.Base - ( Collection - , Key + ( Key , Position , Ref(..) , Name , VALID , RAW , Stage - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( Validation - , Failure(..) + , OperationType(..) + , GQLError(..) + , GQLErrors + , Message ) import Data.Morpheus.Types.Internal.AST.Data - ( OperationType(..) - , Schema(..) - , DataType(..) - , DataTypeContent(..) - , DataObject + ( Schema(..) + , TypeDefinition(..) + , Arguments ) import Data.Morpheus.Types.Internal.AST.Value - ( Value - , Variable(..) + ( Variable(..) + , VariableDefinitions , ResolvedValue ) - +import Data.Morpheus.Types.Internal.AST.MergeSet + ( MergeSet ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap ) +import Data.Morpheus.Types.Internal.Operation + ( KeyOf(..) + , Merge(..) + , Failure(..) + ) +import Data.Morpheus.Error.NameCollision + ( NameCollision(..) ) data Fragment = Fragment - { fragmentType :: Key + { fragmentName :: Name + , fragmentType :: Name , fragmentPosition :: Position - , fragmentSelection :: RawSelectionSet - } deriving (Show,Lift) + , fragmentSelection :: SelectionSet RAW + } deriving ( Show, Eq, Lift) -type FragmentLib = [(Key, Fragment)] +-- ERRORs +instance NameCollision Fragment where + nameCollision _ Fragment { fragmentName , fragmentPosition } = GQLError + { message = "There can be only one fragment named \"" <> fragmentName <> "\"." + , locations = [fragmentPosition] + } -data Argument (valid :: Stage) = Argument { - argumentValue :: Value valid - , argumentPosition :: Position - } deriving (Show,Lift) +instance KeyOf Fragment where + keyOf = fragmentName -type RawArgument = Argument RAW +type Fragments = OrderedMap Fragment -type ValidArgument = Argument VALID +data SelectionContent (s :: Stage) where + SelectionField :: SelectionContent s + SelectionSet :: SelectionSet s -> SelectionContent s + UnionSelection :: UnionSelection -> SelectionContent VALID -type Arguments a = Collection (Argument a) +instance Merge (SelectionContent s) where + merge path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge path s1 s2 + merge path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> merge path u1 u2 + merge path oldC currC + | oldC == currC = pure oldC + | otherwise = failure [ + GQLError { + message = T.concat $ map refName path, + locations = map refPosition path + } + ] -type RawArguments = Arguments RAW +deriving instance Show (SelectionContent a) +deriving instance Eq (SelectionContent a) +deriving instance Lift (SelectionContent a) -type ValidArguments = Collection ValidArgument +data UnionTag = UnionTag { + unionTagName :: Name, + unionTagSelection :: SelectionSet VALID +} deriving (Show, Eq, Lift) -data SelectionContent (valid :: Stage) where - SelectionField ::SelectionContent valid - SelectionSet ::SelectionSet valid -> SelectionContent valid - UnionSelection ::UnionSelection -> SelectionContent VALID -deriving instance Show (SelectionContent a) -deriving instance Lift (SelectionContent a) +mergeConflict :: [Ref] -> GQLError -> GQLErrors +mergeConflict [] err = [err] +mergeConflict refs@(rootField:xs) err = [ + GQLError { + message = renderSubfields <> message err, + locations = map refPosition refs <> locations err + } + ] + where + fieldConflicts ref = "\"" <> refName ref <> "\" conflict because " + renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref + renderStart = "Fields " <> fieldConflicts rootField + renderSubfields = + foldr + renderSubfield + renderStart + xs -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 +instance Merge UnionTag where + merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) + = UnionTag oldTag <$> merge path oldSel currentSel +instance KeyOf UnionTag where + keyOf = unionTagName -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 +type UnionSelection = MergeSet UnionTag -deriving instance Show (Selection a) -deriving instance Lift (Selection a) +type SelectionSet s = MergeSet (Selection s) -type RawSelection = Selection RAW -type ValidSelection = Selection VALID +data Selection (s :: Stage) where + Selection :: + { selectionName :: Name + , selectionAlias :: Maybe Name + , selectionPosition :: Position + , selectionArguments :: Arguments s + , selectionContent :: SelectionContent s + } -> Selection s + InlineFragment :: Fragment -> Selection RAW + Spread :: Ref -> Selection RAW -type DefaultValue = Maybe ResolvedValue +instance KeyOf (Selection s) where + keyOf Selection { selectionName , selectionAlias } = fromMaybe selectionName selectionAlias + keyOf InlineFragment {} = "" + keyOf Spread {} = "" -type VariableDefinitions = Collection (Variable RAW) +useDufferentAliases :: Message +useDufferentAliases + = "Use different aliases on the " + <> "fields to fetch both if this was intentional." -type ValidVariables = Collection (Variable VALID) +instance Merge (Selection a) where + merge path old@Selection{ selectionPosition = pos1 } current@Selection{ selectionPosition = pos2 } + = do + selectionName <- mergeName + let currentPath = path <> [Ref selectionName pos1] + selectionArguments <- mergeArguments currentPath + selectionContent <- merge currentPath (selectionContent old) (selectionContent current) + pure $ Selection { + selectionName, + selectionAlias = mergeAlias, + selectionPosition = pos1, + selectionArguments, + selectionContent + } + where + -- passes if: + -- * { user : user } + -- * { user1: user + -- user1: user + -- } + -- fails if: + -- * { user1: user + -- user1: product + -- } + mergeName + | selectionName old == selectionName current = pure $ selectionName current + | otherwise = failure $ mergeConflict path $ GQLError { + message = "\"" <> selectionName old <> "\" and \"" <> selectionName current + <> "\" are different fields. " <> useDufferentAliases, + locations = [pos1, pos2] + } + --------------------- + -- allias name is relevant only if they collide by allias like: + -- { user1: user + -- user1: user + -- } + mergeAlias + | all (isJust . selectionAlias) [old,current] = selectionAlias old + | otherwise = Nothing + --- arguments must be equal + mergeArguments currentPath + | selectionArguments old == selectionArguments current = pure $ selectionArguments current + | otherwise = failure $ mergeConflict currentPath $ GQLError + { message = "they have differing arguments. " <> useDufferentAliases + , locations = [pos1,pos2] + } + -- TODO: + merge path old current = failure $ mergeConflict path $ GQLError + { message = "can't merge. " <> useDufferentAliases + , locations = map selectionPosition [old,current] + } + +deriving instance Show (Selection a) +deriving instance Lift (Selection a) +deriving instance Eq (Selection a) -data Operation (stage:: Stage) = Operation +type DefaultValue = Maybe ResolvedValue + +data Operation (s:: Stage) = Operation { operationName :: Maybe Key , operationType :: OperationType - , operationArguments :: Collection (Variable stage) - , operationSelection :: SelectionSet stage + , operationArguments :: VariableDefinitions s + , operationSelection :: SelectionSet s , operationPosition :: Position } deriving (Show,Lift) -type RawOperation = Operation RAW - -type ValidOperation = Operation VALID - - getOperationName :: Maybe Key -> Key getOperationName = fromMaybe "AnonymousOperation" -getOperationObject - :: Operation a -> Schema -> Validation (Name, DataObject) -getOperationObject op lib = do - dt <- getOperationDataType op lib - case dt of - DataType { typeContent = DataObject { objectFields }, typeName } -> pure (typeName, objectFields) - DataType { typeName } -> - failure - $ "Type Mismatch: operation \"" - <> typeName - <> "\" must be an Object" - -getOperationDataType :: Operation a -> Schema -> Validation DataType -getOperationDataType Operation { operationType = Query } lib = - pure $ snd $ query lib +getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m TypeDefinition +getOperationDataType Operation { operationType = Query } lib = pure (query lib) getOperationDataType Operation { operationType = Mutation, operationPosition } lib = case mutation lib of - Just (_, mutation') -> pure mutation' - Nothing -> failure $ mutationIsNotDefined operationPosition + Just x -> pure x + Nothing -> failure $ mutationIsNotDefined operationPosition getOperationDataType Operation { operationType = Subscription, operationPosition } lib = case subscription lib of - Just (_, subscription') -> pure subscription' + Just x -> pure x 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 @@ -27,6 +27,8 @@ , ResolvedValue , ResolvedObject , VariableContent(..) + , ObjectEntry(..) + , VariableDefinitions ) where @@ -55,9 +57,10 @@ import Language.Haskell.TH.Syntax ( Lift(..) ) -- MORPHEUS +import Data.Morpheus.Error.NameCollision + ( NameCollision(..) ) import Data.Morpheus.Types.Internal.AST.Base - ( Collection - , Ref(..) + ( Ref(..) , Name , RAW , VALID @@ -65,8 +68,18 @@ , Stage , RESOLVED , TypeRef + , GQLError(..) + , TypeRef(..) ) - +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap + , unsafeFromValues + , foldWithKey + ) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + , KeyOf(..) + ) isReserved :: Name -> Bool isReserved "case" = True @@ -112,7 +125,7 @@ | Float Float | String Text | Boolean Bool - deriving (Show, Generic,Lift) + deriving (Show, Eq, Generic,Lift) instance A.ToJSON ScalarValue where toJSON (Float x) = A.toJSON x @@ -140,24 +153,56 @@ lift (ValidVariableValue x) = [| ValidVariableValue x |] deriving instance Show (VariableContent a) +deriving instance Eq (VariableContent a) data Variable (stage :: Stage) = Variable - { variableType :: TypeRef + { variableName :: Name + , variableType :: TypeRef , variablePosition :: Position , variableValue :: VariableContent (VAR stage) - } deriving (Show,Lift) + } deriving (Show, Eq, Lift) -data Value (valid :: Stage) where +instance KeyOf (Variable s) where + keyOf = variableName + +instance NameCollision (Variable s) where + nameCollision _ Variable { variableName , variablePosition } = GQLError { + message = "There can Be only One Variable Named \"" <> variableName <> "\"", + locations = [variablePosition] + } + +type VariableDefinitions s = OrderedMap (Variable s) + +data Value (stage :: 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 + Object ::Object stage -> Value stage + List ::[Value stage] -> Value stage + Enum ::Name -> Value stage + Scalar ::ScalarValue -> Value stage + Null ::Value stage +deriving instance Eq (Value s) -type Object a = Collection (Value a) +data ObjectEntry (s :: Stage) = ObjectEntry { + entryName :: Name, + entryValue :: Value s + -- ObjectEntryposition :: Position +} deriving (Eq) + +instance Show (ObjectEntry s) where + show (ObjectEntry name value) = unpack name <> ":" <> show value + +instance NameCollision (ObjectEntry s) where + nameCollision _ ObjectEntry { entryName } = GQLError { + message = "There can Be only One field Named \"" <> entryName <> "\"", + locations = [] + } + +instance KeyOf (ObjectEntry s) where + keyOf = entryName + +type Object a = OrderedMap (ObjectEntry a) type ValidObject = Object VALID type RawObject = Object RAW type ResolvedObject = Object RESOLVED @@ -166,7 +211,9 @@ type ResolvedValue = Value RESOLVED deriving instance Lift (Value a) +deriving instance Lift (ObjectEntry a) + instance Show (Value a) where show Null = "null" show (Enum x) = "" <> unpack x @@ -174,11 +221,11 @@ show (ResolvedVariable Ref { refName } Variable { variableValue }) = "($" <> unpack refName <> ": " <> show variableValue <> ") " show (VariableValue Ref { refName }) = "$" <> unpack refName <> " " - show (Object keys ) = "{" <> foldl toEntry "" keys <> "}" + show (Object keys ) = "{" <> foldWithKey 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 + toEntry :: Name -> ObjectEntry a -> String -> String + toEntry _ value "" = show value + toEntry _ value txt = txt <> ", " <> show value show (List list) = "[" <> foldl toEntry "" list <> "]" where toEntry :: String -> Value a -> String @@ -194,8 +241,8 @@ 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 + toJSON (Object fields) = A.object $ map toEntry (toList fields) + where toEntry (ObjectEntry key value) = key A..= A.toJSON value ------------------------------------------- toEncoding (ResolvedVariable _ Variable { variableValue = ValidVariableValue x }) = A.toEncoding x @@ -205,9 +252,10 @@ toEncoding (Enum 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 + toEncoding (Object ordmap) + | null ordmap = A.toEncoding $ A.object [] + | otherwise = A.pairs $ foldl1 (<>) $ map encodeField (toList ordmap) + where encodeField (ObjectEntry key value) = convertToJSONName key A..= value decodeScientific :: Scientific -> ScalarValue decodeScientific v = case floatingOrInteger v of @@ -244,4 +292,6 @@ gqlBoolean = Scalar . Boolean gqlString = Scalar . String gqlList = List - gqlObject = Object + gqlObject = Object . unsafeFromValues . map toEntry + where + toEntry (key,value) = ObjectEntry key value diff --git a/src/Data/Morpheus/Types/Internal/Apollo.hs b/src/Data/Morpheus/Types/Internal/Apollo.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Apollo.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Types.Internal.Apollo - ( SubAction(..) - , apolloFormat - , acceptApolloSubProtocol - , toApolloResponse - ) where - -import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, pairs, - withObject, (.:), (.:?), (.=)) -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Morpheus.Types (GQLRequest (..)) -import Data.Morpheus.Types.IO (GQLResponse) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Network.WebSockets (AcceptRequest (..), RequestHead, getRequestSubprotocols) - -type ApolloID = Text - -data ApolloSubscription payload = - ApolloSubscription - { apolloId :: Maybe ApolloID - , apolloType :: Text - , apolloPayload :: Maybe payload - } - deriving (Show, Generic) - -instance FromJSON a => FromJSON (ApolloSubscription a) where - parseJSON = withObject "ApolloSubscription" objectParser - where - objectParser o = - ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload" - -data RequestPayload = - RequestPayload - { payloadOperationName :: Maybe Text - , payloadQuery :: Maybe Text - , payloadVariables :: Maybe Value - } - deriving (Show, Generic) - -instance FromJSON RequestPayload where - parseJSON = withObject "ApolloPayload" objectParser - where - objectParser o = - RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*> - o .:? "variables" - -instance ToJSON a => ToJSON (ApolloSubscription a) where - toEncoding (ApolloSubscription id' type' payload') = - pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload' - -acceptApolloSubProtocol :: RequestHead -> AcceptRequest -acceptApolloSubProtocol reqHead = - apolloProtocol (getRequestSubprotocols reqHead) - where - apolloProtocol ["graphql-subscriptions"] = - AcceptRequest (Just "graphql-subscriptions") [] - apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") [] - apolloProtocol _ = AcceptRequest Nothing [] - -toApolloResponse :: ApolloID -> GQLResponse -> ByteString -toApolloResponse sid val = - encode $ ApolloSubscription (Just sid) "data" (Just val) - -data SubAction - = RemoveSub ApolloID - | AddSub ApolloID GQLRequest - | SubError String - -apolloFormat :: ByteString -> SubAction -apolloFormat = toWsAPI . eitherDecode - where - toWsAPI :: Either String (ApolloSubscription RequestPayload) -> SubAction - toWsAPI (Right ApolloSubscription { apolloType = "start" - , apolloId = Just sessionId - , apolloPayload = Just RequestPayload { payloadQuery = Just query - , payloadOperationName = operationName - , payloadVariables = variables - } - }) = - AddSub sessionId (GQLRequest {query, operationName, variables}) - toWsAPI (Right ApolloSubscription { apolloType = "stop" - , apolloId = Just sessionId - }) = RemoveSub sessionId - toWsAPI (Right x) = SubError (show x) - toWsAPI (Left x) = SubError x diff --git a/src/Data/Morpheus/Types/Internal/Operation.hs b/src/Data/Morpheus/Types/Internal/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Operation.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Data.Morpheus.Types.Internal.Operation + ( Empty(..) + , Selectable(..) + , Singleton(..) + , Listable(..) + , Merge(..) + , Failure(..) + , KeyOf(..) + , toPair + , selectBy + , member + , keys + ) + where + +import Data.List (find) +import Data.Text ( Text ) +import Instances.TH.Lift ( ) +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as HM +import Data.Morpheus.Types.Internal.AST.Base ( Name + , Named + , GQLErrors + , Ref(..) + ) +import Text.Megaparsec.Internal ( ParsecT(..) ) +import Text.Megaparsec.Stream ( Stream ) + +class Empty a where + empty :: a + +instance Empty (HashMap k v) where + empty = HM.empty + +class Selectable c a | c -> a where + selectOr :: d -> (a -> d) -> Name -> c -> d + +instance KeyOf a => Selectable [a] a where + selectOr fb f key lib = maybe fb f (find ((key ==) . keyOf) lib) + +instance Selectable (HashMap Text a) a where + selectOr fb f key lib = maybe fb f (HM.lookup key lib) + +selectBy :: (Failure e m, Selectable c a, Monad m) => e -> Name -> c -> m a +selectBy err = selectOr (failure err) pure + +member :: forall a c. Selectable c a => Name -> c -> Bool +member = selectOr False toTrue + where + toTrue :: a -> Bool + toTrue _ = True + +class KeyOf a => Singleton c a | c -> a where + singleton :: a -> c + +class KeyOf a where + keyOf :: a -> Name + +instance KeyOf Ref where + keyOf = refName + +toPair :: KeyOf a => a -> (Name,a) +toPair x = (keyOf x, x) + +class Listable c a | c -> a where + size :: c -> Int + size = length . toList + fromAssoc :: (Monad m, Failure GQLErrors m) => [Named a] -> m c + toAssoc :: c -> [Named a] + fromList :: (KeyOf a, Monad m, Failure GQLErrors m) => [a] -> m c + -- TODO: fromValues + toList = map snd . toAssoc + fromList = fromAssoc . map toPair + -- TODO: toValues + toList :: c -> [a] + +keys :: Listable c a => c -> [Name] +keys = map fst . toAssoc + +class Merge a where + (<:>) :: (Monad m, Failure GQLErrors m) => a -> a -> m a + (<:>) = merge [] + merge :: (Monad m, Failure GQLErrors m) => [Ref] -> a -> a -> m a + +class Applicative f => Failure error (f :: * -> *) where + failure :: error -> f v + +instance Failure error (Either error) where + failure = Left + +instance (Stream s, Ord e, Failure [a] m) => Failure [a] (ParsecT e s m) where + failure x = ParsecT $ \_ _ _ _ _ -> failure x 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 @@ -5,13 +5,11 @@ , Resolver , MapStrategy(..) , LiftOperation - , resolveObject - , runResolver - , unsafeBind + , runResolverModel , toResolver , lift , SubEvent - , Validation + , Eventless , Failure(..) , GQLChannel(..) , ResponseEvent(..) @@ -22,18 +20,18 @@ , unpackEvents , LibUpdater , resolveUpdates - , GQLErrors - , GQLError(..) - , Position - , resolve__typename - , DataResolver(..) + , setTypeName + , ObjectDeriving(..) + , Deriving(..) , FieldRes , WithOperation , PushEvents(..) - , runDataResolver , subscribe , Context(..) , unsafeInternalContext + , ResolverModel(..) + , unsafeBind + , liftStateless ) 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,8 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE NamedFieldPuns #-} @@ -12,10 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Resolving.Core - ( GQLError(..) - , Position(..) - , GQLErrors - , Validation + ( Eventless , Result(..) , Failure(..) , ResultT(..) @@ -24,11 +19,11 @@ , resolveUpdates , mapEvent , cleanEvents - , StatelessResT , Event(..) , Channel(..) , GQLChannel(..) , PushEvents(..) + , statelessToResultT ) where @@ -36,38 +31,21 @@ import Data.Function ( (&) ) import Control.Monad.Trans.Class ( MonadTrans(..) ) import Control.Applicative ( liftA2 ) -import Data.Aeson ( FromJSON - , ToJSON +import Data.Morpheus.Types.Internal.Operation + ( + Failure(..) ) import Data.Morpheus.Types.Internal.AST.Base - ( - Position(..) - , Message + ( GQLErrors + , GQLError(..) ) import Data.Text ( Text , pack - , unpack ) -import GHC.Generics ( Generic ) import Data.Semigroup ( (<>) ) -class Applicative f => Failure error (f :: * -> *) where - failure :: error -> f v - -instance Failure error (Either error) where - failure = Left - -data GQLError = GQLError - { message :: Text - , locations :: [Position] - } deriving (Show, Generic, FromJSON, ToJSON) - -type GQLErrors = [GQLError] - -type StatelessResT = ResultT () GQLError 'True -type Validation = Result () GQLError 'True - +type Eventless = Result () -- EVENTS class PushEvents e m where @@ -97,7 +75,7 @@ { channels :: [e], content :: c} -unpackEvents :: Result event c e a -> [event] +unpackEvents :: Result event a -> [event] unpackEvents Success { events } = events unpackEvents _ = [] @@ -105,44 +83,56 @@ -- Result -- -- -data Result events error (concurency :: Bool) a - = Success { result :: a , warnings :: [error] , events:: [events] } - | Failure [error] deriving (Functor) +data Result events a + = Success { result :: a , warnings :: GQLErrors , events:: [events] } + | Failure { errors :: GQLErrors } deriving (Functor) -instance Applicative (Result e cocnurency error) where +instance Applicative (Result e) where pure x = Success x [] [] Success f w1 e1 <*> Success x w2 e2 = Success (f x) (w1 <> w2) (e1 <> e2) Failure e1 <*> Failure e2 = Failure (e1 <> e2) Failure e <*> Success _ w _ = Failure (e <> w) Success _ w _ <*> Failure e = Failure (e <> w) -instance Monad (Result e cocnurency error) where +instance Monad (Result e) where return = pure Success v w1 e1 >>= fm = case fm v of (Success x w2 e2) -> Success x (w1 <> w2) (e1 <> e2) (Failure e ) -> Failure (e <> w1) Failure e >>= _ = Failure e -instance Failure [error] (Result ev error con) where +instance Failure [GQLError] (Result ev) where failure = Failure -instance Failure Text Validation where +instance Failure Text Eventless where failure text = - Failure [GQLError { message = "INTERNAL ERROR: " <> text, locations = [] }] + Failure [GQLError { message = "INTERNAL: " <> text, locations = [] }] -instance PushEvents events (Result events err con) where +instance PushEvents events (Result events) where pushEvents events = Success { result = (), warnings = [], events } - -- ResultT -newtype ResultT event error (concurency :: Bool) (m :: * -> * ) a = ResultT { runResultT :: m (Result event error concurency a ) } - deriving (Functor) +newtype ResultT event (m :: * -> * ) a + = ResultT + { + runResultT :: m (Result event a) + } + deriving (Functor) -instance Applicative m => Applicative (ResultT event error concurency m) where +statelessToResultT + :: Applicative m + => Eventless a + -> ResultT e m a +statelessToResultT + = cleanEvents + . ResultT + . pure + +instance Applicative m => Applicative (ResultT event m) where pure = ResultT . pure . pure ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2 -instance Monad m => Monad (ResultT event error concurency m) where +instance Monad m => Monad (ResultT event m) where return = pure (ResultT m1) >>= mFunc = ResultT $ do result1 <- m1 @@ -154,27 +144,23 @@ Failure errors -> pure $ Failure (errors <> w1) Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2) -instance MonadTrans (ResultT event error concurency) where +instance MonadTrans (ResultT event) where lift = ResultT . fmap pure -instance Monad m => Failure Message (ResultT event String concurency m) where - failure message = ResultT $ pure $ Failure [unpack message] - -instance Applicative m => Failure String (ResultT ev GQLError con m) where +instance Applicative m => Failure String (ResultT event m) where failure x = ResultT $ pure $ Failure [GQLError { message = pack x, locations = [] }] -instance Monad m => Failure GQLErrors (ResultT event GQLError concurency m) where +instance Monad m => Failure GQLErrors (ResultT event m) where failure = ResultT . pure . failure -instance Applicative m => PushEvents events (ResultT events err con m) where +instance Applicative m => PushEvents event (ResultT event m) where pushEvents = ResultT . pure . pushEvents - cleanEvents :: Functor m - => ResultT e1 error concurency m a - -> ResultT e2 error concurency m a + => ResultT e m a + -> ResultT e' m a cleanEvents resT = ResultT $ replace <$> runResultT resT where replace (Success v w _) = Success v w [] @@ -182,9 +168,9 @@ mapEvent :: Monad m - => (ea -> eb) - -> ResultT ea er con m value - -> ResultT eb er con m value + => (e -> e') + -> ResultT e m value + -> ResultT e' m value mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma where mapEv Success { result, warnings, events } = @@ -192,7 +178,7 @@ mapEv (Failure err) = Failure err -- Helper Functions -type LibUpdater lib = lib -> Validation lib +type LibUpdater lib = lib -> Eventless lib -resolveUpdates :: lib -> [LibUpdater lib] -> Validation lib +resolveUpdates :: lib -> [LibUpdater lib] -> Eventless lib resolveUpdates = foldM (&) 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 @@ -8,7 +8,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -24,30 +23,31 @@ , Resolver , MapStrategy(..) , LiftOperation - , resolveObject - , runDataResolver - , runResolver , unsafeBind , toResolver , lift + , subscribe , SubEvent , GQLChannel(..) , ResponseEvent(..) , ResponseStream - , resolve__typename - , DataResolver(..) + , ObjectDeriving(..) + , Deriving(..) , FieldRes , WithOperation - , subscribe , Context(..) , unsafeInternalContext + , runResolverModel + , setTypeName + , ResolverModel(..) + , liftStateless ) where import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Trans.Class ( MonadTrans(..)) import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( maybe ) import Data.Semigroup ( (<>) , Semigroup(..) ) @@ -60,29 +60,37 @@ import Data.Morpheus.Types.Internal.AST.Selection ( Selection(..) , SelectionContent(..) - , ValidSelection - , ValidSelectionRec - , ValidSelectionSet - , ValidSelection - , ValidArguments - , ValidOperation + , SelectionSet + , UnionTag(..) + , UnionSelection + , Operation(..) ) import Data.Morpheus.Types.Internal.AST.Base ( Message - , Key , Name - ) -import Data.Morpheus.Types.Internal.AST.Data - ( MUTATION , OperationType , QUERY + , MUTATION , SUBSCRIPTION - , Schema + , GQLErrors + , GQLError(..) + , VALID + , OperationType(..) ) +import Data.Morpheus.Types.Internal.AST.Data + ( Schema + , Arguments + ) +import Data.Morpheus.Types.Internal.AST.MergeSet + (toOrderedMap) +import Data.Morpheus.Types.Internal.Operation + ( selectOr + , empty + , keyOf + , Merge(..) + ) import Data.Morpheus.Types.Internal.Resolving.Core - ( GQLErrors - , GQLError(..) - , Validation + ( Eventless , Result(..) , Failure(..) , ResultT(..) @@ -93,10 +101,14 @@ , StreamChannel , GQLChannel(..) , PushEvents(..) + , statelessToResultT ) import Data.Morpheus.Types.Internal.AST.Value ( GQLValue(..) , ValidValue + , ObjectEntry(..) + , Value(..) + , ScalarValue(..) ) import Data.Morpheus.Types.IO ( renderResponse , GQLResponse @@ -104,24 +116,33 @@ type WithOperation (o :: OperationType) = LiftOperation o -type ResponseStream event m = ResultT (ResponseEvent m event) GQLError 'True m +type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m -data ResponseEvent m event +data ResponseEvent event (m :: * -> *) = Publish event - | Subscribe (SubEvent m event) + | Subscribe (SubEvent event m) -type SubEvent m event = Event (Channel event) (event -> m GQLResponse) +type SubEvent event m = Event (Channel event) (event -> m GQLResponse) -data Context = Context { - currentSelection :: (Name,ValidSelection), - schema :: Schema, - operation :: ValidOperation -} deriving (Show) +data Context + = Context + { currentSelection :: Selection VALID + , schema :: Schema + , operation :: Operation VALID + , currentTypeName :: Name + } deriving (Show) -- Resolver Internal State -newtype ResolverState event m a = ResolverState { - runResolverState :: ReaderT Context (ResultT event GQLError 'True m) a -} deriving (Functor, Applicative, Monad) +newtype ResolverState event m a + = ResolverState + { + runResolverState :: ReaderT Context (ResultT event m) a + } + deriving + ( Functor + , Applicative + , Monad + ) instance Monad m => MonadFail (ResolverState event m) where fail = failure . pack @@ -140,29 +161,27 @@ instance (Monad m) => PushEvents e (ResolverState e m) where pushEvents = ResolverState . lift . pushEvents - mapResolverState :: - ( ReaderT Context (ResultT e1 GQLError 'True m1) a1 - -> ReaderT Context (ResultT e2 GQLError 'True m2) a2 - ) -> ResolverState e1 m1 a1 - -> ResolverState e2 m2 a2 + ( ReaderT Context (ResultT e m) a + -> ReaderT Context (ResultT e' m') a' + ) -> ResolverState e m a + -> ResolverState e' m' a' mapResolverState f (ResolverState x) = ResolverState (f x) - -getState :: (Monad m) => ResolverState e m (Name,ValidSelection) +getState :: (Monad m) => ResolverState e m (Selection VALID) getState = ResolverState $ currentSelection <$> ask -setState :: (Name,ValidSelection) -> ResolverState e m a -> ResolverState e m a -setState currentSelection = mapResolverState (withReaderT (\ctx -> ctx { currentSelection } )) +mapState :: (Context -> Context ) -> ResolverState e m a -> ResolverState e m a +mapState f = mapResolverState (withReaderT f) -- clear evets and starts new resolver with diferenct type of events but with same value -- use properly. only if you know what you are doing -clearStateResolverEvents :: (Functor m) => ResolverState e1 m a -> ResolverState e2 m a +clearStateResolverEvents :: (Functor m) => ResolverState e m a -> ResolverState e' m a clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents) -resolverFailureMessage :: (Name,ValidSelection) -> Message -> GQLError -resolverFailureMessage (name, Selection { selectionPosition }) message = GQLError - { message = "Failure on Resolving Field \"" <> name <> "\": " <> message +resolverFailureMessage :: Selection VALID -> Message -> GQLError +resolverFailureMessage Selection { selectionName, selectionPosition } message = GQLError + { message = "Failure on Resolving Field \"" <> selectionName <> "\": " <> message , locations = [selectionPosition] } @@ -175,6 +194,11 @@ ResolverM :: { runResolverM :: ResolverState event m value } -> Resolver MUTATION event m value ResolverS :: { runResolverS :: ResolverState (Channel event) m (ReaderT event (Resolver QUERY event m) value) } -> Resolver SUBSCRIPTION event m value +instance Show (Resolver o e m value) where + show ResolverQ {} = "Resolver QUERY e m a" + show ResolverM {} = "Resolver MUTATION e m a" + show ResolverS {} = "Resolver SUBSCRIPTION e m a" + deriving instance (Functor m) => Functor (Resolver o e m) -- Applicative @@ -185,11 +209,7 @@ ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2 -- Monad -instance (Monad m) => Monad (Resolver QUERY e m) where - return = pure - (>>=) = unsafeBind - -instance (Monad m) => Monad (Resolver MUTATION e m) where +instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where return = pure (>>=) = unsafeBind @@ -209,15 +229,29 @@ -- Failure instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where - failure = packResolver .failure + failure = packResolver .failure instance (LiftOperation o, Monad m) => Failure GQLErrors (Resolver o e m) where failure = packResolver . failure -- PushEvents instance (Monad m) => PushEvents e (Resolver MUTATION e m) where - pushEvents = packResolver . pushEvents + pushEvents = packResolver . pushEvents +liftStateless + :: ( LiftOperation o + , Monad m + ) + => Eventless a + -> Resolver o e m a +liftStateless + = packResolver + . ResolverState + . ReaderT + . const + . statelessToResultT + + class LiftOperation (o::OperationType) where packResolver :: Monad m => ResolverState e m a -> Resolver o e m a withResolver :: Monad m => ResolverState e m a -> (a -> Resolver o e m b) -> Resolver o e m b @@ -239,13 +273,22 @@ value <- clearStateResolverEvents ctxRes runResolverS $ toRes value -setSelection :: Monad m => (Name, ValidSelection) -> Resolver o e m a -> Resolver o e m a -setSelection sel (ResolverQ res) = ResolverQ (setState sel res) -setSelection sel (ResolverM res) = ResolverM (setState sel res) -setSelection sel (ResolverS resM) = ResolverS $ do + +mapResolverContext :: Monad m => (Context -> Context) -> Resolver o e m a -> Resolver o e m a +mapResolverContext f (ResolverQ res) = ResolverQ (mapState f res) +mapResolverContext f (ResolverM res) = ResolverM (mapState f res) +mapResolverContext f (ResolverS resM) = ResolverS $ do res <- resM - pure $ ReaderT $ \e -> ResolverQ $ setState sel (runResolverQ (runReaderT res e)) + pure $ ReaderT $ \e -> ResolverQ $ mapState f (runResolverQ (runReaderT res e)) +setSelection :: Monad m => Selection VALID -> Resolver o e m a -> Resolver o e m a +setSelection currentSelection + = mapResolverContext (\ctx -> ctx { currentSelection }) + +setTypeName :: Monad m => Name -> Resolver o e m a -> Resolver o e m a +setTypeName currentTypeName + = mapResolverContext (\ctx -> ctx { currentTypeName } ) + -- unsafe variant of >>= , not for public api. user can be confused: -- ignores `channels` on second Subsciption, only returns events from first Subscription monad. -- reason: second monad is waiting for `event` until he does not have some event can't tell which @@ -261,12 +304,19 @@ unsafeBind (ResolverS res) m2 = ResolverS $ do (readResA :: ReaderT e (Resolver QUERY e m) a ) <- res pure $ ReaderT $ \e -> ResolverQ $ do - let (resA :: Resolver QUERY e m a) = (runReaderT $ readResA) e + let (resA :: Resolver QUERY e m a) = runReaderT readResA e (valA :: a) <- runResolverQ resA (readResB :: ReaderT e (Resolver QUERY e m) b) <- clearStateResolverEvents $ runResolverS (m2 valA) runResolverQ $ runReaderT readResB e -subscribe :: forall e m a . (PushEvents (Channel e) (ResolverState (Channel e) m), Monad m) => [StreamChannel e] -> Resolver QUERY e m (e -> Resolver QUERY e m a) -> Resolver SUBSCRIPTION e m a +subscribe + :: forall e m a + . ( PushEvents (Channel e) (ResolverState (Channel e) m) + , Monad m + ) + => [StreamChannel e] + -> Resolver QUERY e m (e -> Resolver QUERY e m a) + -> Resolver SUBSCRIPTION e m a subscribe ch res = ResolverS $ do pushEvents (map Channel ch :: [Channel e]) (eventRes :: e -> Resolver QUERY e m a) <- clearStateResolverEvents (runResolverQ res) @@ -280,136 +330,179 @@ type instance UnSubResolver (Resolver SUBSCRIPTION e m) = Resolver QUERY e m -- map Resolving strategies -class MapStrategy (from :: OperationType) (to :: OperationType) where - mapStrategy :: Monad m => Resolver from e m a -> Resolver to e m a +class MapStrategy + (from :: OperationType) + (to :: OperationType) where + mapStrategy + :: Monad m + => Resolver from e m (Deriving from e m) + -> Resolver to e m (Deriving to e m) instance MapStrategy o o where mapStrategy = id +data Deriving (o :: OperationType) e (m :: * -> * ) + = DerivingNull + | DerivingScalar ScalarValue + | DerivingEnum Name Name + | DerivingList [Deriving o e m] + | DerivingObject (ObjectDeriving o e m) + | DerivingUnion Name (Resolver o e m (Deriving o e m)) + deriving (Show) + + +data ObjectDeriving o e m + = ObjectDeriving { + __typename :: Name, + objectFields :: [ + ( Name + , Resolver o e m (Deriving o e m) + ) + ] + } deriving (Show) + instance MapStrategy QUERY SUBSCRIPTION where - mapStrategy = ResolverS . pure . lift + mapStrategy = ResolverS . pure . lift . fmap mapDeriving + +mapDeriving + :: ( MapStrategy o o' + , Monad m + ) + => Deriving o e m + -> Deriving o' e m +mapDeriving DerivingNull = DerivingNull +mapDeriving (DerivingScalar x) = DerivingScalar x +mapDeriving (DerivingEnum typeName enum) = DerivingEnum typeName enum +mapDeriving (DerivingList x) = DerivingList $ map mapDeriving x +mapDeriving (DerivingObject x) = DerivingObject (mapObjectDeriving x) +mapDeriving (DerivingUnion name x) = DerivingUnion name (mapStrategy x) +mapObjectDeriving + :: ( MapStrategy o o' + , Monad m + ) + => ObjectDeriving o e m + -> ObjectDeriving o' e m +mapObjectDeriving (ObjectDeriving tyname x) + = ObjectDeriving tyname + $ map (mapEntry mapStrategy) x + +mapEntry :: (a -> b) -> (Name, a) -> (Name, b) +mapEntry f (name,value) = (name, f value) + -- -- Selection Processing --- -type FieldRes o e m - = (Key, Resolver o e m ValidValue) - toResolver :: forall o e m a b. (LiftOperation o, Monad m) - => (ValidArguments -> Validation a) - -> (a -> Resolver o e m b) + => (Arguments VALID -> Eventless a) + -> ( a -> Resolver o e m b) -> Resolver o e m b toResolver toArgs = withResolver args where args :: ResolverState e m a args = do - (_,Selection { selectionArguments }) <- getState + Selection { selectionArguments } <- getState let resT = ResultT $ pure $ toArgs selectionArguments ResolverState $ lift $ cleanEvents resT -- 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 +type FieldRes o e m + = (Name, Resolver o e m (Deriving o e m)) -instance Semigroup (DataResolver o e m) where - ObjectRes x <> ObjectRes y = ObjectRes (x <> y) - _ <> _ = InvalidRes "can't merge: incompatible resolvers" +instance Merge (Deriving o e m) where + merge p (DerivingObject x) (DerivingObject y) + = DerivingObject <$> merge p x y + merge _ _ _ + = failure $ internalResolvingError "can't merge: incompatible resolvers" -pickSelection :: Name -> [(Name, ValidSelectionSet)] -> ValidSelectionSet -pickSelection name = fromMaybe [] . lookup name +instance Merge (ObjectDeriving o e m) where + merge _ (ObjectDeriving tyname x) (ObjectDeriving _ y) + = pure $ ObjectDeriving tyname (x <> y) -resolve__typename - :: (Monad m, LiftOperation o) - => Name - -> (Key, Resolver o e m ValidValue) -resolve__typename name = ("__typename", pure $ gqlString name) -resolveEnum - :: (Monad m, LiftOperation o) - => Name - -> Name - -> ValidSelectionRec - -> Resolver 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", pure $ gqlString enum) - , resolve__typename enumObjectTypeName - ] -resolveEnum _ _ _ = - failure $ internalResolvingError "wrong selection on enum value" +pickSelection :: Name -> UnionSelection -> SelectionSet VALID +pickSelection = selectOr empty unionTagSelection withObject :: (LiftOperation o, Monad m) - => (ValidSelectionSet -> Resolver o e m value) - -> (Key, ValidSelection) + => (SelectionSet VALID -> Resolver o e m value) + -> Selection VALID -> Resolver o e m value -withObject f (key, Selection { selectionContent , selectionPosition }) = checkContent selectionContent +withObject f Selection { selectionName, selectionContent , selectionPosition } = checkContent selectionContent where checkContent (SelectionSet selection) = f selection - checkContent _ = failure (subfieldsNotSelected key "" selectionPosition) - -lookupRes :: (LiftOperation o, Monad m) => Name -> [(Name,Resolver o e m ValidValue)] -> Resolver o e m ValidValue -lookupRes key = fromMaybe (pure gqlNull) . lookup key + checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition) -outputSelectionName :: (Name,ValidSelection) -> Name -outputSelectionName (name,Selection { selectionAlias }) = fromMaybe name selectionAlias +lookupRes + :: (LiftOperation o, Monad m) + => Selection VALID + -> ObjectDeriving o e m + -> Resolver o e m ValidValue +lookupRes + Selection { selectionName } + | selectionName == "__typename" + = pure . Scalar . String . __typename + | otherwise + = maybe + (pure gqlNull) + (`unsafeBind` runDataResolver) + . lookup selectionName + . objectFields resolveObject :: forall o e m. (LiftOperation o , Monad m) - => ValidSelectionSet - -> DataResolver o e m + => SelectionSet VALID + -> Deriving o e m -> Resolver o e m ValidValue -resolveObject selectionSet (ObjectRes resolvers) = - gqlObject <$> traverse resolver selectionSet +resolveObject selectionSet (DerivingObject drv@ObjectDeriving { __typename }) = + Object . toOrderedMap <$> traverse resolver selectionSet where - resolver :: (Name,ValidSelection) -> Resolver o e m (Name,ValidValue) - resolver sel@(name,_) = setSelection sel $ (outputSelectionName sel, ) <$> lookupRes name resolvers + resolver :: Selection VALID -> Resolver o e m (ObjectEntry VALID) + resolver sel + = setSelection sel + $ setTypeName __typename + $ ObjectEntry (keyOf sel) <$> lookupRes sel drv resolveObject _ _ = failure $ internalResolvingError "expected object as resolver" -toEventResolver :: Monad m => (ReaderT event (Resolver QUERY event m) ValidValue) -> Context -> event -> m GQLResponse +toEventResolver :: Monad m => ReaderT event (Resolver QUERY event m) ValidValue -> Context -> event -> m GQLResponse toEventResolver (ReaderT subRes) sel event = do value <- runResultT $ runReaderT (runResolverState $ runResolverQ (subRes event)) sel pure $ renderResponse value -runDataResolver :: (Monad m, LiftOperation o) => Name -> DataResolver o e m -> Resolver o e m ValidValue -runDataResolver typename = withResolver getState . __encode + +runDataResolver :: (Monad m, LiftOperation o) => Deriving o e m -> Resolver o e m ValidValue +runDataResolver = withResolver getState . __encode where - __encode obj (key, sel@Selection { selectionContent }) = encodeNode obj selectionContent + __encode obj sel@Selection { selectionContent } = encodeNode obj selectionContent where + -- LIST + encodeNode (DerivingList x) _ = List <$> traverse runDataResolver x -- Object ----------------- - encodeNode (ObjectRes fields) _ = withObject encodeObject (key, sel) - where - encodeObject selection = - resolveObject selection - $ ObjectRes - $ resolve__typename typename - : fields - encodeNode (EnumRes enum) _ = - resolveEnum typename enum selectionContent - -- Type Reference -------- - encodeNode (UnionRef (fieldTypeName, fieldResolver)) (UnionSelection selections) - = setSelection (key, sel { selectionContent = SelectionSet currentSelection }) fieldResolver - where currentSelection = pickSelection fieldTypeName selections - -- Union Record ---------------- - encodeNode (UnionRes (name, fields)) (UnionSelection selections) = - resolveObject selection resolver - where - selection = pickSelection name selections - resolver = ObjectRes (resolve__typename name : fields) - encodeNode _ _ = failure $ internalResolvingError - "union Resolver should only recieve UnionSelection" + encodeNode objDrv@DerivingObject{} _ = withObject (`resolveObject` objDrv) sel + -- ENUM + encodeNode (DerivingEnum _ enum) SelectionField = pure $ gqlString enum + encodeNode (DerivingEnum typename enum) unionSel@UnionSelection{} + = encodeNode (unionDrv (typename <> "EnumObject")) unionSel + where + unionDrv name + = DerivingUnion name + $ pure + $ DerivingObject + $ ObjectDeriving name [("enum", pure $ DerivingScalar $ String enum)] + encodeNode DerivingEnum {} _ = + failure ( "wrong selection on enum value" :: Message) + -- UNION + encodeNode (DerivingUnion typename unionRef) (UnionSelection selections) + = unionRef >>= resolveObject currentSelection + where currentSelection = pickSelection typename selections + encodeNode (DerivingUnion name _) _ + = failure ("union Resolver \""<> name <> "\" should only recieve UnionSelection" :: Message) + -- SCALARS + encodeNode DerivingNull _ = pure Null + encodeNode (DerivingScalar x) SelectionField = pure $ Scalar x + encodeNode DerivingScalar {} _ + = failure ("scalar Resolver should only recieve SelectionField" :: Message) runResolver :: Monad m @@ -417,9 +510,9 @@ -> Context -> ResponseStream event m ValidValue runResolver (ResolverQ resT) sel = cleanEvents $ (runReaderT $ runResolverState resT) sel -runResolver (ResolverM resT) sel = mapEvent Publish $ (runReaderT $ runResolverState $ resT) sel +runResolver (ResolverM resT) sel = mapEvent Publish $ (runReaderT $ runResolverState resT) sel runResolver (ResolverS resT) sel = ResultT $ do - (readResValue :: Result (Channel event1) GQLError 'True (ReaderT event (Resolver QUERY event m) ValidValue)) <- runResultT $ (runReaderT $ runResolverState $ resT) sel + (readResValue :: Result (Channel event1) (ReaderT event (Resolver QUERY event m) ValidValue)) <- runResultT $ (runReaderT $ runResolverState resT) sel pure $ case readResValue of Failure x -> Failure x Success { warnings ,result , events = channels } -> do @@ -430,6 +523,18 @@ result = gqlNull } +runRootDataResolver + :: (Monad m , LiftOperation o) + => Eventless (Deriving o e m) + -> Context + -> ResponseStream e m (Value VALID) +runRootDataResolver + res + ctx@Context { operation = Operation { operationSelection } } + = do + root <- statelessToResultT res + runResolver (resolveObject operationSelection root) ctx + ------------------------------------------------------------------- -- | GraphQL Root resolver, also the interpreter generates a GQL schema from it. -- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional, @@ -439,3 +544,28 @@ , mutationResolver :: mut (Resolver MUTATION event m) , subscriptionResolver :: sub (Resolver SUBSCRIPTION event m) } + +data ResolverModel e m + = ResolverModel + { query :: Eventless (Deriving QUERY e m) + , mutation :: Eventless (Deriving MUTATION e m) + , subscription :: Eventless (Deriving SUBSCRIPTION e m) + } + +runResolverModel :: Monad m => ResolverModel e m -> Context -> ResponseStream e m (Value VALID) +runResolverModel + ResolverModel + { query + , mutation + , subscription + } + ctx@Context { operation = Operation { operationType} } + = selectByOperation operationType + where + selectByOperation Query + = runRootDataResolver query ctx + selectByOperation Mutation + = runRootDataResolver mutation ctx + selectByOperation Subscription + = runRootDataResolver subscription ctx + diff --git a/src/Data/Morpheus/Types/Internal/Subscription.hs b/src/Data/Morpheus/Types/Internal/Subscription.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Subscription.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Types.Internal.Subscription + ( connectionThread + , toOutStream + , runStreamWS + , runStreamHTTP + , Stream + , Scope(..) + , Input(..) + , WS + , HTTP + , acceptApolloRequest + , publish + , Store(..) + , initDefaultStore + , publishEventWith + ) +where + + +import Control.Exception ( finally ) +import Control.Monad ( forever ) +import Control.Concurrent ( readMVar + , newMVar + , modifyMVar_ + ) +import Data.UUID.V4 ( nextRandom ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.IO.Unlift ( MonadUnliftIO + , withRunInIO + ) + +-- MORPHEUS +import Data.Morpheus.Types.Internal.Operation + (empty) +import Data.Morpheus.Types.Internal.Resolving + ( GQLChannel(..) ) +import Data.Morpheus.Types.Internal.Subscription.Apollo + ( acceptApolloRequest ) +import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore + ( delete + , publish + , ClientConnectionStore + ) +import Data.Morpheus.Types.Internal.Subscription.Stream + ( toOutStream + , runStreamWS + , runStreamHTTP + , Stream + , Scope(..) + , Input(..) + , WS + , HTTP + ) + +connect :: MonadIO m => m (Input WS) +connect = Init <$> liftIO nextRandom + +disconnect:: Scope WS e m -> Input WS -> m () +disconnect ScopeWS { update } (Init clientID) = update (delete clientID) + +-- | PubSubStore interface +-- shared GraphQL state between __websocket__ and __http__ server, +-- you can define your own store if you provide write and read methods +-- to work properly Morpheus needs all entries of ClientConnectionStore (+ client Callbacks) +-- that why it is recomended that you use many local ClientStores on evenry server node +-- rathen then single centralized Store. +-- +data Store e m = Store + { readStore :: m (ClientConnectionStore e m) + , writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m () + } + +publishEventWith :: + ( MonadIO m + , (Eq (StreamChannel event)) + , (GQLChannel event) + ) => Store event m -> event -> m () +publishEventWith store event = readStore store >>= publish event + +-- | initializes empty GraphQL state +initDefaultStore :: + ( MonadIO m + , (Eq (StreamChannel event)) + , (GQLChannel event) + ) + => IO (Store event m) +initDefaultStore = do + store <- newMVar empty + pure Store + { readStore = liftIO $ readMVar store + , writeStore = \changes -> liftIO $ modifyMVar_ store (return . changes) + } + + +finallyM :: MonadUnliftIO m => m () -> m () -> m () +finallyM loop end = withRunInIO $ \runIO -> finally (runIO loop) (runIO end) + + +connectionThread + :: ( MonadUnliftIO m + ) + => (Input WS -> Stream WS e m) + -> Scope WS e m + -> m () +connectionThread api scope = do + input <- connect + finallyM + (connectionLoop api scope input) + (disconnect scope input) + +connectionLoop + :: Monad m + => (Input WS -> Stream WS e m) + -> Scope WS e m + -> Input WS + -> m () +connectionLoop api scope input + = forever + $ runStreamWS scope + $ api input + diff --git a/src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs b/src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.Internal.Subscription.Apollo + ( ApolloAction(..) + , apolloFormat + , acceptApolloRequest + , toApolloResponse + , Validation + ) where + +import Data.Maybe ( maybe ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Aeson ( FromJSON (..) + , ToJSON (..) + , Value (..) + , eitherDecode + , encode + , pairs + , withObject + , (.:) + , (.:?) + , (.=) + ) +import Data.ByteString.Lazy.Char8 ( ByteString + , pack + ) +import Data.Semigroup ( (<>) ) +import Data.Text ( Text + , unpack + ) +import GHC.Generics ( Generic ) +import Network.WebSockets ( AcceptRequest (..) + , RequestHead + , getRequestSubprotocols + , PendingConnection + , Connection + , acceptRequestWith + , pendingRequest + ) + +-- MORPHEUS +import Data.Morpheus.Types.IO ( GQLResponse + , GQLRequest (..) + ) + +type ID = Text + +data ApolloSubscription payload = + ApolloSubscription + { apolloId :: Maybe ID + , apolloType :: Text + , apolloPayload :: Maybe payload + } + deriving (Show, Generic) + +instance FromJSON a => FromJSON (ApolloSubscription a) where + parseJSON = withObject "ApolloSubscription" objectParser + where + objectParser o = + ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload" + +data RequestPayload = + RequestPayload + { payloadOperationName :: Maybe Text + , payloadQuery :: Maybe Text + , payloadVariables :: Maybe Value + } + deriving (Show, Generic) + +instance FromJSON RequestPayload where + parseJSON = withObject "ApolloPayload" objectParser + where + objectParser o = + RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*> + o .:? "variables" + +instance ToJSON a => ToJSON (ApolloSubscription a) where + toEncoding (ApolloSubscription id' type' payload') = + pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload' + +acceptApolloRequest + :: MonadIO m + => PendingConnection + -> m Connection +acceptApolloRequest pending + = liftIO + $ acceptRequestWith + pending + (acceptApolloSubProtocol (pendingRequest pending)) + +acceptApolloSubProtocol :: RequestHead -> AcceptRequest +acceptApolloSubProtocol reqHead = + apolloProtocol (getRequestSubprotocols reqHead) + where + apolloProtocol ["graphql-subscriptions"] = + AcceptRequest (Just "graphql-subscriptions") [] + apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") [] + apolloProtocol _ = AcceptRequest Nothing [] + +toApolloResponse :: ID -> GQLResponse -> ByteString +toApolloResponse sid val = + encode $ ApolloSubscription (Just sid) "data" (Just val) + +data ApolloAction + = SessionStop ID + | SessionStart ID GQLRequest + | ConnectionInit + +type Validation = Either ByteString + +apolloFormat :: ByteString -> Validation ApolloAction +apolloFormat = validateReq . eitherDecode + where + validateReq :: Either String (ApolloSubscription RequestPayload) -> Validation ApolloAction + validateReq = either (Left . pack) validateSub + ------------------------------------- + validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction + validateSub ApolloSubscription { apolloType = "connection_init" } + = pure ConnectionInit + validateSub ApolloSubscription { apolloType = "start", apolloId , apolloPayload } + = do + sessionId <- validateSession apolloId + payload <- validatePayload apolloPayload + pure $ SessionStart sessionId payload + validateSub ApolloSubscription { apolloType = "stop", apolloId } + = SessionStop <$> validateSession apolloId + validateSub ApolloSubscription { apolloType } + = Left $ "Unknown Request type \""<> pack (unpack apolloType) <> "\"." + -------------------------------------------- + validateSession :: Maybe ID -> Validation ID + validateSession = maybe (Left "\"id\" was not provided") Right + ------------------------------------- + validatePayload = maybe (Left "\"payload\" was not provided") validatePayloadContent + ------------------------------------- + validatePayloadContent RequestPayload + { payloadQuery + , payloadOperationName = operationName + , payloadVariables = variables + } = do + query <- maybe (Left "\"payload.query\" was not provided") Right payloadQuery + pure $ GQLRequest {query, operationName, variables} diff --git a/src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs b/src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore + ( ID + , Session + , ClientConnectionStore + , Updates(..) + , startSession + , endSession + , empty + , insert + , delete + , publish + ) +where + +import Data.List ( intersect ) +import Data.Foldable ( traverse_ ) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Semigroup ( (<>) ) +import Data.Text ( Text ) +import Data.UUID ( UUID ) +import Data.HashMap.Lazy ( HashMap , keys) +import qualified Data.HashMap.Lazy as HM ( empty + , insert + , delete + , adjust + , elems + , toList + ) + + +-- MORPHEUS +import Data.Morpheus.Types.Internal.Subscription.Apollo + ( toApolloResponse + ) +import Data.Morpheus.Types.Internal.Operation + (Empty(..)) +import Data.Morpheus.Types.Internal.Resolving + ( SubEvent + , Event(..) + , GQLChannel(..) + ) + +type ID = UUID + +type SesionID = Text + +type Session = (ID, SesionID) + + +data ClientConnection e ( m :: * -> * ) = + ClientConnection + { connectionId :: ID + , connectionCallback :: ByteString -> m () + -- one connection can have multiple subsciprion session + , connectionSessions :: HashMap SesionID (SubEvent e m) + } + +instance Show (ClientConnection e m) where + show ClientConnection { connectionId, connectionSessions } = + "Connection { id: " + <> show connectionId + <> ", sessions: " + <> show (keys connectionSessions) + <> " }" + +publish + :: ( Eq (StreamChannel event) + , GQLChannel event + , Monad m + ) + => event + -> ClientConnectionStore event m + -> m () +publish event = traverse_ sendMessage . elems + where + sendMessage ClientConnection { connectionSessions, connectionCallback } + | null connectionSessions = pure () + | otherwise = traverse_ send (filterByChannels connectionSessions) + where + send (sid, Event { content = subscriptionRes }) + = toApolloResponse sid <$> subscriptionRes event >>= connectionCallback + --------------------------- + filterByChannels = filter + ( not + . null + . intersect (streamChannels event) + . channels + . snd + ) . HM.toList + + + +newtype Updates e ( m :: * -> * ) = + Updates { + _runUpdate:: ClientConnectionStore e m -> ClientConnectionStore e m + } + +updateClient + :: (ClientConnection e m -> ClientConnection e m ) + -> ID + -> Updates e m +updateClient f cid = Updates (adjust f cid) + +endSession :: Session -> Updates e m +endSession (clientId, sessionId) = updateClient endSub clientId + where + endSub client = client { connectionSessions = HM.delete sessionId (connectionSessions client) } + +startSession :: SubEvent e m -> Session -> Updates e m +startSession subscriptions (clientId, sessionId) = updateClient startSub clientId + where + startSub client = client { connectionSessions = HM.insert sessionId subscriptions (connectionSessions client) } + + + +-- stores active client connections +-- every registered client has ID +-- when client connection is closed client(including all its subsciprions) can By removed By its ID +newtype ClientConnectionStore e ( m :: * -> * ) = + ClientConnectionStore + { unpackStore :: HashMap ID (ClientConnection e m) + } deriving (Show) + +type StoreMap e m + = ClientConnectionStore e m + -> ClientConnectionStore e m + +mapStore + :: ( HashMap ID (ClientConnection e m) + -> HashMap ID (ClientConnection e m) + ) + -> StoreMap e m +mapStore f = ClientConnectionStore . f . unpackStore + +elems :: ClientConnectionStore e m -> [ClientConnection e m] +elems = HM.elems . unpackStore + +instance Empty (ClientConnectionStore e m) where + empty = ClientConnectionStore HM.empty + +insert + :: ID + -> (ByteString -> m ()) + -> StoreMap e m +insert connectionId connectionCallback = mapStore (HM.insert connectionId c) + where + c = ClientConnection { connectionId , connectionCallback, connectionSessions = HM.empty } + +adjust + :: (ClientConnection e m -> ClientConnection e m ) + -> ID + -> StoreMap e m +adjust f key = mapStore (HM.adjust f key) + +delete + :: ID + -> StoreMap e m +delete key = mapStore (HM.delete key) diff --git a/src/Data/Morpheus/Types/Internal/Subscription/Stream.hs b/src/Data/Morpheus/Types/Internal/Subscription/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Subscription/Stream.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.Internal.Subscription.Stream + ( toOutStream + , runStreamWS + , runStreamHTTP + , Stream + , Scope(..) + , Input(..) + , API(..) + , HTTP + , WS + ) +where + +import Data.Foldable ( traverse_ ) +import Data.ByteString.Lazy.Char8 (ByteString) + +-- MORPHEUS +import Data.Morpheus.Error.Utils ( globalErrorMessage + ) +import Data.Morpheus.Types.Internal.AST + ( Value(..) + , VALID + , GQLErrors + ) +import Data.Morpheus.Types.IO ( GQLRequest(..) + , GQLResponse(..) + ) +import Data.Morpheus.Types.Internal.Operation + ( failure ) +import Data.Morpheus.Types.Internal.Resolving + ( GQLChannel(..) + , ResponseEvent(..) + , ResponseStream + , runResultT + , Result(..) + , ResultT(..) + ) +import Data.Morpheus.Types.Internal.Subscription.Apollo + ( ApolloAction(..) + , apolloFormat + , toApolloResponse + ) +import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore + ( ClientConnectionStore + , insert + , ID + , Updates(..) + , startSession + , endSession + , Session + ) + +data API = HTTP | WS + +type WS = 'WS + +type HTTP = 'HTTP + +data Input + (api:: API) + where + Init :: ID -> Input WS + Request :: GQLRequest -> Input HTTP + +run :: Scope WS e m -> Updates e m -> m () +run ScopeWS { update } (Updates changes) = update changes + +data Scope (api :: API ) event (m :: * -> * ) where + ScopeHTTP :: + { httpCallback :: event -> m () + } -> Scope HTTP event m + ScopeWS :: + { listener :: m ByteString + , callback :: ByteString -> m () + , update :: (ClientConnectionStore event m -> ClientConnectionStore event m) -> m () + } -> Scope WS event m + + +data Stream + (api:: API) + e + (m :: * -> * ) + where + StreamWS + :: + { streamWS :: Scope WS e m -> m (Either ByteString [Updates e m]) + } -> Stream WS e m + StreamHTTP + :: + { streamHTTP :: Scope HTTP e m -> m GQLResponse + } -> Stream HTTP e m + +handleResponseStream + :: ( Eq (StreamChannel e) + , GQLChannel e + , Monad m + ) + => Session + -> ResponseStream e m (Value VALID) + -> Stream WS e m +handleResponseStream session (ResultT res) + = StreamWS $ const $ unfoldR <$> res + where + execute Publish {} = apolloError $ globalErrorMessage "websocket can only handle subscriptions, not mutations" + execute (Subscribe sub) = Right $ startSession sub session + -------------------------- + unfoldR Success { events } = traverse execute events + unfoldR Failure { errors } = apolloError errors + -------------------------- + apolloError :: GQLErrors -> Either ByteString a + apolloError = Left . toApolloResponse (snd session) . Errors + +handleWSRequest + :: ( Monad m + , Eq (StreamChannel e) + , GQLChannel e + , Functor m + ) + => ( GQLRequest + -> ResponseStream e m (Value VALID) + ) + -> ID + -> ByteString + -> Stream WS e m +handleWSRequest gqlApp clientId = handle . apolloFormat + where + --handle :: Applicative m => Validation ApolloAction -> Stream WS e m + handle = either (liftWS . Left) handleAction + -------------------------------------------------- + -- handleAction :: ApolloAction -> Stream WS e m + handleAction ConnectionInit = liftWS $ Right [] + handleAction (SessionStart sessionId request) + = handleResponseStream (clientId, sessionId) (gqlApp request) + handleAction (SessionStop sessionId) + = liftWS + $ Right [endSession (clientId, sessionId)] + +liftWS + :: Applicative m + => Either ByteString [Updates e m] + -> Stream WS e m +liftWS = StreamWS . const . pure + +runStreamWS + :: (Monad m) + => Scope WS e m + -> Stream WS e m + -> m () +runStreamWS scope@ScopeWS{ callback } StreamWS { streamWS } + = streamWS scope + >>= either callback (traverse_ (run scope)) + +runStreamHTTP + :: (Monad m) + => Scope HTTP e m + -> Stream HTTP e m + -> m GQLResponse +runStreamHTTP scope StreamHTTP { streamHTTP } + = streamHTTP scope + +toOutStream + :: ( Monad m + , Eq (StreamChannel e) + , GQLChannel e + , Functor m + ) + => ( GQLRequest + -> ResponseStream e m (Value VALID) + ) + -> Input api + -> Stream api e m +toOutStream app (Init clienId) + = StreamWS handle + where + handle ws@ScopeWS { listener , callback } = do + let runS (StreamWS x) = x ws + bla <- listener >>= runS . handleWSRequest app clienId + pure $ (Updates (insert clienId callback) :) <$> bla +toOutStream app (Request req) = StreamHTTP $ handleResponseHTTP (app req) + +handleResponseHTTP + :: ( Eq (StreamChannel e) + , GQLChannel e + , Monad m + ) + => ResponseStream e m (Value VALID) + -> Scope HTTP e m + -> m GQLResponse +handleResponseHTTP + res + ScopeHTTP { httpCallback } = do + x <- runResultT (handleRes res execute) + case x of + Success r _ events-> do + traverse_ httpCallback events + pure $ Data r + Failure err -> pure (Errors err) + where + execute (Publish event) = pure event + execute Subscribe {} = failure ("http can't handle subscription" :: String) + +handleRes + :: ( Eq (StreamChannel e) + , GQLChannel e + , Monad m + ) + => ResponseStream e m a + -> (ResponseEvent e m -> ResultT e' m e') + -> ResultT e' m a +handleRes res execute = ResultT $ runResultT res >>= runResultT . unfoldRes execute + +unfoldRes + :: (Monad m) + => (e -> ResultT e' m e') + -> Result e a + -> ResultT e' m a +unfoldRes execute Success { events, result, warnings } = do + events' <- traverse execute events + ResultT $ pure $ Success + { result + , warnings + , events = events' + } +unfoldRes _ Failure { errors } = ResultT $ pure $ Failure { errors } diff --git a/src/Data/Morpheus/Types/Internal/Validation.hs b/src/Data/Morpheus/Types/Internal/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Types.Internal.Validation + ( Validator + , SelectionValidator + , InputValidator + , BaseValidator + , InputSource(..) + , Context(..) + , SelectionContext(..) + , runValidator + , askSchema + , askContext + , askFragments + , askFieldType + , askTypeMember + , selectRequired + , selectKnown + , Constraint(..) + , constraint + , withScope + , withScopeType + , withScopePosition + , askScopeTypeName + , selectWithDefaultValue + , askScopePosition + , askInputFieldType + , askInputMember + , startInput + , withInputScope + , inputMessagePrefix + , checkUnused + , Prop(..) + , constraintInputUnion + ) + where + +import Data.Semigroup ( (<>) + , Semigroup(..) + ) +import Control.Monad.Trans.Reader ( ReaderT(..) + , ask + , withReaderT + ) + +-- MORPHEUS +import Data.Morpheus.Types.Internal.Operation + ( Failure(..) + , Selectable + , selectBy + , selectOr + , KeyOf(..) + , member + , size + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless ) +import Data.Morpheus.Types.Internal.AST + ( Name + , Position + , Message + , Ref(..) + , TypeRef(..) + , Fragments + , Schema + , FieldDefinition(..) + , FieldsDefinition(..) + , TypeDefinition(..) + , TypeContent(..) + , isInputDataType + , isFieldNullable + , Value(..) + , Object + , entryValue + , __inputname + ) +import Data.Morpheus.Types.Internal.Validation.Validator + ( Validator(..) + , Constraint(..) + , Target(..) + , InputSource(..) + , InputContext(..) + , Context(..) + , Prop(..) + , renderInputPrefix + , Resolution + , SelectionValidator + , InputValidator + , BaseValidator + , SelectionContext(..) + ) +import Data.Morpheus.Types.Internal.Validation.Error + ( MissingRequired(..) + , KindViolation(..) + , Unknown(..) + , InternalError(..) + , Unused(..) + ) + +getUnused :: (KeyOf b ,Selectable ca a) => ca -> [b] -> [b] +getUnused uses = filter (not . (`member` uses) . keyOf) + +failOnUnused :: Unused b => [b] -> Validator ctx () +failOnUnused x + | null x = return () + | otherwise = do + (gctx,_) <- Validator ask + failure $ map (unused gctx) x + +checkUnused :: (KeyOf b ,Selectable ca a, Unused b) => ca -> [b] -> Validator ctx () +checkUnused uses = failOnUnused . getUnused uses + +constraint + :: forall (a :: Target) inp ctx. KindViolation a inp + => Constraint ( a :: Target) + -> inp + -> TypeDefinition + -> Validator ctx (Resolution a) +constraint OBJECT _ TypeDefinition { typeContent = DataObject { objectFields } , typeName } + = pure (typeName, objectFields) +constraint INPUT _ x | isInputDataType x = pure x +constraint target ctx _ = failure [kindViolation target ctx] + +selectRequired + :: ( Selectable c value + , MissingRequired c ctx + ) + => Ref + -> c + -> Validator ctx value +selectRequired selector container + = do + (gctx,ctx) <- Validator ask + selectBy + [missingRequired gctx ctx selector container] + (keyOf selector) + container + +selectWithDefaultValue + :: ( Selectable values value + , MissingRequired values ctx + ) + => value + -> FieldDefinition + -> values + -> Validator ctx value +selectWithDefaultValue + fallbackValue + field@FieldDefinition { fieldName } + values + = selectOr + handleNullable + pure + fieldName + values + where + ------------------ + handleNullable + | isFieldNullable field = pure fallbackValue + | otherwise = failSelection + ----------------- + failSelection = do + (gctx, ctx) <- Validator ask + failure [missingRequired gctx ctx (Ref fieldName (scopePosition gctx)) values] + +selectKnown + :: ( Selectable c a + , Unknown c ctx + , KeyOf (UnknownSelector c) + ) + => UnknownSelector c + -> c + -> Validator ctx a +selectKnown selector lib + = do + (gctx, ctx) <- Validator ask + selectBy + (unknown gctx ctx lib selector) + (keyOf selector) + lib + +askFieldType + :: FieldDefinition + -> SelectionValidator TypeDefinition +askFieldType field@FieldDefinition{ fieldType = TypeRef { typeConName } } + = do + schema <- askSchema + selectBy + [internalError field] + typeConName + schema + +askTypeMember + :: Name + -> SelectionValidator (Name, FieldsDefinition) +askTypeMember + name + = askSchema + >>= selectOr notFound pure name + >>= constraintOBJECT + where + notFound = do + scopeType <- askScopeTypeName + failure $ + "Type \"" <> name + <> "\" referenced by union \"" <> scopeType + <> "\" can't found in Schema." + -------------------------------------- + constraintOBJECT TypeDefinition { typeName , typeContent } = con typeContent + where + con DataObject { objectFields } = pure (typeName, objectFields) + con _ = do + scopeType <- askScopeTypeName + failure $ + "Type \"" <> typeName + <> "\" referenced by union \"" <> scopeType + <> "\" must be an OBJECT." + +askInputFieldType + :: FieldDefinition + -> InputValidator TypeDefinition +askInputFieldType field@FieldDefinition{ fieldName , fieldType = TypeRef { typeConName } } + = askSchema + >>= selectBy + [internalError field] + typeConName + >>= constraintINPUT + where + constraintINPUT x + | isInputDataType x = pure x + | otherwise = failure $ + "Type \"" <> typeName x + <> "\" referenced by field \"" <> fieldName + <> "\" must be an input type." + +askInputMember + :: Name + -> InputValidator TypeDefinition +askInputMember + name + = askSchema + >>= selectOr notFound pure name + >>= constraintINPUT_OBJECT + where + typeInfo tName + = "Type \"" <> tName <> "\" referenced by inputUnion " + notFound = do + scopeType <- askScopeTypeName + failure $ typeInfo name <> scopeType <> "\" can't found in Schema." + -------------------------------------- + constraintINPUT_OBJECT tyDef@TypeDefinition { typeName , typeContent } = con typeContent + where + con DataInputObject { } = pure tyDef + con _ = do + scopeType <- askScopeTypeName + failure $ typeInfo typeName <> "\"" <> scopeType <> "\" must be an INPUT_OBJECT." + +startInput :: InputSource -> InputValidator a -> Validator ctx a +startInput inputSource + = setContext + $ const InputContext + { inputSource + , inputPath = [] + } + +withInputScope :: Prop -> InputValidator a -> InputValidator a +withInputScope prop = setContext update + where + update ctx@InputContext { inputPath = old } + = ctx { inputPath = old <> [prop] } + +runValidator :: Validator ctx a -> Context -> ctx -> Eventless a +runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX,ctx) + +askContext :: Validator ctx ctx +askContext = snd <$> Validator ask + +askSchema :: Validator ctx Schema +askSchema = schema . fst <$> Validator ask + +askFragments :: Validator ctx Fragments +askFragments = fragments . fst <$> Validator ask + +askScopeTypeName :: Validator ctx Name +askScopeTypeName = scopeTypeName . fst <$> Validator ask + +askScopePosition :: Validator ctx Position +askScopePosition = scopePosition . fst <$> Validator ask + +setContext + :: (c' -> c) + -> Validator c a + -> Validator c' a +setContext f = Validator . withReaderT ( \(x,y) -> (x,f y)) . _runValidator + +setGlobalContext + :: (Context -> Context) + -> Validator c a + -> Validator c a +setGlobalContext f = Validator . withReaderT ( \(x,y) -> (f x,y)) . _runValidator + +withScope :: Name -> Ref -> Validator ctx a -> Validator ctx a +withScope scopeTypeName (Ref scopeSelectionName scopePosition) = setGlobalContext update + where + update ctx = ctx { scopeTypeName , scopePosition , scopeSelectionName} + +withScopePosition :: Position -> Validator ctx a -> Validator ctx a +withScopePosition scopePosition = setGlobalContext update + where + update ctx = ctx { scopePosition } + +withScopeType :: Name -> Validator ctx a -> Validator ctx a +withScopeType scopeTypeName = setGlobalContext update + where + update ctx = ctx { scopeTypeName } + +inputMessagePrefix :: InputValidator Message +inputMessagePrefix = renderInputPrefix <$> askContext + + +constraintInputUnion + :: forall stage. [(Name, Bool)] + -> Object stage + -> Either Message (Name, Maybe (Value stage)) +constraintInputUnion tags hm = do + (enum :: Value stage) <- entryValue <$> selectBy + ("valid input union should contain \"" <> __inputname <> "\" and actual value") + __inputname + hm + tyName <- isPosibeInputUnion tags enum + case size hm of + 1 -> pure (tyName, Nothing) + 2 -> do + value <- entryValue <$> selectBy + ("value for Union \""<> tyName <> "\" was not Provided.") + tyName + hm + pure (tyName , Just value) + _ -> failure ("input union can have only one variant." :: Message) + +isPosibeInputUnion :: [(Name, Bool)] -> Value stage -> Either Message Name +isPosibeInputUnion tags (Enum name) = case lookup name tags of + Nothing -> failure (name <> " is not posible union type" :: Message) + _ -> pure name +isPosibeInputUnion _ _ = failure $ "\""<> __inputname <> "\" must be Enum" diff --git a/src/Data/Morpheus/Types/Internal/Validation/Error.hs b/src/Data/Morpheus/Types/Internal/Validation/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation/Error.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Morpheus.Types.Internal.Validation.Error + ( MissingRequired(..) + , KindViolation(..) + , Unknown(..) + , InternalError(..) + , Target(..) + , Unused(..) + ) + where + +import Data.Semigroup ((<>)) + +-- MORPHEUS +import Data.Morpheus.Error.Utils ( errorMessage ) +import Data.Morpheus.Error.Selection ( unknownSelectionField ) +import Data.Morpheus.Types.Internal.Validation.Validator + ( Context(..) + , InputContext(..) + , renderInputPrefix + , Target(..) + ) +import Data.Morpheus.Types.Internal.AST + ( RESOLVED + , Ref(..) + , TypeRef(..) + , GQLError(..) + , GQLErrors + , Argument(..) + , ObjectEntry(..) + , Fragment(..) + , Fragments + , Variable(..) + , VariableDefinitions + , FieldDefinition(..) + , FieldsDefinition + , InputFieldsDefinition + , Schema + , Object + , Arguments + , getOperationName + ) + + + +class InternalError a where + internalError :: a -> GQLError + + + +instance InternalError FieldDefinition where + internalError FieldDefinition + { fieldName + , fieldType = TypeRef { typeConName } + } = GQLError + { message + = "INTERNAL: Type \"" <> typeConName + <> "\" referenced by field \"" <> fieldName + <> "\" can't found in Schema " + , locations = [] + } + + + +class Unused c where + unused :: Context -> c -> GQLError + +-- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".", +instance Unused (Variable s) where + unused + Context { operationName } + Variable{ variableName , variablePosition} + = GQLError + { message + = "Variable \"$" <> variableName + <> "\" is never used in operation \"" + <> getOperationName operationName <> "\"." + , locations = [variablePosition] + } + +instance Unused Fragment where + unused + _ + Fragment { fragmentName , fragmentPosition } + = GQLError + { message + = "Fragment \"" <> fragmentName + <> "\" is never used." + , locations = [fragmentPosition] + } + +class MissingRequired c ctx where + missingRequired :: Context -> ctx -> Ref -> c -> GQLError + +instance MissingRequired (Arguments s) ctx where + missingRequired + Context { scopePosition , scopeSelectionName } + _ + Ref { refName } _ + = GQLError + { message + = "Field \"" <> scopeSelectionName <> "\" argument \"" + <> refName <> "\" is required but not provided." + , locations = [scopePosition] + } + +instance MissingRequired (Object s) InputContext where + missingRequired + Context { scopePosition } + inputCTX + Ref { refName } + _ + = GQLError + { message + = renderInputPrefix inputCTX <> "Undefined Field \"" <> refName <> "\"." + , locations = [scopePosition] + } + +instance MissingRequired (VariableDefinitions s) ctx where + missingRequired + Context { operationName } + _ + Ref { refName , refPosition } _ + = GQLError + { message + = "Variable \"" <> refName + <> "\" is not defined by operation \"" + <> getOperationName operationName <> "\"." + , locations = [refPosition] + } + + +class Unknown c ctx where + type UnknownSelector c + unknown :: Context -> ctx -> c -> UnknownSelector c -> GQLErrors + +-- {...H} -> "Unknown fragment \"H\"." +instance Unknown Fragments ctx where + type UnknownSelector Fragments = Ref + unknown _ _ _ (Ref name pos) + = errorMessage pos + ("Unknown Fragment \"" <> name <> "\".") + +instance Unknown Schema ctx where + type UnknownSelector Schema = Ref + unknown _ _ _ Ref { refName , refPosition } + = errorMessage refPosition ("Unknown type \"" <> refName <> "\".") + +instance Unknown FieldDefinition ctx where + type UnknownSelector FieldDefinition = Argument RESOLVED + unknown _ _ FieldDefinition { fieldName } Argument { argumentName, argumentPosition } + = errorMessage argumentPosition + ("Unknown Argument \"" <> argumentName <> "\" on Field \"" <> fieldName <> "\".") + +instance Unknown InputFieldsDefinition InputContext where + type UnknownSelector InputFieldsDefinition = ObjectEntry RESOLVED + unknown Context { scopePosition } ctx _ ObjectEntry { entryName } = + [ + GQLError + { message = renderInputPrefix ctx <>"Unknown Field \"" <> entryName <> "\"." + , locations = [scopePosition] + } + ] + +instance Unknown FieldsDefinition ctx where + type UnknownSelector FieldsDefinition = Ref + unknown Context { scopeTypeName } _ _ + = unknownSelectionField scopeTypeName + +class KindViolation (t :: Target) ctx where + kindViolation :: c t -> ctx -> GQLError + +instance KindViolation 'TARGET_OBJECT Fragment where + kindViolation _ Fragment { fragmentName, fragmentType, fragmentPosition } + = GQLError + { message + = "Fragment \"" <> fragmentName + <> "\" cannot condition on non composite type \"" + <> fragmentType <>"\"." + , locations = [fragmentPosition] + } + +instance KindViolation 'TARGET_INPUT (Variable s) where + kindViolation _ Variable + { variableName + , variablePosition + , variableType = TypeRef { typeConName } + } + = GQLError + { message + = "Variable \"$" <> variableName + <> "\" cannot be non-input type \"" + <> typeConName <>"\"." + , locations = [variablePosition] + } diff --git a/src/Data/Morpheus/Types/Internal/Validation/Validator.hs b/src/Data/Morpheus/Types/Internal/Validation/Validator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation/Validator.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Types.Internal.Validation.Validator + ( Validator(..) + , SelectionValidator + , InputValidator + , BaseValidator + , runValidator + , askSchema + , askContext + , askFragments + , Constraint(..) + , withScope + , withScopeType + , withScopePosition + , askScopeTypeName + , askScopePosition + , withInputScope + , inputMessagePrefix + , Context(..) + , InputSource(..) + , InputContext(..) + , SelectionContext(..) + , renderInputPrefix + , Target(..) + , Prop(..) + , Resolution + ) + where + +import Data.Semigroup ( (<>) + , Semigroup(..) + ) +import Control.Monad.Trans.Reader ( ReaderT(..) + , ask + , withReaderT + ) +import Data.Text ( intercalate ) +import Control.Monad.Trans.Class ( MonadTrans(..) ) + + +-- MORPHEUS +import Data.Morpheus.Types.Internal.Operation + ( Failure(..) + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless ) +import Data.Morpheus.Types.Internal.AST + ( Name + , Position + , Message + , GQLErrors + , GQLError(..) + , Fragments + , Schema + , FieldsDefinition(..) + , TypeDefinition(..) + , Argument(..) + , Variable(..) + , VariableDefinitions + , RESOLVED + , RAW + , VALID + ) + +data Prop = + Prop + { propName :: Name + , propTypeName :: Name + } deriving (Show) + +type Path = [Prop] + +renderPath :: Path -> Message +renderPath [] = "" +renderPath path = "in field \"" <> intercalate "." (fmap propName path) <> "\": " + +renderInputPrefix :: InputContext -> Message +renderInputPrefix InputContext { inputPath , inputSource } = + renderSource inputSource <> renderPath inputPath + +renderSource :: InputSource -> Message +renderSource (SourceArgument Argument { argumentName }) + = "Argument \"" <> argumentName <>"\" got invalid value. " +renderSource (SourceVariable Variable { variableName }) + = "Variable \"$" <> variableName <>"\" got invalid value. " + +data Context = Context + { schema :: Schema + , fragments :: Fragments + , scopePosition :: Position + , scopeTypeName :: Name + , operationName :: Maybe Name + , scopeSelectionName :: Name + } deriving (Show) + +data InputContext + = InputContext + { inputSource :: InputSource + , inputPath :: [Prop] + } deriving (Show) + +data InputSource + = SourceArgument (Argument RESOLVED) + | SourceVariable (Variable RAW) + deriving (Show) + +newtype SelectionContext + = SelectionContext + { variables :: VariableDefinitions VALID + } deriving (Show) + +data Target + = TARGET_OBJECT + | TARGET_INPUT + +data Constraint (a :: Target) where + OBJECT :: Constraint 'TARGET_OBJECT + INPUT :: Constraint 'TARGET_INPUT +-- UNION :: Constraint 'TARGET_UNION + +type family Resolution (a :: Target) +type instance Resolution 'TARGET_OBJECT = (Name, FieldsDefinition) +type instance Resolution 'TARGET_INPUT = TypeDefinition +--type instance Resolution 'TARGET_UNION = DataUnion + +withInputScope :: Prop -> InputValidator a -> InputValidator a +withInputScope prop = setContext update + where + update ctx@InputContext { inputPath = old } + = ctx { inputPath = old <> [prop] } + + +askContext :: Validator ctx ctx +askContext = snd <$> Validator ask + +askSchema :: Validator ctx Schema +askSchema = schema . fst <$> Validator ask + +askFragments :: Validator ctx Fragments +askFragments = fragments . fst <$> Validator ask + +askScopeTypeName :: Validator ctx Name +askScopeTypeName = scopeTypeName . fst <$> Validator ask + +askScopePosition :: Validator ctx Position +askScopePosition = scopePosition . fst <$> Validator ask + +setContext + :: (c' -> c) + -> Validator c a + -> Validator c' a +setContext f = Validator . withReaderT ( \(x,y) -> (x,f y)) . _runValidator + +setGlobalContext + :: (Context -> Context) + -> Validator c a + -> Validator c a +setGlobalContext f = Validator . withReaderT ( \(x,y) -> (f x,y)) . _runValidator + + +withScope :: Name -> Position -> Validator ctx a -> Validator ctx a +withScope scopeTypeName scopePosition = setGlobalContext update + where + update ctx = ctx { scopeTypeName , scopePosition } + + +withScopePosition :: Position -> Validator ctx a -> Validator ctx a +withScopePosition scopePosition = setGlobalContext update + where + update ctx = ctx { scopePosition } + +withScopeType :: Name -> Validator ctx a -> Validator ctx a +withScopeType scopeTypeName = setGlobalContext update + where + update ctx = ctx { scopeTypeName } + +inputMessagePrefix :: InputValidator Message +inputMessagePrefix = renderInputPrefix <$> askContext + + +runValidator :: Validator ctx a -> Context -> ctx -> Eventless a +runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX,ctx) + +newtype Validator ctx a + = Validator + { + _runValidator :: ReaderT + (Context, ctx) + Eventless + a + } + deriving + ( Functor + , Applicative + , Monad + ) + +type BaseValidator = Validator () +type SelectionValidator = Validator SelectionContext +type InputValidator = Validator InputContext + +-- can be only used for internal errors +instance Failure Message (Validator ctx) where + failure inputMessage = do + position <- askScopePosition + failure + [ + GQLError + { message = "INTERNAL: " <> inputMessage + , locations = [position] + } + ] + +instance Failure GQLErrors (Validator ctx) where + failure = Validator . lift . failure diff --git a/src/Data/Morpheus/Types/Internal/WebSocket.hs b/src/Data/Morpheus/Types/Internal/WebSocket.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/WebSocket.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Types.Internal.WebSocket - ( GQLClient(..) - , ClientID - , ClientDB - , GQLState - , SesionID - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) -import Data.UUID ( UUID ) -import Network.WebSockets ( Connection ) -import Data.HashMap.Lazy ( HashMap , keys) -import Control.Concurrent ( MVar ) - --- MORPHEUS -import Data.Morpheus.Types.Internal.Resolving - ( SubEvent ) - - --- | shared GraphQL state between __websocket__ and __http__ server, --- stores information about subscriptions -type GQLState m e = MVar (ClientDB m e) -- SharedState - -type ClientDB m e = HashMap ClientID (GQLClient m e) - -type ClientID = UUID - -type SesionID = Text - -data GQLClient m e = - GQLClient - { clientID :: ClientID - , clientConnection :: Connection - , clientSessions :: HashMap SesionID (SubEvent m e) - } - -instance (Show e) => Show (GQLClient m e) where - show GQLClient { clientID, clientSessions } = - "GQLClient {id:" - <> show clientID - <> ", sessions:" - <> show (keys clientSessions) - <> "}" 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 @@ -1,7 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} - module Data.Morpheus.Validation.Document.Validation ( validatePartialDocument ) @@ -19,55 +17,56 @@ import Data.Morpheus.Rendering.RenderGQL ( RenderGQL(..) ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) - , DataType(..) - , DataObject - , DataTypeContent(..) - , Name - , Key + ( Name + , FieldDefinition(..) + , TypeDefinition(..) + , FieldsDefinition(..) + , TypeContent(..) , TypeRef(..) , isWeaker + , lookupWith ) +import Data.Morpheus.Types.Internal.Operation + ( Selectable(..) + , Listable(..) + ) import Data.Morpheus.Types.Internal.Resolving - ( Validation + ( Eventless , Failure(..) ) -validatePartialDocument :: [(Key, DataType)] -> Validation [(Key, DataType)] +validatePartialDocument :: [TypeDefinition] -> Eventless [TypeDefinition] validatePartialDocument lib = catMaybes <$> traverse validateType lib where - validateType :: (Key, DataType) -> Validation (Maybe (Key, DataType)) - validateType (name, dt@DataType { typeName , typeContent = DataObject { objectImplements , objectFields} }) = do + validateType :: TypeDefinition -> Eventless (Maybe TypeDefinition) + validateType dt@TypeDefinition { typeName , typeContent = DataObject { objectImplements , objectFields} } = do interface <- traverse getInterfaceByKey objectImplements case concatMap (mustBeSubset objectFields) interface of - [] -> pure $ Just (name, dt) + [] -> pure (Just dt) errors -> failure $ partialImplements typeName errors - validateType (_,DataType { typeContent = DataInterface {}}) = pure Nothing - validateType (name, x) = pure $ Just (name, x) + validateType TypeDefinition { typeContent = DataInterface {}} = pure Nothing + validateType x = pure (Just x) mustBeSubset - :: DataObject -> (Name, DataObject) -> [(Key, Key, ImplementsError)] - mustBeSubset objFields (typeName, interfaceFields ) = concatMap - checkField - interfaceFields + :: FieldsDefinition -> (Name, FieldsDefinition) -> [(Name, Name, ImplementsError)] + mustBeSubset objFields (typeName, fields) = concatMap checkField (toList fields) where - checkField :: (Key, DataField) -> [(Key, Key, ImplementsError)] - checkField (key, DataField { fieldType = interfaceT@TypeRef { typeConName = interfaceTypeName, typeWrappers = interfaceWrappers } }) - = case lookup key objFields of - Just DataField { fieldType = objT@TypeRef { typeConName, typeWrappers } } - | typeConName == interfaceTypeName && not - (isWeaker typeWrappers interfaceWrappers) - -> [] + checkField :: FieldDefinition -> [(Name, Name, ImplementsError)] + checkField FieldDefinition { fieldName, fieldType = interfaceT@TypeRef { typeConName = interfaceTypeName, typeWrappers = interfaceWrappers } } + = selectOr err checkTypeEq fieldName objFields + where + err = [(typeName, fieldName, UndefinedField)] + checkTypeEq FieldDefinition { fieldType = objT@TypeRef { typeConName, typeWrappers } } + | typeConName == interfaceTypeName && not (isWeaker typeWrappers interfaceWrappers) + = [] | otherwise - -> [ ( typeName - , key + = [ ( typeName , fieldName , UnexpectedType { expectedType = render interfaceT , foundType = render objT } ) ] - Nothing -> [(typeName, key, UndefinedField)] ------------------------------- - getInterfaceByKey :: Key -> Validation (Name,DataObject) - getInterfaceByKey key = case lookup key lib of - Just DataType { typeContent = DataInterface { interfaceFields } } -> pure (key,interfaceFields) - _ -> failure $ unknownInterface key + getInterfaceByKey :: Name -> Eventless (Name, FieldsDefinition) + getInterfaceByKey interfaceName = case lookupWith typeName interfaceName lib of + Just TypeDefinition { typeContent = DataInterface { interfaceFields } } -> pure (interfaceName,interfaceFields) + _ -> failure $ unknownInterface interfaceName 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 @@ -3,198 +3,191 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Validation.Internal.Value - ( validateInputValue - , validateEnum - ) + ( validateInput ) where +import Data.Semigroup ((<>)) +import Data.Maybe (maybe) +import Data.Foldable (traverse_) import Data.List ( elem ) -- MORPHEUS + +import Data.Morpheus.Error.Utils ( errorMessage ) import Data.Morpheus.Error.Variable ( incompatibleVariableType ) -import Data.Morpheus.Error.Input ( InputError(..) - , InputValidation - , Prop(..) - ) +import Data.Morpheus.Error.Input ( typeViolation ) import Data.Morpheus.Types.Internal.AST - ( DataField(..) - , DataTypeContent(..) - , DataType(..) - , Schema(..) - , DataValidator(..) - , Key + ( FieldDefinition(..) + , TypeContent(..) + , TypeDefinition(..) + , ScalarDefinition(..) , TypeRef(..) , TypeWrapper(..) , DataEnumValue(..) - , lookupField - , lookupInputType , Value(..) , ValidValue , Variable(..) , Ref(..) - , isWeaker - , DataScalar , Message , Name , ResolvedValue , VALID , VariableContent(..) - , unpackInputUnion - , isFieldNullable , TypeRef(..) + , isWeaker , isNullableWrapper + , ObjectEntry(..) + , RESOLVED + , InputFieldsDefinition(..) + , Variable(..) ) - -import Data.Morpheus.Types.Internal.Resolving +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( unsafeFromValues ) +import Data.Morpheus.Types.Internal.Operation ( Failure(..) ) -import Data.Morpheus.Rendering.RenderGQL - ( RenderGQL(..) ) +import Data.Morpheus.Types.Internal.Validation + ( InputValidator + , askInputFieldType + , constraintInputUnion + , askInputMember + , selectKnown + , selectWithDefaultValue + , askScopePosition + , withScopeType + , withInputScope + , inputMessagePrefix + , Prop(..) + ) +castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a +castFailure expected message value = do + pos <- askScopePosition + prefix <- inputMessagePrefix + failure + $ errorMessage pos + $ prefix <> typeViolation expected value <> maybe "" (" " <>) message + checkTypeEquality :: (Name, [TypeWrapper]) -> Ref -> Variable VALID - -> InputValidation ValidValue -checkTypeEquality (tyConName, tyWrappers) Ref { refName, refPosition } Variable { variableValue = ValidVariableValue value, variableType } + -> InputValidator ValidValue +checkTypeEquality (tyConName, tyWrappers) ref var@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 - } - - + = failure $ incompatibleVariableType + ref + var + TypeRef + { typeConName = tyConName + , typeWrappers = tyWrappers + , typeArgs = Nothing + } -- Validate Variable Argument or all Possible input Values -validateInputValue - :: Schema - -> [Prop] - -> [TypeWrapper] - -> DataType - -> (Key, ResolvedValue) - -> InputValidation ValidValue -validateInputValue lib props rw datatype@DataType { typeContent, typeName } = - validateWrapped rw typeContent +validateInput + :: [TypeWrapper] + -> TypeDefinition + -> ObjectEntry RESOLVED + -> InputValidator ValidValue +validateInput tyWrappers TypeDefinition { typeContent = tyCont, typeName } = + withScopeType typeName + . validateWrapped tyWrappers tyCont where - throwError :: [TypeWrapper] -> ResolvedValue -> InputValidation ValidValue - throwError wrappers value = - Left $ UnexpectedType props (renderWrapped datatype wrappers) value Nothing + mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue + mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing -- VALIDATION validateWrapped :: [TypeWrapper] - -> DataTypeContent - -> (Key, ResolvedValue) - -> InputValidation ValidValue + -> TypeContent + -> ObjectEntry RESOLVED + -> InputValidator ValidValue -- Validate Null. value = null ? - validateWrapped wrappers _ (_, ResolvedVariable ref variable) = + validateWrapped wrappers _ ObjectEntry { entryValue = ResolvedVariable ref variable} = checkTypeEquality (typeName, wrappers) ref variable - validateWrapped wrappers _ (_, Null) + validateWrapped wrappers _ ObjectEntry { entryValue = Null} | isNullableWrapper wrappers = return Null - | otherwise = throwError wrappers Null + | otherwise = mismatchError wrappers Null -- Validate LIST validateWrapped (TypeMaybe : wrappers) _ value = - validateInputValue lib props wrappers datatype value - validateWrapped (TypeList : wrappers) _ (key, List list) = - List <$> mapM validateElement list + validateWrapped wrappers tyCont value + validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) = + List <$> traverse validateElement list where - validateElement element = - validateInputValue lib props wrappers datatype (key, element) + validateElement = validateWrapped wrappers tyCont . ObjectEntry key {-- 2. VALIDATE TYPES, all wrappers are already Processed --} {-- VALIDATE OBJECT--} validateWrapped [] dt v = validate dt v where validate - :: DataTypeContent -> (Key, ResolvedValue) -> InputValidation ValidValue - validate (DataInputObject parentFields) (_, Object fields) = - traverse requiredFieldsDefined parentFields - >> Object - <$> traverse validateField fields + :: TypeContent -> ObjectEntry RESOLVED -> InputValidator ValidValue + validate (DataInputObject parentFields) ObjectEntry { entryValue = Object fields} = do + traverse_ requiredFieldsDefined (unInputFieldsDefinition parentFields) + Object <$> traverse validateField fields where - requiredFieldsDefined (fName, datafield) - | fName `elem` map fst fields || isFieldNullable datafield = pure () - | otherwise = failure (UndefinedField props fName) + requiredFieldsDefined :: FieldDefinition -> InputValidator (ObjectEntry RESOLVED) + requiredFieldsDefined fieldDef@FieldDefinition { fieldName} + = selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields 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'') + :: ObjectEntry RESOLVED -> InputValidator (ObjectEntry VALID) + validateField entry@ObjectEntry { entryName } = do + inputField@FieldDefinition{ fieldType = TypeRef { typeConName , typeWrappers }} <- getField + inputTypeDef <- askInputFieldType inputField + withInputScope (Prop entryName typeConName) $ ObjectEntry entryName + <$> validateInput + typeWrappers + inputTypeDef + entry 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) + getField = selectKnown entry parentFields -- 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)]) + -- TODO: enhance input union Validation + validate (DataInputUnion inputUnion) ObjectEntry { entryValue = Object rawFields} = + case constraintInputUnion inputUnion rawFields of + Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields) + Right (name, Nothing ) -> return (Object $ unsafeFromValues [ObjectEntry "__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)]) - + inputDef <- askInputMember name + validValue <- validateInput + [TypeMaybe] + inputDef + (ObjectEntry name value) + return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name), ObjectEntry name validValue]) {-- VALIDATE ENUM --} - validate (DataEnum tags) (_, value) = - validateEnum (UnexpectedType props typeName value Nothing) tags value + validate (DataEnum tags) ObjectEntry { entryValue } = + validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue {-- VALIDATE SCALAR --} - validate (DataScalar dataScalar) (_, value) = - validateScalar dataScalar value (UnexpectedType props typeName) - validate _ (_, value) = throwError [] value + validate (DataScalar dataScalar) ObjectEntry { entryValue } = + validateScalar dataScalar entryValue (castFailure (TypeRef typeName Nothing [])) + validate _ ObjectEntry { entryValue } = mismatchError [] entryValue {-- 3. THROW ERROR: on invalid values --} - validateWrapped wrappers _ (_, value) = throwError wrappers value - + validateWrapped wrappers _ ObjectEntry { entryValue } = mismatchError wrappers entryValue validateScalar - :: DataScalar + :: ScalarDefinition -> ResolvedValue - -> (ResolvedValue -> Maybe Message -> InputError) - -> InputValidation ValidValue -validateScalar DataValidator { validateValue } value err = do + -> (Maybe Message -> ResolvedValue -> InputValidator ValidValue) + -> InputValidator ValidValue +validateScalar ScalarDefinition { 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) + Left "" -> err Nothing value + Left message -> err (Just message) value where - toScalar :: ResolvedValue -> InputValidation ValidValue + toScalar :: ResolvedValue -> InputValidator ValidValue toScalar (Scalar x) = pure (Scalar x) - toScalar scValue = Left (err scValue Nothing) + toScalar scValue = err Nothing scValue -validateEnum - :: error -> [DataEnumValue] -> ResolvedValue -> Either error ValidValue -validateEnum gqlError enumValues (Enum enumValue) +validateEnum + :: (ResolvedValue -> InputValidator ValidValue) + -> [DataEnumValue] + -> ResolvedValue + -> InputValidator ValidValue +validateEnum err enumValues value@(Enum enumValue) | enumValue `elem` tags = pure (Enum enumValue) - | otherwise = Left gqlError + | otherwise = err value where tags = map enumName enumValues -validateEnum gqlError _ _ = Left gqlError - -typeMismatch :: ResolvedValue -> Key -> [Prop] -> InputError -typeMismatch jsType expected' path' = - UnexpectedType path' expected' jsType Nothing +validateEnum err _ value = err value 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,161 +1,123 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Validation.Query.Arguments ( validateArguments ) where -import Data.Maybe ( maybe ) -import Data.Morpheus.Error.Arguments ( argumentGotInvalidValue - , argumentNameCollision - , undefinedArgument - , unknownArguments - ) -import Data.Morpheus.Error.Input ( InputValidation - , inputErrorMessage - ) -import Data.Morpheus.Error.Internal ( internalUnknownTypeMessage ) -import Data.Morpheus.Error.Variable ( undefinedVariable ) +import Data.Foldable (traverse_) import Data.Morpheus.Types.Internal.AST - ( ValidVariables - , Variable(..) - , Argument(..) - , RawArgument - , RawArguments - , ValidArgument - , ValidArguments + ( Argument(..) + , ArgumentsDefinition(..) , Arguments - , Ref(..) - , Position - , DataArgument - , DataField(..) - , Schema + , ArgumentDefinition + , FieldDefinition(..) , TypeRef(..) - , isFieldNullable - , lookupInputType , Value(..) - , Name , RawValue , ResolvedValue , RESOLVED , VALID - , checkForUnknownKeys - , checkNameCollision + , ObjectEntry(..) + , RAW ) -import Data.Morpheus.Types.Internal.Resolving - ( Validation - , Failure(..) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + , empty ) +import Data.Morpheus.Types.Internal.Validation + ( SelectionValidator + , InputSource(..) + , SelectionContext(..) + , selectKnown + , selectRequired + , selectWithDefaultValue + , askScopePosition + , withScopePosition + , askInputFieldType + , startInput + , askContext + ) import Data.Morpheus.Validation.Internal.Value - ( validateInputValue ) -import Data.Text ( Text ) + ( validateInput ) -- only Resolves , doesnot checks the types -resolveObject :: Name -> ValidVariables -> RawValue -> Validation ResolvedValue -resolveObject operationName variables = resolve +resolveObject :: RawValue -> SelectionValidator ResolvedValue +resolveObject = resolve where - resolve :: RawValue -> Validation ResolvedValue + resolveEntry :: ObjectEntry RAW -> SelectionValidator (ObjectEntry RESOLVED) + resolveEntry (ObjectEntry name v) = ObjectEntry name <$> resolve v + ------------------------------------------------ + resolve :: RawValue -> SelectionValidator 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 (Object obj) = Object <$> traverse resolveEntry obj 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 - - + variables <$> askContext + >>= fmap (ResolvedVariable ref) + . selectRequired ref resolveArgumentVariables - :: Name - -> ValidVariables - -> DataField - -> RawArguments - -> Validation (Arguments RESOLVED) -resolveArgumentVariables operationName variables DataField { fieldName, fieldArgs } - = mapM resolveVariable + :: Arguments RAW + -> SelectionValidator (Arguments RESOLVED) +resolveArgumentVariables + = traverse resolveVariable where - 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) + resolveVariable :: Argument RAW -> SelectionValidator (Argument RESOLVED) + resolveVariable (Argument key val position) = do + constValue <- resolveObject val + pure $ Argument key constValue position validateArgument - :: Schema - -> Position - -> Arguments RESOLVED - -> (Text, DataArgument) - -> Validation (Text, ValidArgument) -validateArgument lib fieldPosition requestArgs (key, argType@DataField { fieldType = TypeRef { typeConName, typeWrappers } }) - = case lookup key requestArgs of - Nothing -> handleNullable - -- 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 + :: Arguments RESOLVED + -> ArgumentDefinition + -> SelectionValidator (Argument VALID) +validateArgument + requestArgs + argumentDef@FieldDefinition + { fieldName + , fieldType = TypeRef { typeWrappers } + } + = do + argumentPosition <- askScopePosition + argument <- selectWithDefaultValue + Argument { argumentName = fieldName, argumentValue = Null, argumentPosition } + argumentDef + requestArgs + validateArgumentValue argument where - handleNullable - | isFieldNullable argType - = pure - (key, Argument { argumentValue = Null, argumentPosition = fieldPosition }) - | otherwise - = failure $ undefinedArgument (Ref key fieldPosition) ------------------------------------------------------------------------- - 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 - --------- - 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 + validateArgumentValue :: Argument RESOLVED -> SelectionValidator (Argument VALID) + validateArgumentValue arg@Argument { argumentValue = value, .. } = + withScopePosition argumentPosition + $ startInput (SourceArgument arg) + $ do + datatype <- askInputFieldType argumentDef + argumentValue <- validateInput + typeWrappers + datatype + (ObjectEntry fieldName value) + pure Argument { argumentValue , .. } validateArguments - :: Schema - -> Text - -> ValidVariables - -> (Text, DataField) - -> Position - -> RawArguments - -> Validation ValidArguments -validateArguments typeLib operatorName variables (key, field@DataField { fieldArgs }) pos rawArgs + :: FieldDefinition + -> Arguments RAW + -> SelectionValidator (Arguments VALID) +validateArguments + fieldDef@FieldDefinition { fieldArgs } + rawArgs = do - args <- resolveArgumentVariables operatorName variables field rawArgs - dataArgs <- checkForUnknownArguments args - mapM (validateArgument typeLib pos args) dataArgs + args <- resolveArgumentVariables rawArgs + traverse_ checkUnknown (toList args) + traverse (validateArgument args) argsDef where - checkForUnknownArguments - :: Arguments RESOLVED -> Validation [(Text, DataField)] - checkForUnknownArguments args = - checkForUnknownKeys enhancedKeys fieldKeys argError - >> checkNameCollision enhancedKeys argumentNameCollision - >> pure fieldArgs - where - argError = unknownArguments key - enhancedKeys = map argToKey args - argToKey :: (Name, Argument RESOLVED) -> Ref - argToKey (key', Argument { argumentPosition }) = Ref key' argumentPosition - fieldKeys = map fst fieldArgs + argsDef = case fieldArgs of + (ArgumentsDefinition _ argsD) -> argsD + NoArguments -> empty + ------------------------------------------------- + checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition + checkUnknown = (`selectKnown` fieldDef) 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,125 +1,137 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} module Data.Morpheus.Validation.Query.Fragment ( validateFragments , castFragmentType , resolveSpread - , getFragment ) where -import Data.List ( (\\) ) import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) +import Data.Foldable (traverse_) -- MORPHEUS import Data.Morpheus.Error.Fragment ( cannotBeSpreadOnType , cannotSpreadWithinItself - , fragmentNameCollision - , unknownFragment - , unusedFragment ) -import Data.Morpheus.Error.Variable ( unknownType ) import Data.Morpheus.Types.Internal.AST - ( Fragment(..) - , FragmentLib - , RawSelection + ( Name + , Fragment(..) + , Fragments , SelectionContent(..) , Selection(..) , Ref(..) , Position - , Schema - , DataLookup(..) - , checkNameCollision - , DataObject - , Name + , SelectionSet + , RAW ) -import Data.Morpheus.Types.Internal.Resolving - ( Validation +import Data.Morpheus.Types.Internal.Operation + ( selectOr + , toList , Failure(..) ) - - -validateFragments - :: Schema -> FragmentLib -> [(Text, RawSelection)] -> Validation () -validateFragments lib fragments operatorSel = - validateNameCollision >> checkLoop >> checkUnusedFragments - where - validateNameCollision = - checkNameCollision fragmentsKeys fragmentNameCollision - checkUnusedFragments = - case fragmentsKeys \\ usedFragments fragments operatorSel of - [] -> return () - unused -> failure (unusedFragment unused) - checkLoop = mapM (validateFragment lib) fragments >>= detectLoopOnFragments - fragmentsKeys = map toRef fragments - where toRef (key, Fragment { fragmentPosition }) = Ref key fragmentPosition - -type Node = Ref - -type NodeEdges = (Node, [Node]) +import Data.Morpheus.Types.Internal.Validation + ( BaseValidator + , askSchema + , askFragments + , selectKnown + , constraint + , Constraint(..) + , Validator + , checkUnused + ) -type Graph = [NodeEdges] +validateFragments :: SelectionSet RAW -> BaseValidator () +validateFragments selectionSet + = fragmentsCycleChecking + *> checkUnusedFragments selectionSet + *> fragmentsConditionTypeChecking -getFragment :: Ref -> FragmentLib -> Validation Fragment -getFragment Ref { refName, refPosition } lib = case lookup refName lib of - Nothing -> failure $ unknownFragment refName refPosition - Just fragment -> pure fragment +checkUnusedFragments :: SelectionSet RAW -> BaseValidator () +checkUnusedFragments selectionSet = do + fragments <- askFragments + checkUnused + (usedFragments fragments (toList selectionSet)) + (toList fragments) castFragmentType - :: Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment -castFragmentType key' position' typeMembers fragment@Fragment { fragmentType } - = if fragmentType `elem` typeMembers - then pure fragment - else failure $ cannotBeSpreadOnType key' fragmentType position' typeMembers + :: Maybe Name -> Position -> [Name] -> Fragment -> Validator ctx Fragment +castFragmentType key position typeMembers fragment@Fragment { fragmentType } + | fragmentType `elem` typeMembers = pure fragment + | otherwise = failure $ cannotBeSpreadOnType key fragmentType position typeMembers -resolveSpread :: FragmentLib -> [Text] -> Ref -> Validation Fragment -resolveSpread fragments allowedTargets reference@Ref { refName, refPosition } = - getFragment reference fragments +resolveSpread :: [Name] -> Ref -> Validator ctx Fragment +resolveSpread allowedTargets ref@Ref { refName, refPosition } + = askFragments + >>= selectKnown ref >>= castFragmentType (Just refName) refPosition allowedTargets -usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node] -usedFragments fragments = concatMap (findAllUses . snd) +usedFragments :: Fragments -> [Selection RAW] -> [Node] +usedFragments fragments = concatMap findAllUses where - findAllUses :: RawSelection -> [Node] + findAllUses :: Selection RAW -> [Node] findAllUses Selection { selectionContent = SelectionField } = [] findAllUses Selection { selectionContent = SelectionSet selectionSet } = - concatMap (findAllUses . snd) selectionSet + concatMap findAllUses selectionSet findAllUses (InlineFragment Fragment { fragmentSelection }) = - concatMap (findAllUses . snd) fragmentSelection + concatMap findAllUses fragmentSelection findAllUses (Spread Ref { refName, refPosition }) = [Ref refName refPosition] <> searchInFragment where - searchInFragment = maybe - [] - (concatMap (findAllUses . snd) . fragmentSelection) - (lookup refName fragments) + searchInFragment = selectOr + [] + (concatMap findAllUses . fragmentSelection) + refName + fragments -scanForSpread :: (Text, RawSelection) -> [Node] -scanForSpread (_, Selection { selectionContent = SelectionField }) = [] -scanForSpread (_, Selection { selectionContent = SelectionSet selectionSet }) = +fragmentsConditionTypeChecking :: BaseValidator () +fragmentsConditionTypeChecking + = toList <$> askFragments + >>= traverse_ checkTypeExistence + +checkTypeExistence :: Fragment -> BaseValidator () +checkTypeExistence fr@Fragment { fragmentType, fragmentPosition } + = askSchema + >>= selectKnown (Ref fragmentType fragmentPosition) + >>= constraint OBJECT fr + >> pure () + +fragmentsCycleChecking :: BaseValidator () +fragmentsCycleChecking = exploreSpreads >>= fragmentCycleChecking + +exploreSpreads :: BaseValidator Graph +exploreSpreads = map exploreFragmentSpreads . toList <$> askFragments + +exploreFragmentSpreads :: Fragment -> NodeEdges +exploreFragmentSpreads Fragment { fragmentName, fragmentSelection, fragmentPosition } + = ( Ref fragmentName fragmentPosition, concatMap scanForSpread fragmentSelection) + +scanForSpread :: Selection RAW -> [Node] +scanForSpread Selection { selectionContent = SelectionField } = [] +scanForSpread Selection { selectionContent = SelectionSet selectionSet } = concatMap scanForSpread selectionSet -scanForSpread (_, InlineFragment Fragment { fragmentSelection = selection' }) = - concatMap scanForSpread selection' -scanForSpread (_, Spread Ref { refName = name', refPosition = position' }) = - [Ref name' position'] +scanForSpread (InlineFragment Fragment { fragmentSelection }) = + concatMap scanForSpread fragmentSelection +scanForSpread (Spread Ref { refName, refPosition }) = + [Ref refName refPosition] -validateFragment :: Schema -> (Text, Fragment) -> Validation NodeEdges -validateFragment lib (fName, Fragment { fragmentSelection, fragmentType, fragmentPosition }) - = (lookupResult validationError fragmentType lib :: Validation ( Name, DataObject) )>> pure - (Ref fName fragmentPosition, concatMap scanForSpread fragmentSelection) - where validationError = unknownType fragmentType fragmentPosition +type Node = Ref -detectLoopOnFragments :: Graph -> Validation () -detectLoopOnFragments lib = mapM_ checkFragment lib +type NodeEdges = (Node, [Node]) + +type Graph = [NodeEdges] + +fragmentCycleChecking :: Graph -> BaseValidator () +fragmentCycleChecking lib = traverse_ checkFragment lib where checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID] -checkForCycle :: Graph -> Node -> [Node] -> Validation Graph +checkForCycle :: Graph -> Node -> [Node] -> BaseValidator Graph checkForCycle lib parentNode history = case lookup parentNode lib of - Just node -> concat <$> mapM checkNode node + Just node -> concat <$> traverse checkNode node Nothing -> pure [] where checkNode x = if x `elem` history then cycleError x else recurse x 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 @@ -5,52 +5,58 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Data.Morpheus.Validation.Query.Selection - ( validateSelectionSet + ( validateOperation ) where -import Data.Maybe ( fromMaybe ) -import Data.Text ( Text ) +import Data.Semigroup ( (<>) ) -- MORPHEUS -import Data.Morpheus.Error.Selection ( cannotQueryField - , duplicateQuerySelections - , hasNoSubfields +import Data.Morpheus.Error.Selection ( hasNoSubfields , subfieldsNotSelected ) -import Data.Morpheus.Error.Variable ( unknownType ) import Data.Morpheus.Types.Internal.AST - ( ValidVariables - , Selection(..) + ( Selection(..) , SelectionContent(..) - , ValidSelection - , ValidSelectionSet , Fragment(..) - , FragmentLib - , RawSelection - , RawSelectionSet - , DataField(..) + , SelectionSet + , FieldDefinition(..) + , FieldsDefinition(..) + , TypeContent(..) + , TypeDefinition(..) + , Operation(..) , Ref(..) - , DataObject - , DataTypeContent(..) - , DataType(..) - , Schema(..) - , TypeRef(..) , Name + , RAW + , VALID + , Arguments , isEntNode - , lookupFieldAsSelectionSet - , lookupSelectionField - , DataLookup(..) - , lookupUnionTypes - , checkNameCollision + , getOperationDataType + , GQLError(..) + , OperationType(..) ) -import Data.Morpheus.Types.Internal.Resolving - ( Validation +import Data.Morpheus.Types.Internal.AST.MergeSet + ( concatTraverse ) +import Data.Morpheus.Types.Internal.Operation + ( empty + , singleton , Failure(..) + , keyOf + , toList ) +import Data.Morpheus.Types.Internal.Validation + ( SelectionValidator + , askFieldType + , selectKnown + , withScope + , askSchema + ) +import Data.Morpheus.Validation.Query.UnionSelection + (validateUnionSelection) import Data.Morpheus.Validation.Query.Arguments ( validateArguments ) import Data.Morpheus.Validation.Query.Fragment @@ -58,177 +64,142 @@ , resolveSpread ) -checkDuplicatesOn :: Name -> ValidSelectionSet -> Validation ValidSelectionSet -checkDuplicatesOn typeName keys = checkNameCollision enhancedKeys selError - >> pure keys - where - selError = duplicateQuerySelections typeName - enhancedKeys = map selToKey keys - selToKey :: (Name, ValidSelection) -> Ref - selToKey (key, Selection { selectionPosition = position', selectionAlias }) = - Ref (fromMaybe key selectionAlias) position' +type TypeDef = (Name, FieldsDefinition) -clusterUnionSelection - :: FragmentLib - -> Text - -> [Name] - -> (Text, RawSelection) - -> Validation ([Fragment], ValidSelectionSet) -clusterUnionSelection fragments type' typeNames = splitFrag - where - packFragment fragment = return ([fragment], []) - splitFrag - :: (Text, RawSelection) -> Validation ([Fragment], ValidSelectionSet) - splitFrag (_, Spread ref) = - resolveSpread fragments typeNames ref >>= packFragment - 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 - :: [(Name, DataObject)] -> [Fragment] -> [((Name, DataObject), [Fragment])] -categorizeTypes types fragments = filter notEmpty $ map categorizeType types - where - notEmpty = (0 /=) . length . snd - categorizeType :: (Name, DataObject) -> ((Name, DataObject), [Fragment]) - categorizeType datatype = (datatype, filter matches fragments) - where matches fragment = fragmentType fragment == fst datatype +getOperationObject + :: Operation a -> SelectionValidator (Name, FieldsDefinition) +getOperationObject operation = do + dt <- askSchema >>= getOperationDataType operation + case dt of + TypeDefinition { typeContent = DataObject { objectFields }, typeName } -> pure (typeName, objectFields) + TypeDefinition { typeName } -> + failure + $ "Type Mismatch: operation \"" + <> typeName + <> "\" must be an Object" -flatTuple :: [([a], [b])] -> ([a], [b]) -flatTuple list' = (concatMap fst list', concatMap snd list') - {- - - all Variable and Fragment references will be: resolved and validated - - unionTypes: will be clustered under type names - ...A on T1 {} - ...B on T2 {} - ...C on T2 {} - will be become : [ - ("T1",[]), - ("T2",[,]) - ] - -} +selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID] +selectionsWitoutTypename = filter (("__typename" /=) . keyOf) . toList + +singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator () +singleTopLevelSelection Operation { operationType = Subscription , operationName } selSet = + case selectionsWitoutTypename selSet of + (_:xs) | not (null xs) -> failure $ map (singleTopLevelSelectionError operationName) xs + _ -> pure () +singleTopLevelSelection _ _ = pure () + +singleTopLevelSelectionError :: Maybe Name -> Selection VALID -> GQLError +singleTopLevelSelectionError name Selection { selectionPosition } = GQLError + { message + = subscriptionName <> " must select " + <> "only one top level field." + , locations = [selectionPosition] + } + where + subscriptionName = maybe "Anonymous Subscription" (("Subscription \"" <>) . (<> "\"")) name + +validateOperation + :: Operation RAW + -> SelectionValidator (Operation VALID) +validateOperation + rawOperation@Operation + { operationName + , operationType + , operationSelection + , operationPosition + } + = do + typeDef <- getOperationObject rawOperation + selection <- validateSelectionSet typeDef operationSelection + singleTopLevelSelection rawOperation selection + pure $ Operation + { operationName + , operationType + , operationArguments = empty + , operationSelection = selection + , operationPosition + } + + validateSelectionSet - :: Schema - -> FragmentLib - -> Text - -> ValidVariables - -> (Name, DataObject) - -> RawSelectionSet - -> Validation ValidSelectionSet -validateSelectionSet lib fragments' operatorName variables = __validate - where - __validate - :: (Name, DataObject) -> RawSelectionSet -> Validation ValidSelectionSet - __validate dataType@(typeName, objectFields) selectionSet = - concat - <$> mapM validateSelection selectionSet - >>= checkDuplicatesOn typeName + :: TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID) +validateSelectionSet dataType@(typeName,fieldsDef) = + concatTraverse validateSelection where - -- 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 <- lookupResult - (unknownType (typeConName $fieldType selectionField) selectionPosition) - (typeConName $ fieldType selectionField) - lib - return (selectionField, fieldDataType, arguments) -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet - -- - validateSelection :: (Text, RawSelection) -> Validation ValidSelectionSet - validateSelection ("__typename", sel@Selection { selectionArguments = [], selectionContent = SelectionField}) = - pure [("__typename", sel { selectionArguments = [], selectionContent = SelectionField })] - validateSelection (key', fullRawSelection@Selection { selectionArguments = selArgs, selectionContent = SelectionSet rawSelection, selectionPosition }) - = do - (dataField, datatype, arguments) <- getValidationData - key' - (selArgs, selectionPosition) - case typeContent datatype of - DataUnion _ -> do - (categories, __typename) <- clusterTypes - mapM (validateCluster __typename) categories - >>= returnSelection arguments - . UnionSelection + validateSelection :: Selection RAW -> SelectionValidator (SelectionSet VALID) + validateSelection + sel@Selection + { selectionName + , selectionArguments + , selectionContent + , selectionPosition + } + = withScope + typeName + currentSelectionRef + $ validateSelectionContent + selectionContent + where + currentSelectionRef = Ref selectionName selectionPosition + commonValidation :: SelectionValidator (TypeDefinition, Arguments VALID) + commonValidation = do + (fieldDef :: FieldDefinition) <- selectKnown (Ref selectionName selectionPosition) fieldsDef + -- validate field Argument ----- + arguments <- validateArguments + fieldDef + selectionArguments + -- check field Type existence ----- + (typeDef :: TypeDefinition) <- askFieldType fieldDef + pure (typeDef, arguments) + ----------------------------------------------------------------------------------- + validateSelectionContent :: SelectionContent RAW -> SelectionValidator (SelectionSet VALID) + validateSelectionContent SelectionField + | null selectionArguments && selectionName == "__typename" + = pure $ singleton $ sel { selectionArguments = empty, selectionContent = SelectionField } + | otherwise = do + (datatype, validArgs) <- commonValidation + isLeaf datatype + pure $ singleton $ sel { selectionArguments = validArgs, selectionContent = SelectionField } + where + ------------------------------------------------------------ + isLeaf :: TypeDefinition -> SelectionValidator () + isLeaf TypeDefinition { typeName = typename, typeContent } + | isEntNode typeContent = pure () + | otherwise = failure + $ subfieldsNotSelected selectionName typename selectionPosition + ----- SelectionSet + validateSelectionContent (SelectionSet rawSelectionSet) + = do + (TypeDefinition { typeName = name , typeContent}, validArgs) <- commonValidation + selContent <- withScope name currentSelectionRef $ validateByTypeContent name typeContent + pure $ singleton $ sel { selectionArguments = validArgs, selectionContent = selContent } where - clusterTypes = do - unionTypes <- lookupUnionTypes selectionPosition - key' - lib - dataField - (spreads, __typename) <- - flatTuple - <$> mapM - ( clusterUnionSelection fragments' typeName - $ fst - <$> unionTypes - ) - rawSelection - return (categorizeTypes unionTypes spreads, __typename) - -- - -- second arguments will be added to every selection cluster - validateCluster - :: ValidSelectionSet - -> ((Name, DataObject), [Fragment]) - -> Validation (Text, ValidSelectionSet) - validateCluster sysSelection' (type', frags') = do - selection' <- __validate type' - (concatMap fragmentSelection frags') - return (fst type', sysSelection' ++ selection') - DataObject {} -> do - fieldType' <- lookupFieldAsSelectionSet selectionPosition - key' - lib - dataField - __validate fieldType' rawSelection - >>= returnSelection arguments - . SelectionSet - _ -> failure $ hasNoSubfields key' - (typeConName $fieldType dataField) - selectionPosition - where - returnSelection selectionArguments selectionContent = - pure [(key', fullRawSelection { selectionArguments, selectionContent })] - validateSelection (key, rawSelection@Selection { selectionArguments = selArgs, selectionPosition, selectionContent = SelectionField }) - = do - (dataField, datatype, selectionArguments) <- getValidationData - key - (selArgs, selectionPosition) - isLeaf (typeContent datatype) dataField - pure - [ ( key - , rawSelection { selectionArguments, selectionContent = SelectionField } - ) - ] - where - isLeaf datatype DataField { fieldType = TypeRef { typeConName } } - | isEntNode datatype = pure () - | otherwise = failure - $ subfieldsNotSelected key typeConName selectionPosition - validateSelection (_, Spread reference') = - resolveSpread fragments' [typeName] reference' >>= validateFragment - validateSelection (_, InlineFragment fragment') = - castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment' + validateByTypeContent :: Name -> TypeContent -> SelectionValidator (SelectionContent VALID) + -- Validate UnionSelection + validateByTypeContent _ DataUnion { unionMembers } + = validateUnionSelection + validateSelectionSet + rawSelectionSet + unionMembers + -- Validate Regular selection set + validateByTypeContent typename DataObject { objectFields } + = SelectionSet + <$> validateSelectionSet + (typename, objectFields) + rawSelectionSet + validateByTypeContent typename _ + = failure + $ hasNoSubfields + (Ref selectionName selectionPosition) + typename + validateSelection (Spread ref) + = resolveSpread [typeName] ref >>= validateFragment - validateFragment Fragment { fragmentSelection } = __validate dataType fragmentSelection + validateSelection (InlineFragment fragment') + = castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment' + >>= validateFragment + -------------------------------------------------------------------------------- + validateFragment Fragment { fragmentSelection } = validateSelectionSet dataType fragmentSelection diff --git a/src/Data/Morpheus/Validation/Query/UnionSelection.hs b/src/Data/Morpheus/Validation/Query/UnionSelection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/UnionSelection.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Morpheus.Validation.Query.UnionSelection + ( validateUnionSelection + ) +where + + +import Control.Monad ((>=>)) + +-- MORPHEUS +import Data.Morpheus.Error.Selection ( unknownSelectionField ) +import Data.Morpheus.Types.Internal.AST + ( Selection(..) + , SelectionContent(..) + , Fragment(..) + , SelectionSet + , FieldsDefinition(..) + , Name + , RAW + , VALID + , SelectionSet + , UnionTag(..) + , Ref(..) + , DataUnion + ) +import qualified Data.Morpheus.Types.Internal.AST.MergeSet as MS + ( join ) +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) + , selectOr + , empty + , singleton + , Failure(..) + ) +import Data.Morpheus.Types.Internal.Validation + ( SelectionValidator + , askTypeMember + , askScopeTypeName + ) +import Data.Morpheus.Validation.Query.Fragment + ( castFragmentType + , resolveSpread + ) + + +type TypeDef = (Name, FieldsDefinition) + +-- returns all Fragments used in Union +exploreUnionFragments + :: [Name] + -> Selection RAW + -> SelectionValidator [Fragment] +exploreUnionFragments unionTags = splitFrag + where + packFragment fragment = [fragment] + splitFrag + :: Selection RAW -> SelectionValidator [Fragment] + splitFrag (Spread ref) = packFragment <$> resolveSpread unionTags ref + splitFrag Selection { selectionName = "__typename",selectionContent = SelectionField } = pure [] + splitFrag Selection { selectionName, selectionPosition } = do + typeName <- askScopeTypeName + failure $ unknownSelectionField typeName (Ref selectionName selectionPosition) + splitFrag (InlineFragment fragment) = packFragment <$> + castFragmentType Nothing (fragmentPosition fragment) unionTags fragment + +-- sorts Fragment by contitional Types +-- [ +-- ( Type for Tag User , [ Fragment for User] ) +-- ( Type for Tag Product , [ Fragment for Product] ) +-- ] +tagUnionFragments + :: [TypeDef] -> [Fragment] -> [(TypeDef, [Fragment])] +tagUnionFragments types fragments + = filter notEmpty + $ map categorizeType types + where + notEmpty = not . null . snd + categorizeType :: (Name, FieldsDefinition) -> (TypeDef, [Fragment]) + categorizeType datatype = (datatype, filter matches fragments) + where matches fragment = fragmentType fragment == fst datatype + + +{- + - all Variable and Fragment references will be: resolved and validated + - unionTypes: will be clustered under type names + ...A on T1 {} + ...B on T2 {} + ...C on T2 {} + will be become : [ + UnionTag "T1" {}, + UnionTag "T2" {,} + ] + -} +validateCluster + :: (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) + -> SelectionSet RAW + -> [(TypeDef, [Fragment])] + -> SelectionValidator (SelectionContent VALID) +validateCluster validator __typename = traverse _validateCluster >=> fmap UnionSelection . fromList + where + _validateCluster :: (TypeDef, [Fragment]) -> SelectionValidator UnionTag + _validateCluster (unionType, fragmets) = do + fragmentSelections <- MS.join (__typename:map fragmentSelection fragmets) + UnionTag (fst unionType) <$> validator unionType fragmentSelections + +validateUnionSelection + :: (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) + -> SelectionSet RAW + -> DataUnion + -> SelectionValidator (SelectionContent VALID) +validateUnionSelection validate selectionSet members = do + let (__typename :: SelectionSet RAW) = selectOr empty singleton "__typename" selectionSet + -- get union Types defined in GraphQL schema -> (union Tag, union Selection set) + -- [("User", FieldsDefinition { ... }), ("Product", FieldsDefinition { ... + unionTypes <- traverse askTypeMember members + -- find all Fragments used in Selection + spreads <- concat <$> traverse (exploreUnionFragments members) (toList selectionSet) + let categories = tagUnionFragments unionTypes spreads + validateCluster validate __typename categories 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 @@ -1,7 +1,9 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Validation.Query.Validation ( validateRequest @@ -11,43 +13,62 @@ import Data.Map ( fromList ) import Data.Morpheus.Types.Internal.AST ( Operation(..) - , ValidOperation - , getOperationName - , getOperationObject + , VALID , Schema(..) , GQLQuery(..) , VALIDATION_MODE ) +import Data.Morpheus.Types.Internal.Validation + ( Context(..) + , runValidator + , SelectionContext(..) + ) import Data.Morpheus.Types.Internal.Resolving - ( Validation ) + ( Eventless ) import Data.Morpheus.Validation.Query.Fragment ( validateFragments ) import Data.Morpheus.Validation.Query.Selection - ( validateSelectionSet ) + ( validateOperation ) import Data.Morpheus.Validation.Query.Variable ( resolveOperationVariables ) validateRequest - :: Schema -> VALIDATION_MODE -> GQLQuery -> Validation ValidOperation -validateRequest lib validationMode GQLQuery { fragments, inputVariables, operation = rawOperation@Operation { operationName, operationType, operationSelection, operationPosition } } + :: Schema + -> VALIDATION_MODE + -> GQLQuery + -> Eventless (Operation VALID) +validateRequest + schema + validationMode + GQLQuery + { fragments + , inputVariables, + operation = operation@Operation + { operationName + , operationSelection + , operationPosition + } + } = do - operationDataType <- getOperationObject rawOperation lib - variables <- resolveOperationVariables lib - fragments - (fromList inputVariables) - validationMode - rawOperation - validateFragments lib fragments operationSelection - selection <- validateSelectionSet lib - fragments - (getOperationName operationName) - variables - operationDataType - operationSelection - pure $ Operation { operationName - , operationType - , operationArguments = [] - , operationSelection = selection - , operationPosition - } + variables <- runValidator validateHelpers ctx () + runValidator + (validateOperation operation) + ctx + SelectionContext + { variables } + where + ctx = Context + { schema + , fragments + , scopeTypeName = "Root" + , scopeSelectionName = "Root" + , scopePosition = operationPosition + , operationName + } + validateHelpers = + validateFragments operationSelection *> + resolveOperationVariables + (fromList inputVariables) + validationMode + operation 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 @@ -8,172 +8,162 @@ ) where -import Data.List ( (\\) ) + import qualified Data.Map as M ( lookup ) import Data.Maybe ( maybe ) import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) --- MORPHEUS -import Data.Morpheus.Error.Input ( inputErrorMessage ) -import Data.Morpheus.Error.Variable ( uninitializedVariable - , unknownType - , unusedVariables - , variableGotInvalidValue - ) +import Data.Morpheus.Error.Variable ( uninitializedVariable) import Data.Morpheus.Types.Internal.AST ( DefaultValue , Operation(..) - , RawOperation - , ValidVariables , Variable(..) - , getOperationName + , VariableDefinitions , Fragment(..) - , FragmentLib , Argument(..) - , RawArgument , Selection(..) , SelectionContent(..) - , RawSelection - , RawSelectionSet + , SelectionSet , Ref(..) - , Position - , DataType - , Schema - , lookupInputType + , TypeDefinition , Variables , Value(..) , ValidValue , RawValue , ResolvedValue - , Name , VALID , RAW , VariableContent(..) , isNullable , TypeRef(..) , VALIDATION_MODE(..) + , ObjectEntry(..) ) -import Data.Morpheus.Types.Internal.Resolving - ( Validation +import Data.Morpheus.Types.Internal.Operation + ( Listable(..) , Failure(..) ) +import Data.Morpheus.Types.Internal.Validation + ( BaseValidator + , askSchema + , askFragments + , selectKnown + , constraint + , Constraint(..) + , withScopePosition + , startInput + , InputSource(..) + , checkUnused + ) import Data.Morpheus.Validation.Internal.Value - ( validateInputValue ) -import Data.Morpheus.Validation.Query.Fragment - ( getFragment ) - -getVariableType :: Text -> Position -> Schema -> Validation DataType -getVariableType type' position' lib' = lookupInputType type' lib' error' - where error' = unknownType type' position' - -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f = fmap concat . mapM f - + ( validateInput ) class ExploreRefs a where exploreRefs :: a -> [Ref] instance ExploreRefs RawValue where exploreRefs (VariableValue ref ) = [ref] - exploreRefs (Object fields) = concatMap (exploreRefs . snd) fields + exploreRefs (Object fields) = concatMap (exploreRefs . entryValue) fields exploreRefs (List ls ) = concatMap exploreRefs ls exploreRefs _ = [] -instance ExploreRefs (Text, RawArgument) where - exploreRefs (_, Argument { argumentValue }) = exploreRefs argumentValue +instance ExploreRefs (Argument RAW) where + exploreRefs = exploreRefs . argumentValue -allVariableRefs :: FragmentLib -> [RawSelectionSet] -> Validation [Ref] -allVariableRefs fragmentLib = concatMapM (concatMapM searchRefs) - where +mapSelection :: (Selection RAW -> BaseValidator [b]) -> SelectionSet RAW -> BaseValidator [b] +mapSelection f = fmap concat . traverse f +allVariableRefs :: [SelectionSet RAW] -> BaseValidator [Ref] +allVariableRefs = fmap concat . traverse (mapSelection searchRefs) + where -- | search used variables in every arguments - searchRefs :: (Text, RawSelection) -> Validation [Ref] - searchRefs (_, Selection { selectionArguments, selectionContent = SelectionField }) + searchRefs :: Selection RAW -> BaseValidator [Ref] + searchRefs Selection { selectionArguments, selectionContent = SelectionField } = return $ concatMap exploreRefs selectionArguments - searchRefs (_, Selection { selectionArguments, selectionContent = SelectionSet selSet }) - = getArgs <$> concatMapM searchRefs selSet + searchRefs Selection { selectionArguments, selectionContent = SelectionSet selSet } + = getArgs <$> mapSelection searchRefs selSet where getArgs :: [Ref] -> [Ref] getArgs x = concatMap exploreRefs selectionArguments <> x - searchRefs (_, InlineFragment Fragment { fragmentSelection }) = - concatMapM searchRefs fragmentSelection - searchRefs (_, Spread reference) = - getFragment reference fragmentLib - >>= concatMapM searchRefs + searchRefs (InlineFragment Fragment { fragmentSelection }) + = mapSelection searchRefs fragmentSelection + searchRefs (Spread reference) + = askFragments + >>= selectKnown reference + >>= mapSelection searchRefs . fragmentSelection resolveOperationVariables - :: Schema - -> FragmentLib - -> Variables + :: Variables -> VALIDATION_MODE - -> RawOperation - -> Validation ValidVariables -resolveOperationVariables typeLib lib root validationMode Operation { operationName, operationSelection, operationArguments } - = do - allVariableRefs lib [operationSelection] >>= checkUnusedVariables - mapM (lookupAndValidateValueOnBody typeLib root validationMode) - operationArguments + -> Operation RAW + -> BaseValidator (VariableDefinitions VALID) +resolveOperationVariables + root + validationMode + Operation + { operationSelection + , operationArguments + } + = checkUnusedVariables *> + traverse (lookupAndValidateValueOnBody root validationMode) operationArguments where - varToKey :: (Text, Variable a) -> Ref - varToKey (key', Variable { variablePosition }) = Ref key' variablePosition - -- - checkUnusedVariables :: [Ref] -> Validation () - checkUnusedVariables refs = case map varToKey operationArguments \\ refs of - [] -> pure () - unused' -> - failure $ unusedVariables (getOperationName operationName) unused' + checkUnusedVariables :: BaseValidator () + checkUnusedVariables = do + uses <- allVariableRefs [operationSelection] + checkUnused uses (toList operationArguments) lookupAndValidateValueOnBody - :: Schema - -> Variables + :: Variables -> VALIDATION_MODE - -> (Text, Variable RAW) - -> Validation (Text, Variable VALID) -lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType, variablePosition, variableValue = DefaultValue defaultValue }) - = toVariable - <$> ( getVariableType (typeConName variableType) variablePosition typeLib - >>= checkType getVariable defaultValue + -> Variable RAW + -> BaseValidator (Variable VALID) +lookupAndValidateValueOnBody + bodyVariables + validationMode + var@Variable { + variableName, + variableType, + variablePosition, + variableValue = DefaultValue defaultValue + } + = withScopePosition variablePosition + $ toVariable + <$> ( askSchema + >>= selectKnown (Ref (typeConName variableType) variablePosition) + >>= constraint INPUT var + >>= checkType getVariable defaultValue ) where - toVariable (varKey, x) = - (varKey, var { variableValue = ValidVariableValue x }) + toVariable x = var { variableValue = ValidVariableValue x } getVariable :: Maybe ResolvedValue - getVariable = M.lookup key bodyVariables + getVariable = M.lookup variableName bodyVariables ------------------------------------------------------------------ -- checkType :: checkType :: Maybe ResolvedValue -> DefaultValue - -> DataType - -> Validation (Name, ValidValue) + -> TypeDefinition + -> BaseValidator 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 && not (isNullable variableType) - = failure - $ uninitializedVariable variablePosition (typeConName variableType) key + = failure $ uninitializedVariable var | otherwise = returnNull where returnNull = - maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables) + maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables) ----------------------------------------------------------------------------------------------- - validator :: DataType -> ResolvedValue -> Validation (Name, ValidValue) - validator varType varValue = - case - validateInputValue typeLib - [] - (typeWrappers variableType) - varType - (key, varValue) - of - Left message -> failure $ case inputErrorMessage message of - Left errors -> errors - Right errMessage -> - variableGotInvalidValue key errMessage variablePosition - Right value -> pure (key, value) + validator :: TypeDefinition -> ResolvedValue -> BaseValidator ValidValue + validator varType varValue + = startInput (SourceVariable var) + $ validateInput + (typeWrappers variableType) + varType + (ObjectEntry variableName varValue) 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 @@ -54,8 +54,6 @@ importGQLDocument "test/Feature/Holistic/schema.gql" - - alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either" @@ -63,12 +61,15 @@ rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver { queryResolver = Query { user - , testUnion = pure Nothing + , testUnion = Just . TestUnionUser <$> user , fail1 = liftEither alwaysFail , fail2 = failRes "fail with failRes" } , mutationResolver = Mutation { createUser = const user } - , subscriptionResolver = Subscription { newUser = subscribe [Channel] (pure $ const user)} + , subscriptionResolver = Subscription + { newUser = subscribe [Channel] (pure $ const user) + , newAddress = subscribe [Channel] (pure resolveAddress) + } } where user :: Applicative m => m (User m) @@ -78,9 +79,9 @@ , office = resolveAddress , friend = pure Nothing } - where - resolveAddress :: Applicative m => a -> m (Address m) - resolveAddress _ = pure Address { city = pure "" + ----------------------------------------------------- + resolveAddress :: Applicative m => a -> m (Address m) + resolveAddress _ = pure Address { city = pure "" , houseNumber = pure 0 , street = const $ pure Nothing } diff --git a/test/Feature/Holistic/arguments/nameConflict/response.json b/test/Feature/Holistic/arguments/nameConflict/response.json --- a/test/Feature/Holistic/arguments/nameConflict/response.json +++ b/test/Feature/Holistic/arguments/nameConflict/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 3, - "column": 35 + "column": 26 } ] } diff --git a/test/Feature/Holistic/arguments/undefinedArgument/response.json b/test/Feature/Holistic/arguments/undefinedArgument/response.json --- a/test/Feature/Holistic/arguments/undefinedArgument/response.json +++ b/test/Feature/Holistic/arguments/undefinedArgument/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Required Argument: \"coordinates\" was not Defined", + "message": "Field \"address\" argument \"coordinates\" is required but not provided.", "locations": [ { "line": 3, diff --git a/test/Feature/Holistic/arguments/unknownArguments/query.gql b/test/Feature/Holistic/arguments/unknownArguments/query.gql --- a/test/Feature/Holistic/arguments/unknownArguments/query.gql +++ b/test/Feature/Holistic/arguments/unknownArguments/query.gql @@ -1,5 +1,5 @@ { - user (name:bal , parent:sa ){ + user (name:bal , parent:sa ) { name } } diff --git a/test/Feature/Holistic/arguments/unknownArguments/response.json b/test/Feature/Holistic/arguments/unknownArguments/response.json --- a/test/Feature/Holistic/arguments/unknownArguments/response.json +++ b/test/Feature/Holistic/arguments/unknownArguments/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 2, - "column": 14 + "column": 9 } ] }, @@ -14,7 +14,7 @@ "locations": [ { "line": 2, - "column": 27 + "column": 20 } ] } 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 @@ -28,14 +28,22 @@ "description": "fail when: is not selected subFields on object type" }, { - "path": "selection/nameConflict", - "description": "fail when: selected fields has same name" + "path": "selection/mergeConflict/arguments", + "description": "fail when: selections with on same fields have different arguments" }, { - "path": "selection/AliasNameConflict", - "description": "fail when: selected alias has same name" + "path": "selection/mergeConflict/union", + "description": "fail when: conflicting union" }, { + "path": "selection/mergeUnionSelection", + "description": "merge union selections" + }, + { + "path": "selection/mergeConflict/alias", + "description": "fail when: selections on different fields have same alias" + }, + { "path": "selection/AliasResolve", "description": "resolves same field with different name" }, @@ -64,6 +72,14 @@ "description": "fail when: fragments are defined with same name" }, { + "path": "fragment/conditionTypeViolation", + "description": "fail when: condtion type is not an Object" + }, + { + "path": "fragment/unknownConditionType", + "description": "fail when: condtion type is not defined by schema" + }, + { "path": "parsing/duplicatedFields", "description": "fail when: user supplies duplicated fields" }, @@ -92,6 +108,10 @@ "description": "fails on a query with too many commas" }, { + "path": "parsing/inputListValues", + "description": "returns query when input list values are separated by newlines or commas" + }, + { "path": "parsing/notNullSpacing", "description": "returns on a query that pads all '!' chars with whitespace" }, @@ -234,5 +254,17 @@ { "path": "selection/__typename", "description": "test __typename on object types" + }, + { + "path": "selection/mergeSelection", + "description": "merge selection on same fields" + }, + { + "path": "selection/subscription/singleTopLevelField/fail", + "description": "fail if subscription selects more then one top level field." + }, + { + "path": "selection/subscription/singleTopLevelField/failAnonymous", + "description": "fail if subscription selects more then one top level field. (for anonymous subscription)" } ] diff --git a/test/Feature/Holistic/fragment/conditionTypeViolation/query.gql b/test/Feature/Holistic/fragment/conditionTypeViolation/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/fragment/conditionTypeViolation/query.gql @@ -0,0 +1,8 @@ +{ + user { + ...MyFragment + } +} +fragment MyFragment on Coordinates { + latitude +} diff --git a/test/Feature/Holistic/fragment/conditionTypeViolation/response.json b/test/Feature/Holistic/fragment/conditionTypeViolation/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/fragment/conditionTypeViolation/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "Fragment \"MyFragment\" cannot condition on non composite type \"Coordinates\".", + "locations": [ + { + "line": 6, + "column": 10 + } + ] + } + ] +} 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 @@ -3,9 +3,92 @@ { "message": "Cannot spread fragment \"A\" within itself via A, A, C.", "locations": [ - { "line": 17, "column": 3 }, - { "line": 7, "column": 10 }, - { "line": 9, "column": 3 } + { + "line": 17, + "column": 3 + }, + { + "line": 7, + "column": 10 + }, + { + "line": 9, + "column": 3 + } + ] + }, + { + "message": "Cannot spread fragment \"C\" within itself via C, B, C, A.", + "locations": [ + { + "line": 9, + "column": 3 + }, + { + "line": 12, + "column": 10 + }, + { + "line": 13, + "column": 3 + }, + { + "line": 17, + "column": 3 + } + ] + }, + { + "message": "Cannot spread fragment \"C\" within itself via C, C, A.", + "locations": [ + { + "line": 9, + "column": 3 + }, + { + "line": 16, + "column": 10 + }, + { + "line": 17, + "column": 3 + } + ] + }, + { + "message": "Fragment \"A\" is never used.", + "locations": [ + { + "line": 7, + "column": 10 + } + ] + }, + { + "message": "Fragment \"B\" is never used.", + "locations": [ + { + "line": 12, + "column": 10 + } + ] + }, + { + "message": "Fragment \"C\" is never used.", + "locations": [ + { + "line": 16, + "column": 10 + } + ] + }, + { + "message": "Fragment \"D\" is never used.", + "locations": [ + { + "line": 20, + "column": 10 + } ] } ] diff --git a/test/Feature/Holistic/fragment/unknownConditionType/query.gql b/test/Feature/Holistic/fragment/unknownConditionType/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/fragment/unknownConditionType/query.gql @@ -0,0 +1,8 @@ +{ + user { + ...MyFragment + } +} +fragment MyFragment on BjsK { + name +} diff --git a/test/Feature/Holistic/fragment/unknownConditionType/response.json b/test/Feature/Holistic/fragment/unknownConditionType/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/fragment/unknownConditionType/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "Unknown type \"BjsK\".", + "locations": [ + { + "line": 6, + "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 @@ -1,32 +1,67 @@ { "errors": [ { - "message": "Argument coordinates got invalid value ;on longitude Expected type \"Int\" found [null,[[],[{\"uid\":\"1\"}]]].", - "locations": [{ "line": 8, "column": 36 }] + "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null,[[],[{\"uid\":\"1\"}]]].", + "locations": [ + { + "line": 8, + "column": 23 + } + ] }, { - "message": "Argument coordinates got invalid value ;on longitude Expected type \"Int\" found [].", - "locations": [{ "line": 11, "column": 36 }] + "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [].", + "locations": [ + { + "line": 11, + "column": 23 + } + ] }, { - "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".", - "locations": [{ "line": 15, "column": 21 }] + "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found \"HH\".", + "locations": [ + { + "line": 15, + "column": 25 + } + ] }, { - "message": "Argument cityID got invalid value ; Expected type \"TestEnum\" found \"HH\".", - "locations": [{ "line": 15, "column": 33 }] + "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".", + "locations": [ + { + "line": 15, + "column": 21 + } + ] }, { "message": "Cannot query field \"home\" on type \"User\".", - "locations": [{ "line": 25, "column": 5 }] + "locations": [ + { + "line": 25, + "column": 5 + } + ] }, { "message": "Cannot query field \"myUnion\" on type \"User\".", - "locations": [{ "line": 26, "column": 18 }] + "locations": [ + { + "line": 26, + "column": 18 + } + ] }, { "message": "Cannot query field \"myUnion\" on type \"User\".", - "locations": [{ "line": 32, "column": 18 }] + "locations": [ + { + "line": 32, + "column": 18 + } + ] } ] } diff --git a/test/Feature/Holistic/parsing/directive/notOnArgument/response.json b/test/Feature/Holistic/parsing/directive/notOnArgument/response.json --- a/test/Feature/Holistic/parsing/directive/notOnArgument/response.json +++ b/test/Feature/Holistic/parsing/directive/notOnArgument/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', IgnoredTokens, assignment, or white space\n", + "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', Argument, IgnoredTokens, or white space\n", "locations": [ { "line": 2, diff --git a/test/Feature/Holistic/parsing/duplicatedFields/response.json b/test/Feature/Holistic/parsing/duplicatedFields/response.json --- a/test/Feature/Holistic/parsing/duplicatedFields/response.json +++ b/test/Feature/Holistic/parsing/duplicatedFields/response.json @@ -1,13 +1,7 @@ { - "errors": [ - { - "message": "duplicate selection of key \"email\" on type \"User\".", - "locations": [ - { - "line": 1, - "column": 17 - } - ] + "data": { + "user": { + "email": "" } - ] + } } diff --git a/test/Feature/Holistic/parsing/extraCommas/query.gql b/test/Feature/Holistic/parsing/extraCommas/query.gql --- a/test/Feature/Holistic/parsing/extraCommas/query.gql +++ b/test/Feature/Holistic/parsing/extraCommas/query.gql @@ -1,24 +1,24 @@ { - user {name,,,address} + user {name,,,email} - user {name, ,address} + user {name, ,email} - user {name , address , } + user {name , email , } user { name, - address + email } user { - name,address + name,email } user { - name, address + name, email } user { - name ,address + name ,email } } diff --git a/test/Feature/Holistic/parsing/extraCommas/response.json b/test/Feature/Holistic/parsing/extraCommas/response.json --- a/test/Feature/Holistic/parsing/extraCommas/response.json +++ b/test/Feature/Holistic/parsing/extraCommas/response.json @@ -1,32 +1,8 @@ { - "errors": [ - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 2, "column": 18 }] - }, - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 4, "column": 18 }] - }, - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 6, "column": 18 }] - }, - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 10, "column": 9 }] - }, - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 14, "column": 14 }] - }, - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 18, "column": 15 }] - }, - { - "message": "Required Argument: \"coordinates\" was not Defined", - "locations": [{ "line": 22, "column": 15 }] + "data": { + "user": { + "name": "testName", + "email": "" } - ] + } } diff --git a/test/Feature/Holistic/parsing/inputListValues/query.gql b/test/Feature/Holistic/parsing/inputListValues/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/inputListValues/query.gql @@ -0,0 +1,19 @@ +query GetUsers($v1: Int!, $v2: Int!, $v3: Int!) { + newlines: user { + office( + zipCode: [ + $v1 # Comment to prevent formatting + $v2 # Comment to prevent formatting + $v3 # Comment to prevent formatting + ] + cityID: EnumA + ) { + houseNumber + } + } + commas: user { + office(zipCode: [$v1, $v2, $v3], cityID: EnumA) { + houseNumber + } + } +} diff --git a/test/Feature/Holistic/parsing/inputListValues/response.json b/test/Feature/Holistic/parsing/inputListValues/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/inputListValues/response.json @@ -0,0 +1,14 @@ +{ + "data": { + "newlines": { + "office": { + "houseNumber": 0 + } + }, + "commas": { + "office": { + "houseNumber": 0 + } + } + } +} diff --git a/test/Feature/Holistic/parsing/inputListValues/variables.json b/test/Feature/Holistic/parsing/inputListValues/variables.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/inputListValues/variables.json @@ -0,0 +1,5 @@ +{ + "v1": 1, + "v2": 2, + "v3": 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 @@ -102,4 +102,5 @@ type Subscription { newUser: User! + newAddress: Address! } diff --git a/test/Feature/Holistic/selection/AliasNameConflict/query.gql b/test/Feature/Holistic/selection/AliasNameConflict/query.gql deleted file mode 100644 --- a/test/Feature/Holistic/selection/AliasNameConflict/query.gql +++ /dev/null @@ -1,8 +0,0 @@ -{ - user { - name2: name - name2: name - name2: name - name - } -} diff --git a/test/Feature/Holistic/selection/AliasNameConflict/response.json b/test/Feature/Holistic/selection/AliasNameConflict/response.json deleted file mode 100644 --- a/test/Feature/Holistic/selection/AliasNameConflict/response.json +++ /dev/null @@ -1,22 +0,0 @@ -{ - "errors": [ - { - "message": "duplicate selection of key \"name2\" on type \"User\".", - "locations": [ - { - "line": 4, - "column": 5 - } - ] - }, - { - "message": "duplicate selection of key \"name2\" on type \"User\".", - "locations": [ - { - "line": 5, - "column": 5 - } - ] - } - ] -} diff --git a/test/Feature/Holistic/selection/mergeConflict/alias/query.gql b/test/Feature/Holistic/selection/mergeConflict/alias/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeConflict/alias/query.gql @@ -0,0 +1,19 @@ +{ + user { + bla: email + email + bla: email + address(coordinates: {latitude:"", longitude: []}) { + city + bla : city + } + } + user { + address(coordinates: {latitude:"", longitude: []}) { + street + bla: houseNumber + } + city + bla: email + } +} diff --git a/test/Feature/Holistic/selection/mergeConflict/alias/response.json b/test/Feature/Holistic/selection/mergeConflict/alias/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeConflict/alias/response.json @@ -0,0 +1,25 @@ +{ + "errors": [ + { + "message": "Fields \"user\" conflict because subfields \"address\" conflict because \"city\" and \"houseNumber\" are different fields. Use different aliases on the fields to fetch both if this was intentional.", + "locations": [ + { + "line": 2, + "column": 8 + }, + { + "line": 6, + "column": 56 + }, + { + "line": 8, + "column": 25 + }, + { + "line": 14, + "column": 7 + } + ] + } + ] +} diff --git a/test/Feature/Holistic/selection/mergeConflict/arguments/query.gql b/test/Feature/Holistic/selection/mergeConflict/arguments/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeConflict/arguments/query.gql @@ -0,0 +1,19 @@ +{ + user { + bla: email + email + bla: email + address(coordinates: {latitude:"", longitude: 3}) { + city + houseNumber + } + } + user { + address(coordinates: {latitude:"", longitude: 2}) { + city + bla: houseNumber + } + name + bla: email + } +} diff --git a/test/Feature/Holistic/selection/mergeConflict/arguments/response.json b/test/Feature/Holistic/selection/mergeConflict/arguments/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeConflict/arguments/response.json @@ -0,0 +1,25 @@ +{ + "errors": [ + { + "message": "Fields \"user\" conflict because subfields \"address\" conflict because they have differing arguments. Use different aliases on the fields to fetch both if this was intentional.", + "locations": [ + { + "line": 2, + "column": 8 + }, + { + "line": 6, + "column": 55 + }, + { + "line": 6, + "column": 55 + }, + { + "line": 12, + "column": 55 + } + ] + } + ] +} diff --git a/test/Feature/Holistic/selection/mergeConflict/union/query.gql b/test/Feature/Holistic/selection/mergeConflict/union/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeConflict/union/query.gql @@ -0,0 +1,20 @@ +{ + testUnion { + ... on User { + name + email + address(coordinates: { latitude: "", longitude: 1 }) { + city: houseNumber + } + } + } + + testUnion { + ... on User { + name: email + address(coordinates: { latitude: "", longitude: 1 }) { + city + } + } + } +} diff --git a/test/Feature/Holistic/selection/mergeConflict/union/response.json b/test/Feature/Holistic/selection/mergeConflict/union/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeConflict/union/response.json @@ -0,0 +1,17 @@ +{ + "errors": [ + { + "message": "\"name\" and \"email\" are different fields. Use different aliases on the fields to fetch both if this was intentional.", + "locations": [ + { + "line": 4, + "column": 7 + }, + { + "line": 14, + "column": 7 + } + ] + } + ] +} diff --git a/test/Feature/Holistic/selection/mergeSelection/query.gql b/test/Feature/Holistic/selection/mergeSelection/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeSelection/query.gql @@ -0,0 +1,32 @@ +{ + user { + name + name + name + name2 : name + name2 : name + name2 : name + name: name + } + user { + name + name2 : name + } + user { + bla: email + email + bla: email + address(coordinates: {latitude:"", longitude: 2}) { + city + houseNumber + } + } + user { + address(coordinates: {latitude:"", longitude: 2}) { + city + bla: houseNumber + } + name + bla: email + } +} diff --git a/test/Feature/Holistic/selection/mergeSelection/response.json b/test/Feature/Holistic/selection/mergeSelection/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeSelection/response.json @@ -0,0 +1,15 @@ +{ + "data": { + "user": { + "name": "testName", + "name2": "testName", + "bla": "", + "email": "", + "address": { + "city": "", + "houseNumber": 0, + "bla": 0 + } + } + } +} diff --git a/test/Feature/Holistic/selection/mergeUnionSelection/query.gql b/test/Feature/Holistic/selection/mergeUnionSelection/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeUnionSelection/query.gql @@ -0,0 +1,19 @@ +{ + testUnion { + ... on User { + name + email + } + } + + testUnion { + ... on User { + name + email2: email + address(coordinates: { latitude: "", longitude: 1 }) { + city + } + } + } +} + diff --git a/test/Feature/Holistic/selection/mergeUnionSelection/response.json b/test/Feature/Holistic/selection/mergeUnionSelection/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/mergeUnionSelection/response.json @@ -0,0 +1,12 @@ +{ + "data": { + "testUnion": { + "name": "testName", + "email": "", + "email2": "", + "address": { + "city": "" + } + } + } +} diff --git a/test/Feature/Holistic/selection/nameConflict/query.gql b/test/Feature/Holistic/selection/nameConflict/query.gql deleted file mode 100644 --- a/test/Feature/Holistic/selection/nameConflict/query.gql +++ /dev/null @@ -1,7 +0,0 @@ -{ - user { - name - name - name - } -} diff --git a/test/Feature/Holistic/selection/nameConflict/response.json b/test/Feature/Holistic/selection/nameConflict/response.json deleted file mode 100644 --- a/test/Feature/Holistic/selection/nameConflict/response.json +++ /dev/null @@ -1,22 +0,0 @@ -{ - "errors": [ - { - "message": "duplicate selection of key \"name\" on type \"User\".", - "locations": [ - { - "line": 4, - "column": 5 - } - ] - }, - { - "message": "duplicate selection of key \"name\" on type \"User\".", - "locations": [ - { - "line": 5, - "column": 5 - } - ] - } - ] -} diff --git a/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql b/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql @@ -0,0 +1,8 @@ +subscription SomeTestSubscription { + newUser { + name + } + newAddress { + houseNumber + } +} diff --git a/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json b/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "Subscription \"SomeTestSubscription\" must select only one top level field.", + "locations": [ + { + "line": 5, + "column": 14 + } + ] + } + ] +} diff --git a/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql b/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql @@ -0,0 +1,11 @@ +subscription { + newUser { + name + } + newAddress { + houseNumber + } + address2: newAddress { + houseNumber + } +} diff --git a/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json b/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json @@ -0,0 +1,22 @@ +{ + "errors": [ + { + "message": "Anonymous Subscription must select only one top level field.", + "locations": [ + { + "line": 5, + "column": 14 + } + ] + }, + { + "message": "Anonymous Subscription must select only one top level field.", + "locations": [ + { + "line": 8, + "column": 24 + } + ] + } + ] +} diff --git a/test/Feature/Input/Enum/decodeInvalidValue/query.gql b/test/Feature/Input/Enum/decodeInvalidValue/query.gql --- a/test/Feature/Input/Enum/decodeInvalidValue/query.gql +++ b/test/Feature/Input/Enum/decodeInvalidValue/query.gql @@ -1,3 +1,3 @@ query ValidDecoding { - test2 (level:LK) + test2 ( level: LK ) } diff --git a/test/Feature/Input/Enum/decodeInvalidValue/response.json b/test/Feature/Input/Enum/decodeInvalidValue/response.json --- a/test/Feature/Input/Enum/decodeInvalidValue/response.json +++ b/test/Feature/Input/Enum/decodeInvalidValue/response.json @@ -1,11 +1,11 @@ { "errors": [ { - "message": "Argument level got invalid value ; Expected type \"TwoCon\" found \"LK\".", + "message": "Argument \"level\" got invalid value. Expected type \"TwoCon!\" found \"LK\".", "locations": [ { "line": 2, - "column": 16 + "column": 11 } ] } diff --git a/test/Feature/Input/Object/API.hs b/test/Feature/Input/Object/API.hs --- a/test/Feature/Input/Object/API.hs +++ b/test/Feature/Input/Object/API.hs @@ -25,7 +25,8 @@ data InputObject = InputObject { field :: Text, - nullableField :: Maybe Int + nullableField :: Maybe Int, + recursive :: Maybe InputObject } deriving (Generic, Show) instance GQLType InputObject where diff --git a/test/Feature/Input/Object/nullableUndefinedField/response.json b/test/Feature/Input/Object/nullableUndefinedField/response.json --- a/test/Feature/Input/Object/nullableUndefinedField/response.json +++ b/test/Feature/Input/Object/nullableUndefinedField/response.json @@ -1,5 +1,5 @@ { "data": { - "input": "InputObject {field = \"value\", nullableField = Nothing}" + "input": "InputObject {field = \"value\", nullableField = Nothing, recursive = Nothing}" } } diff --git a/test/Feature/Input/Object/resolveObject/query.gql b/test/Feature/Input/Object/resolveObject/query.gql --- a/test/Feature/Input/Object/resolveObject/query.gql +++ b/test/Feature/Input/Object/resolveObject/query.gql @@ -1,4 +1,4 @@ query ResolveObject { i1: input(value: { field: "v1", nullableField: 123 }) - i2: input(value: { field: "v2" }) + i2: input(value: { field: "v2" , recursive: { field: "v3" } }) } diff --git a/test/Feature/Input/Object/resolveObject/response.json b/test/Feature/Input/Object/resolveObject/response.json --- a/test/Feature/Input/Object/resolveObject/response.json +++ b/test/Feature/Input/Object/resolveObject/response.json @@ -1,6 +1,6 @@ { "data": { - "i1": "InputObject {field = \"v1\", nullableField = Just 123}", - "i2": "InputObject {field = \"v2\", nullableField = Nothing}" + "i1": "InputObject {field = \"v1\", nullableField = Just 123, recursive = Nothing}", + "i2": "InputObject {field = \"v2\", nullableField = Nothing, recursive = Just (InputObject {field = \"v3\", nullableField = Nothing, recursive = Nothing})}" } } diff --git a/test/Feature/Input/Object/resolveVariable/response.json b/test/Feature/Input/Object/resolveVariable/response.json --- a/test/Feature/Input/Object/resolveVariable/response.json +++ b/test/Feature/Input/Object/resolveVariable/response.json @@ -1,6 +1,6 @@ { "data": { - "i1": "InputObject {field = \"string from variable\", nullableField = Just 123011}", - "i2": "InputObject {field = \"\", nullableField = Nothing}" + "i1": "InputObject {field = \"string from variable\", nullableField = Just 123011, recursive = Nothing}", + "i2": "InputObject {field = \"\", nullableField = Nothing, recursive = Nothing}" } } diff --git a/test/Feature/Input/Object/undefinedField/query.gql b/test/Feature/Input/Object/undefinedField/query.gql --- a/test/Feature/Input/Object/undefinedField/query.gql +++ b/test/Feature/Input/Object/undefinedField/query.gql @@ -1,4 +1,5 @@ query UndefinedField { i1: input(value: { nullableField: 1 }) - i2: input(value: {}) + i2: input(value: { }) + i3: input(value: { field: "v2" , recursive: { field: "v3" , recursive: {} } }) } diff --git a/test/Feature/Input/Object/undefinedField/response.json b/test/Feature/Input/Object/undefinedField/response.json --- a/test/Feature/Input/Object/undefinedField/response.json +++ b/test/Feature/Input/Object/undefinedField/response.json @@ -1,12 +1,31 @@ { "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": 2, + "column": 13 + } + ] }, { - "message": "Argument value got invalid value ; Undefined Field \"field\".", - "locations": [{ "line": 3, "column": 20 }] + "message": "Argument \"value\" got invalid value. Undefined Field \"field\".", + "locations": [ + { + "line": 3, + "column": 13 + } + ] + }, + { + "message": "Argument \"value\" got invalid value. in field \"recursive.recursive\": Undefined Field \"field\".", + "locations": [ + { + "line": 4, + "column": 13 + } + ] } ] } diff --git a/test/Feature/Input/Object/unexpectedValue/query.gql b/test/Feature/Input/Object/unexpectedValue/query.gql --- a/test/Feature/Input/Object/unexpectedValue/query.gql +++ b/test/Feature/Input/Object/unexpectedValue/query.gql @@ -3,4 +3,7 @@ i2: input(value: 1) i3: input(value: { field: {} }) i4: input(value: { field: 3 }) + i5: input(value: { field: null } ) + # deep recursive + i6: input(value: { field: "v2" , recursive: { field: "v3" , recursive: { field: 5 } } }) } diff --git a/test/Feature/Input/Object/unexpectedValue/response.json b/test/Feature/Input/Object/unexpectedValue/response.json --- a/test/Feature/Input/Object/unexpectedValue/response.json +++ b/test/Feature/Input/Object/unexpectedValue/response.json @@ -1,20 +1,58 @@ { "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 \"some text\".", + "locations": [ + { + "line": 2, + "column": 13 + } + ] }, { - "message": "Argument value got invalid value ; Expected type \"InputObject!\" found 1.", - "locations": [{ "line": 3, "column": 20 }] + "message": "Argument \"value\" got invalid value. Expected type \"InputObject!\" found 1.", + "locations": [ + { + "line": 3, + "column": 13 + } + ] }, { - "message": "Argument value got invalid value ;on field Expected type \"String\" found {}.", - "locations": [{ "line": 4, "column": 20 }] + "message": "Argument \"value\" got invalid value. in field \"field\": Expected type \"String!\" found {}.", + "locations": [ + { + "line": 4, + "column": 13 + } + ] }, { - "message": "Argument value got invalid value ;on field Expected type \"String\" found 3.", - "locations": [{ "line": 5, "column": 20 }] + "message": "Argument \"value\" got invalid value. in field \"field\": Expected type \"String!\" found 3.", + "locations": [ + { + "line": 5, + "column": 13 + } + ] + }, + { + "message": "Argument \"value\" got invalid value. in field \"field\": Expected type \"String!\" found null.", + "locations": [ + { + "line": 6, + "column": 13 + } + ] + }, + { + "message": "Argument \"value\" got invalid value. in field \"recursive.recursive.field\": Expected type \"String!\" found 5.", + "locations": [ + { + "line": 8, + "column": 13 + } + ] } ] } diff --git a/test/Feature/Input/Object/unknownField/query.gql b/test/Feature/Input/Object/unknownField/query.gql --- a/test/Feature/Input/Object/unknownField/query.gql +++ b/test/Feature/Input/Object/unknownField/query.gql @@ -1,3 +1,4 @@ -query UndefinedField { - input(value: { moo: 1, field: "some field" }) +query UnknownField { + i1: input( value: { moo: 1, field: "some field" }) + i2: input(value: { field: "v2" , recursive: { field: "v3" , recursive: { field: "bal" , unkField : "test Unkown" } } }) } diff --git a/test/Feature/Input/Object/unknownField/response.json b/test/Feature/Input/Object/unknownField/response.json --- a/test/Feature/Input/Object/unknownField/response.json +++ b/test/Feature/Input/Object/unknownField/response.json @@ -1,8 +1,22 @@ { "errors": [ { - "message": "Argument value got invalid value ; Unknown Field \"moo\".", - "locations": [{ "line": 2, "column": 16 }] + "message": "Argument \"value\" got invalid value. Unknown Field \"moo\".", + "locations": [ + { + "line": 2, + "column": 14 + } + ] + }, + { + "message": "Argument \"value\" got invalid value. in field \"recursive.recursive\": Unknown Field \"unkField\".", + "locations": [ + { + "line": 3, + "column": 13 + } + ] } ] } diff --git a/test/Feature/InputType/cases.json b/test/Feature/InputType/cases.json --- a/test/Feature/InputType/cases.json +++ b/test/Feature/InputType/cases.json @@ -74,5 +74,13 @@ { "path": "variables/incompatibleType/weakerType3", "description": "weaker types are invalid" + }, + { + "path": "variables/nameCollision", + "description": "fail on: variable name collision" + }, + { + "path": "variables/nonInputTypeViolation", + "description": "fail on: non-input type in variable definition" } ] diff --git a/test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json b/test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json --- a/test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json +++ b/test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Variable \"$v1\" got invalid value; Expected type \"[[[Int!]!]]!\" found {\"id\":\"12\"}.", + "message": "Variable \"$v1\" got invalid value. Expected type \"[[[Int!]!]]!\" found {\"id\":\"12\"}.", "locations": [ { "line": 1, diff --git a/test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json b/test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json --- a/test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json +++ b/test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Variable \"$v1\" got invalid value; Expected type \"[Int!]!\" found \"boo\".", + "message": "Variable \"$v1\" got invalid value. Expected type \"[Int!]!\" found \"boo\".", "locations": [ { "line": 1, diff --git a/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json b/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json --- a/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json +++ b/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Variable \"$v1\" got invalid value; Expected type \"String!\" found null.", + "message": "Variable \"$v1\" got invalid value. Expected type \"String!\" found null.", "locations": [ { "line": 1, diff --git a/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json --- a/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json +++ b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Variable \"$v1\" got invalid value; Expected type \"[Int!]!\" found null.", + "message": "Variable \"$v1\" got invalid value. Expected type \"[Int!]!\" found null.", "locations": [ { "line": 1, diff --git a/test/Feature/InputType/variables/nameCollision/query.gql b/test/Feature/InputType/variables/nameCollision/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/InputType/variables/nameCollision/query.gql @@ -0,0 +1,5 @@ +query variableNameCollision($v1: String!, $v1: String! ) { + q1 { + a2(argList: $v1) + } +} diff --git a/test/Feature/InputType/variables/nameCollision/response.json b/test/Feature/InputType/variables/nameCollision/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/InputType/variables/nameCollision/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "There can Be only One Variable Named \"v1\"", + "locations": [ + { + "line": 1, + "column": 43 + } + ] + } + ] +} diff --git a/test/Feature/InputType/variables/nameCollision/variables.json b/test/Feature/InputType/variables/nameCollision/variables.json new file mode 100644 --- /dev/null +++ b/test/Feature/InputType/variables/nameCollision/variables.json @@ -0,0 +1,5 @@ +{ + "v1": [ + "a" + ] +} diff --git a/test/Feature/InputType/variables/nonInputTypeViolation/query.gql b/test/Feature/InputType/variables/nonInputTypeViolation/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/InputType/variables/nonInputTypeViolation/query.gql @@ -0,0 +1,5 @@ +query testUnknownType ($bo: A ){ + q1 { + a1(arg1:$bo) + } +} diff --git a/test/Feature/InputType/variables/nonInputTypeViolation/response.json b/test/Feature/InputType/variables/nonInputTypeViolation/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/InputType/variables/nonInputTypeViolation/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "Variable \"$bo\" cannot be non-input type \"A\".", + "locations": [ + { + "line": 1, + "column": 24 + } + ] + } + ] +} diff --git a/test/Feature/TypeInference/API.hs b/test/Feature/TypeInference/API.hs --- a/test/Feature/TypeInference/API.hs +++ b/test/Feature/TypeInference/API.hs @@ -27,12 +27,12 @@ data Power = Thunderbolts | Shapeshift | Hurricanes deriving (Generic,GQLType) -data Deity = Deity { +data Deity (m :: * -> *) = Deity { name :: Text , power :: Power } deriving(Generic,GQLType) -deityRes :: Deity +deityRes :: Deity m deityRes = Deity { name = "Morpheus", power = Shapeshift } data Hydra = Hydra { @@ -52,30 +52,29 @@ instance GQLType Monster where type KIND Monster = INPUT -data Character = - CharacterDeity Deity -- Only should generate direct link +data Character (m :: * -> *) = + CharacterDeity (Deity m) -- Only should generate direct link -- RECORDS | Creature { creatureName :: Text, creatureAge :: Int } - | BoxedDeity { boxedDeity :: Deity} + | BoxedDeity { boxedDeity :: Deity m} | ScalarRecord { scalarText :: Text } --- Types | CharacterInt Int -- all scalars mus be boxed -- Types - | SomeDeity Deity + | SomeDeity (Deity m) | SomeMutli Int Text --- ENUMS | Zeus | Cronus deriving (Generic, GQLType) - newtype MonsterArgs = MonsterArgs { monster :: Monster } deriving (Generic) data Query (m :: * -> *) = Query - { deity :: Deity, - character :: [Character], + { deity :: Deity m, + character :: [Character m], showMonster :: MonsterArgs -> m Text } deriving (Generic, GQLType) @@ -87,7 +86,7 @@ } where showMonster MonsterArgs { monster } = pure (pack $ show monster) - character :: [Character] + character :: [Character m] character = [ CharacterDeity deityRes , Creature { creatureName = "Lamia", creatureAge = 205 } diff --git a/test/Feature/TypeInference/introspection/complexInput/response.json b/test/Feature/TypeInference/introspection/complexInput/response.json --- a/test/Feature/TypeInference/introspection/complexInput/response.json +++ b/test/Feature/TypeInference/introspection/complexInput/response.json @@ -6,17 +6,25 @@ "fields": null, "inputFields": [ { - "name": "__typename", + "name": "inputname", "type": { "kind": "NON_NULL", "name": null, - "ofType": { "kind": "ENUM", "name": "MonsterTags", "ofType": null } + "ofType": { + "kind": "ENUM", + "name": "MonsterTags", + "ofType": null + } }, "defaultValue": null }, { "name": "Hydra", - "type": { "kind": "INPUT_OBJECT", "name": "Hydra", "ofType": null }, + "type": { + "kind": "INPUT_OBJECT", + "name": "Hydra", + "ofType": null + }, "defaultValue": null }, { @@ -40,7 +48,11 @@ "inputFields": null, "interfaces": null, "enumValues": [ - { "name": "Hydra", "isDeprecated": false, "deprecationReason": null }, + { + "name": "Hydra", + "isDeprecated": false, + "deprecationReason": null + }, { "name": "Cerberus", "isDeprecated": false, diff --git a/test/Feature/TypeInference/resolving/complexUnion/response.json b/test/Feature/TypeInference/resolving/complexUnion/response.json --- a/test/Feature/TypeInference/resolving/complexUnion/response.json +++ b/test/Feature/TypeInference/resolving/complexUnion/response.json @@ -1,18 +1,49 @@ { "data": { "character": [ - { "__typename": "Deity", "name": "Morpheus" }, - { "__typename": "Creature", "creatureName": "Lamia", "creatureAge": 205 }, - { "__typename": "BoxedDeity", "boxedDeity": { "power": "Shapeshift" } }, - { "__typename": "ScalarRecord", "scalarText": "Some Text" }, { + "__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" } + "_0": { + "name": "Morpheus", + "power": "Shapeshift" + } }, - { "__typename": "CharacterInt", "_0": 12 }, - { "__typename": "SomeMutli", "_0": 21, "_1": "some text" }, - { "__typename": "CharacterEnumObject", "enum": "Zeus" }, - { "__typename": "CharacterEnumObject", "enum": "Cronus" } + { + "__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 --- a/test/Feature/TypeInference/resolving/input/query.gql +++ b/test/Feature/TypeInference/resolving/input/query.gql @@ -1,9 +1,9 @@ { object: showMonster( - monster: { __typename: Hydra, Hydra: { name: "someName", age: 12 } } + monster: { inputname: Hydra, Hydra: { name: "someName", age: 12 } } ) record: showMonster( - monster: { __typename: Cerberus, Cerberus: { name: "someName" } } + monster: { inputname: Cerberus, Cerberus: { name: "someName" } } ) - enum: showMonster(monster: { __typename: UnidentifiedMonster }) + enum: showMonster(monster: { inputname: UnidentifiedMonster }) } diff --git a/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json b/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json --- a/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json +++ b/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Cannot query field \"aText\" on type \"Query\".", + "message": "Cannot query field \"aText\" on type \"Sum\".", "locations": [ { "line": 4, diff --git a/test/TestFeature.hs b/test/TestFeature.hs --- a/test/TestFeature.hs +++ b/test/TestFeature.hs @@ -23,8 +23,11 @@ import Test.Tasty.HUnit (assertFailure, testCase) packGQLRequest :: ByteString -> Maybe Value -> GQLRequest -packGQLRequest queryBS variables = - GQLRequest {operationName = Nothing, query = LT.toStrict $ decodeUtf8 queryBS, variables} +packGQLRequest queryBS variables = GQLRequest + { operationName = Nothing + , query = LT.toStrict $ decodeUtf8 queryBS + , variables + } data Case = Case { path :: Text