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.11.0 + - morpheus-graphql-0.12.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update` @@ -76,7 +76,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Document (importGQLDocumentWithNamespace) -import Data.Morpheus.Types (GQLRootResolver (..), IORes, Undefined(..)) +import Data.Morpheus.Types (GQLRootResolver (..), ResolverQ, Undefined(..)) import Data.Text (Text) importGQLDocumentWithNamespace "schema.gql" @@ -109,7 +109,7 @@ ### with Native Haskell Types To define a GraphQL API with Morpheus we start by defining the API Schema as a native Haskell data type, -which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> IORes b`, representing resolving a set of arguments `a` to a concrete value `b`. +which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> ResolverQ () IO b`, representing resolving a set of arguments `a` to a concrete value `b`. ```haskell data Query m = Query @@ -143,7 +143,7 @@ The field name in the final request will be `type` instead of `type'`. The Morpheus request parser converts each of the reserved identities in Haskell 2010 to their corresponding names internally. This also applies to selections. ```haskell -resolveDeity :: DeityArgs -> IORes e Deity +resolveDeity :: DeityArgs -> ResolverQ e () Deity resolveDeity DeityArgs { name, mythology } = liftEither $ dbDeity name mythology askDB :: Text -> Maybe Text -> IO (Either String Deity) @@ -312,7 +312,6 @@ You will get the following schema: - ```gql # has wrapper types @@ -389,24 +388,24 @@ ## Handling Errors -for errors you can use use either `liftEither` or `failRes`: +for errors you can use use either `liftEither` or `MonadFail`: at the and they have same result. with `liftEither` ```haskell -resolveDeity :: DeityArgs -> IORes e Deity +resolveDeity :: DeityArgs -> ResolverQ e IO Deity resolveDeity DeityArgs {} = liftEither $ dbDeity dbDeity :: IO Either Deity dbDeity = pure $ Left "db error" ``` -with `failRes` +with `MonadFail` ```haskell -resolveDeity :: DeityArgs -> IORes e Deity -resolveDeity DeityArgs { } = failRes "db error" +resolveDeity :: DeityArgs -> ResolverQ e IO Deity +resolveDeity DeityArgs { } = fail "db error" ``` ### Mutations @@ -427,7 +426,7 @@ } where -- Mutation Without Event Triggering - createDeity :: MutArgs -> ResolveM () IO Deity + createDeity :: MutArgs -> ResolverM () IO Deity createDeity_args = lift setDBAddress gqlApi :: ByteString -> IO ByteString @@ -474,7 +473,7 @@ } where -- Mutation Without Event Triggering - createDeity :: ResolveM EVENT IO Address + createDeity :: ResolverM EVENT IO Address createDeity = do requireAuthorized publish [Event { channels = [ChannelA], content = ContentA 1 }] @@ -487,6 +486,35 @@ deityByEvent (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State deityByEvent _ = fetchDeity -- Resolve Old State ``` + +### Interface + +1. defining interface with Haskell Types (runtime validation): + + ```hs + -- interface is just regular type derived as interface + newtype Person m = Person {name :: m Text} + deriving (Generic) + + instance GQLType (Person m) where + type KIND (Person m) = INTERFACE + + -- with GQLType user can links interfaces to implementing object + instance GQLType Deity where + implements _ = [interface (Proxy @Person)] + ``` + +2. defining with `importGQLDocument` and `DSL` (compile time validation): + + ```gql + interface Account { + name: String! + } + + type User implements Account { + name: String! + } + ``` ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,88 @@ # Changelog +## 0.12.0 - 21.05.2020 + +### Breaking Changes + +Package was extracted as: + +- `morpheus-graphql-core`: core components like: parser, validator, executor, utils. + - Data.Morpheus.Core + - Data.Morpheus.QuasiQuoter + - Data.Morpheus.Error + - Data.Morpheus.Internal.TH + - Data.Morpheus.Internal.Utils + - Data.Morpheus.Types.Internal.Resolving + - Data.Morpheus.Types.Internal.Operation + - Data.Morpheus.Types.Internal.AST + - Data.Morpheus.Types.IO + +- `morpheus-graphql-client`: lightweight version of morpheus client without server implementation + - Data.Morpheus.Client + +- `morpheus-graphql`: morpheus graphql server + - Data.Morpheus + - Data.Morpheus.Kind + - Data.Morpheus.Types + - Data.Morpheus.Server + - Data.Morpheus.Document + +deprecated: + +- `Res`, `IORes`, `ResolveQ` : use `ResolverQ` +- `MutRes`, `IOMutRes`, `ResolveM` : use `ResolverM` +- `SubRes`, `IOSubRes`, `ResolveS`: use `ResolverS` +- `failRes`: use `MonadFail` + +## New Feature + +- `Semigroup` support for Resolver +- `MonadFail` Support for Resolver +- flexible resolvers: `ResolverO`, `ResolverQ` , `RwsolverM`, `ResolverS` + they can handle object and scalar types: + + ```hs + -- if we have record and regular Int + data Object m = Object { field :: m Int } + + -- we canwrite + -- handes kind : (* -> *) -> * + resolveObject :: ResolverO o EVENT IO Object + -- is alias to: Resolver o () IO (Object (Resolver o () IO)) + -- or + -- handes kind : * + resolveInt :: ResolverO o EVENT IO Int + -- is alias to: Resolver o () IO Int + ``` + + the resolvers : `ResolverQ` , `RwsolverM`, `ResolverS` , are like + `ResolverO` but with `QUERY` , `MUTATION` and `SUBSCRIPTION` as argument. + +- flexible compsed Resolver Type alias: `ComposedResolver`. extends `ResolverO` with + parameter `(f :: * -> *)`. so that you can compose Resolvers e.g: + + ```hs + resolveList :: ComposedResolver o EVENT IO [] Object + -- is alias to: Resolver o () IO [Object (Resolver o () IO))] + + resolveList :: ComposedResolver o EVENT IO Maybe Int + -- is alias to: Resolver o () IO (Maybe Int) + ``` + +- server supports interfaces (see Readme): + + 1. define interface with Haskell Types (runtime validation): + 2. define interface with `importGQLDocument` and `DSL` (compile time validation): + +- support default directives: `@skip` and `@include` + +- SelectionTree interface + +### minor + +- fixed subscription sessions, srarting new session does not affects old ones. +- added tests for subscriptions + ## 0.11.0 - 01.05.2020 ### Breaking Changes diff --git a/morpheus-graphql.cabal b/morpheus-graphql.cabal --- a/morpheus-graphql.cabal +++ b/morpheus-graphql.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: e10665dda7dcb75f84d447086dcbd786a36aea915278bd6bbf4285a01cf9d21a +-- hash: c98d51df8567b3a33a0b9f3dcf93217534d9f3a1d666f1ac2ab69b5ce6cfe0b6 name: morpheus-graphql -version: 0.11.0 +version: 0.12.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -47,6 +47,8 @@ test/Feature/Holistic/introspection/description/inputObject/query.gql test/Feature/Holistic/introspection/description/object/query.gql test/Feature/Holistic/introspection/description/union/query.gql + test/Feature/Holistic/introspection/directives/default/query.gql + test/Feature/Holistic/introspection/interface/query.gql test/Feature/Holistic/introspection/kinds/ENUM/query.gql test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql test/Feature/Holistic/introspection/kinds/OBJECT/query.gql @@ -78,10 +80,24 @@ test/Feature/Holistic/parsing/notNullSpacing/query.gql test/Feature/Holistic/parsing/numbers/query.gql test/Feature/Holistic/parsing/singleLineComments/query.gql + test/Feature/Holistic/reservedNames/query.gql test/Feature/Holistic/schema.gql test/Feature/Holistic/selection/__typename/query.gql test/Feature/Holistic/selection/AliasResolve/query.gql test/Feature/Holistic/selection/AliasUnknownField/query.gql + test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql + test/Feature/Holistic/selection/directives/default/resolve/query.gql + test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql + test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql + test/Feature/Holistic/selection/directives/default/withMerge/query.gql + test/Feature/Holistic/selection/directives/default/withVariable/query.gql + test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql + test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql + test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql + test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql + test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql + test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql + test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/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 @@ -157,6 +173,7 @@ test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql test/Feature/WrappedTypeName/validWrappedTypes/query.gql test/Rendering/schema.gql + test/Subscription/schema.gql test/Feature/Holistic/arguments/nameConflict/response.json test/Feature/Holistic/arguments/undefinedArgument/response.json test/Feature/Holistic/arguments/unknownArguments/response.json @@ -182,6 +199,8 @@ test/Feature/Holistic/introspection/description/inputObject/response.json test/Feature/Holistic/introspection/description/object/response.json test/Feature/Holistic/introspection/description/union/response.json + test/Feature/Holistic/introspection/directives/default/response.json + test/Feature/Holistic/introspection/interface/response.json test/Feature/Holistic/introspection/kinds/ENUM/response.json test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json test/Feature/Holistic/introspection/kinds/OBJECT/response.json @@ -215,9 +234,23 @@ test/Feature/Holistic/parsing/notNullSpacing/variables.json test/Feature/Holistic/parsing/numbers/response.json test/Feature/Holistic/parsing/singleLineComments/response.json + test/Feature/Holistic/reservedNames/response.json test/Feature/Holistic/selection/__typename/response.json test/Feature/Holistic/selection/AliasResolve/response.json test/Feature/Holistic/selection/AliasUnknownField/response.json + test/Feature/Holistic/selection/directives/default/requiredArgument/response.json + test/Feature/Holistic/selection/directives/default/resolve/response.json + test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json + test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json + test/Feature/Holistic/selection/directives/default/withMerge/response.json + test/Feature/Holistic/selection/directives/default/withVariable/response.json + test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json + test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json + test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json + test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json + test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json + test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json + test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/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 @@ -327,88 +360,29 @@ Data.Morpheus.Types Data.Morpheus.Server Data.Morpheus.Document - Data.Morpheus.Client - Data.Morpheus.Types.Internal.AST - other-modules: - 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.NameCollision - Data.Morpheus.Error.Operation - Data.Morpheus.Error.Schema - Data.Morpheus.Error.Selection - Data.Morpheus.Error.Utils - Data.Morpheus.Error.Variable - Data.Morpheus.Execution.Client.Aeson - Data.Morpheus.Execution.Client.Build - Data.Morpheus.Execution.Client.Compile - Data.Morpheus.Execution.Client.Fetch - Data.Morpheus.Execution.Client.Selection - Data.Morpheus.Execution.Document.Compile - Data.Morpheus.Execution.Document.Convert - Data.Morpheus.Execution.Document.Declare - Data.Morpheus.Execution.Document.Decode - Data.Morpheus.Execution.Document.Encode - Data.Morpheus.Execution.Document.GQLType - Data.Morpheus.Execution.Document.Introspect - Data.Morpheus.Execution.Internal.Declare - Data.Morpheus.Execution.Internal.Decode - Data.Morpheus.Execution.Internal.Utils - Data.Morpheus.Execution.Server.Decode - Data.Morpheus.Execution.Server.Encode - Data.Morpheus.Execution.Server.Generics.EnumRep - Data.Morpheus.Execution.Server.Interpreter - Data.Morpheus.Execution.Server.Introspect - Data.Morpheus.Execution.Server.Resolve - 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.Operation - Data.Morpheus.Parsing.Request.Parser - Data.Morpheus.Parsing.Request.Selection - Data.Morpheus.Rendering.RenderGQL - Data.Morpheus.Rendering.RenderIntrospection - Data.Morpheus.Schema.Schema - Data.Morpheus.Schema.SchemaAPI - Data.Morpheus.Schema.TypeKind - Data.Morpheus.Types.GQLScalar - Data.Morpheus.Types.GQLType - Data.Morpheus.Types.ID - 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 + other-modules: + Data.Morpheus.Server.Deriving.Decode + Data.Morpheus.Server.Deriving.Encode + Data.Morpheus.Server.Deriving.Interpreter + Data.Morpheus.Server.Deriving.Introspect + Data.Morpheus.Server.Deriving.Resolve + Data.Morpheus.Server.Deriving.Utils + Data.Morpheus.Server.Document.Compile + Data.Morpheus.Server.Document.Convert + Data.Morpheus.Server.Document.Declare + Data.Morpheus.Server.Document.Decode + Data.Morpheus.Server.Document.Encode + Data.Morpheus.Server.Document.GQLType + Data.Morpheus.Server.Document.Introspect + Data.Morpheus.Server.Internal.TH.Decode + Data.Morpheus.Server.Types.GQLScalar + Data.Morpheus.Server.Types.GQLType + Data.Morpheus.Server.Types.ID + Data.Morpheus.Server.Types.Types 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.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 - Data.Morpheus.Validation.Internal.Value - 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 hs-source-dirs: src @@ -419,17 +393,17 @@ , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0 - , mtl >=2.0 && <=2.3 + , morpheus-graphql-core >=0.12.0 + , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 - , template-haskell >=2.0 && <=2.16 + , template-haskell >=2.0 && <=3.0 , 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 + , unliftio-core >=0.0.1 && <=0.4 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13 - , websockets >=0.11.0 && <=0.13 + , websockets >=0.11.0 && <=1.0 default-language: Haskell2010 test-suite morpheus-test @@ -449,7 +423,13 @@ Lib Rendering.Schema Rendering.TestSchemaRendering + Subscription.API + Subscription.Case.ApolloRequest + Subscription.Case.Publishing + Subscription.Test + Subscription.Utils TestFeature + Types Paths_morpheus_graphql hs-source-dirs: test @@ -461,17 +441,17 @@ , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0 , morpheus-graphql - , mtl >=2.0 && <=2.3 + , morpheus-graphql-core >=0.12.0 + , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , tasty , tasty-hunit - , template-haskell >=2.0 && <=2.16 + , template-haskell >=2.0 && <=3.0 , 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 + , unliftio-core >=0.0.1 && <=0.4 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13 - , websockets >=0.11.0 && <=0.13 + , websockets >=0.11.0 && <=1.0 default-language: Haskell2010 diff --git a/src/Data/Morpheus.hs b/src/Data/Morpheus.hs --- a/src/Data/Morpheus.hs +++ b/src/Data/Morpheus.hs @@ -1,8 +1,9 @@ -- | Build GraphQL APIs with your favourite functional language! module Data.Morpheus - ( Interpreter(..) + ( Interpreter (..), ) where -import Data.Morpheus.Execution.Server.Interpreter - ( Interpreter(..) ) +import Data.Morpheus.Server.Deriving.Interpreter + ( Interpreter (..), + ) diff --git a/src/Data/Morpheus/Client.hs b/src/Data/Morpheus/Client.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Client - ( gql - , Fetch(..) - , defineQuery - , defineByDocument - , defineByDocumentFile - , defineByIntrospection - , defineByIntrospectionFile - ) -where - -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString.Lazy as L - ( readFile ) -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -import Data.Morpheus.Document ( parseFullGQLDocument ) --- MORPHEUS -import Data.Morpheus.Execution.Client.Build - ( defineQuery ) -import Data.Morpheus.Execution.Client.Compile - ( compileSyntax ) -import Data.Morpheus.Execution.Client.Fetch - ( Fetch(..) ) -import Data.Morpheus.Parsing.JSONSchema.Parse - ( decodeIntrospection ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless ) -import Data.Morpheus.Types.Internal.AST - ( GQLQuery - , Schema - ) - -gql :: QuasiQuoter -gql = QuasiQuoter { quoteExp = compileSyntax - , quotePat = notHandled "Patterns" - , quoteType = notHandled "Types" - , quoteDec = notHandled "Declarations" - } - where - notHandled things = - error $ things ++ " are not supported by the GraphQL QuasiQuoter" - -defineByDocumentFile :: String -> (GQLQuery, String) -> Q [Dec] -defineByDocumentFile = defineByDocument . L.readFile - -defineByIntrospectionFile :: String -> (GQLQuery, String) -> Q [Dec] -defineByIntrospectionFile = defineByIntrospection . L.readFile - --- --- --- TODO: Define By API --- Validates By Server API --- -defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec] -defineByDocument doc = defineQuery (schemaByDocument doc) - -schemaByDocument :: IO ByteString -> IO (Eventless Schema) -schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL - -defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec] -defineByIntrospection json = defineQuery (decodeIntrospection <$> json) 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 @@ -1,82 +1,37 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-} module Data.Morpheus.Document - ( toGraphQLDocument - , gqlDocument - , parseFullGQLDocument - , importGQLDocument - , importGQLDocumentWithNamespace - , parseDSL + ( toGraphQLDocument, + gqlDocument, + importGQLDocument, + importGQLDocumentWithNamespace, ) where -import Control.Monad ( (>=>) ) -import Data.ByteString.Lazy.Char8 ( ByteString - , pack - ) -import Data.Text ( Text ) -import qualified Data.Text.Lazy as LT - ( toStrict ) -import Data.Text.Lazy.Encoding ( decodeUtf8 ) -import Language.Haskell.TH - --- --- MORPHEUS -import Data.Morpheus.Execution.Document.Compile - ( compileDocument - , gqlDocument - ) -import Data.Morpheus.Execution.Server.Resolve - ( RootResCon - , fullSchema - ) -import Data.Morpheus.Parsing.Document.TypeSystem - ( parseSchema - ) -import Data.Morpheus.Rendering.RenderGQL - ( renderGraphQLDocument - ) -import Data.Morpheus.Schema.SchemaAPI ( defaultTypes ) -import Data.Morpheus.Types ( GQLRootResolver ) -import Data.Morpheus.Types.Internal.AST - ( Schema - , createDataTypeLib - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Result(..) - ) -import Data.Morpheus.Validation.Document.Validation - ( validatePartialDocument ) - - -parseDSL :: ByteString -> Either String Schema -parseDSL doc = case parseGraphQLDocument doc of - Failure errors -> Left (show errors) - Success { result } -> Right result - - -parseDocument :: Text -> Eventless Schema -parseDocument doc = - parseSchema doc >>= validatePartialDocument >>= createDataTypeLib - -parseGraphQLDocument :: ByteString -> Eventless Schema -parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x) - -parseFullGQLDocument :: ByteString -> Eventless Schema -parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes - --- | Generates schema.gql file from 'GQLRootResolver' -toGraphQLDocument - :: RootResCon m event query mut sub - => proxy (GQLRootResolver m event query mut sub) - -> ByteString -toGraphQLDocument x = case fullSchema x of - Failure errors -> pack (show errors) - Success { result = lib } -> renderGraphQLDocument lib - - +import Data.ByteString.Lazy.Char8 + ( ByteString, + pack, + ) +import Data.Morpheus.Core + ( render, + ) +import Data.Morpheus.Server.Deriving.Resolve + ( RootResCon, + fullSchema, + ) +import Data.Morpheus.Server.Document.Compile + ( compileDocument, + gqlDocument, + ) +import Data.Morpheus.Types (GQLRootResolver) +import Data.Morpheus.Types.Internal.Resolving + ( resultOr, + ) +import qualified Data.Text.Lazy as LT + ( fromStrict, + ) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Language.Haskell.TH importGQLDocument :: String -> Q [Dec] importGQLDocument src = runIO (readFile src) >>= compileDocument False @@ -84,3 +39,12 @@ importGQLDocumentWithNamespace :: String -> Q [Dec] importGQLDocumentWithNamespace src = runIO (readFile src) >>= compileDocument True + +-- | Generates schema.gql file from 'GQLRootResolver' +toGraphQLDocument :: + RootResCon m event query mut sub => + proxy (GQLRootResolver m event query mut sub) -> + ByteString +toGraphQLDocument = + resultOr (pack . show) (encodeUtf8 . LT.fromStrict . render) + . fullSchema diff --git a/src/Data/Morpheus/Error/Client/Client.hs b/src/Data/Morpheus/Error/Client/Client.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Client/Client.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Client.Client - ( renderGQLErrors - , deprecatedEnum - , deprecatedField - , gqlWarnings - ) -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.AST.Base - ( Ref(..) - , Description - , Name - , GQLErrors - ) - - -renderGQLErrors :: GQLErrors -> String -renderGQLErrors = unpack . encode - -deprecatedEnum :: Name -> Ref -> Maybe Description -> GQLErrors -deprecatedEnum typeName Ref { refPosition, refName } reason = - errorMessage refPosition - $ "the enum value " - <> typeName - <> "." - <> refName - <> "\" is deprecated." - <> maybe "" (" " <>) reason - -deprecatedField :: Name -> Ref -> Maybe Description -> GQLErrors -deprecatedField typeName Ref { refPosition, refName } reason = - errorMessage refPosition - $ "the field \"" - <> typeName - <> "." - <> refName - <> "\" is deprecated." - <> maybe "" (" " <>) reason - -gqlWarnings :: GQLErrors -> Q () -gqlWarnings [] = pure () -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 deleted file mode 100644 --- a/src/Data/Morpheus/Error/Document/Interface.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Document.Interface - ( unknownInterface - , partialImplements - , ImplementsError(..) - ) -where - -import Data.Morpheus.Error.Utils ( globalErrorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Key - , GQLError(..) - , GQLErrors - ) -import Data.Semigroup ( (<>) ) - -unknownInterface :: Key -> GQLErrors -unknownInterface name = globalErrorMessage message - where message = "Unknown Interface \"" <> name <> "\"." - -data ImplementsError - = UnexpectedType { expectedType :: Key - , foundType :: Key } - | UndefinedField - -partialImplements :: Key -> [(Key, Key, ImplementsError)] -> GQLErrors -partialImplements name = map impError - where - impError (interfaceName, key, errorType) = GQLError { message = message - , locations = [] - } - where - message = - "type \"" - <> name - <> "\" implements Interface \"" - <> interfaceName - <> "\" Partially," - <> detailedMessage errorType - detailedMessage UnexpectedType { expectedType, foundType } = - " on key \"" - <> key - <> "\" expected type \"" - <> expectedType - <> "\" found \"" - <> foundType - <> "\"." - detailedMessage UndefinedField = " key \"" <> key <> "\" not found ." diff --git a/src/Data/Morpheus/Error/Fragment.hs b/src/Data/Morpheus/Error/Fragment.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Fragment.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Fragment - ( cannotSpreadWithinItself - , cannotBeSpreadOnType - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , intercalate - ) -import qualified Data.Text as T - --- MORPHEUS -import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Ref(..) - , Position - , GQLError(..) - , GQLErrors - ) - -{- - FRAGMENT: - type Experience { - experience ( lang: LANGUAGE ) : String , - date: String - } - fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"." - fragment H on T1 { ...A} , fragment A on T { ...H } -> "Cannot spread fragment \"H\" within itself via A." - fragment H on D {...} -> "Unknown type \"D\"." - {...H} -> "Unknown fragment \"H\"." --} - -cannotSpreadWithinItself :: [Ref] -> GQLErrors -cannotSpreadWithinItself fragments = [GQLError { message = text, locations = map refPosition fragments }] - where - 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 - msg - where - msg = - "Fragment " - <> getName key - <> "cannot be spread here as objects of type \"" - <> intercalate ", " typeMembers - <> "\" can never be of type \"" - <> fragmentType - <> "\"." - getName (Just x) = "\"" <> x <> "\" " - getName Nothing = "" diff --git a/src/Data/Morpheus/Error/Input.hs b/src/Data/Morpheus/Error/Input.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Input.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Input - ( typeViolation - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Aeson ( encode ) -import Data.ByteString.Lazy.Char8 ( unpack ) -import Data.Text ( pack ) - --- MORPHEUS -import Data.Morpheus.Types.Internal.AST - ( Message - , ResolvedValue - , TypeRef(..) - ) -import Data.Morpheus.Rendering.RenderGQL - ( RenderGQL(..) ) - - -typeViolation :: TypeRef -> ResolvedValue -> Message -typeViolation expected found = "Expected type \"" - <> render expected - <> "\" found " - <> pack (unpack $ encode found) - <> "." - -{- - 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\"." --} diff --git a/src/Data/Morpheus/Error/Internal.hs b/src/Data/Morpheus/Error/Internal.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Internal.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Internal - ( internalTypeMismatch - , internalError - , internalResolvingError - ) -where - -import Data.Text ( pack ) -import Data.Semigroup ( (<>) ) - --- MORPHEUS -import Data.Morpheus.Error.Utils ( globalErrorMessage ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( 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 :: Message -> Eventless a -internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x - -internalResolvingError :: Message -> GQLErrors -internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>) - --- if value is already validated but value has different type -internalTypeMismatch :: Message -> ValidValue -> Eventless a -internalTypeMismatch text jsType = - internalError $ "Type mismatch " <> text <> pack (show jsType) diff --git a/src/Data/Morpheus/Error/NameCollision.hs b/src/Data/Morpheus/Error/NameCollision.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/NameCollision.hs +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 --- a/src/Data/Morpheus/Error/Operation.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Error/Schema.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Schema - ( nameCollisionError - , schemaValidationError - ) -where - -import Data.Morpheus.Error.Utils ( globalErrorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( GQLErrors ) -import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) - -schemaValidationError :: Text -> GQLErrors -schemaValidationError error' = - globalErrorMessage $ "Schema Validation Error, " <> error' - -nameCollisionError :: Text -> GQLErrors -nameCollisionError name = - schemaValidationError - $ "Name collision: \"" - <> name - <> "\" is used for different dataTypes in two separate modules" diff --git a/src/Data/Morpheus/Error/Selection.hs b/src/Data/Morpheus/Error/Selection.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Selection.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Error.Selection - ( unknownSelectionField - , subfieldsNotSelected - , hasNoSubfields - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST.Base - ( Position - , GQLErrors - , Ref(..) - , Name - ) -import Data.Text ( Text ) - --- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields." -hasNoSubfields :: Ref -> Name -> GQLErrors -hasNoSubfields (Ref selectionName position) typeName = errorMessage position text - where - text = "Field \"" <> selectionName <> "\" must not have a selection since type \"" <> typeName <> "\" has no subfields." - -unknownSelectionField :: Name -> Ref -> GQLErrors -unknownSelectionField typeName Ref { refName , refPosition } = errorMessage refPosition text - where - 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 = "Field \"" <> key <> "\" of type \"" - <> typeName <> "\" must have a selection of subfields" diff --git a/src/Data/Morpheus/Error/Utils.hs b/src/Data/Morpheus/Error/Utils.hs deleted file mode 100644 --- a/src/Data/Morpheus/Error/Utils.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Error.Utils - ( errorMessage - , globalErrorMessage - , badRequestError - ) -where - -import Data.Semigroup ((<>)) -import Data.ByteString.Lazy.Char8 ( ByteString - , pack - ) -import Data.Morpheus.Types.Internal.AST.Base - ( Position(..) - , GQLError(..) - , GQLErrors - ) -import Data.Text ( Text ) - - -errorMessage :: Position -> Text -> GQLErrors -errorMessage position message = [GQLError { message, locations = [position] }] - -globalErrorMessage :: Text -> GQLErrors -globalErrorMessage message = [GQLError { message, locations = [] }] - -badRequestError :: String -> ByteString -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 deleted file mode 100644 --- a/src/Data/Morpheus/Error/Variable.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Error.Variable - ( uninitializedVariable - , incompatibleVariableType - ) -where - -import Data.Morpheus.Error.Utils ( errorMessage ) -import Data.Morpheus.Types.Internal.AST - ( GQLErrors - , Ref(..) - , Variable(..) - , TypeRef - ) -import Data.Semigroup ( (<>) ) -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 :: Ref -> Variable s -> TypeRef -> GQLErrors -incompatibleVariableType - (Ref variableName argPosition) - Variable { variableType } - argumentType = - errorMessage argPosition text - where - text = - "Variable \"$" - <> variableName - <> "\" of type \"" - <> render variableType - <> "\" used in position expecting type \"" - <> render argumentType - <> "\"." - -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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Client/Aeson.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Morpheus.Execution.Client.Aeson - ( deriveFromJSON - , deriveToJSON - , takeValueType - ) -where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.HashMap.Lazy as H - ( lookup ) -import Data.Semigroup ( (<>) ) -import Data.Text ( append - , Text - , unpack - ) -import Language.Haskell.TH - -import Data.Morpheus.Execution.Internal.Utils - ( nameSpaceType ) - --- --- MORPHEUS -import Data.Morpheus.Execution.Internal.Declare - ( isEnum ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , isFieldNullable - , ConsD(..) - , TypeD(..) - , Key - ) -import Data.Morpheus.Types.Internal.TH - ( destructRecord - , instanceFunD - , instanceHeadT - ) - --- FromJSON -deriveFromJSON :: TypeD -> Q Dec -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 (aesonFromJSONEnumBody tName) tCons - | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD - where name = nameSpaceType tNamespace tName - -aesonObject :: [Key] -> ConsD -> ExpQ -aesonObject tNamespace con@ConsD { cName } = appE - [|withObject name|] - (lamE [varP (mkName "o")] (aesonObjectBody tNamespace con)) - where name = unpack $ nameSpaceType tNamespace cName - -aesonObjectBody :: [Key] -> ConsD -> ExpQ -aesonObjectBody namespace ConsD { cName, cFields } = handleFields cFields - where - consName = mkName $ unpack $ nameSpaceType namespace cName - ---------------------------------------------------------- - handleFields [] = fail $ "Type \""<>unpack cName <>"\" is Empty Object" - handleFields fields = startExp fields - ---------------------------------------------------------- - where - defField field@FieldDefinition { fieldName } - | isFieldNullable field = [|o .:? fName|] - | otherwise = [|o .: fName|] - where fName = unpack fieldName - -------------------------------------------------------- - startExp fNames = uInfixE (conE consName) - (varE '(<$>)) - (applyFields fNames) - where - applyFields [] = fail "No Empty fields" - applyFields [x] = defField x - applyFields (x : xs) = - uInfixE (defField x) (varE '(<*>)) (applyFields xs) - -aesonUnionObject :: [Key] -> TypeD -> ExpQ -aesonUnionObject namespace TypeD { tCons } = appE - (varE 'takeValueType) - (lamCaseE (map buildMatch tCons <> [elseCaseEXP])) - where - buildMatch cons@ConsD { cName } = match objectPattern body [] - where - objectPattern = tupP [litP (stringL $ unpack cName), varP $ mkName "o"] - body = normalB $ aesonObjectBody namespace cons - -takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a -takeValueType f (Object hMap) = case H.lookup "__typename" hMap of - Nothing -> fail "key \"__typename\" not found on object" - Just (String x) -> pure (unpack x, hMap) >>= f - Just val -> - fail $ "key \"__typename\" should be string but found: " <> show val -takeValueType _ _ = fail "expected Object" - -defineFromJSON :: Key -> (t -> ExpQ) -> t -> DecQ -defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method] - where - iHead = instanceHeadT ''FromJSON tName [] - ----------------------------------------- - method = instanceFunD 'parseJSON [] (parseJ cFields) - -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 $ append tName cName) - -elseCaseEXP :: MatchQ -elseCaseEXP = match (varP varName) body [] - where - varName = mkName "invalidValue" - body = normalB $ appE - (varE $ mkName "fail") - (uInfixE (appE (varE 'show) (varE varName)) - (varE '(<>)) - (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 = [] } = - fail "Type Should Have at least one Constructor" -deriveToJSON TypeD { tName, tCons = [ConsD { cFields }] } = - pure <$> instanceD (cxt []) appHead methods - where - appHead = instanceHeadT ''ToJSON tName [] - ------------------------------------------------------------------ - -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...] - methods = [funD 'toJSON [clause argsE (normalB body) []]] - where - argsE = [destructRecord tName varNames] - body = appE (varE 'object) (listE $ map (decodeVar . unpack) varNames) - decodeVar name = [|name .= $(varName)|] where varName = varE $ mkName name - varNames = map fieldName cFields -deriveToJSON TypeD { tName, tCons } - | isEnum tCons - = let methods = [funD 'toJSON clauses] - clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []] - in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) 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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Client/Build.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Execution.Client.Build - ( defineQuery - ) -where - -import Data.Semigroup ( (<>) ) -import Language.Haskell.TH -import Data.Text ( unpack ) - --- --- MORPHEUS -import Data.Morpheus.Error.Client.Client - ( renderGQLErrors - , gqlWarnings - ) -import Data.Morpheus.Execution.Client.Aeson - ( deriveFromJSON - , deriveToJSON - ) -import Data.Morpheus.Execution.Client.Compile - ( validateWith ) -import Data.Morpheus.Execution.Client.Fetch - ( deriveFetch ) -import Data.Morpheus.Execution.Internal.Declare - ( declareType - , Scope(..) - ) - -import Data.Morpheus.Types.Internal.AST - ( GQLQuery(..) - , DataTypeKind(..) - , Schema - , isOutputObject - , ClientType(..) - , ClientQuery(..) - , TypeD(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Result(..) - ) - -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 - rootDecs <- defineOperationType (queryArgumentType queryArgsType) - queryText - rootType - subTypeDecs <- concat <$> traverse declareT subTypes - return $ rootDecs ++ subTypeDecs - where - declareT ClientType { clientType, clientKind } - | isOutputObject clientKind || clientKind == KindUnion = withToJSON - declareOutputType - clientType - | clientKind == KindEnum = withToJSON declareInputType clientType - | otherwise = declareInputType clientType -defineQueryD ClientQuery { queryTypes = [] } = return [] - -declareOutputType :: TypeD -> Q [Dec] -declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD] - -declareInputType :: TypeD -> Q [Dec] -declareInputType typeD = do - toJSONDec <- deriveToJSON typeD - pure $ declareType CLIENT True Nothing [''Show] typeD : toJSONDec - -withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec] -withToJSON f datatype = do - toJson <- deriveFromJSON datatype - dec <- f datatype - pure (toJson : dec) - -queryArgumentType :: Maybe TypeD -> (Type, Q [Dec]) -queryArgumentType Nothing = (ConT $ mkName "()", pure []) -queryArgumentType (Just rootType@TypeD { tName }) = - (ConT $ mkName $ unpack tName, declareInputType rootType) - -defineOperationType :: (Type, Q [Dec]) -> String -> ClientType -> Q [Dec] -defineOperationType (argType, argumentTypes) query ClientType { clientType } = - do - rootType <- withToJSON declareOutputType clientType - typeClassFetch <- deriveFetch argType (tName clientType) query - argsT <- argumentTypes - pure $ rootType <> typeClassFetch <> argsT diff --git a/src/Data/Morpheus/Execution/Client/Compile.hs b/src/Data/Morpheus/Execution/Client/Compile.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Client/Compile.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Execution.Client.Compile - ( compileSyntax - , validateWith - ) -where - -import qualified Data.Text as T - ( pack ) -import Language.Haskell.TH - --- --- Morpheus - - -import Data.Morpheus.Error.Client.Client - ( renderGQLErrors - , gqlWarnings - ) - -import Data.Morpheus.Execution.Client.Selection - ( operationTypes ) -import Data.Morpheus.Parsing.Request.Parser - ( parseGQL ) -import qualified Data.Morpheus.Types.Internal.AST - as O - ( Operation(..) ) -import Data.Morpheus.Types.IO ( GQLRequest(..) ) - -import Data.Morpheus.Types.Internal.AST - ( GQLQuery(..) - , Schema - , ClientQuery(..) - , VALIDATION_MODE(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Result(..) - ) -import Data.Morpheus.Validation.Query.Validation - ( validateRequest ) - -compileSyntax :: String -> Q Exp -compileSyntax queryText = case parseGQL request of - Failure errors -> fail (renderGQLErrors errors) - Success { result, warnings } -> - gqlWarnings warnings >> [|(result, queryText)|] - where - request = GQLRequest { query = T.pack queryText - , operationName = Nothing - , variables = Nothing - } - -validateWith :: Schema -> (GQLQuery, String) -> Eventless ClientQuery -validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do - validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest - (queryArgsType, queryTypes) <- operationTypes - schema - (O.operationArguments operation) - validOperation - return ClientQuery { queryText, queryTypes, queryArgsType } diff --git a/src/Data/Morpheus/Execution/Client/Fetch.hs b/src/Data/Morpheus/Execution/Client/Fetch.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Client/Fetch.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Morpheus.Execution.Client.Fetch - ( Fetch(..) - , deriveFetch - ) -where - -import Control.Monad ( (>=>) ) -import Data.Aeson ( FromJSON - , ToJSON(..) - , eitherDecode - , encode - ) -import Data.ByteString.Lazy ( ByteString ) -import Data.Text ( pack - , unpack - , Text - ) -import Language.Haskell.TH - - -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A - --- --- MORPHEUS -import Data.Morpheus.Types.Internal.TH - ( instanceHeadT - , typeInstanceDec - ) -import Data.Morpheus.Types.IO ( GQLRequest(..) - , JSONResponse(..) - ) - - -fixVars :: A.Value -> Maybe A.Value -fixVars x | x == A.emptyArray = Nothing - | otherwise = Just x - -class Fetch a where - type Args a :: * - __fetch :: - (Monad m, Show a, ToJSON (Args a), FromJSON a) - => String - -> Text - -> (ByteString -> m ByteString) - -> Args a - -> m (Either String a) - __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq) - where - gqlReq = GQLRequest {operationName = Just opName, query = pack strQuery, variables = fixVars (toJSON vars)} - ------------------------------------------------------------- - processResponse JSONResponse {responseData = Just x} = Right x - processResponse invalidResponse = Left (show invalidResponse) - fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a) - - -deriveFetch :: Type -> Text -> String -> Q [Dec] -deriveFetch resultType typeName queryString = - pure <$> instanceD (cxt []) iHead methods - where - iHead = instanceHeadT ''Fetch typeName [] - methods = - [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []] - , pure $ typeInstanceDec ''Args (ConT $ mkName $ unpack typeName) resultType - ] diff --git a/src/Data/Morpheus/Execution/Client/Selection.hs b/src/Data/Morpheus/Execution/Client/Selection.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Client/Selection.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Morpheus.Execution.Client.Selection - ( operationTypes - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , pack - ) --- --- MORPHEUS -import Data.Morpheus.Error.Client.Client - ( deprecatedField ) -import Data.Morpheus.Error.Utils ( globalErrorMessage ) -import Data.Morpheus.Execution.Internal.Utils - ( nameSpaceType ) -import Data.Morpheus.Types.Internal.AST - ( Operation(..) - , Key - , Name - , RAW - , VALID - , Variable(..) - , VariableDefinitions - , Selection(..) - , SelectionContent(..) - , SelectionSet - , Ref(..) - , FieldDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , DataTypeKind(..) - , Schema(..) - , TypeRef(..) - , DataEnumValue(..) - , ConsD(..) - , ClientType(..) - , TypeD(..) - , ArgumentsDefinition(..) - , getOperationName - , getOperationDataType - , lookupDeprecated - , lookupDeprecatedReason - , typeFromScalar - , removeDuplicates - , Position - , GQLErrors - , UnionTag(..) - ) -import Data.Morpheus.Types.Internal.Operation - ( Listable(..) - , selectBy - , keyOf - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Failure(..) - , Result(..) - , LibUpdater - , resolveUpdates - ) - - -compileError :: Text -> GQLErrors -compileError x = - globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" - -operationTypes - :: Schema - -> VariableDefinitions RAW - -> Operation VALID - -> Eventless (Maybe TypeD, [ClientType]) -operationTypes lib variables = genOperation - where - genOperation operation@Operation { operationName, operationSelection } = do - datatype <- getOperationDataType operation lib - (queryTypes, enums) <- genRecordType [] - (getOperationName operationName) - datatype - operationSelection - inputTypeRequests <- resolveUpdates [] - $ map (scanInputTypes lib . typeConName . variableType) (toList variables) - inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums) - pure - ( rootArguments (getOperationName operationName <> "Args") - , queryTypes <> inputTypesAndEnums - ) - ------------------------------------------------------------------------- - buildListedTypes = - fmap concat . traverse (buildInputType lib) . removeDuplicates - ------------------------------------------------------------------------- - -- generates argument types for Operation Head - rootArguments :: Text -> Maybe TypeD - rootArguments argsName | null variables = Nothing - | otherwise = Just rootArgumentsType - - where - rootArgumentsType :: TypeD - rootArgumentsType = TypeD - { tName = argsName - , tNamespace = [] - , tCons = [ConsD { cName = argsName, cFields = map fieldD (toList variables) }] - , tMeta = Nothing - } - where - fieldD :: Variable RAW -> FieldDefinition - fieldD Variable { variableName, variableType } = FieldDefinition - { fieldName = variableName - , fieldArgs = NoArguments - , fieldType = variableType - , fieldMeta = Nothing - } - --------------------------------------------------------- - -- generates selection Object Types - genRecordType - :: [Name] - -> Name - -> TypeDefinition - -> SelectionSet VALID - -> Eventless ([ClientType], [Name]) - genRecordType path tName dataType recordSelSet = do - (con, subTypes, requests) <- genConsD tName dataType recordSelSet - pure - ( ClientType - { clientType = TypeD { tName - , tNamespace = path - , tCons = [con] - , tMeta = Nothing - } - , clientKind = KindObject Nothing - } - : subTypes - , requests - ) - where - genConsD - :: Name - -> TypeDefinition - -> SelectionSet VALID - -> Eventless (ConsD, [ClientType], [Text]) - genConsD cName datatype selSet = do - (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet) - pure (ConsD { cName, cFields }, concat subTypes, concat requests) - where - genField - :: Selection VALID - -> Eventless (FieldDefinition, [ClientType], [Text]) - genField - sel@Selection - { selectionName - , selectionPosition - } = - do - (fieldDataType, fieldType) <- lookupFieldType lib - fieldPath - datatype - selectionPosition - selectionName - (subTypes, requests) <- subTypesBySelection fieldDataType sel - pure - ( FieldDefinition - { fieldName - , fieldType - , fieldArgs = NoArguments - , fieldMeta = Nothing - } - , subTypes - , requests - ) - where - fieldPath = path <> [fieldName] - ------------------------------- - fieldName = keyOf sel - ------------------------------------------ - subTypesBySelection - :: TypeDefinition -> Selection VALID -> Eventless ([ClientType], [Text]) - subTypesBySelection dType Selection { selectionContent = SelectionField } - = leafType dType - --withLeaf buildLeaf dType - subTypesBySelection dType Selection { selectionContent = SelectionSet selectionSet } - = genRecordType fieldPath (typeFrom [] dType) dType selectionSet - ---- UNION - subTypesBySelection dType Selection { selectionContent = UnionSelection unionSelections } - = do - (tCons, subTypes, requests) <- - unzip3 <$> traverse getUnionType (toList unionSelections) - pure - ( ClientType - { clientType = TypeD { tNamespace = fieldPath - , tName = typeFrom [] dType - , tCons - , tMeta = Nothing - } - , clientKind = KindUnion - } - : concat subTypes - , concat requests - ) - where - getUnionType (UnionTag selectedTyName selectionVariant) = do - conDatatype <- getType lib selectedTyName - genConsD selectedTyName conDatatype selectionVariant - -scanInputTypes :: Schema -> Key -> LibUpdater [Key] -scanInputTypes lib name collected | name `elem` collected = pure collected - | otherwise = getType lib name >>= scanInpType - where - scanInpType TypeDefinition { typeContent, typeName } = scanType typeContent - where - scanType (DataInputObject fields) = resolveUpdates - (name : collected) (map toInputTypeD $ toList fields) - where - toInputTypeD :: FieldDefinition -> LibUpdater [Key] - toInputTypeD FieldDefinition { fieldType = TypeRef { typeConName } } = - scanInputTypes lib typeConName - scanType (DataEnum _) = pure (collected <> [typeName]) - scanType _ = pure collected - -buildInputType :: Schema -> Text -> Eventless [ClientType] -buildInputType lib name = getType lib name >>= generateTypes - where - generateTypes TypeDefinition { typeName, typeContent } = subTypes typeContent - where - subTypes (DataInputObject inputFields) = do - fields <- traverse toFieldD (toList inputFields) - pure - [ ClientType - { clientType = TypeD - { tName = typeName - , tNamespace = [] - , tCons = [ ConsD { cName = typeName - , cFields = fields - } - ] - , tMeta = Nothing - } - , clientKind = KindInputObject - } - ] - where - toFieldD :: FieldDefinition -> Eventless FieldDefinition - toFieldD field@FieldDefinition { fieldType } = do - typeConName <- typeFrom [] <$> getType lib (typeConName fieldType) - pure $ field { fieldType = fieldType { typeConName } } - subTypes (DataEnum enumTags) = pure - [ ClientType - { clientType = TypeD { tName = typeName - , tNamespace = [] - , tCons = map enumOption enumTags - , tMeta = Nothing - } - , clientKind = KindEnum - } - ] - where - enumOption DataEnumValue { enumName } = - ConsD { cName = enumName, cFields = [] } - subTypes _ = pure [] - -lookupFieldType - :: Schema - -> [Key] - -> TypeDefinition - -> Position - -> Text - -> 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 :: Eventless () - checkDeprecated = case fieldMeta >>= lookupDeprecated of - Just deprecation -> Success { result = (), warnings, events = [] } - where - warnings = deprecatedField typeName - Ref { refName = key, refPosition } - (lookupDeprecatedReason deprecation) - Nothing -> pure () -lookupFieldType _ _ dt _ _ = - failure (compileError $ "Type should be output Object \"" <> pack (show dt)) - - -leafType :: TypeDefinition -> Eventless ([ClientType], [Text]) -leafType TypeDefinition { typeName, typeContent } = fromKind typeContent - where - fromKind :: TypeContent -> Eventless ([ClientType], [Text]) - fromKind DataEnum{} = pure ([], [typeName]) - fromKind DataScalar{} = pure ([], []) - fromKind _ = failure $ compileError "Invalid schema Expected scalar" - -getType :: Schema -> Text -> Eventless TypeDefinition -getType lib typename = selectBy (compileError typename) typename lib - -typeFrom :: [Name] -> TypeDefinition -> Name -typeFrom path TypeDefinition { typeName, typeContent } = __typeFrom typeContent - where - __typeFrom DataScalar{} = typeFromScalar typeName - __typeFrom DataObject{} = nameSpaceType path typeName - __typeFrom DataUnion{} = nameSpaceType path typeName - __typeFrom _ = typeName diff --git a/src/Data/Morpheus/Execution/Document/Compile.hs b/src/Data/Morpheus/Execution/Document/Compile.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/Compile.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-#LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Execution.Document.Compile - ( compileDocument - , gqlDocument - , gqlDocumentNamespace - ) -where - -import qualified Data.Text as T - ( pack ) -import Language.Haskell.TH -import Language.Haskell.TH.Quote - --- --- Morpheus -import Data.Morpheus.Error.Client.Client - ( renderGQLErrors - , gqlWarnings - ) -import Data.Morpheus.Execution.Document.Convert - ( toTHDefinitions ) -import Data.Morpheus.Execution.Document.Declare - ( declareTypes ) -import Data.Morpheus.Parsing.Document.TypeSystem - ( parseSchema ) -import Data.Morpheus.Validation.Document.Validation -import Data.Morpheus.Types.Internal.Resolving - ( Result(..) ) - - -gqlDocumentNamespace :: QuasiQuoter -gqlDocumentNamespace = QuasiQuoter { quoteExp = notHandled "Expressions" - , quotePat = notHandled "Patterns" - , quoteType = notHandled "Types" - , quoteDec = compileDocument True - } - where - notHandled things = - error $ things ++ " are not supported by the GraphQL QuasiQuoter" - -gqlDocument :: QuasiQuoter -gqlDocument = QuasiQuoter { quoteExp = notHandled "Expressions" - , quotePat = notHandled "Patterns" - , quoteType = notHandled "Types" - , quoteDec = compileDocument False - } - where - notHandled things = - error $ things ++ " are not supported by the GraphQL QuasiQuoter" - -compileDocument :: Bool -> String -> Q [Dec] -compileDocument namespace documentTXT = - case - parseSchema (T.pack documentTXT) - >>= validatePartialDocument - of - Failure errors -> fail (renderGQLErrors errors) - Success { result = schema, warnings } -> - gqlWarnings warnings >> toTHDefinitions namespace schema >>= declareTypes namespace diff --git a/src/Data/Morpheus/Execution/Document/Convert.hs b/src/Data/Morpheus/Execution/Document/Convert.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/Convert.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} --- {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Morpheus.Execution.Document.Convert - ( toTHDefinitions - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Text (unpack) -import Language.Haskell.TH - --- MORPHEUS -import Data.Morpheus.Types.Internal.TH (infoTyVars) -import Data.Morpheus.Execution.Internal.Utils - ( capital ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , TypeRef(..) - , DataEnumValue(..) - , ConsD(..) - , GQLTypeD(..) - , TypeD(..) - , Key - , InputFieldsDefinition(..) - , ArgumentsDefinition(..) - , hasArguments - , lookupWith - , toHSFieldDefinition - , hsTypeName - , kindOf - ) -import Data.Morpheus.Types.Internal.Operation - (Listable(..)) - -m_ :: Key -m_ = "m" - -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 <$> lookupWith typeName key lib of - Just x -> pure (kindToTyArgs x) - Nothing -> getTyArgs <$> reify (mkName $ unpack key) - -getTyArgs :: Info -> Maybe Key -getTyArgs x - | null (infoTyVars x) = Nothing - | otherwise = Just m_ - -kindToTyArgs :: TypeContent -> Maybe Key -kindToTyArgs DataObject{} = Just m_ -kindToTyArgs DataUnion{} = Just m_ -kindToTyArgs _ = Nothing - -toTHDefinitions :: Bool -> [TypeDefinition] -> Q [GQLTypeD] -toTHDefinitions namespace lib = traverse renderTHType lib - where - renderTHType :: TypeDefinition -> Q GQLTypeD - renderTHType x = generateType x - where - genArgsTypeName :: Key -> Key - genArgsTypeName fieldName | namespace = hsTypeName (typeName x) <> argTName - | otherwise = argTName - where argTName = capital fieldName <> "Args" - --------------------------------------------------------------------------------------------- - 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 } - , fieldArgs = fieldArguments - } - where - fieldArguments - | hasArguments fieldArgs = fieldArgs { argumentsTypename = Just $ genArgsTypeName fieldName } - | otherwise = fieldArgs - -------------------------------------------- - generateType :: TypeDefinition -> Q GQLTypeD - generateType typeOriginal@TypeDefinition { typeName, typeContent, typeMeta } = genType - typeContent - where - 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 - } - , typeArgD = [] - , .. - } - where - enumOption DataEnumValue { enumName } = - ConsD { cName = hsTypeName enumName, cFields = [] } - genType DataScalar {} = fail "Scalar Types should defined By Native Haskell Types" - genType DataInputUnion {} = fail "Input Unions not Supported" - genType DataInterface {} = fail "interfaces must be eliminated in Validation" - genType (DataInputObject fields) = pure GQLTypeD - { typeD = buildType $ buildObjectCons $ genInputFields fields - , typeArgD = [] - , .. - } - genType DataObject {objectFields} = do - typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (toList objectFields) - objCons <- buildObjectCons <$> traverse genResField (toList objectFields) - pure GQLTypeD - { typeD = buildType objCons - , typeArgD - , .. - } - genType (DataUnion members) = - pure GQLTypeD - { typeD = buildType (map unionCon members) - , typeArgD = [] - , .. - } - where - unionCon memberName = ConsD - { cName - , cFields = [ FieldDefinition - { fieldName = "un" <> cName - , fieldType = TypeRef { typeConName = utName - , typeArgs = Just m_ - , typeWrappers = [] - } - , fieldMeta = Nothing - , fieldArgs = NoArguments - } - ] - } - where - cName = hsTypeName typeName <> utName - utName = hsTypeName memberName - - -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 = genArguments fieldArgs - } - ] - , tMeta = Nothing - } - ] - where tName = namespaceWith (hsTypeName fieldName) - -genArguments :: ArgumentsDefinition -> [FieldDefinition] -genArguments = genInputFields . InputFieldsDefinition . arguments - -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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/Declare.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Execution.Document.Declare - ( declareTypes - ) -where - -import Data.Semigroup ( (<>) ) -import Language.Haskell.TH - - --- MORPHEUS -import Data.Morpheus.Execution.Document.Decode - ( deriveDecode ) -import Data.Morpheus.Execution.Document.Encode - ( deriveEncode ) -import Data.Morpheus.Execution.Document.GQLType - ( deriveGQLType ) -import Data.Morpheus.Execution.Document.Introspect - ( deriveObjectRep - , instanceIntrospect - ) -import Data.Morpheus.Execution.Internal.Declare - ( declareType - , Scope(..) - ) -import Data.Morpheus.Types.Internal.AST - ( isInput - , isObject - , GQLTypeD(..) - ) - -declareTypes :: Bool -> [GQLTypeD] -> Q [Dec] -declareTypes namespace = fmap concat . traverse (declareGQLType namespace) - -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 - pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum - where - deriveGQLInstances = concat <$> sequence gqlInstances - where - gqlInstances - | isObject typeKindD && isInput typeKindD - = [deriveObjectRep (typeD, Nothing), deriveDecode typeD] - | isObject typeKindD - = [deriveObjectRep (typeD, Just typeKindD), deriveEncode gqlType] - | otherwise - = [] - -------------------------------------------------- - declareArgTypes = do - introspectArgs <- concat <$> traverse deriveArgsRep typeArgD - decodeArgs <- concat <$> traverse deriveDecode typeArgD - return $ argsTypeDecs <> decodeArgs <> introspectArgs - where - deriveArgsRep args = deriveObjectRep (args, Nothing) - ---------------------------------------------------- - argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD - -------------------------------------------------- - declareMainType = declareT - where - declareT = - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/Decode.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Execution.Document.Decode - ( deriveDecode - ) -where - -import Data.Text ( Text ) -import Language.Haskell.TH - --- --- MORPHEUS -import Data.Morpheus.Execution.Internal.Decode - ( decodeFieldWith - , decodeObjectExpQ - , withObject - ) -import Data.Morpheus.Execution.Server.Decode - ( Decode(..) - , DecodeType(..) - ) -import Data.Morpheus.Types.Internal.AST - ( TypeD(..) - , ValidValue - ) -import Data.Morpheus.Types.Internal.TH - ( instanceHeadT ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless ) - -(.:) :: Decode a => ValidValue -> Text -> Eventless a -value .: selectorName = withObject (decodeFieldWith decode selectorName) value - -deriveDecode :: TypeD -> Q [Dec] -deriveDecode TypeD { tName, tCons = [cons] } = - pure <$> instanceD (cxt []) appHead methods - where - appHead = instanceHeadT ''DecodeType tName [] - methods = [funD 'decodeType [clause argsE (normalB body) []]] - where - argsE = map (varP . mkName) ["o"] - body = decodeObjectExpQ [|(.:)|] cons -deriveDecode _ = pure [] diff --git a/src/Data/Morpheus/Execution/Document/Encode.hs b/src/Data/Morpheus/Execution/Document/Encode.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/Encode.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Execution.Document.Encode - ( deriveEncode - ) -where - -import Data.Text ( unpack ) -import Data.Typeable ( Typeable ) -import Language.Haskell.TH -import Data.Semigroup ( (<>) ) - --- --- MORPHEUS -import Data.Morpheus.Execution.Server.Encode - ( Encode(..) - , ExploreResolvers(..) - ) -import Data.Morpheus.Types.GQLType ( TRUE ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , QUERY - , SUBSCRIPTION - , isSubscription - , ConsD(..) - , GQLTypeD(..) - , TypeD(..) - , Key - ) -import Data.Morpheus.Types.Internal.Resolving - ( Resolver - , MapStrategy(..) - , LiftOperation - , Deriving(..) - , ObjectDeriving(..) - ) -import Data.Morpheus.Types.Internal.TH - ( applyT - , destructRecord - , instanceHeadMultiT - , typeT - ) - - - -m_ :: Key -m_ = "m" - -fo_ :: Key -fo_ = "fieldOperationKind" - -po_ :: Key -po_ = "parentOparation" - -e_ :: Key -e_ = "encodeEvent" - -encodeVars :: [Key] -encodeVars = [e_, m_] - -encodeVarsT :: [TypeQ] -encodeVarsT = map (varT . mkName . unpack) encodeVars - -deriveEncode :: GQLTypeD -> Q [Dec] -deriveEncode GQLTypeD { typeKindD, typeD = TypeD { tName, tCons = [ConsD { cFields }] } } - = pure <$> instanceD (cxt constrains) appHead methods - where - subARgs = conT ''SUBSCRIPTION : encodeVarsT - instanceArgs | isSubscription typeKindD = subARgs - | otherwise = map (varT . mkName . unpack) (po_ : encodeVars) - mainType = applyT (mkName $ unpack tName) [mainTypeArg] - where - mainTypeArg | isSubscription typeKindD = applyT ''Resolver subARgs - | otherwise = typeT ''Resolver (fo_ : encodeVars) - ----------------------------------------------------------------------------------------- - typeables - | isSubscription typeKindD - = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]] - | otherwise - = [ iLiftOp po_ - , iLiftOp fo_ - , typeT ''MapStrategy [fo_, po_] - , iTypeable fo_ - , iTypeable po_ - ] - ------------------------- - iLiftOp op = applyT ''LiftOperation [varT $ mkName $ unpack op] - ------------------------- - iTypeable name = typeT ''Typeable [name] - ------------------------------------------- - -- defines Constraint: (Typeable m, Monad m) - constrains = - typeables - <> [ typeT ''Monad [m_] - , applyT ''Encode (mainType : instanceArgs) - , iTypeable e_ - , iTypeable m_ - ] - ------------------------------------------------------------------- - -- defines: instance => ObjectResolvers ('TRUE) ( (ResolveT m)) (ResolveT m value) where - appHead = instanceHeadMultiT ''ExploreResolvers - (conT ''TRUE) - (mainType : instanceArgs) - ------------------------------------------------------------------ - -- defines: objectResolvers = [("field1",encode field1),("field2",encode field2), ...] - methods = [funD 'exploreResolvers [clause argsE (normalB body) []]] - where - argsE = [varP (mkName "_"), destructRecord tName 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 -deriveEncode _ = pure [] diff --git a/src/Data/Morpheus/Execution/Document/GQLType.hs b/src/Data/Morpheus/Execution/Document/GQLType.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/GQLType.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Execution.Document.GQLType - ( deriveGQLType - ) -where - -import Data.Text ( pack - , unpack - ) -import Language.Haskell.TH -import Data.Semigroup ( (<>) ) --- --- MORPHEUS -import Data.Morpheus.Execution.Internal.Declare - ( tyConArgs ) -import Data.Morpheus.Kind ( ENUM - , SCALAR - , WRAPPER - , INPUT - , OUTPUT - ) -import Data.Morpheus.Types.GQLType ( GQLType(..) - , TRUE - ) -import Data.Morpheus.Types.Internal.AST - ( DataTypeKind(..) - , Meta(..) - , isObject - , isSchemaTypeName - , GQLTypeD(..) - , TypeD(..) - , Key - ) -import Data.Morpheus.Types.Internal.TH - ( instanceHeadT - , typeT - , typeInstanceDec - , instanceProxyFunD - ) -import Data.Typeable ( Typeable ) - -deriveGQLType :: GQLTypeD -> Q [Dec] -deriveGQLType GQLTypeD { typeD = TypeD { tName, tMeta }, typeKindD } = - pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies) - where - functions = map - instanceProxyFunD - [('__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 = [deriveKIND, deriveCUSTOM] - | otherwise = [deriveKIND] - where - deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE - deriveKIND = deriveInstance ''KIND (kindName typeKindD) - ------------------------------------------------------- - deriveInstance :: Name -> Name -> Q Dec - deriveInstance insName tyName = do - typeN <- headSig - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Document/Introspect.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Morpheus.Execution.Document.Introspect - ( deriveObjectRep , instanceIntrospect - ) where - -import Data.Maybe(maybeToList) -import Data.Proxy (Proxy (..)) -import Data.Text (unpack,Text) -import Data.Typeable (Typeable) -import Language.Haskell.TH - --- MORPHEUS -import Data.Morpheus.Execution.Internal.Declare (tyConArgs) -import Data.Morpheus.Execution.Server.Introspect (Introspect (..), introspectObjectFields, IntrospectRep (..),TypeScope(..)) -import Data.Morpheus.Types.GQLType (GQLType (__typeName), TRUE) -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 :: 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 typeName [] - defineIntrospect = instanceProxyFunD ('introspect,body) - where - body =[| insertType TypeDefinition { typeContent = DataEnum enumType, .. } |] -instanceIntrospect _ = pure [] - --- [(FieldDefinition, TypeUpdater)] -deriveObjectRep :: (TypeD, Maybe DataTypeKind) -> Q [Dec] -deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) = - pure <$> instanceD (cxt constrains) iHead methods - where - mainTypeName = typeT (mkName $ unpack tName) typeArgs - typeArgs = concatMap tyConArgs (maybeToList tKind) - constrains = map conTypeable typeArgs - where - conTypeable name = typeT ''Typeable [name] - ----------------------------------------------- - iHead = instanceHeadMultiT ''IntrospectRep (conT ''TRUE) [mainTypeName] - methods = [instanceFunD 'introspectRep ["_proxy1", "_proxy2"] body] - where - body - | tKind == Just KindInputObject || null tKind = [| (DataInputObject $ unsafeFromInputFields $(buildFields cFields), concat $(buildTypes cFields))|] - | otherwise = [| (DataObject [] $ unsafeFromFields $(buildFields cFields), concat $(buildTypes cFields))|] -deriveObjectRep _ = pure [] - -buildTypes :: [FieldDefinition] -> ExpQ -buildTypes = listE . concatMap introspectField - where - introspectField FieldDefinition {fieldType, fieldArgs } = - [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgs - where - inputTypes ArgumentsDefinition { argumentsTypename = Just argsTypeName } - | argsTypeName /= "()" = [[| snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]] - where - tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing} - inputTypes _ = [] - -conTX :: Text -> Q Type -conTX = conT . mkName . unpack - -varTX :: Text -> Q Type -varTX = varT . mkName . unpack - -proxyT :: TypeRef -> Q Exp -proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|] - where - genSig (Just m) = appT (conTX typeConName) (varTX m) - genSig _ = conTX typeConName - -buildFields :: [FieldDefinition] -> ExpQ -buildFields = listE . map buildField - where - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Internal/Declare.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# 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 - --- MORPHEUS -import Data.Morpheus.Execution.Internal.Utils - ( nameSpaceType - , nameSpaceWith - ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , DataTypeKind(..) - , DataTypeKind(..) - , TypeRef(..) - , TypeWrapper(..) - , isOutputObject - , isSubscription - , ConsD(..) - , TypeD(..) - , Key - , isOutputObject - , ArgumentsDefinition(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( UnSubResolver ) - -type Arrow = (->) - - -m_ :: Key -m_ = "m" - -declareTypeRef :: Bool -> TypeRef -> Type -declareTypeRef isSub TypeRef { typeConName, typeWrappers, typeArgs } = wrappedT - typeWrappers - where - wrappedT :: [TypeWrapper] -> Type - wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs - wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs - wrappedT [] = decType typeArgs - ------------------------------------------------------ - typeName = ConT (mkName $ unpack typeConName) - -------------------------------------------- - decType _ | isSub = - AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName $ unpack m_)) - decType (Just par) = AppT typeName (VarT $ mkName $ unpack par) - decType _ = typeName - -tyConArgs :: DataTypeKind -> [Key] -tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = [m_] - | otherwise = [] - -data Scope = CLIENT | SERVER - deriving Eq - --- declareType -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 - tVars = maybe [] (declareTyVar . tyConArgs) kindD - where declareTyVar = map (PlainTV . mkName . unpack) - defBang = Bang NoSourceUnpackedness NoSourceStrictness - derive className = DerivClause Nothing [ConT className] - 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 FieldDefinition { fieldName, fieldArgs, fieldType } = - (fName, defBang, fiType) - where - fName | namespace = mkName $ unpack (nameSpaceWith tName fieldName) - | otherwise = mkName (unpack fieldName) - fiType = genFieldT fieldArgs - where - monadVar = VarT $ mkName $ unpack m_ - --------------------------- - genFieldT ArgumentsDefinition { argumentsTypename = Just argsTypename } = AppT - (AppT arrowType argType) - (AppT monadVar result) - where - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Internal/Decode.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Morpheus.Execution.Internal.Decode - ( withObject - , withMaybe - , withList - , withEnum - , withUnion - , decodeFieldWith - , decodeObjectExpQ - ) -where - -import Data.Text ( unpack ) -import Language.Haskell.TH ( ExpQ - , conE - , mkName - , uInfixE - , varE - ) - --- MORPHEUS -import Data.Morpheus.Error.Internal ( - internalTypeMismatch - ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , Key - , ConsD(..) - , ValidObject - , Value(..) - , ValidValue - , Message - , ObjectEntry(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Failure(..) - ) -import Data.Morpheus.Types.Internal.Operation - ( selectBy - , selectOr - , empty - ) - -decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ -decodeObjectExpQ fieldDecoder ConsD { cName, cFields } = handleFields cFields - where - consName = conE (mkName $ unpack cName) - ---------------------------------------------------------------------------------- - handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames) - where - applyFields [] = fail "No Empty fields" - applyFields [x ] = defField x - applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs) - ------------------------------------------------------------------------ - defField FieldDefinition { fieldName } = uInfixE (varE (mkName "o")) - fieldDecoder - [|fName|] - where fName = unpack fieldName - -withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a -withObject f (Object object) = f object -withObject _ isType = internalTypeMismatch "Object" isType - -withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a) -withMaybe _ Null = pure Nothing -withMaybe decode x = Just <$> decode x - -withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a] -withList decode (List li) = traverse decode li -withList _ isType = internalTypeMismatch "List" isType - -withEnum :: (Key -> Eventless a) -> ValidValue -> Eventless a -withEnum decode (Enum value) = decode value -withEnum _ isType = internalTypeMismatch "Enum" isType - -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 -> Eventless a) -> Key -> ValidObject -> Eventless a -decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue) diff --git a/src/Data/Morpheus/Execution/Internal/Utils.hs b/src/Data/Morpheus/Execution/Internal/Utils.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Internal/Utils.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Data.Morpheus.Execution.Internal.Utils - ( capital - , nonCapital - , nameSpaceWith - , nameSpaceType - ) -where - -import Data.Char ( toLower - , toUpper - ) -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , unpack - , pack - ) -import qualified Data.Text as T - ( concat ) - - -nameSpaceType :: [Text] -> Text -> Text -nameSpaceType list name = T.concat $ map capital (list <> [name]) - -nameSpaceWith :: Text -> Text -> Text -nameSpaceWith nSpace name = nonCapital nSpace <> capital name - -nonCapital :: Text -> Text -nonCapital = pack . __nonCapital . unpack - where - __nonCapital [] = [] - __nonCapital (x : xs) = toLower x : xs - -capital :: Text -> Text -capital = pack . __capital . unpack - where - __capital [] = [] - __capital (x : xs) = toUpper x : xs diff --git a/src/Data/Morpheus/Execution/Server/Decode.hs b/src/Data/Morpheus/Execution/Server/Decode.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Decode.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TupleSections #-} - -module Data.Morpheus.Execution.Server.Decode - ( decodeArguments - , Decode(..) - , DecodeType(..) - ) -where - -import Data.Proxy ( Proxy(..) ) -import Data.Semigroup ( Semigroup(..) ) -import Data.Text ( pack ) -import GHC.Generics - --- MORPHEUS -import Data.Morpheus.Error.Internal ( internalTypeMismatch - , internalError - ) -import Data.Morpheus.Execution.Internal.Decode - ( decodeFieldWith - , withList - , withMaybe - , withObject - , withUnion - ) -import Data.Morpheus.Kind ( ENUM - , GQL_KIND - , SCALAR - , OUTPUT - , INPUT - ) -import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) - , toScalar - ) -import Data.Morpheus.Types.GQLType ( GQLType(KIND, __typeName) ) -import Data.Morpheus.Types.Internal.AST - ( Name - , Argument(..) - , ObjectEntry(..) - , ValidObject - , Value(..) - , ValidValue - , Arguments - , VALID - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Failure(..) - ) -import Data.Morpheus.Types.Internal.Operation - ( Listable(..) - ) - - --- GENERIC -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 -> Eventless a - -instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where - decode = decodeKind (Proxy @(KIND a)) - -instance Decode a => Decode (Maybe a) where - decode = withMaybe decode - -instance Decode a => Decode [a] where - decode = withList decode - --- | Decode GraphQL type with Specific Kind -class DecodeKind (kind :: GQL_KIND) a where - decodeKind :: Proxy kind -> ValidValue -> Eventless a - --- SCALAR -instance (GQLScalar a) => DecodeKind SCALAR a where - decodeKind _ value = case toScalar value >>= parseValue of - Right scalar -> return scalar - Left errorMessage -> internalTypeMismatch errorMessage value - --- ENUM -instance DecodeType a => DecodeKind ENUM a where - decodeKind _ = decodeType - --- TODO: remove -instance DecodeType a => DecodeKind OUTPUT a where - decodeKind _ = decodeType - --- INPUT_OBJECT and INPUT_UNION -instance DecodeType a => DecodeKind INPUT a where - decodeKind _ = decodeType - - -class DecodeType a where - decodeType :: ValidValue -> Eventless a - -instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a))=> DecodeType a where - decodeType = fmap to . decodeRep . (, Cont D_CONS "") - --- data Inpuz = --- InputHuman Human -- direct link: { __typename: Human, Human: {field: ""} } --- | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} } --- | IndexedType Int Text -- { __typename: InputRecord, _0:2 , _1:"" } --- | Zeus -- { __typename: Zeus } --- deriving (Generic, GQLType) - -decideUnion - :: ([Name], value -> Eventless (f1 a)) - -> ([Name], value -> Eventless (f2 a)) - -> Name - -> value - -> Eventless ((:+:) f1 f2 a) -decideUnion (left, f1) (right, f2) name value - | name `elem` left - = L1 <$> f1 value - | name `elem` right - = R1 <$> f2 value - | otherwise - = failure $ "Constructor \"" <> name <> "\" could not find in Union" - -data Tag = D_CONS | D_UNION deriving (Eq ,Ord) - -data Cont = Cont { - contKind:: Tag, - typeName :: Name -} - -data Info = Info { - kind :: Tag, - tagName :: [Name] -} - -instance Semigroup Info where - Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2) - Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2) - Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2) - --- --- GENERICS --- -class DecodeRep f where - tags :: Proxy f -> Name -> Info - 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 -> 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) - decodeRep = __decode - where - - __decode (Object obj, cont) = withUnion handleUnion obj - where - handleUnion name unions object - | name == typeName cont <> "EnumObject" - = getEnumTag object >>= __decode . (, ctx) . Enum - | [name] == l1 - = L1 <$> decodeRep (Object object, ctx) - | [name] == r1 - = R1 <$> decodeRep (Object object, ctx) - | otherwise - = decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx) - l1 = tagName l1t - r1 = tagName r1t - l1t = tags (Proxy @a) (typeName cont) - r1t = tags (Proxy @b) (typeName cont) - ctx = cont { contKind = kind (l1t <> r1t) } - __decode (Enum name, cxt) = decideUnion - (tagName $ tags (Proxy @a) (typeName cxt), decodeRep) - (tagName $ tags (Proxy @b) (typeName cxt), decodeRep) - name - (Enum name, cxt) - __decode _ = internalError "lists and scalars are not allowed in Union" - -instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where - decodeRep = fmap M1 . decodeFields - tags _ baseName = getTag (refType (Proxy @a)) - where - getTag (Just memberRef) - | isUnionRef memberRef = Info { kind = D_UNION, tagName = [memberRef] } - | otherwise = Info { kind = D_CONS, tagName = [consName] } - getTag Nothing = Info { kind = D_CONS, tagName = [consName] } - -------- - consName = pack $ conName unsafeType - ---------- - isUnionRef x = baseName <> x == consName - -------------------------- - unsafeType :: (M1 C c U1 x) - unsafeType = undefined - -class DecodeFields f where - refType :: Proxy f -> Maybe Name - decodeFields :: (ValidValue,Cont) -> Eventless (f a) - -instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where - refType _ = Nothing - decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql - -instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where - refType _ = Just $ __typeName (Proxy @a) - decodeFields (value, Cont { contKind }) - | contKind == D_UNION = M1 . K1 <$> decode value - | otherwise = __decode value - where - __decode = fmap (M1 . K1) . decodeRec - fieldName = pack $ selName (undefined :: M1 S s f a) - decodeRec = withObject (decodeFieldWith decode fieldName) - -instance DecodeFields U1 where - refType _ = Nothing - decodeFields _ = pure U1 diff --git a/src/Data/Morpheus/Execution/Server/Encode.hs b/src/Data/Morpheus/Execution/Server/Encode.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Encode.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GADTs #-} - -module Data.Morpheus.Execution.Server.Encode - ( EncodeCon - , Encode(..) - , ExploreResolvers(..) - , deriveModel - ) -where - -import Data.Map ( Map ) -import qualified Data.Map as M - ( toList ) -import Data.Proxy ( Proxy(..) ) -import Data.Semigroup ( (<>) ) -import Data.Set ( Set ) -import qualified Data.Set as S - ( toList ) -import Data.Text ( pack ) -import GHC.Generics - --- MORPHEUS -import Data.Morpheus.Execution.Server.Decode - ( DecodeType - , decodeArguments - ) -import Data.Morpheus.Kind ( ENUM - , GQL_KIND - , ResContext(..) - , SCALAR - , OUTPUT - , VContext(..) - ) -import Data.Morpheus.Types.Types ( MapKind - , Pair(..) - , mapKindFromList - ) -import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) ) -import Data.Morpheus.Types.GQLType ( GQLType(..) ) -import Data.Morpheus.Types.Internal.AST - ( Name - , OperationType(..) - , QUERY - , SUBSCRIPTION - , MUTATION - , Message - ) -import Data.Morpheus.Types.Internal.Operation - (Merge(..)) -import Data.Morpheus.Types.Internal.Resolving - ( MapStrategy(..) - , LiftOperation - , Resolver - , toResolver - , Deriving(..) - , FieldRes - , GQLRootResolver(..) - , ResolverModel(..) - , unsafeBind - , failure - , ObjectDeriving(..) - , Eventless - , liftStateless - ) - -class Encode resolver o e (m :: * -> *) where - 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 DerivingNull) encode - --- LIST [] -instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where - encode = fmap DerivingList . traverse encode - --- Tuple (a,b) -instance Encode (Pair k v) o e m => Encode (k, v) o e m where - encode (key, value) = encode (Pair key value) - --- Set -instance Encode [a] o e m => Encode (Set a) o e m where - encode = encode . S.toList - --- Map -instance (Eq k, Monad m,LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where - encode value = - 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 - , 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 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 (Deriving o e m) - --- SCALAR -instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where - encodeKind = pure . DerivingScalar . serialize . unVContext - --- ENUM -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, 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 - -> 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 [] = DerivingEnum resDatatypeName resTypeName - -- Type References -------------------------------------------------------------- - encodeUnion [FieldNode { fieldTypeName, fieldResolver, isFieldObject }] - | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName - = DerivingUnion fieldTypeName fieldResolver - -- Inline Union Types ---------------------------------------------------------------------------- - encodeUnion fields - = DerivingUnion - resTypeName - $ pure - $ DerivingObject - $ ObjectDeriving - resTypeName - (map toFieldRes resolvers) - where - resolvers | isResRecord = fields - | otherwise = setFieldNames fields - --- Types & Constrains ------------------------------------------------------- -type GQL_RES a = (Generic a, GQLType a) - -type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) - ---- GENERICS ------------------------------------------------ -class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where - 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 = - pure - $ convertNode - $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value) - ------ HELPERS ---------------------------- -objectResolvers - :: forall a o e m - . ( ExploreResolvers (CUSTOM a) a o e m - , Monad m - , LiftOperation o - ) - => 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) - -type Con o e m a - = ExploreResolvers - (CUSTOM - (a (Resolver o e m)) - ) - (a (Resolver o e m)) - o - e - m - -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 - -data ResNode o e m = ResNode { - resDatatypeName :: Name, - resTypeName :: Name, - resKind :: REP_KIND, - resFields :: [FieldNode o e m], - isResRecord :: Bool - } - -data FieldNode o e m = FieldNode { - fieldTypeName :: Name, - fieldSelName :: Name, - fieldResolver :: Resolver o e m (Deriving o e m), - isFieldObject :: Bool - } - --- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text } -setFieldNames :: [FieldNode o e m] -> [FieldNode o e m] -setFieldNames = zipWith setFieldName ([0 ..] :: [Int]) - where setFieldName i field = field { fieldSelName = "_" <> pack (show i) } - -class TypeRep f o e (m :: * -> *) where - typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m - -instance (Datatype d,TypeRep f o e m) => TypeRep (M1 D d f) o e m where - typeResolvers context (M1 src) = (typeResolvers context src) - { resDatatypeName = pack $ datatypeName (undefined :: M1 D d f a) } - ---- UNION OR OBJECT -instance (TypeRep a o e m,TypeRep b o e m) => TypeRep (a :+: b) o e m where - typeResolvers context (L1 x) = - (typeResolvers context x) { resKind = REP_UNION } - typeResolvers context (R1 x) = - (typeResolvers context x) { resKind = REP_UNION } - -instance (FieldRep f o e m,Constructor c) => TypeRep (M1 C c f) o e m where - typeResolvers context (M1 src) = ResNode { resDatatypeName = "" - , resTypeName = pack (conName proxy) - , resKind = REP_OBJECT - , resFields = fieldRep context src - , isResRecord = conIsRecord proxy - } - where proxy = undefined :: (M1 C c U1 x) - - --- FIELDS -class FieldRep f o e (m :: * -> *) where - fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m] - -instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where - fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b - -instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where - fieldRep _ m@(M1 (K1 src)) = - [ FieldNode { fieldSelName = pack (selName m) - , fieldTypeName = __typeName (Proxy @a) - , fieldResolver = encode src - , isFieldObject = isObjectKind (Proxy @a) - } - ] - -instance FieldRep U1 o e m where - fieldRep _ _ = [] diff --git a/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs b/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Morpheus.Execution.Server.Generics.EnumRep - ( EnumRep(..) - ) -where - -import Data.Proxy ( Proxy(..) ) -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , pack - ) -import GHC.Generics - --- MORPHEUS -import Data.Morpheus.Error.Internal ( internalError ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless ) - -class EnumRep f where - encodeRep :: f a -> Text - decodeEnum :: Text -> Eventless (f a) - enumTags :: Proxy f -> [Text] - -instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where - encodeRep (M1 src) = encodeRep src - decodeEnum = fmap M1 . decodeEnum - enumTags _ = enumTags (Proxy @f) - -instance (Constructor c) => EnumRep (M1 C c U1) where - encodeRep m@(M1 _) = pack $ conName m - decodeEnum _ = pure $ M1 U1 - enumTags _ = [pack $ conName (undefined :: (M1 C c U1 x))] - -instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where - encodeRep (L1 x) = encodeRep x - encodeRep (R1 x) = encodeRep x - decodeEnum name - | name `elem` enumTags (Proxy @a) = L1 <$> decodeEnum name - | name `elem` enumTags (Proxy @b) = R1 <$> decodeEnum name - | otherwise = internalError - ("Constructor \"" <> name <> "\" could not find in Union") - enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b) diff --git a/src/Data/Morpheus/Execution/Server/Interpreter.hs b/src/Data/Morpheus/Execution/Server/Interpreter.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Interpreter.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Morpheus.Execution.Server.Interpreter - ( Interpreter(..) - ) -where - - --- MORPHEUS -import Data.Morpheus.Types.Internal.Subscription - ( Stream - , Input - , toOutStream - ) -import Data.Morpheus.Execution.Server.Resolve - ( RootResCon - , coreResolver - , statelessResolver - ) -import Data.Morpheus.Types.Internal.Resolving - ( GQLRootResolver(..) - ) -import Data.Morpheus.Types.IO ( GQLRequest - , GQLResponse - , MapAPI(..) - ) - --- | main query processor and resolver --- possible versions of interpreter --- --- 1. with effect and state: where 'GQLState' is State Monad of subscriptions --- --- @ --- k :: GQLState -> a -> IO a --- @ --- --- 2. without effect and state: stateless query processor without any effect, --- if you don't need any subscription use this one , is simple and fast --- --- @ --- k :: a -> IO a --- -- or --- k :: GQLRequest -> IO GQLResponse --- @ -class Interpreter e m a b where - interpreter :: - Monad m - => (RootResCon m e query mut sub) - => GQLRootResolver m e query mut sub - -> a - -> b - -instance Interpreter e m GQLRequest (m GQLResponse) where - interpreter = statelessResolver - -instance Interpreter e m (Input api) (Stream api e m) where - interpreter root = toOutStream (coreResolver root) - -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 deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Introspect.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# 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 - , Introspect(..) - , IntrospectRep(..) - , IntroCon - , updateLib - , buildType - , introspectObjectFields - , TypeScope(..) - ) -where - -import Data.Map ( Map ) -import Data.Proxy ( Proxy(..) ) -import Data.Set ( Set ) -import Data.Text ( Text - , pack - ) -import GHC.Generics -import Data.Semigroup ( (<>) ) -import Data.List ( partition ) - --- MORPHEUS -import Data.Morpheus.Error.Utils ( globalErrorMessage ) -import Data.Morpheus.Error.Schema ( nameCollisionError ) -import Data.Morpheus.Execution.Server.Generics.EnumRep - ( EnumRep(..) ) -import Data.Morpheus.Kind ( Context(..) - , ENUM - , GQL_KIND - , SCALAR - , OUTPUT - , INPUT - ) -import Data.Morpheus.Types.Types ( MapKind - , Pair - ) -import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) ) -import Data.Morpheus.Types.GQLType ( GQLType(..) ) -import Data.Morpheus.Types.Internal.Resolving - ( Failure(..) - , resolveUpdates - , Resolver - ) -import Data.Morpheus.Types.Internal.AST - ( Name - , ArgumentsDefinition(..) - , Meta(..) - , FieldDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , Key - , createAlias - , defineType - , isTypeDefined - , toListField - , toNullableField - , createEnumValue - , TypeUpdater - , DataFingerprint(..) - , DataUnion - , FieldsDefinition(..) - , InputFieldsDefinition(..) - , TypeRef(..) - , Message - , unsafeFromFields - ) -import Data.Morpheus.Types.Internal.Operation - ( Empty(..) - , Singleton(..) - ) - -type IntroCon a = (GQLType a, IntrospectRep (CUSTOM a) a) - - --- | Generates internal GraphQL Schema for query validation and introspection rendering -class Introspect a where - isObject :: proxy a -> Bool - default isObject :: GQLType a => proxy a -> Bool - isObject _ = isObjectKind (Proxy @a) - field :: proxy a -> Text -> FieldDefinition - introspect :: proxy a -> TypeUpdater - ----------------------------------------------- - default field :: GQLType 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) - --- Maybe -instance Introspect a => Introspect (Maybe a) where - isObject _ = False - field _ = toNullableField . field (Proxy @a) - introspect _ = introspect (Proxy @a) - --- List -instance Introspect a => Introspect [a] where - isObject _ = False - field _ = toListField . field (Proxy @a) - introspect _ = introspect (Proxy @a) - --- Tuple -instance Introspect (Pair k v) => Introspect (k, v) where - isObject _ = True - field _ = field (Proxy @(Pair k v)) - introspect _ = introspect (Proxy @(Pair k v)) - --- Set -instance Introspect [a] => Introspect (Set a) where - isObject _ = False - field _ = field (Proxy @[a]) - introspect _ = introspect (Proxy @[a]) - --- Map -instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where - isObject _ = True - field _ = field (Proxy @(MapKind k v Maybe)) - introspect _ = introspect (Proxy @(MapKind k v Maybe)) - --- Resolver : a -> Resolver b -instance (GQLType b, IntrospectRep 'False a, Introspect b) => Introspect (a -> m b) where - isObject _ = False - field _ name = fieldObj { fieldArgs } - where - fieldObj = field (Proxy @b) name - fieldArgs = ArgumentsDefinition Nothing $ unFieldsDefinition $ fst $ introspectObjectFields - (Proxy :: Proxy 'False) - (__typeName (Proxy @b), OutputType, Proxy @a) - introspect _ typeLib = resolveUpdates typeLib - (introspect (Proxy @b) : inputs) - where - name = "Arguments for " <> __typeName (Proxy @b) - inputs :: [TypeUpdater] - inputs = - snd $ introspectObjectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a) - --- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY -instance (GQLType b, Introspect b) => Introspect (Resolver fo e m b) where - isObject _ = False - field _ = field (Proxy @b) - introspect _ = introspect (Proxy @b) - - --- | Introspect With specific Kind: 'kind': object, scalar, enum ... -class IntrospectKind (kind :: GQL_KIND) a where - introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema - --- SCALAR -instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where - introspectKind _ = updateLib scalarType [] (Proxy @a) - where scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a) - --- ENUM -instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where - introspectKind _ = updateLib enumType [] (Proxy @a) - where - enumType = - buildType $ DataEnum $ map createEnumValue $ enumTags (Proxy @(Rep a)) - -instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind INPUT a where - introspectKind _ = derivingData (Proxy @a) InputType - -instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind OUTPUT a where - introspectKind _ = derivingData (Proxy @a) OutputType - -derivingData - :: forall a - . (GQLType a, IntrospectRep (CUSTOM a) a) - => Proxy a - -> TypeScope - -> TypeUpdater -derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a) - where - (datatypeContent, updates) = introspectRep - (Proxy @(CUSTOM a)) - (Proxy @a, scope, baseName, baseFingerprint) - baseName = __typeName (Proxy @a) - baseFingerprint = __typeFingerprint (Proxy @a) - -type GQL_TYPE a = (Generic a, GQLType a) - -fromInput :: InputFieldsDefinition -> FieldsDefinition -fromInput = FieldsDefinition . unInputFieldsDefinition - -toInput :: FieldsDefinition -> InputFieldsDefinition -toInput = InputFieldsDefinition . unFieldsDefinition - -introspectObjectFields - :: IntrospectRep custom a - => proxy1 (custom :: Bool) - -> (Name, TypeScope, proxy2 a) - -> (FieldsDefinition, [TypeUpdater]) -introspectObjectFields p1 (name, scope, proxy) = withObject - (introspectRep p1 (proxy, scope, "", DataFingerprint "" [])) - where - withObject (DataObject {objectFields}, ts) = (objectFields, ts) - 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) -> (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 -> ArgumentsDefinition -> Text -> FieldDefinition -buildField proxy fieldArgs fieldName = FieldDefinition - { fieldType = createAlias $ __typeName proxy - , fieldMeta = Nothing - , .. - } - -buildType :: GQLType a => TypeContent -> Proxy a -> TypeDefinition -buildType typeContent proxy = TypeDefinition - { typeName = __typeName proxy - , typeFingerprint = __typeFingerprint proxy - , typeMeta = Just Meta { metaDescription = description proxy - , metaDirectives = [] - } - , typeContent - } - -updateLib - :: GQLType a - => (Proxy a -> TypeDefinition) - -> [TypeUpdater] - -> Proxy a - -> TypeUpdater -updateLib typeBuilder stack proxy lib = - case isTypeDefined (__typeName proxy) lib of - Nothing -> resolveUpdates - (defineType (typeBuilder proxy) lib) - stack - Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib - -- throw error if 2 different types has same name - Just _ -> failure $ nameCollisionError (__typeName proxy) - - --- NEW AUTOMATIC DERIVATION SYSTEM - -data ConsRep = ConsRep { - consName :: Key, - consIsRecord :: Bool, - consFields :: [FieldRep] -} - -data FieldRep = FieldRep { - fieldTypeName :: Name, - fieldData :: FieldDefinition, - fieldTypeUpdater :: TypeUpdater, - fieldIsObject :: Bool -} - -data ResRep = ResRep { - enumCons :: [Name], - unionRef :: [Name], - unionRecordRep :: [ConsRep ] -} - -isEmpty :: ConsRep -> Bool -isEmpty ConsRep { consFields = [] } = True -isEmpty _ = False - -isUnionRef :: Name -> ConsRep -> Bool -isUnionRef baseName ConsRep { consName, consFields = [FieldRep { fieldIsObject = True, fieldTypeName }] } - = consName == baseName <> fieldTypeName -isUnionRef _ _ = False - -setFieldNames :: ConsRep -> ConsRep -setFieldNames cons@ConsRep { consFields } = cons - { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields - } - where - setFieldName i fieldR@FieldRep { fieldData = fieldD } = fieldR { fieldData = fieldD { fieldName } } - where fieldName = "_" <> pack (show i) - -analyseRep :: Name -> [ConsRep] -> ResRep -analyseRep baseName cons = ResRep - { enumCons = map consName enumRep - , unionRef = map fieldTypeName $ concatMap consFields unionRefRep - , unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep - } - where - (enumRep , left1 ) = partition isEmpty cons - (unionRefRep , left2 ) = partition (isUnionRef baseName) left1 - (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2 - -derivingDataContent - :: forall a - . (Generic a, TypeRep (Rep a)) - => Proxy a - -> (Name, DataFingerprint) - -> TypeScope - -> (TypeContent, [TypeUpdater]) -derivingDataContent _ (baseName, baseFingerprint) scope = - builder $ typeRep $ Proxy @(Rep a) - where - builder [ConsRep { consFields }] = buildObject scope consFields - builder cons = genericUnion scope cons - where - genericUnion InputType = buildInputUnion (baseName, baseFingerprint) - genericUnion OutputType = - buildUnionType (baseName, baseFingerprint) DataUnion (DataObject []) - - -buildInputUnion - :: (Name, DataFingerprint) -> [ConsRep ] -> (TypeContent, [TypeUpdater]) -buildInputUnion (baseName, baseFingerprint) cons = datatype - (analyseRep baseName cons) - where - datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } = - (DataEnum (map createEnumValue enumCons), types) - datatype ResRep { unionRef, unionRecordRep, enumCons } = - (DataInputUnion typeMembers, types <> unionTypes) - where - typeMembers = - map (, True) (unionRef <> unionMembers) <> map (, False) enumCons - (unionMembers, unionTypes) = - buildUnions (DataInputObject . toInput) baseFingerprint unionRecordRep - types = map fieldTypeUpdater $ concatMap consFields cons - -buildUnionType - :: (Name, DataFingerprint) - -> (DataUnion -> TypeContent) - -> (FieldsDefinition -> TypeContent) - -> [ConsRep] - -> (TypeContent, [TypeUpdater]) -buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype - (analyseRep baseName cons) - where - datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } = - (DataEnum (map createEnumValue enumCons), types) - datatype ResRep { unionRef, unionRecordRep, enumCons } = - (wrapUnion typeMembers, types <> enumTypes <> unionTypes) - where - typeMembers = unionRef <> enumMembers <> unionMembers - (enumMembers, enumTypes) = - buildUnionEnum wrapObject baseName baseFingerprint enumCons - (unionMembers, unionTypes) = - buildUnions wrapObject baseFingerprint unionRecordRep - types = map fieldTypeUpdater $ concatMap consFields cons - - -buildObject :: TypeScope -> [FieldRep] -> (TypeContent, [TypeUpdater]) -buildObject isOutput consFields = (wrapWith fields, types) - where - (fields, types) = buildDataObject consFields - wrapWith | isOutput == OutputType = DataObject [] - | otherwise = DataInputObject . toInput - -buildDataObject :: [FieldRep] -> (FieldsDefinition , [TypeUpdater]) -buildDataObject consFields = (fields, types) - where - fields = unsafeFromFields $ map fieldData consFields - types = map fieldTypeUpdater consFields - -buildUnions - :: (FieldsDefinition -> TypeContent) - -> DataFingerprint - -> [ConsRep] - -> ([Name], [TypeUpdater]) -buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons) - where - buildURecType consRep = pure . defineType - (buildUnionRecord wrapObject baseFingerprint consRep) - members = map consName cons - -buildUnionRecord - :: (FieldsDefinition -> TypeContent) -> DataFingerprint -> ConsRep -> TypeDefinition -buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } = TypeDefinition - { typeName = consName - , typeFingerprint - , typeMeta = Nothing - , typeContent = wrapObject $ unsafeFromFields $ map fieldData consFields - } - -buildUnionEnum - :: (FieldsDefinition -> TypeContent) - -> Name - -> DataFingerprint - -> [Name] - -> ([Name], [TypeUpdater]) -buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates) - where - members | null enums = [] - | otherwise = [enumTypeWrapperName] - enumTypeName = baseName <> "Enum" - enumTypeWrapperName = enumTypeName <> "Object" - ------------------------- - updates :: [TypeUpdater] - updates - | null enums - = [] - | otherwise - = [ buildEnumObject wrapObject - enumTypeWrapperName - baseFingerprint - enumTypeName - , buildEnum enumTypeName baseFingerprint enums - ] - -buildEnum :: Name -> DataFingerprint -> [Name] -> TypeUpdater -buildEnum typeName typeFingerprint tags = pure . defineType - TypeDefinition - { typeMeta = Nothing - , typeContent = DataEnum $ map createEnumValue tags - , .. - } - -buildEnumObject - :: (FieldsDefinition -> TypeContent) - -> Name - -> DataFingerprint - -> Name - -> TypeUpdater -buildEnumObject wrapObject typeName typeFingerprint enumTypeName = - pure . defineType - TypeDefinition - { typeName - , typeFingerprint - , typeMeta = Nothing - , typeContent = wrapObject $ singleton - FieldDefinition - { fieldName = "enum" - , fieldArgs = NoArguments - , fieldType = createAlias enumTypeName - , fieldMeta = Nothing - } - } - -data TypeScope = InputType | OutputType deriving (Show,Eq,Ord) - --- GENERIC UNION -class TypeRep f where - typeRep :: Proxy f -> [ConsRep] - -instance TypeRep f => TypeRep (M1 D d f) where - typeRep _ = typeRep (Proxy @f) - --- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT' -instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where - typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b) - -instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where - typeRep _ = - [ ConsRep { consName = pack $ conName (undefined :: (M1 C c f a)) - , consFields = conRep (Proxy @f) - , consIsRecord = conIsRecord (undefined :: (M1 C c f a)) - } - ] - -class ConRep f where - conRep :: Proxy f -> [FieldRep] - --- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION' -instance (ConRep a, ConRep b) => ConRep (a :*: b) where - conRep _ = conRep (Proxy @a) <> conRep (Proxy @b) - -instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where - conRep _ = - [ FieldRep { fieldTypeName = typeConName $ fieldType fieldData - , fieldData = fieldData - , fieldTypeUpdater = introspect (Proxy @a) - , fieldIsObject = isObject (Proxy @a) - } - ] - where - name = pack $ selName (undefined :: M1 S s (Rec0 ()) ()) - fieldData = field (Proxy @a) name - -instance ConRep U1 where - conRep _ = [] diff --git a/src/Data/Morpheus/Execution/Server/Resolve.hs b/src/Data/Morpheus/Execution/Server/Resolve.hs deleted file mode 100644 --- a/src/Data/Morpheus/Execution/Server/Resolve.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - - -module Data.Morpheus.Execution.Server.Resolve - ( statelessResolver - , RootResCon - , fullSchema - , coreResolver - , EventCon - ) -where - - -import Data.Functor.Identity ( Identity(..) ) -import Data.Proxy ( Proxy(..) ) - --- MORPHEUS -import Data.Morpheus.Execution.Server.Encode - ( EncodeCon - , deriveModel - ) -import Data.Morpheus.Execution.Server.Introspect - ( IntroCon - , introspectObjectFields - , TypeScope(..) - ) -import Data.Morpheus.Parsing.Request.Parser - ( parseGQL ) -import Data.Morpheus.Schema.SchemaAPI ( defaultTypes - , hiddenRootFields - , schemaAPI - ) -import Data.Morpheus.Types.GQLType ( GQLType(CUSTOM) ) -import Data.Morpheus.Types.Internal.AST - ( Operation(..) - , DataFingerprint(..) - , TypeContent(..) - , Schema(..) - , TypeDefinition(..) - , MUTATION - , QUERY - , SUBSCRIPTION - , initTypeLib - , ValidValue - , Name - , VALIDATION_MODE(..) - , Selection(..) - , SelectionContent(..) - , FieldsDefinition(..) - ) -import Data.Morpheus.Types.Internal.Operation - ( Merge(..) - , empty - ) -import Data.Morpheus.Types.Internal.Resolving - ( GQLRootResolver(..) - , Resolver - , GQLChannel(..) - , ResponseStream - , Eventless - , cleanEvents - , ResultT(..) - , resolveUpdates - , Context(..) - , runResolverModel - ) -import Data.Morpheus.Types.IO ( GQLRequest(..) - , GQLResponse(..) - , renderResponse - ) -import Data.Morpheus.Validation.Query.Validation - ( validateRequest ) -import Data.Typeable ( Typeable ) - - -type EventCon event - = (Eq (StreamChannel event), Typeable event, GQLChannel event) - -type IntrospectConstraint m event query mutation subscription - = ( IntroCon (query (Resolver QUERY event m)) - , IntroCon (mutation (Resolver MUTATION event m)) - , IntroCon (subscription (Resolver SUBSCRIPTION event m)) - ) - -type RootResCon m event query mutation subscription - = ( EventCon event - , Typeable m - , IntrospectConstraint m event query mutation subscription - , EncodeCon QUERY event m (query (Resolver QUERY event m)) - , EncodeCon MUTATION event m (mutation (Resolver MUTATION event m)) - , EncodeCon - SUBSCRIPTION - event - m - (subscription (Resolver SUBSCRIPTION event m)) - ) - -statelessResolver - :: (Monad m, RootResCon m event query mut sub) - => GQLRootResolver m event query mut sub - -> GQLRequest - -> m GQLResponse -statelessResolver root req = - 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 request - = validRequest >>= execOperator - where - validRequest - :: Monad m => ResponseStream event m Context - validRequest = cleanEvents $ ResultT $ pure $ do - schema <- fullSchema $ Identity root - operation <- parseGQL request >>= validateRequest schema FULL_VALIDATION - pure $ Context { - schema - , operation - , currentTypeName = "Root" - , currentSelection = Selection - { selectionName = "Root" - , selectionArguments = empty - , selectionPosition = operationPosition operation - , selectionAlias = Nothing - , selectionContent = SelectionSet (operationSelection operation) - } - } - ---------------------------------------------------------- - 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) - -> Eventless Schema -fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema - where - querySchema = do - fs <- hiddenRootFields <:> fields - resolveUpdates (initTypeLib (operatorType fs "Query")) (defaultTypes : types) - where - (fields, types) = introspectObjectFields - (Proxy @(CUSTOM (query (Resolver QUERY event m)))) - ("type for query", OutputType, Proxy @(query (Resolver QUERY event m))) - ------------------------------ - mutationSchema lib = resolveUpdates - (lib { mutation = maybeOperator fields "Mutation" }) - types - where - (fields, types) = introspectObjectFields - (Proxy @(CUSTOM (mutation (Resolver MUTATION event m)))) - ( "type for mutation" - , OutputType - , Proxy @(mutation (Resolver MUTATION event m)) - ) - ------------------------------ - subscriptionSchema lib = resolveUpdates - (lib { subscription = maybeOperator fields "Subscription" }) - types - where - (fields, types) = introspectObjectFields - (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m)))) - ( "type for subscription" - , OutputType - , Proxy @(subscription (Resolver SUBSCRIPTION event m)) - ) - maybeOperator :: FieldsDefinition -> Name -> Maybe TypeDefinition - maybeOperator (FieldsDefinition x) | null x = const Nothing - maybeOperator fields = Just . operatorType fields - ------------------------------------------------- - operatorType :: FieldsDefinition -> Name -> TypeDefinition - operatorType fields typeName = TypeDefinition - { typeContent = DataObject [] fields - , typeName - , typeFingerprint = DataFingerprint typeName [] - , typeMeta = Nothing - } diff --git a/src/Data/Morpheus/Kind.hs b/src/Data/Morpheus/Kind.hs --- a/src/Data/Morpheus/Kind.hs +++ b/src/Data/Morpheus/Kind.hs @@ -1,27 +1,29 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | associating types to GraphQL Kinds module Data.Morpheus.Kind - ( SCALAR - , OBJECT - , ENUM - , WRAPPER - , UNION - , INPUT_OBJECT - , GQL_KIND - , Context(..) - , VContext(..) - , ResContext(..) - , OUTPUT - , INPUT + ( SCALAR, + OBJECT, + ENUM, + WRAPPER, + UNION, + INPUT_OBJECT, + GQL_KIND, + Context (..), + VContext (..), + ResContext (..), + OUTPUT, + INPUT, + INTERFACE, ) where -import Data.Morpheus.Types.Internal.AST - ( OperationType(..) ) +import Data.Morpheus.Types.Internal.AST + ( OperationType (..), + ) data GQL_KIND = SCALAR @@ -29,15 +31,17 @@ | INPUT | OUTPUT | WRAPPER + | INTERFACE -data ResContext (kind :: GQL_KIND) (operation:: OperationType) event (m :: * -> * ) value = ResContext +data ResContext (kind :: GQL_KIND) (operation :: OperationType) event (m :: * -> *) value = ResContext --type ObjectConstraint a = + -- | context , like Proxy with multiple parameters -- * 'kind': object, scalar, enum ... -- * 'a': actual gql type -data Context (kind :: GQL_KIND) a = - Context +data Context (kind :: GQL_KIND) a + = Context newtype VContext (kind :: GQL_KIND) a = VContext { unVContext :: a @@ -59,13 +63,18 @@ type INPUT = 'INPUT {-# DEPRECATED INPUT_OBJECT "use more generalised kind: INPUT" #-} + -- | GraphQL input Object type INPUT_OBJECT = 'INPUT {-# DEPRECATED UNION "use: deriving(GQLType), INPORTANT: only types with will sustain their form, other union constructors will be wrapped inside an new object" #-} + -- | GraphQL Union type UNION = 'OUTPUT {-# DEPRECATED OBJECT "use: deriving(GQLType), will be automatically inferred" #-} + -- | GraphQL Object type OBJECT = 'OUTPUT + +type INTERFACE = 'INTERFACE diff --git a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Parsing.Document.TypeSystem - ( parseSchema - ) -where - -import Data.Text ( Text ) -import Text.Megaparsec ( label - , sepBy1 - , (<|>) - , eof - , manyTill - ) - --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser - , processParser - ) -import Data.Morpheus.Parsing.Internal.Pattern - ( fieldsDefinition - , optionalDirectives - , typDeclaration - , enumValueDefinition - , inputFieldsDefinition - ) -import Data.Morpheus.Parsing.Internal.Terms - ( keyword - , operator - , optDescription - , parseName - , pipeLiteral - , sepByAnd - , collection - , spaceAndComments - ) -import Data.Morpheus.Types.Internal.AST - ( 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 Description -> Parser TypeDefinition -scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do - typeName <- typDeclaration "scalar" - metaDirectives <- optionalDirectives - 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 --- --- ObjectTypeDefinition: --- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) --- --- ImplementsInterfaces --- implements &(opt) NamedType --- ImplementsInterfaces & NamedType --- --- FieldsDefinition --- { FieldDefinition(list) } --- --- FieldDefinition --- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) --- -objectTypeDefinition :: Maybe Description -> Parser TypeDefinition -objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do - typeName <- typDeclaration "type" - objectImplements <- optionalImplementsInterfaces - metaDirectives <- optionalDirectives - objectFields <- fieldsDefinition - -- build object - pure TypeDefinition - { typeName - , typeMeta = Just Meta { metaDescription, metaDirectives } - , typeFingerprint = DataFingerprint typeName [] - , typeContent = DataObject { objectImplements, objectFields } - } - -optionalImplementsInterfaces :: Parser [Name] -optionalImplementsInterfaces = implements <|> pure [] - where - implements = - label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseName - --- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces --- --- InterfaceTypeDefinition --- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) --- -interfaceTypeDefinition :: Maybe Description -> Parser TypeDefinition -interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do - typeName <- typDeclaration "interface" - metaDirectives <- optionalDirectives - fields <- fieldsDefinition - -- 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 --- --- UnionTypeDefinition: --- Description(opt) union Name Directives(Const)(opt) UnionMemberTypes(opt) --- --- UnionMemberTypes: --- = |(opt) NamedType --- UnionMemberTypes | NamedType --- -unionTypeDefinition :: Maybe Description -> Parser TypeDefinition -unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do - typeName <- typDeclaration "union" - metaDirectives <- optionalDirectives - memberTypes <- unionMemberTypes - -- 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 --- --- EnumTypeDefinition --- Description(opt) enum Name Directives(Const)(opt) EnumValuesDefinition(opt) --- --- EnumValuesDefinition --- { EnumValueDefinition(list) } --- --- EnumValueDefinition --- Description(opt) EnumValue Directives(Const)(opt) --- -enumTypeDefinition :: Maybe Description -> Parser TypeDefinition -enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do - typeName <- typDeclaration "enum" - metaDirectives <- optionalDirectives - 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 --- --- InputObjectTypeDefinition --- Description(opt) input Name Directives(Const)(opt) InputFieldsDefinition(opt) --- --- InputFieldsDefinition: --- { InputValueDefinition(list) } --- -inputObjectTypeDefinition :: Maybe Description -> Parser TypeDefinition -inputObjectTypeDefinition metaDescription = - label "InputObjectTypeDefinition" $ do - typeName <- typDeclaration "input" - metaDirectives <- optionalDirectives - fields <- inputFieldsDefinition - -- build input - pure TypeDefinition - { typeName - , typeContent = DataInputObject fields - , typeFingerprint = DataFingerprint typeName [] - , typeMeta = Just Meta { metaDescription, metaDirectives } - } - -parseDataType :: Parser TypeDefinition -parseDataType = label "TypeDefinition" $ do - description <- optDescription - -- 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 deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Internal/Arguments.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Internal/Internal.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Parsing.Internal.Internal - ( Parser - , Position - , getLocation - , processParser - ) -where - -import qualified Data.List.NonEmpty as NonEmpty -import Data.Morpheus.Types.Internal.AST - ( Position(..) - , GQLError(..) - , GQLErrors - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , failure - , Result(..) - ) -import Data.Text ( Text - , pack - ) -import Text.Megaparsec ( ParseError - , ParseErrorBundle - ( ParseErrorBundle - ) - , ParsecT - , SourcePos - , attachSourcePos - , bundleErrors - , bundlePosState - , errorOffset - , getSourcePos - , parseErrorPretty - , runParserT - , SourcePos(..) - , unPos - ) -import Data.Void (Void) - -getLocation :: Parser Position -getLocation = fmap toLocation getSourcePos - -toLocation :: SourcePos -> Position -toLocation SourcePos { sourceLine, sourceColumn } = - Position { line = unPos sourceLine, column = unPos sourceColumn } - -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 MyError, SourcePos) -> GQLError - parseErrorToGQLError (err, position) = GQLError - { message = pack (parseErrorPretty err) - , locations = [toLocation position] - } - bundleToErrors - :: ErrorBundle -> [(ParseError Text MyError, SourcePos)] - bundleToErrors ParseErrorBundle { bundleErrors, bundlePosState } = - NonEmpty.toList $ fst $ attachSourcePos errorOffset - bundleErrors - bundlePosState diff --git a/src/Data/Morpheus/Parsing/Internal/Pattern.hs b/src/Data/Morpheus/Parsing/Internal/Pattern.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Internal/Pattern.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Parsing.Internal.Pattern - ( inputValueDefinition - , fieldsDefinition - , typDeclaration - , optionalDirectives - , enumValueDefinition - , inputFieldsDefinition - ) -where - -import Text.Megaparsec ( label - , many - , (<|>) - ) - --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser ) -import Data.Morpheus.Parsing.Internal.Terms - ( keyword - , litAssignment - , operator - , optDescription - , parseName - , parseType - , setOf - , uniqTuple - ) -import Data.Morpheus.Parsing.Internal.Arguments - ( parseArgumentsOpt ) -import Data.Morpheus.Parsing.Internal.Value - ( parseDefaultValue ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , Directive(..) - , Meta(..) - , DataEnumValue(..) - , Name - , ArgumentsDefinition(..) - , FieldsDefinition(..) - , InputFieldsDefinition(..) - ) - --- EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition --- --- EnumValueDefinition --- Description(opt) EnumValue Directives(Const)(opt) --- -enumValueDefinition :: Parser DataEnumValue -enumValueDefinition = label "EnumValueDefinition" $ do - metaDescription <- optDescription - enumName <- parseName - metaDirectives <- optionalDirectives - return $ DataEnumValue - { enumName - , enumMeta = Just Meta { metaDescription, metaDirectives } - } - --- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition --- --- InputValueDefinition --- Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) --- -inputValueDefinition :: Parser FieldDefinition -inputValueDefinition = label "InputValueDefinition" $ do - metaDescription <- optDescription - fieldName <- parseName - litAssignment -- ':' - fieldType <- parseType - _ <- parseDefaultValue - metaDirectives <- optionalDirectives - 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 ArgumentsDefinition -argumentsDefinition = label "ArgumentsDefinition" - $ uniqTuple inputValueDefinition - <|> pure NoArguments - --- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition --- --- FieldsDefinition : --- { FieldDefinition(list) } --- -fieldsDefinition :: Parser FieldsDefinition -fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition - --- FieldDefinition --- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) --- -fieldDefinition :: Parser FieldDefinition -fieldDefinition = label "FieldDefinition" $ do - metaDescription <- optDescription - fieldName <- parseName - fieldArgs <- argumentsDefinition - litAssignment -- ':' - fieldType <- parseType - metaDirectives <- optionalDirectives - 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 --- --- example: @directive ( arg1: "value" , .... ) --- --- Directives[Const] --- Directive[Const](list) --- -optionalDirectives :: Parser [Directive] -optionalDirectives = label "Directives" $ many directive - --- Directive[Const] --- --- @ Name Arguments[Const](opt) -directive :: Parser Directive -directive = label "Directive" $ do - operator '@' - directiveName <- parseName - directiveArgs <- parseArgumentsOpt - pure Directive { directiveName, directiveArgs } - --- typDeclaration : Not in spec ,start part of type definitions --- --- typDeclaration --- Description(opt) scalar Name --- -typDeclaration :: Name -> Parser Name -typDeclaration kind = do - keyword kind - parseName diff --git a/src/Data/Morpheus/Parsing/Internal/Terms.hs b/src/Data/Morpheus/Parsing/Internal/Terms.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Internal/Terms.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Data.Morpheus.Parsing.Internal.Terms - ( token - , qualifier - , variable - , spaceAndComments - , spaceAndComments1 - , pipeLiteral - ------------- - , collection - , setOf - , uniqTuple - , uniqTupleOpt - , parseTypeCondition - , spreadLiteral - , parseNonNull - , parseAssignment - , parseWrappedType - , litEquals - , litAssignment - , parseTuple - , parseAlias - , sepByAnd - , parseName - , parseType - , keyword - , operator - , optDescription - , optionalList - , parseNegativeSign - ) -where - -import Control.Monad ((>=>)) -import Data.Functor ( ($>) ) -import Data.Text ( Text - , pack - , strip - ) -import Text.Megaparsec ( between - , label - , try - , many - , manyTill - , optional - , sepBy - , sepEndBy - , skipMany - , skipManyTill - , try - , () - , (<|>) - ) -import Text.Megaparsec.Char ( char - , digitChar - , letterChar - , newline - , printChar - , space - , space1 - , string - ) - --- MORPHEUS -import Data.Morpheus.Types.Internal.Operation - ( Listable(..) - , KeyOf - ) -import Data.Morpheus.Parsing.Internal.Internal - ( Parser - , Position - , getLocation - ) -import Data.Morpheus.Types.Internal.AST - ( DataTypeWrapper(..) - , Key - , Description - , Name - , toHSWrappers - , convertToHaskellName - , Ref(..) - , TypeRef(..) - ) - - --- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names --- --- Name :: /[_A-Za-z][_0-9A-Za-z]*/ --- - -parseNegativeSign :: Parser Bool -parseNegativeSign = (char '-' $> True <* spaceAndComments) <|> pure False - -parseName :: Parser Name -parseName = token - -keyword :: Key -> Parser () -keyword word = string word *> space1 *> spaceAndComments - -operator :: Char -> Parser () -operator x = char x *> spaceAndComments - --- LITERALS -braces :: Parser [a] -> Parser [a] -braces = - between - (char '{' *> spaceAndComments) - (char '}' *> spaceAndComments) - -pipeLiteral :: Parser () -pipeLiteral = char '|' *> spaceAndComments - -litEquals :: Parser () -litEquals = char '=' *> spaceAndComments - -litAssignment :: Parser () -litAssignment = char ':' *> spaceAndComments - --- PRIMITIVE ------------------------------------- -token :: Parser Text -token = label "token" $ do - firstChar <- letterChar <|> char '_' - restToken <- many $ letterChar <|> char '_' <|> digitChar - spaceAndComments - return $ convertToHaskellName $ pack $ firstChar : restToken - -qualifier :: Parser (Text, Position) -qualifier = label "qualifier" $ do - position <- getLocation - value <- token - return (value, position) - - --- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable --- --- Variable : $Name --- -variable :: Parser Ref -variable = label "variable" $ do - refPosition <- getLocation - _ <- char '$' - refName <- token - spaceAndComments - pure $ Ref { refName, refPosition } - -spaceAndComments1 :: Parser () -spaceAndComments1 = space1 *> spaceAndComments - --- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description --- --- Description: --- StringValue --- TODO: should support """ and " --- -optDescription :: Parser (Maybe Description) -optDescription = optional parseDescription - -parseDescription :: Parser Text -parseDescription = - strip . pack <$> (blockDescription <|> singleLine) <* spaceAndComments - where - blockDescription = - blockQuotes - *> manyTill (printChar <|> newline) blockQuotes - <* spaceAndComments - where blockQuotes = string "\"\"\"" - ---------------------------- - singleLine = - stringQuote *> manyTill printChar stringQuote <* spaceAndComments - where stringQuote = char '"' - --- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens --- Ignored: --- UnicodeBOM --- WhiteSpace --- LineTerminator --- Comment --- Comma --- TODO: implement as in specification -spaceAndComments :: Parser () -spaceAndComments = ignoredTokens - -ignoredTokens :: Parser () -ignoredTokens = - label "IgnoredTokens" $ space *> skipMany inlineComment *> space - where inlineComment = char '#' *> skipManyTill printChar newline *> space - ------------------------------------------------------------------------ - --- COMPLEX -sepByAnd :: Parser a -> Parser [a] -sepByAnd entry = entry `sepBy` (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 - -optionalList :: Parser [a] -> Parser [a] -optionalList x = x <|> pure [] - -parseTuple :: Parser a -> Parser [a] -parseTuple parser = label "Tuple" $ between - (char '(' *> spaceAndComments) - (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 - name' <- nameParser - litAssignment - value' <- valueParser - pure (name', value') - --- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions --- --- TypeCondition: --- on NamedType --- -parseTypeCondition :: Parser Text -parseTypeCondition = do - _ <- string "on" - space1 - token - -spreadLiteral :: Parser Position -spreadLiteral = do - index <- getLocation - _ <- string "..." - space - return index - -parseWrappedType :: Parser ([DataTypeWrapper], Text) -parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments - where - unwrapped :: Parser ([DataTypeWrapper], Text) - unwrapped = ([], ) <$> token <* spaceAndComments - ---------------------------------------------- - wrapped :: Parser ([DataTypeWrapper], Text) - wrapped = between - (char '[' *> spaceAndComments) - (char ']' *> spaceAndComments) - (do - (wrappers, name) <- unwrapped <|> wrapped - nonNull' <- parseNonNull - return ((ListType : nonNull') ++ wrappers, name) - ) - --- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias --- Alias --- Name: -parseAlias :: Parser (Maybe Key) -parseAlias = try (optional alias) <|> pure Nothing - where alias = label "alias" $ token <* char ':' <* spaceAndComments - - -parseType :: Parser TypeRef -parseType = do - (wrappers, typeConName) <- parseWrappedType - nonNull <- parseNonNull - pure TypeRef { typeConName - , typeArgs = Nothing - , typeWrappers = toHSWrappers $ nonNull ++ wrappers - } diff --git a/src/Data/Morpheus/Parsing/Internal/Value.hs b/src/Data/Morpheus/Parsing/Internal/Value.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Internal/Value.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Parsing.Internal.Value - ( parseValue - , enumValue - , parseDefaultValue - , parseRawValue - ) -where - -import Data.Functor ( ($>) ) -import Data.Text ( pack ) -import Text.Megaparsec ( anySingleBut - , between - , choice - , label - , many - , optional - , sepBy - , (<|>) - ) -import Text.Megaparsec.Char ( char - , string - ) -import Text.Megaparsec.Char.Lexer ( scientific ) - --- --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser ) -import Data.Morpheus.Parsing.Internal.Terms - ( litEquals - , parseAssignment - , spaceAndComments - , token - , parseNegativeSign - , variable - , setOf - ) -import Data.Morpheus.Types.Internal.AST - ( ScalarValue(..) - , Value(..) - , RawValue - , ValidValue - , decodeScientific - , Value(..) - , ResolvedValue - , OrderedMap - , ObjectEntry(..) - ) - -valueNull :: Parser (Value a) -valueNull = string "null" $> Null - -booleanValue :: Parser (Value a) -booleanValue = boolTrue <|> boolFalse - where - boolTrue = string "true" $> Scalar (Boolean True) - boolFalse = string "false" $> Scalar (Boolean False) - -valueNumber :: Parser (Value a) -valueNumber = do - isNegative <- parseNegativeSign - Scalar . decodeScientific . signedNumber isNegative <$> scientific - where - signedNumber isNegative number | isNegative = -number - | otherwise = number - -enumValue :: Parser (Value a) -enumValue = do - enum <- Enum <$> token - spaceAndComments - return enum - -escaped :: Parser Char -escaped = label "escaped" $ do - x <- anySingleBut '\"' - if x == '\\' then choice (zipWith escapeChar codes replacements) else pure x - where - replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/'] - codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/'] - escapeChar code replacement = char code >> return replacement - -stringValue :: Parser (Value a) -stringValue = label "stringValue" $ Scalar . String . pack <$> between - (char '"') - (char '"') - (many escaped) - -listValue :: Parser a -> Parser [a] -listValue parser = label "ListValue" $ between - (char '[' *> spaceAndComments) - (char ']' *> spaceAndComments) - (parser `sepBy` (many (char ',') *> spaceAndComments)) - -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 = - label "Value" - $ ( parsePrimitives - <|> (Object <$> objectValue parser) - <|> (List <$> listValue parser) - ) - <* spaceAndComments - -parsePrimitives :: Parser (Value a) -parsePrimitives = - valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue - -parseDefaultValue :: Parser (Maybe ResolvedValue) -parseDefaultValue = optional $ do - litEquals - parseV - where - parseV :: Parser ResolvedValue - parseV = structValue parseV - - -parseValue :: Parser ValidValue -parseValue = structValue parseValue - -parseRawValue :: Parser RawValue -parseRawValue = (VariableValue <$> variable) <|> structValue parseRawValue diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Morpheus.Parsing.JSONSchema.Parse - ( decodeIntrospection - ) -where - -import Data.Aeson -import Data.ByteString.Lazy ( ByteString ) -import Data.Morpheus.Error.Internal ( internalError ) -import Data.Morpheus.Parsing.JSONSchema.Types - ( EnumValue(..) - , Field(..) - , InputValue(..) - , Introspection(..) - , Schema(..) - , Type(..) - ) -import Data.Morpheus.Schema.TypeKind ( TypeKind(..) ) -import qualified Data.Morpheus.Types.Internal.AST as AST - ( Schema) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition - , TypeDefinition(..) - , TypeContent(..) - , DataTypeWrapper(..) - , TypeWrapper - , createArgument - , createDataTypeLib - , createEnumType - , createField - , createScalarType - , createType - , createUnionType - , toHSWrappers - , ArgumentsDefinition(..) - ) -import Data.Morpheus.Types.Internal.Operation - ( Listable(..)) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless ) -import Data.Morpheus.Types.IO ( JSONResponse(..) ) -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , pack - ) - -decodeIntrospection :: ByteString -> Eventless AST.Schema -decodeIntrospection jsonDoc = case jsonSchema of - Left errors -> internalError $ pack errors - Right JSONResponse { responseData = Just Introspection { __schema = Schema { types } } } - -> traverse parse types >>= createDataTypeLib . concat - Right res -> internalError (pack $ show res) - where - jsonSchema :: Either String (JSONResponse Introspection) - jsonSchema = eitherDecode jsonDoc - -class ParseJSONSchema a b where - parse :: a -> Eventless b - -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 } = - pure [createEnumType typeName (map enumName enums)] - parse Type { name = Just typeName, kind = UNION, possibleTypes = Just unions } - = case traverse name unions of - Nothing -> internalError "ERROR: GQL ERROR" - Just uni -> pure [createUnionType typeName uni] - parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields } - = do - (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 :: [FieldDefinition]) <- traverse parse oFields - fs <- fromList fields - pure [createType typeName $ DataObject [] fs] - parse _ = pure [] - -instance ParseJSONSchema Field FieldDefinition where - parse Field { fieldName, fieldArgs, fieldType } = do - fType <- fieldTypeFromJSON fieldType - 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 FieldDefinition where - parse InputValue { inputName, inputType } = createField NoArguments inputName <$> fieldTypeFromJSON inputType - -fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], Text) -fieldTypeFromJSON = fmap toHs . fieldTypeRec [] - where - toHs (w, t) = (toHSWrappers w, t) - fieldTypeRec - :: [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 } = - fieldTypeRec (NonNullType : acc) ofType - fieldTypeRec acc Type { name = Just name } = pure (acc, name) - fieldTypeRec _ x = internalError $ "Unsuported Field" <> pack (show x) diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Types.hs b/src/Data/Morpheus/Parsing/JSONSchema/Types.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/JSONSchema/Types.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Morpheus.Parsing.JSONSchema.Types - ( Introspection(..) - , Schema(..) - , Type(..) - , Field(..) - , InputValue(..) - , EnumValue(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics (Generic) - --- --- MORPHEUS -import Data.Morpheus.Schema.TypeKind (TypeKind) - --- TYPES FOR DECODING JSON INTROSPECTION --- -newtype Introspection = Introspection - { __schema :: Schema - } deriving (Generic, Show, FromJSON) - -newtype Schema = Schema - { types :: [Type] - } deriving (Generic, Show, FromJSON) - --- TYPE -data Type = Type - { kind :: TypeKind - , name :: Maybe Text - , fields :: Maybe [Field] - , interfaces :: Maybe [Type] - , possibleTypes :: Maybe [Type] - , enumValues :: Maybe [EnumValue] - , inputFields :: Maybe [InputValue] - , ofType :: Maybe Type - } deriving (Generic, Show, FromJSON) - --- FIELD -data Field = Field - { fieldName :: Text - , fieldArgs :: [InputValue] - , fieldType :: Type - } deriving (Show, Generic) - -instance FromJSON Field where - parseJSON = withObject "Field" objectParser - where - objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type" - --- INPUT -data InputValue = InputValue - { inputName :: Text - , inputType :: Type - } deriving (Show, Generic) - -instance FromJSON InputValue where - parseJSON = withObject "InputValue" objectParser - where - objectParser o = InputValue <$> o .: "name" <*> o .: "type" - --- ENUM -newtype EnumValue = EnumValue - { enumName :: Text - } deriving (Generic, Show) - -instance FromJSON EnumValue where - parseJSON = withObject "EnumValue" objectParser - where - objectParser o = EnumValue <$> o .: "name" diff --git a/src/Data/Morpheus/Parsing/Request/Operation.hs b/src/Data/Morpheus/Parsing/Request/Operation.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Request/Operation.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Morpheus.Parsing.Request.Operation - ( parseOperation - ) -where - -import Data.Functor ( ($>) ) -import Text.Megaparsec ( label - , optional - , () - , (<|>) - ) -import Text.Megaparsec.Char ( string ) - --- --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser - , getLocation - ) -import Data.Morpheus.Parsing.Internal.Pattern - ( optionalDirectives ) -import Data.Morpheus.Parsing.Internal.Terms - ( operator - , uniqTupleOpt - , parseName - , parseType - , spaceAndComments1 - , variable - ) -import Data.Morpheus.Parsing.Internal.Value - ( parseDefaultValue ) -import Data.Morpheus.Parsing.Request.Selection - ( parseSelectionSet ) -import Data.Morpheus.Types.Internal.Operation - (empty) -import Data.Morpheus.Types.Internal.AST - ( Operation(..) - , Variable(..) - , OperationType(..) - , Ref(..) - , VariableContent(..) - , RAW - ) - - --- Variables : https://graphql.github.io/graphql-spec/June2018/#VariableDefinition --- --- VariableDefinition --- Variable : Type DefaultValue(opt) --- -variableDefinition :: Parser (Variable RAW) -variableDefinition = label "VariableDefinition" $ do - (Ref variableName variablePosition) <- variable - operator ':' - variableType <- parseType - variableValue <- DefaultValue <$> parseDefaultValue - pure Variable{..} - --- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations --- --- OperationDefinition --- OperationType Name(opt) VariableDefinitions(opt) Directives(opt) SelectionSet --- --- OperationType: one of --- query, mutation, subscription -parseOperationDefinition :: Parser (Operation RAW) -parseOperationDefinition = label "OperationDefinition" $ do - operationPosition <- getLocation - operationType <- parseOperationType - operationName <- optional parseName - operationArguments <- uniqTupleOpt variableDefinition - -- TODO: handle directives - _directives <- optionalDirectives - operationSelection <- parseSelectionSet - pure Operation {..} - -parseOperationType :: Parser OperationType -parseOperationType = label "OperationType" $ do - kind <- - (string "query" $> Query) - <|> (string "mutation" $> Mutation) - <|> (string "subscription" $> Subscription) - spaceAndComments1 - return kind - -parseAnonymousQuery :: Parser (Operation RAW) -parseAnonymousQuery = label "AnonymousQuery" $ do - operationPosition <- getLocation - operationSelection <- parseSelectionSet - pure - (Operation { operationName = Nothing - , operationType = Query - , operationArguments = empty - , .. - } - ) - "can't parse AnonymousQuery" - -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 deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Request/Parser.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Parsing.Request.Parser - ( parseGQL - , processParser - ) -where - -import qualified Data.Aeson as Aeson - ( Value(..) ) -import Data.HashMap.Lazy ( toList ) -import Data.Text ( Text ) -import Text.Megaparsec ( eof - , label - , manyTill - ) - --- --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser - , processParser - ) -import Data.Morpheus.Parsing.Internal.Terms - ( spaceAndComments ) -import Data.Morpheus.Parsing.Request.Operation - ( parseOperation ) -import Data.Morpheus.Parsing.Request.Selection - ( parseFragmentDefinition ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless ) -import Data.Morpheus.Types.Internal.AST - ( replaceValue - , GQLQuery(..) - , ResolvedValue - ) -import Data.Morpheus.Types.IO ( GQLRequest(..) ) -import Data.Morpheus.Types.Internal.Operation - (fromList) - -request :: Parser GQLQuery -request = label "GQLQuery" $ do - spaceAndComments - operation <- parseOperation - fragments <- manyTill parseFragmentDefinition eof >>= fromList - pure GQLQuery { operation, fragments, inputVariables = [] } - -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) - toVariableMap _ = [] diff --git a/src/Data/Morpheus/Parsing/Request/Selection.hs b/src/Data/Morpheus/Parsing/Request/Selection.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Request/Selection.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Morpheus.Parsing.Request.Selection - ( parseSelectionSet - , parseFragmentDefinition - ) -where - -import Text.Megaparsec ( label - , try - , (<|>) - ) - --- --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal - ( Parser - , getLocation - ) -import Data.Morpheus.Parsing.Internal.Pattern - ( optionalDirectives ) -import Data.Morpheus.Parsing.Internal.Terms - ( keyword - , parseAlias - , parseName - , parseTypeCondition - , setOf - , spreadLiteral - , token - ) -import Data.Morpheus.Parsing.Internal.Arguments - ( maybeArguments ) -import Data.Morpheus.Types.Internal.AST - ( Selection(..) - , SelectionContent(..) - , Ref(..) - , Fragment(..) - , Arguments - , RAW - , SelectionSet - , Name - , Position - ) - - --- Selection Sets : https://graphql.github.io/graphql-spec/June2018/#sec-Selection-Sets --- --- SelectionSet: --- { Selection(list) } --- --- Selection: --- Field --- FragmentSpread --- InlineFragment --- -parseSelectionSet :: Parser (SelectionSet RAW) -parseSelectionSet = label "SelectionSet" $ setOf parseSelection - where - parseSelection = - label "Selection" - $ try inlineFragment - <|> try spread - <|> parseSelectionField - --- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields --- --- Field --- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt) --- -parseSelectionField :: Parser (Selection RAW) -parseSelectionField = label "SelectionField" $ do - selectionPosition <- getLocation - selectionAlias <- parseAlias - selectionName <- parseName - selectionArguments <- maybeArguments - -- TODO: handle Directives - _directives <- optionalDirectives - selSet selectionName selectionAlias selectionArguments <|> pure Selection { selectionContent = SelectionField, ..} - where - ----------------------------------------- - selSet :: Name -> Maybe Name -> Arguments RAW -> Parser (Selection RAW) - selSet selectionName selectionAlias selectionArguments = label "body" $ do - selectionPosition <- getLocation - selectionSet <- parseSelectionSet - pure Selection { selectionContent = SelectionSet selectionSet, ..} - --- --- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments --- --- FragmentName : Name --- - --- FragmentSpread --- ...FragmentName Directives(opt) --- -spread :: Parser (Selection RAW) -spread = label "FragmentSpread" $ do - refPosition <- spreadLiteral - refName <- token - -- TODO: handle Directives - _directives <- optionalDirectives - pure $ Spread Ref { .. } - --- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition --- --- FragmentDefinition: --- fragment FragmentName TypeCondition Directives(opt) SelectionSet --- -parseFragmentDefinition :: Parser Fragment -parseFragmentDefinition = label "FragmentDefinition" $ do - keyword "fragment" - fragmentPosition <- getLocation - 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 (Selection RAW) -inlineFragment = label "InlineFragment" $ do - fragmentPosition <- spreadLiteral - 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 $ Fragment { .. } diff --git a/src/Data/Morpheus/Rendering/RenderGQL.hs b/src/Data/Morpheus/Rendering/RenderGQL.hs deleted file mode 100644 --- a/src/Data/Morpheus/Rendering/RenderGQL.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GADTs #-} - -module Data.Morpheus.Rendering.RenderGQL - ( RenderGQL(..) - , renderGraphQLDocument - , renderWrapped - ) -where - -import Data.ByteString.Lazy.Char8 ( ByteString ) -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , intercalate - ) -import qualified Data.Text.Lazy as LT - ( fromStrict ) -import Data.Text.Lazy.Encoding ( encodeUtf8 ) - --- MORPHEUS -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , InputFieldsDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , Schema - , DataTypeWrapper(..) - , Key - , TypeRef(..) - , TypeWrapper(..) - , allDataTypes - , createInputUnionFields - , fieldVisibility - , isDefaultTypeName - , 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 . typeName) (allDataTypes lib) - -class RenderGQL a where - render :: a -> Key - -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 - - -ignoreHidden :: [FieldDefinition] -> [FieldDefinition] -ignoreHidden = filter fieldVisibility - --- 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 TypeRef where - render TypeRef { typeConName, typeWrappers } = renderWrapped typeConName typeWrappers - -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 = " " - -renderObject :: (a -> Text) -> [a] -> Text -renderObject f list = - " { \n " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}" diff --git a/src/Data/Morpheus/Rendering/RenderIntrospection.hs b/src/Data/Morpheus/Rendering/RenderIntrospection.hs deleted file mode 100644 --- a/src/Data/Morpheus/Rendering/RenderIntrospection.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts , FlexibleInstances #-} - -module Data.Morpheus.Rendering.RenderIntrospection - ( render - , createObjectType - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Text ( Text ) -import Data.Maybe ( isJust ) - - --- Morpheus -import Data.Morpheus.Schema.Schema -import Data.Morpheus.Schema.TypeKind ( TypeKind(..) ) -import Data.Morpheus.Types.Internal.AST - ( DataInputUnion - , FieldDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , DataTypeKind(..) - , Schema - , DataTypeWrapper(..) - , DataUnion - , Meta(..) - , TypeRef(..) - , createInputUnionFields - , fieldVisibility - , kindOf - , lookupDataType - , toGQLWrapper - , DataEnumValue(..) - , lookupDeprecated - , DataInputUnion - , lookupDeprecatedReason - , convertToJSONName - , ArgumentsDefinition(..) - ) -import Data.Morpheus.Types.Internal.Operation - ( Listable(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( Failure(..) ) - -constRes :: Applicative m => a -> b -> m a -constRes = const . pure - -type Result m a = Schema -> m a - -class RenderSchema a b where - render :: (Monad m, Failure Text m) => a -> Schema -> m (b m) - -instance RenderSchema TypeDefinition S__Type where - render TypeDefinition { typeName , typeMeta, typeContent } = __render typeContent - where - __render - :: (Monad m, Failure Text m) => TypeContent -> Schema -> m (S__Type m) - __render DataScalar{} = - constRes $ createLeafType SCALAR typeName typeMeta Nothing - __render (DataEnum enums) = constRes - $ createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums) - __render (DataInputObject fields) = \lib -> - 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 (typeName, typeMeta, union) - __render (DataInputUnion members) = - renderInputUnion (typeName, typeMeta, members) - -createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m -createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue - { s__EnumValueName = pure enumName - , s__EnumValueDescription = pure (enumMeta >>= metaDescription) - , s__EnumValueIsDeprecated = pure (isJust deprecated) - , s__EnumValueDeprecationReason = pure (deprecated >>= lookupDeprecatedReason) - } - where deprecated = enumMeta >>= lookupDeprecated - -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 - pure S__Field - { s__FieldName = pure (convertToJSONName fieldName) - , s__FieldDescription = pure (fieldMeta >>= metaDescription) - , s__FieldArgs = renderArguments fieldArgs lib - , s__FieldType' = - pure (applyTypeWrapper field $ createType kind typeConName Nothing $ Just []) - , s__FieldIsDeprecated = pure (isJust deprecated) - , s__FieldDeprecationReason = pure - (deprecated >>= lookupDeprecatedReason) - } - where deprecated = fieldMeta >>= lookupDeprecated - -renderTypeKind :: DataTypeKind -> TypeKind -renderTypeKind KindScalar = SCALAR -renderTypeKind (KindObject _) = OBJECT -renderTypeKind KindUnion = UNION -renderTypeKind KindInputUnion = INPUT_OBJECT -renderTypeKind KindEnum = ENUM -renderTypeKind KindInputObject = INPUT_OBJECT -renderTypeKind KindList = LIST -renderTypeKind KindNonNull = NON_NULL - -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 -wrapByTypeWrapper ListType = wrapAs LIST -wrapByTypeWrapper NonNullType = wrapAs NON_NULL - -lookupKind :: (Monad m, Failure Text m) => Text -> Result m DataTypeKind -lookupKind name lib = case lookupDataType name lib of - Nothing -> failure $ "Kind Not Found: " <> name - Just value -> pure (kindOf value) - -renderinputValue - :: (Monad m, Failure Text m) - => FieldDefinition - -> Result m (S__InputValue m) -renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input - -createInputObjectType - :: (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 $ applyTypeWrapper field $ createType kind typeConName Nothing $ Just [] - - -renderInputUnion - :: (Monad m, Failure Text m) - => (Text, Maybe Meta, DataInputUnion) - -> Result m (S__Type m) -renderInputUnion (key, meta, fields) lib = - createInputObject key meta <$> traverse - createField - (createInputUnionFields key $ map fst $ filter snd fields) - where - createField field = - createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib - -createLeafType - :: Monad m - => TypeKind - -> Text - -> Maybe Meta - -> Maybe [S__EnumValue m] - -> S__Type m -createLeafType kind name meta enums = S__Type - { s__TypeKind = pure kind - , s__TypeName = pure $ Just name - , s__TypeDescription = pure (meta >>= metaDescription) - , s__TypeFields = constRes Nothing - , s__TypeOfType = pure Nothing - , s__TypeInterfaces = pure Nothing - , s__TypePossibleTypes = pure Nothing - , s__TypeEnumValues = constRes enums - , s__TypeInputFields = pure Nothing - } - -typeFromUnion :: Monad m => (Text, Maybe Meta, DataUnion) -> S__Type m -typeFromUnion (name, typeMeta, typeContent) = S__Type - { s__TypeKind = pure UNION - , s__TypeName = pure $ Just name - , s__TypeDescription = pure (typeMeta >>= metaDescription) - , s__TypeFields = constRes Nothing - , s__TypeOfType = pure Nothing - , s__TypeInterfaces = pure Nothing - , s__TypePossibleTypes = - pure $ Just (map (\x -> createObjectType x Nothing $ Just []) typeContent) - , s__TypeEnumValues = constRes Nothing - , s__TypeInputFields = pure Nothing - } - -createObjectType - :: Monad m => Text -> Maybe Text -> Maybe [S__Field m] -> S__Type m -createObjectType name description fields = S__Type - { s__TypeKind = pure OBJECT - , s__TypeName = pure $ Just name - , s__TypeDescription = pure description - , s__TypeFields = constRes fields - , s__TypeOfType = pure Nothing - , s__TypeInterfaces = pure $ Just [] - , s__TypePossibleTypes = pure Nothing - , s__TypeEnumValues = constRes Nothing - , s__TypeInputFields = pure Nothing - } - -createInputObject - :: Monad m => Text -> Maybe Meta -> [S__InputValue m] -> S__Type m -createInputObject name meta fields = S__Type - { s__TypeKind = pure INPUT_OBJECT - , s__TypeName = pure $ Just name - , s__TypeDescription = pure (meta >>= metaDescription) - , s__TypeFields = constRes Nothing - , s__TypeOfType = pure Nothing - , s__TypeInterfaces = pure Nothing - , s__TypePossibleTypes = pure Nothing - , s__TypeEnumValues = constRes Nothing - , s__TypeInputFields = pure $ Just fields - } - -createType - :: Monad m - => TypeKind - -> Text - -> Maybe Text - -> Maybe [S__Field m] - -> S__Type m -createType kind name description fields = S__Type - { s__TypeKind = pure kind - , s__TypeName = pure $ Just name - , s__TypeDescription = pure description - , s__TypeFields = constRes fields - , s__TypeOfType = pure Nothing - , s__TypeInterfaces = pure Nothing - , s__TypePossibleTypes = pure Nothing - , s__TypeEnumValues = constRes $ Just [] - , s__TypeInputFields = pure Nothing - } - -wrapAs :: Monad m => TypeKind -> S__Type m -> S__Type m -wrapAs kind contentType = S__Type { s__TypeKind = pure kind - , s__TypeName = pure Nothing - , s__TypeDescription = pure Nothing - , s__TypeFields = constRes Nothing - , s__TypeOfType = pure $ Just contentType - , s__TypeInterfaces = pure Nothing - , s__TypePossibleTypes = pure Nothing - , s__TypeEnumValues = constRes Nothing - , s__TypeInputFields = pure Nothing - } - -createInputValueWith - :: Monad m => Text -> Maybe Meta -> S__Type m -> S__InputValue m -createInputValueWith name meta ivType = S__InputValue - { s__InputValueName = pure (convertToJSONName name) - , s__InputValueDescription = pure (meta >>= metaDescription) - , s__InputValueType' = pure ivType - , s__InputValueDefaultValue = pure Nothing - } diff --git a/src/Data/Morpheus/Schema/Schema.hs b/src/Data/Morpheus/Schema/Schema.hs deleted file mode 100644 --- a/src/Data/Morpheus/Schema/Schema.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - - -module Data.Morpheus.Schema.Schema - ( Root(..) - , Root__typeArgs(..) - , S__Schema(..) - , S__Type(..) - , S__Field(..) - , S__EnumValue(..) - , S__InputValue(..) - ) -where - -import Data.Text ( Text ) - --- MORPHEUS -import Data.Morpheus.Execution.Document.Compile - ( gqlDocumentNamespace ) -import Data.Morpheus.Schema.TypeKind ( TypeKind ) - -type S__TypeKind = TypeKind - -[gqlDocumentNamespace| - -type __Schema { - types: [__Type!]! - queryType: __Type! - mutationType: __Type - subscriptionType: __Type - directives: [__Directive!]! -} - -type __Type { - kind: __TypeKind! - name: String - description: String - - # OBJECT and INTERFACE only - fields(includeDeprecated: Boolean = false): [__Field!] - - # OBJECT only - interfaces: [__Type!] - - # INTERFACE and UNION only - possibleTypes: [__Type!] - - # ENUM only - enumValues(includeDeprecated: Boolean = false): [__EnumValue!] - - # INPUT_OBJECT only - inputFields: [__InputValue!] - - # NON_NULL and LIST only - ofType: __Type -} - -type __Field { - name: String! - description: String - args: [__InputValue!]! - type: __Type! - isDeprecated: Boolean! - deprecationReason: String -} - -type __InputValue { - name: String! - description: String - type: __Type! - defaultValue: String -} - -type __EnumValue { - name: String! - description: String - isDeprecated: Boolean! - deprecationReason: String -} - -type __Directive { - name: String! - description: String - locations: [__DirectiveLocation!]! - args: [__InputValue!]! -} - -enum __DirectiveLocation { - QUERY - MUTATION - SUBSCRIPTION - FIELD - FRAGMENT_DEFINITION - FRAGMENT_SPREAD - INLINE_FRAGMENT - SCHEMA - SCALAR - OBJECT - FIELD_DEFINITION - ARGUMENT_DEFINITION - INTERFACE - UNION - ENUM - ENUM_VALUE - INPUT_OBJECT - INPUT_FIELD_DEFINITION -} - -type Root { - __type(name: String!): __Type - __schema : __Schema! -} - -|] diff --git a/src/Data/Morpheus/Schema/SchemaAPI.hs b/src/Data/Morpheus/Schema/SchemaAPI.hs deleted file mode 100644 --- a/src/Data/Morpheus/Schema/SchemaAPI.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Schema.SchemaAPI - ( hiddenRootFields - , defaultTypes - , schemaAPI - ) -where - -import Data.Proxy -import Data.Text ( Text ) - --- MORPHEUS -import Data.Morpheus.Execution.Server.Introspect - ( introspectObjectFields - , TypeUpdater - , introspect - , TypeScope(..) - ) -import Data.Morpheus.Rendering.RenderIntrospection - ( createObjectType - , render - ) -import Data.Morpheus.Schema.Schema ( Root(..) - , Root__typeArgs(..) - , S__Schema(..) - , S__Type - ) -import Data.Morpheus.Types.GQLType ( CUSTOM ) -import Data.Morpheus.Types.ID ( ID ) -import Data.Morpheus.Types.Internal.AST - ( Schema(..) - , QUERY - , TypeDefinition(..) - , allDataTypes - , lookupDataType - , FieldsDefinition - ) -import Data.Morpheus.Types.Internal.Resolving - ( Resolver - , resolveUpdates - ) - - -convertTypes - :: Monad m => Schema -> Resolver QUERY e m [S__Type (Resolver QUERY e m)] -convertTypes lib = traverse (`render` lib) (allDataTypes lib) - -buildSchemaLinkType - :: Monad m => TypeDefinition -> S__Type (Resolver QUERY e m) -buildSchemaLinkType TypeDefinition { typeName } = createObjectType typeName Nothing $ Just [] - -findType - :: Monad m - => Text - -> Schema - -> Resolver QUERY e m (Maybe (S__Type (Resolver QUERY e m))) -findType name lib = renderT (lookupDataType name lib) - where - renderT (Just datatype) = Just <$> render datatype lib - renderT Nothing = pure Nothing - -initSchema - :: Monad m - => Schema - -> Resolver QUERY e m (S__Schema (Resolver QUERY e m)) -initSchema lib = pure S__Schema - { s__SchemaTypes = convertTypes lib - , s__SchemaQueryType = pure $ buildSchemaLinkType $ query lib - , s__SchemaMutationType = pure $ buildSchemaLinkType <$> mutation lib - , s__SchemaSubscriptionType = pure $ buildSchemaLinkType <$> subscription lib - , s__SchemaDirectives = pure [] - } - -hiddenRootFields :: FieldsDefinition -hiddenRootFields = fst $ introspectObjectFields - (Proxy :: Proxy (CUSTOM (Root Maybe))) - ("Root", OutputType, Proxy @(Root Maybe)) - -defaultTypes :: TypeUpdater -defaultTypes = flip - resolveUpdates - [ introspect (Proxy @Bool) - , introspect (Proxy @Int) - , introspect (Proxy @Float) - , introspect (Proxy @Text) - , introspect (Proxy @ID) - , introspect (Proxy @(S__Schema Maybe)) - ] - -schemaAPI :: Monad m => Schema -> Root (Resolver QUERY e m) -schemaAPI lib = Root { root__type, root__schema = initSchema lib } - where root__type (Root__typeArgs name) = findType name lib diff --git a/src/Data/Morpheus/Schema/TypeKind.hs b/src/Data/Morpheus/Schema/TypeKind.hs deleted file mode 100644 --- a/src/Data/Morpheus/Schema/TypeKind.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Morpheus.Schema.TypeKind - ( TypeKind(..) - ) -where - -import Data.Aeson ( FromJSON(..) ) -import Data.Morpheus.Kind ( ENUM ) -import Data.Morpheus.Types.GQLType ( GQLType(KIND, __typeName) ) -import GHC.Generics - -instance GQLType TypeKind where - type KIND TypeKind = ENUM - __typeName = const "__TypeKind" - -data TypeKind - = SCALAR - | OBJECT - | INTERFACE - | UNION - | ENUM - | INPUT_OBJECT - | LIST - | NON_NULL - deriving (Eq, Generic, FromJSON, Show) 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,54 +1,65 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | GraphQL Wai Server Applications module Data.Morpheus.Server - ( webSocketsApp - , httpPubApp + ( webSocketsApp, + httpPubApp, + subscriptionApp, + ServerConstraint, ) where - -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 - +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Unlift + ( MonadUnliftIO, + withRunInIO, + ) -- MORPHEUS -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.IO (MapAPI (..)) +import Data.Morpheus.Types.Internal.Resolving + ( GQLChannel (..), + ) +import Data.Morpheus.Types.Internal.Subscription + ( HTTP, + Input (..), + Scope (..), + Store (..), + Stream, + WS, + acceptApolloRequest, + connectionThread, + initDefaultStore, + publishEventWith, + runStreamHTTP, + ) +import Network.WebSockets + ( Connection, + ServerApp, + receiveData, + sendTextData, + ) +import qualified Network.WebSockets as WS +type ServerConstraint e m = + ( MonadIO m, + MonadUnliftIO m, + Eq (StreamChannel e), + GQLChannel e + ) + -- support old version of Websockets pingThread :: Connection -> IO () -> IO () + #if MIN_VERSION_websockets(0,12,6) pingThread connection = WS.withPingThread connection 30 (return ()) #else @@ -56,46 +67,71 @@ #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 - } +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 +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 -webSocketsApp - :: ( MonadIO m - , MonadUnliftIO m - , (Eq (StreamChannel e)) - , (GQLChannel e) +subscriptionApp :: + ( MonadUnliftIO m, + (Eq (StreamChannel e)), + (GQLChannel e) + ) => + ( Store e m -> + (Scope WS e m -> m ()) -> + m app + ) -> + (Input WS -> Stream WS e m) -> + m (app, e -> m ()) +subscriptionApp appWrapper api = + do + store <- initDefaultStore + app <- appWrapper store (connectionThread api) + pure + ( app, + publishEventWith store ) - => (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 - wsApp store pending = do - connection <- acceptApolloRequest pending - let scope = defaultWSScope store connection - pingThread - connection - $ runIO (connectionThread api scope) + +webSocketsWrapper :: + (MonadUnliftIO m, MonadIO m) => + Store e m -> + (Scope WS e m -> m ()) -> + m ServerApp +webSocketsWrapper store handler = + withRunInIO $ + \runIO -> + pure $ + \pending -> do + conn <- acceptApolloRequest pending + pingThread + conn + $ runIO (handler (defaultWSScope store conn)) + +-- | Wai WebSocket Server App for GraphQL subscriptions +webSocketsApp :: + ( MonadIO m, + MonadUnliftIO m, + (Eq (StreamChannel e)), + (GQLChannel e) + ) => + (Input WS -> Stream WS e m) -> + m (ServerApp, e -> m ()) +webSocketsApp = subscriptionApp webSocketsWrapper diff --git a/src/Data/Morpheus/Server/Deriving/Decode.hs b/src/Data/Morpheus/Server/Deriving/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Decode.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Server.Deriving.Decode + ( decodeArguments, + Decode (..), + DecodeType (..), + ) +where + +-- MORPHEUS +import Data.Morpheus.Error + ( internalError, + internalTypeMismatch, + ) +import Data.Morpheus.Internal.Utils + ( elems, + ) +import Data.Morpheus.Kind + ( ENUM, + GQL_KIND, + INPUT, + OUTPUT, + SCALAR, + ) +import Data.Morpheus.Server.Deriving.Utils + ( conNameProxy, + datatypeNameProxy, + selNameProxy, + ) +import Data.Morpheus.Server.Internal.TH.Decode + ( decodeFieldWith, + withList, + withMaybe, + withObject, + withUnion, + ) +import Data.Morpheus.Server.Types.GQLScalar + ( GQLScalar (..), + toScalar, + ) +import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __typeName)) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + Arguments, + ObjectEntry (..), + TypeName (..), + VALID, + ValidObject, + ValidValue, + Value (..), + msg, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Failure (..), + ) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Semigroup (..)) +import GHC.Generics + +-- GENERIC +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 -> Eventless a + +instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where + decode = decodeKind (Proxy @(KIND a)) + +instance Decode a => Decode (Maybe a) where + decode = withMaybe decode + +instance Decode a => Decode [a] where + decode = withList decode + +-- | Decode GraphQL type with Specific Kind +class DecodeKind (kind :: GQL_KIND) a where + decodeKind :: Proxy kind -> ValidValue -> Eventless a + +-- SCALAR +instance (GQLScalar a) => DecodeKind SCALAR a where + decodeKind _ value = case toScalar value >>= parseValue of + Right scalar -> return scalar + Left errorMessage -> internalTypeMismatch (msg errorMessage) value + +-- ENUM +instance DecodeType a => DecodeKind ENUM a where + decodeKind _ = decodeType + +-- TODO: remove +instance DecodeType a => DecodeKind OUTPUT a where + decodeKind _ = decodeType + +-- INPUT_OBJECT and INPUT_UNION +instance DecodeType a => DecodeKind INPUT a where + decodeKind _ = decodeType + +class DecodeType a where + decodeType :: ValidValue -> Eventless a + +instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a)) => DecodeType a where + decodeType = fmap to . decodeRep . (,Cont D_CONS "") + +-- data Inpuz = +-- InputHuman Human -- direct link: { __typename: Human, Human: {field: ""} } +-- | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} } +-- | IndexedType Int Text -- { __typename: InputRecord, _0:2 , _1:"" } +-- | Zeus -- { __typename: Zeus } +-- deriving (Generic, GQLType) + +decideUnion :: + ([TypeName], value -> Eventless (f1 a)) -> + ([TypeName], value -> Eventless (f2 a)) -> + TypeName -> + value -> + Eventless ((:+:) f1 f2 a) +decideUnion (left, f1) (right, f2) name value + | name `elem` left = + L1 <$> f1 value + | name `elem` right = + R1 <$> f2 value + | otherwise = + failure $ + "Constructor \"" + <> msg name + <> "\" could not find in Union" + +data Tag = D_CONS | D_UNION deriving (Eq, Ord) + +data Cont = Cont + { contKind :: Tag, + typeName :: TypeName + } + +data Info = Info + { kind :: Tag, + tagName :: [TypeName] + } + +instance Semigroup Info where + Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2) + Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2) + Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2) + +-- +-- GENERICS +-- +class DecodeRep f where + tags :: Proxy f -> TypeName -> Info + 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 = datatypeNameProxy (Proxy @d)}) + +getEnumTag :: ValidObject -> Eventless TypeName +getEnumTag x = case elems 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) + decodeRep = __decode + where + __decode (Object obj, cont) = withUnion handleUnion obj + where + handleUnion name unions object + | name == typeName cont <> "EnumObject" = + getEnumTag object >>= __decode . (,ctx) . Enum + | [name] == l1 = + L1 <$> decodeRep (Object object, ctx) + | [name] == r1 = + R1 <$> decodeRep (Object object, ctx) + | otherwise = + decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx) + l1 = tagName l1t + r1 = tagName r1t + l1t = tags (Proxy @a) (typeName cont) + r1t = tags (Proxy @b) (typeName cont) + ctx = cont {contKind = kind (l1t <> r1t)} + __decode (Enum name, cxt) = + decideUnion + (tagName $ tags (Proxy @a) (typeName cxt), decodeRep) + (tagName $ tags (Proxy @b) (typeName cxt), decodeRep) + name + (Enum name, cxt) + __decode _ = internalError "lists and scalars are not allowed in Union" + +instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where + decodeRep = fmap M1 . decodeFields + tags _ baseName = getTag (refType (Proxy @a)) + where + getTag (Just memberRef) + | isUnionRef memberRef = Info {kind = D_UNION, tagName = [memberRef]} + | otherwise = Info {kind = D_CONS, tagName = [consName]} + getTag Nothing = Info {kind = D_CONS, tagName = [consName]} + -------- + consName = conNameProxy (Proxy @c) + ---------- + isUnionRef x = baseName <> x == consName + +class DecodeFields f where + refType :: Proxy f -> Maybe TypeName + decodeFields :: (ValidValue, Cont) -> Eventless (f a) + +instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where + refType _ = Nothing + decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql + +instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where + refType _ = Just $ __typeName (Proxy @a) + decodeFields (value, Cont {contKind}) + | contKind == D_UNION = M1 . K1 <$> decode value + | otherwise = __decode value + where + __decode = fmap (M1 . K1) . decodeRec + fieldName = selNameProxy (Proxy @s) + decodeRec = withObject (decodeFieldWith decode fieldName) + +instance DecodeFields U1 where + refType _ = Nothing + decodeFields _ = pure U1 diff --git a/src/Data/Morpheus/Server/Deriving/Encode.hs b/src/Data/Morpheus/Server/Deriving/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Encode.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Server.Deriving.Encode + ( EncodeCon, + Encode (..), + ExploreResolvers (..), + deriveModel, + ) +where + +import Data.Map (Map) +import qualified Data.Map as M + ( toList, + ) +-- MORPHEUS + +import Data.Morpheus.Kind + ( ENUM, + GQL_KIND, + INTERFACE, + OUTPUT, + ResContext (..), + SCALAR, + VContext (..), + ) +import Data.Morpheus.Server.Deriving.Decode + ( DecodeType, + decodeArguments, + ) +import Data.Morpheus.Server.Deriving.Utils + ( conNameProxy, + datatypeNameProxy, + isRecordProxy, + ) +import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..)) +import Data.Morpheus.Server.Types.GQLType (GQLType (..)) +import Data.Morpheus.Server.Types.Types + ( MapKind, + Pair (..), + mapKindFromList, + ) +import Data.Morpheus.Types + ( GQLRootResolver (..), + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + FieldName (..), + MUTATION, + Message, + OperationType (..), + QUERY, + SUBSCRIPTION, + TypeName, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + FieldResModel, + LiftOperation, + MapStrategy (..), + ObjectResModel (..), + ResModel (..), + Resolver, + RootResModel (..), + failure, + liftStateless, + toResolver, + unsafeBind, + ) +import Data.Proxy (Proxy (..)) +import Data.Semigroup ((<>)) +import Data.Set (Set) +import qualified Data.Set as S + ( toList, + ) +import Data.Text (pack) +import GHC.Generics + +class Encode resolver o e (m :: * -> *) where + encode :: resolver -> Resolver o e m (ResModel 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 ResNull) encode + +-- LIST [] +instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where + encode = fmap ResList . traverse encode + +-- Tuple (a,b) +instance Encode (Pair k v) o e m => Encode (k, v) o e m where + encode (key, value) = encode (Pair key value) + +-- Set +instance Encode [a] o e m => Encode (Set a) o e m where + encode = encode . S.toList + +-- Map +instance (Eq k, Monad m, LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where + encode value = + 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, + 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 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 (ResModel o e m) + +-- SCALAR +instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where + encodeKind = pure . ResScalar . serialize . unVContext + +-- ENUM +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, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where + encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value + +instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind INTERFACE a o e m where + encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value + +convertNode :: + (Monad m, LiftOperation o) => + ResNode o e m -> + ResModel o e m +convertNode ResNode {resDatatypeName, resKind = REP_OBJECT, resFields} = + ResObject (ObjectResModel resDatatypeName $ map toFieldRes resFields) +convertNode ResNode {resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord} = + encodeUnion resFields + where + -- ENUM + encodeUnion [] = ResEnum resDatatypeName resTypeName + -- Type References -------------------------------------------------------------- + encodeUnion [FieldNode {fieldTypeName, fieldResolver, isFieldObject}] + | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName = + ResUnion fieldTypeName fieldResolver + -- Inline Union Types ---------------------------------------------------------------------------- + encodeUnion fields = + ResUnion + resTypeName + $ pure + $ ResObject + $ ObjectResModel + resTypeName + (map toFieldRes resolvers) + where + resolvers + | isResRecord = fields + | otherwise = setFieldNames fields + +-- Types & Constrains ------------------------------------------------------- +type GQL_RES a = (Generic a, GQLType a) + +type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) + +--- GENERICS ------------------------------------------------ +class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where + exploreResolvers :: Proxy custom -> a -> Eventless (ResModel 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 = + pure + $ convertNode + $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value) + +----- HELPERS ---------------------------- +objectResolvers :: + forall a o e m. + ( ExploreResolvers (CUSTOM a) a o e m, + Monad m, + LiftOperation o + ) => + a -> + Eventless (ResModel o e m) +objectResolvers value = + exploreResolvers (Proxy @(CUSTOM a)) value + >>= constraintOnject + where + constraintOnject obj@ResObject {} = + pure obj + constraintOnject _ = + failure ("resolver must be an object" :: Message) + +type Con o e m a = + ExploreResolvers + ( CUSTOM + (a (Resolver o e m)) + ) + (a (Resolver o e m)) + o + e + m + +deriveModel :: + forall e m query mut sub. + ( Con QUERY e m query, + Con MUTATION e m mut, + Con SUBSCRIPTION e m sub, + Applicative m, + Monad m + ) => + GQLRootResolver m e query mut sub -> + RootResModel e m +deriveModel + GQLRootResolver + { queryResolver, + mutationResolver, + subscriptionResolver + } = + RootResModel + { query = objectResolvers queryResolver, + mutation = objectResolvers mutationResolver, + subscription = objectResolvers subscriptionResolver + } + +toFieldRes :: FieldNode o e m -> FieldResModel o e m +toFieldRes FieldNode {fieldSelName, fieldResolver} = + (fieldSelName, fieldResolver) + +-- NEW AUTOMATIC DERIVATION SYSTEM +data REP_KIND = REP_UNION | REP_OBJECT + +data ResNode o e m = ResNode + { resDatatypeName :: TypeName, + resTypeName :: TypeName, + resKind :: REP_KIND, + resFields :: [FieldNode o e m], + isResRecord :: Bool + } + +data FieldNode o e m = FieldNode + { fieldTypeName :: TypeName, + fieldSelName :: FieldName, + fieldResolver :: Resolver o e m (ResModel o e m), + isFieldObject :: Bool + } + +-- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text } +setFieldNames :: [FieldNode o e m] -> [FieldNode o e m] +setFieldNames = zipWith setFieldName ([0 ..] :: [Int]) + where + setFieldName i field = field {fieldSelName = FieldName $ "_" <> pack (show i)} + +class TypeRep f o e (m :: * -> *) where + typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m + +instance (Datatype d, TypeRep f o e m) => TypeRep (M1 D d f) o e m where + typeResolvers context (M1 src) = + (typeResolvers context src) + { resDatatypeName = datatypeNameProxy (Proxy @d) + } + +--- UNION OR OBJECT +instance (TypeRep a o e m, TypeRep b o e m) => TypeRep (a :+: b) o e m where + typeResolvers context (L1 x) = + (typeResolvers context x) {resKind = REP_UNION} + typeResolvers context (R1 x) = + (typeResolvers context x) {resKind = REP_UNION} + +instance (FieldRep f o e m, Constructor c) => TypeRep (M1 C c f) o e m where + typeResolvers context (M1 src) = + ResNode + { resDatatypeName = "", + resTypeName = conNameProxy (Proxy @c), + resKind = REP_OBJECT, + resFields = fieldRep context src, + isResRecord = isRecordProxy (Proxy @c) + } + +--- FIELDS +class FieldRep f o e (m :: * -> *) where + fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m] + +instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where + fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b + +instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where + fieldRep _ m@(M1 (K1 src)) = + [ FieldNode + { fieldSelName = FieldName $ pack (selName m), + fieldTypeName = __typeName (Proxy @a), + fieldResolver = encode src, + isFieldObject = isObjectKind (Proxy @a) + } + ] + +instance FieldRep U1 o e m where + fieldRep _ _ = [] diff --git a/src/Data/Morpheus/Server/Deriving/Interpreter.hs b/src/Data/Morpheus/Server/Deriving/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Interpreter.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Data.Morpheus.Server.Deriving.Interpreter + ( Interpreter (..), + ) +where + +-- MORPHEUS + +import Data.Morpheus.Server.Deriving.Resolve + ( RootResCon, + coreResolver, + statelessResolver, + ) +import Data.Morpheus.Types + ( GQLRootResolver (..), + ) +import Data.Morpheus.Types.IO + ( GQLRequest, + GQLResponse, + MapAPI (..), + ) +import Data.Morpheus.Types.Internal.Subscription + ( Input, + Stream, + toOutStream, + ) + +-- | main query processor and resolver +-- possible versions of interpreter +-- +-- 1. with effect and state: where 'GQLState' is State Monad of subscriptions +-- +-- @ +-- k :: GQLState -> a -> IO a +-- @ +-- +-- 2. without effect and state: stateless query processor without any effect, +-- if you don't need any subscription use this one , is simple and fast +-- +-- @ +-- k :: a -> IO a +-- -- or +-- k :: GQLRequest -> IO GQLResponse +-- @ +class Interpreter e m a b where + interpreter :: + Monad m => + (RootResCon m e query mut sub) => + GQLRootResolver m e query mut sub -> + a -> + b + +instance Interpreter e m GQLRequest (m GQLResponse) where + interpreter = statelessResolver + +instance Interpreter e m (Input api) (Stream api e m) where + interpreter root = toOutStream (coreResolver root) + +instance + (MapAPI a) => + Interpreter e m a (m a) + where + interpreter root = mapAPI (interpreter root) diff --git a/src/Data/Morpheus/Server/Deriving/Introspect.hs b/src/Data/Morpheus/Server/Deriving/Introspect.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Introspect.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Server.Deriving.Introspect + ( TypeUpdater, + Introspect (..), + DeriveTypeContent (..), + IntroCon, + updateLib, + buildType, + introspectObjectFields, + deriveCustomInputObjectType, + TypeScope (..), + ) +where + +import Data.List (partition) +import Data.Map (Map) +-- MORPHEUS + +import Data.Morpheus.Error (globalErrorMessage) +import Data.Morpheus.Internal.Utils + ( empty, + singleton, + ) +import Data.Morpheus.Kind + ( Context (..), + ENUM, + GQL_KIND, + INPUT, + INTERFACE, + OUTPUT, + SCALAR, + ) +import Data.Morpheus.Server.Deriving.Utils + ( EnumRep (..), + conNameProxy, + isRecordProxy, + selNameProxy, + ) +import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..)) +import Data.Morpheus.Server.Types.GQLType (GQLType (..)) +import Data.Morpheus.Server.Types.Types + ( MapKind, + Pair, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + DataFingerprint (..), + DataUnion, + FALSE, + FieldDefinition (..), + FieldName, + FieldName (..), + FieldsDefinition, + IN, + Message, + Meta (..), + OUT, + TRUE, + TypeCategory, + TypeContent (..), + TypeDefinition (..), + TypeName (..), + TypeRef (..), + TypeUpdater, + createAlias, + createEnumValue, + defineType, + fieldsToArguments, + msg, + toAny, + toAny, + toListField, + toNullableField, + unsafeFromFields, + updateSchema, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Failure (..), + Resolver, + resolveUpdates, + ) +import Data.Proxy (Proxy (..)) +import Data.Semigroup ((<>)) +import Data.Set (Set) +import Data.Text + ( pack, + ) +import GHC.Generics + +type IntroCon a = (GQLType a, DeriveTypeContent (CUSTOM a) a) + +-- | Generates internal GraphQL Schema for query validation and introspection rendering +class Introspect a where + isObject :: proxy a -> Bool + default isObject :: GQLType a => proxy a -> Bool + isObject _ = isObjectKind (Proxy @a) + field :: proxy a -> FieldName -> FieldDefinition cat + introspect :: proxy a -> TypeUpdater + + ----------------------------------------------- + default field :: + GQLType a => + proxy a -> + FieldName -> + FieldDefinition cat + field _ = buildField (Proxy @a) NoArguments + +instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect a where + introspect _ = introspectKind (Context :: Context (KIND a) a) + +-- Maybe +instance Introspect a => Introspect (Maybe a) where + isObject _ = False + field _ = toNullableField . field (Proxy @a) + introspect _ = introspect (Proxy @a) + +-- List +instance Introspect a => Introspect [a] where + isObject _ = False + field _ = toListField . field (Proxy @a) + introspect _ = introspect (Proxy @a) + +-- Tuple +instance Introspect (Pair k v) => Introspect (k, v) where + isObject _ = True + field _ = field (Proxy @(Pair k v)) + introspect _ = introspect (Proxy @(Pair k v)) + +-- Set +instance Introspect [a] => Introspect (Set a) where + isObject _ = False + field _ = field (Proxy @[a]) + introspect _ = introspect (Proxy @[a]) + +-- Map +instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where + isObject _ = True + field _ = field (Proxy @(MapKind k v Maybe)) + introspect _ = introspect (Proxy @(MapKind k v Maybe)) + +-- Resolver : a -> Resolver b +instance (GQLType b, DeriveTypeContent 'False a, Introspect b) => Introspect (a -> m b) where + isObject _ = False + field _ name = fieldObj {fieldArgs} + where + fieldObj = field (Proxy @b) name + fieldArgs = + fieldsToArguments $ mockFieldsDefinition $ fst $ + introspectObjectFields + (Proxy :: Proxy 'False) + (__typeName (Proxy @b), InputType, Proxy @a) + introspect _ typeLib = + resolveUpdates + typeLib + (introspect (Proxy @b) : inputs) + where + name = "Arguments for " <> __typeName (Proxy @b) + inputs :: [TypeUpdater] + inputs = + snd $ introspectObjectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a) + +-- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY +instance (GQLType b, Introspect b) => Introspect (Resolver fo e m b) where + isObject _ = False + field _ = field (Proxy @b) + introspect _ = introspect (Proxy @b) + +-- | Introspect With specific Kind: 'kind': object, scalar, enum ... +class IntrospectKind (kind :: GQL_KIND) a where + introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema + +-- SCALAR +instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where + introspectKind _ = updateLib scalarType [] (Proxy @a) + where + scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a) + +-- ENUM +instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where + introspectKind _ = updateLib enumType [] (Proxy @a) + where + enumType = + buildType $ DataEnum $ map (createEnumValue . TypeName) $ enumTags (Proxy @(Rep a)) + +instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind INPUT a where + introspectKind _ = derivingData (Proxy @a) InputType + +instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind OUTPUT a where + introspectKind _ = derivingData (Proxy @a) OutputType + +instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind INTERFACE a where + introspectKind _ = updateLib (buildType (DataInterface (mockFieldsDefinition fields) :: TypeContent TRUE OUT)) types (Proxy @a) + where + (fields, types) = + introspectObjectFields + (Proxy @(CUSTOM a)) + (baseName, OutputType, Proxy @a) + baseName = __typeName (Proxy @a) + +derivingData :: + forall a cat. + (GQLType a, DeriveTypeContent (CUSTOM a) a) => + Proxy a -> + TypeScope cat -> + TypeUpdater +derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a) + where + (datatypeContent, updates) = + deriveTypeContent + (Proxy @(CUSTOM a)) + (Proxy @a, unzip $ implements (Proxy @a), scope, baseName, baseFingerprint) + baseName = __typeName (Proxy @a) + baseFingerprint = __typeFingerprint (Proxy @a) + +type GQL_TYPE a = (Generic a, GQLType a) + +deriveCustomInputObjectType :: + DeriveTypeContent TRUE a => + (TypeName, proxy a) -> + TypeUpdater +deriveCustomInputObjectType (name, proxy) = + flip + resolveUpdates + (deriveCustomObjectType (name, InputType, proxy)) + +deriveCustomObjectType :: + DeriveTypeContent TRUE a => + (TypeName, TypeScope cat, proxy a) -> + [TypeUpdater] +deriveCustomObjectType = snd . introspectObjectFields (Proxy :: Proxy TRUE) + +introspectObjectFields :: + DeriveTypeContent custom a => + proxy1 (custom :: Bool) -> + (TypeName, TypeScope cat, proxy2 a) -> + (FieldsDefinition cat, [TypeUpdater]) +introspectObjectFields p1 (name, scope, proxy) = + withObject name (deriveTypeContent p1 (proxy, ([], []), scope, "", DataFingerprint "" [])) + +withObject :: TypeName -> (TypeContent TRUE (cat :: TypeCategory), [TypeUpdater]) -> (FieldsDefinition cat2, [TypeUpdater]) +withObject _ (DataObject {objectFields}, ts) = (mockFieldsDefinition objectFields, ts) +withObject _ (DataInputObject {inputObjectFields}, ts) = (mockFieldsDefinition inputObjectFields, ts) +withObject name _ = (empty, [introspectFailure (msg name <> " should have only one nonempty constructor")]) + +introspectFailure :: Message -> TypeUpdater +introspectFailure = const . failure . globalErrorMessage . ("invalid schema: " <>) + +-- Object Fields +class DeriveTypeContent (custom :: Bool) a where + deriveTypeContent :: proxy1 custom -> (proxy2 a, ([TypeName], [TypeUpdater]), TypeScope cat, TypeName, DataFingerprint) -> (TypeContent TRUE ANY, [TypeUpdater]) + +instance (TypeRep (Rep a), Generic a) => DeriveTypeContent FALSE a where + deriveTypeContent _ (_, interfaces, scope, baseName, baseFingerprint) = + fa $ builder $ typeRep $ Proxy @(Rep a) + where + fa (x, y) = (toAny x, y) + builder [ConsRep {consFields}] = buildObject interfaces scope consFields + builder cons = genericUnion scope cons + where + genericUnion InputType = buildInputUnion (baseName, baseFingerprint) + genericUnion OutputType = buildUnionType (baseName, baseFingerprint) DataUnion (DataObject []) + +buildField :: GQLType a => Proxy a -> ArgumentsDefinition -> FieldName -> FieldDefinition cat +buildField proxy fieldArgs fieldName = + FieldDefinition + { fieldType = createAlias $ __typeName proxy, + fieldMeta = Nothing, + .. + } + +buildType :: GQLType a => TypeContent TRUE cat -> Proxy a -> TypeDefinition cat +buildType typeContent proxy = + TypeDefinition + { typeName = __typeName proxy, + typeFingerprint = __typeFingerprint proxy, + typeMeta = + Just + Meta + { metaDescription = description proxy, + metaDirectives = [] + }, + typeContent + } + +updateLib :: + GQLType a => + (Proxy a -> TypeDefinition cat) -> + [TypeUpdater] -> + Proxy a -> + TypeUpdater +updateLib f stack proxy = updateSchema (__typeName proxy) (__typeFingerprint proxy) stack f proxy + +-- NEW AUTOMATIC DERIVATION SYSTEM + +data ConsRep = ConsRep + { consName :: TypeName, + consIsRecord :: Bool, + consFields :: [FieldRep] + } + +data FieldRep = FieldRep + { fieldTypeName :: TypeName, + fieldData :: FieldDefinition ANY, + fieldTypeUpdater :: TypeUpdater, + fieldIsObject :: Bool + } + +data ResRep = ResRep + { enumCons :: [TypeName], + unionRef :: [TypeName], + unionRecordRep :: [ConsRep] + } + +isEmpty :: ConsRep -> Bool +isEmpty ConsRep {consFields = []} = True +isEmpty _ = False + +isUnionRef :: TypeName -> ConsRep -> Bool +isUnionRef baseName ConsRep {consName, consFields = [FieldRep {fieldIsObject = True, fieldTypeName}]} = + consName == baseName <> fieldTypeName +isUnionRef _ _ = False + +setFieldNames :: ConsRep -> ConsRep +setFieldNames cons@ConsRep {consFields} = + cons + { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields + } + where + setFieldName i fieldR@FieldRep {fieldData = fieldD} = fieldR {fieldData = fieldD {fieldName}} + where + fieldName = FieldName ("_" <> pack (show i)) + +analyseRep :: TypeName -> [ConsRep] -> ResRep +analyseRep baseName cons = + ResRep + { enumCons = map consName enumRep, + unionRef = map fieldTypeName $ concatMap consFields unionRefRep, + unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep + } + where + (enumRep, left1) = partition isEmpty cons + (unionRefRep, left2) = partition (isUnionRef baseName) left1 + (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2 + +buildInputUnion :: + (TypeName, DataFingerprint) -> [ConsRep] -> (TypeContent TRUE IN, [TypeUpdater]) +buildInputUnion (baseName, baseFingerprint) cons = + datatype + (analyseRep baseName cons) + where + datatype :: ResRep -> (TypeContent TRUE IN, [TypeUpdater]) + datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = + (DataEnum (map createEnumValue enumCons), types) + datatype ResRep {unionRef, unionRecordRep, enumCons} = + (DataInputUnion typeMembers, types <> unionTypes) + where + typeMembers :: [(TypeName, Bool)] + typeMembers = + map (,True) (unionRef <> unionMembers) <> map (,False) enumCons + (unionMembers, unionTypes) = + buildUnions wrapInputObject baseFingerprint unionRecordRep + types = map fieldTypeUpdater $ concatMap consFields cons + wrapInputObject :: (FieldsDefinition IN -> TypeContent TRUE IN) + wrapInputObject = DataInputObject + +buildUnionType :: + (TypeName, DataFingerprint) -> + (DataUnion -> TypeContent TRUE cat) -> + (FieldsDefinition cat -> TypeContent TRUE cat) -> + [ConsRep] -> + (TypeContent TRUE cat, [TypeUpdater]) +buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = + datatype + (analyseRep baseName cons) + where + --datatype :: ResRep -> (TypeContent TRUE cat, [TypeUpdater]) + datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} = + (DataEnum (map createEnumValue enumCons), types) + datatype ResRep {unionRef, unionRecordRep, enumCons} = + (wrapUnion typeMembers, types <> enumTypes <> unionTypes) + where + typeMembers = unionRef <> enumMembers <> unionMembers + (enumMembers, enumTypes) = + buildUnionEnum wrapObject baseName baseFingerprint enumCons + (unionMembers, unionTypes) = + buildUnions wrapObject baseFingerprint unionRecordRep + types = map fieldTypeUpdater $ concatMap consFields cons + +buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep] -> (TypeContent TRUE cat, [TypeUpdater]) +buildObject (interfaces, interfaceTypes) scope consFields = + ( wrapWith scope (mockFieldsDefinition fields), + types <> interfaceTypes + ) + where + (fields, types) = buildDataObject consFields + --- wrap with + wrapWith :: TypeScope cat -> FieldsDefinition cat -> TypeContent TRUE cat + wrapWith InputType = DataInputObject + wrapWith OutputType = DataObject interfaces + +buildDataObject :: [FieldRep] -> (FieldsDefinition ANY, [TypeUpdater]) +buildDataObject consFields = (fields, types) + where + fields = unsafeFromFields $ map fieldData consFields + types = map fieldTypeUpdater consFields + +buildUnions :: + (FieldsDefinition cat -> TypeContent TRUE cat) -> + DataFingerprint -> + [ConsRep] -> + ([TypeName], [TypeUpdater]) +buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons) + where + buildURecType consRep = + pure + . defineType + (buildUnionRecord wrapObject baseFingerprint consRep) + members = map consName cons + +mockFieldsDefinition :: FieldsDefinition a -> FieldsDefinition b +mockFieldsDefinition = fmap mockFieldDefinition + +mockFieldDefinition :: FieldDefinition a -> FieldDefinition b +mockFieldDefinition FieldDefinition {..} = FieldDefinition {..} + +buildUnionRecord :: + (FieldsDefinition cat -> TypeContent TRUE cat) -> DataFingerprint -> ConsRep -> TypeDefinition cat +buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} = + TypeDefinition + { typeName = consName, + typeFingerprint, + typeMeta = Nothing, + typeContent = + wrapObject + $ mockFieldsDefinition + $ unsafeFromFields + $ map fieldData consFields + } + +buildUnionEnum :: + (FieldsDefinition cat -> TypeContent TRUE cat) -> + TypeName -> + DataFingerprint -> + [TypeName] -> + ([TypeName], [TypeUpdater]) +buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates) + where + members + | null enums = [] + | otherwise = [enumTypeWrapperName] + enumTypeName = baseName <> "Enum" + enumTypeWrapperName = enumTypeName <> "Object" + ------------------------- + updates :: [TypeUpdater] + updates + | null enums = + [] + | otherwise = + [ buildEnumObject + wrapObject + enumTypeWrapperName + baseFingerprint + enumTypeName, + buildEnum enumTypeName baseFingerprint enums + ] + +buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> TypeUpdater +buildEnum typeName typeFingerprint tags = + pure + . defineType + TypeDefinition + { typeMeta = Nothing, + typeContent = DataEnum $ map createEnumValue tags, + .. + } + +buildEnumObject :: + (FieldsDefinition cat -> TypeContent TRUE cat) -> + TypeName -> + DataFingerprint -> + TypeName -> + TypeUpdater +buildEnumObject wrapObject typeName typeFingerprint enumTypeName = + pure + . defineType + TypeDefinition + { typeName, + typeFingerprint, + typeMeta = Nothing, + typeContent = + wrapObject $ + singleton + FieldDefinition + { fieldName = "enum", + fieldArgs = NoArguments, + fieldType = createAlias enumTypeName, + fieldMeta = Nothing + } + } + +data TypeScope (cat :: TypeCategory) where + InputType :: TypeScope IN + OutputType :: TypeScope OUT + +deriving instance Show (TypeScope cat) + +deriving instance Eq (TypeScope cat) + +deriving instance Ord (TypeScope cat) + +-- GENERIC UNION +class TypeRep f where + typeRep :: Proxy f -> [ConsRep] + +instance TypeRep f => TypeRep (M1 D d f) where + typeRep _ = typeRep (Proxy @f) + +-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT' +instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where + typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b) + +instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where + typeRep _ = + [ ConsRep + { consName = conNameProxy (Proxy @c), + consFields = conRep (Proxy @f), + consIsRecord = isRecordProxy (Proxy @c) + } + ] + +class ConRep f where + conRep :: Proxy f -> [FieldRep] + +-- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION' +instance (ConRep a, ConRep b) => ConRep (a :*: b) where + conRep _ = conRep (Proxy @a) <> conRep (Proxy @b) + +instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where + conRep _ = + [ FieldRep + { fieldTypeName = typeConName $ fieldType fieldData, + fieldData = fieldData, + fieldTypeUpdater = introspect (Proxy @a), + fieldIsObject = isObject (Proxy @a) + } + ] + where + name = selNameProxy (Proxy @s) + fieldData = field (Proxy @a) name + +instance ConRep U1 where + conRep _ = [] diff --git a/src/Data/Morpheus/Server/Deriving/Resolve.hs b/src/Data/Morpheus/Server/Deriving/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Resolve.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Morpheus.Server.Deriving.Resolve + ( statelessResolver, + RootResCon, + fullSchema, + coreResolver, + EventCon, + ) +where + +import Data.Functor.Identity (Identity (..)) +-- MORPHEUS + +import Data.Morpheus.Core + ( runApi, + ) +import Data.Morpheus.Server.Deriving.Encode + ( EncodeCon, + deriveModel, + ) +import Data.Morpheus.Server.Deriving.Introspect + ( IntroCon, + TypeScope (..), + introspectObjectFields, + ) +import Data.Morpheus.Server.Types.GQLType (GQLType (CUSTOM)) +import Data.Morpheus.Types + ( GQLRootResolver (..), + ) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + GQLResponse (..), + renderResponse, + ) +import Data.Morpheus.Types.Internal.AST + ( DataFingerprint (..), + FieldsDefinition, + MUTATION, + OUT, + QUERY, + SUBSCRIPTION, + Schema (..), + TypeContent (..), + TypeDefinition (..), + TypeName, + ValidValue, + initTypeLib, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + GQLChannel (..), + Resolver, + ResponseStream, + ResultT (..), + cleanEvents, + resolveUpdates, + ) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) + +type EventCon event = + (Eq (StreamChannel event), Typeable event, GQLChannel event) + +type IntrospectConstraint m event query mutation subscription = + ( IntroCon (query (Resolver QUERY event m)), + IntroCon (mutation (Resolver MUTATION event m)), + IntroCon (subscription (Resolver SUBSCRIPTION event m)) + ) + +type RootResCon m event query mutation subscription = + ( EventCon event, + Typeable m, + IntrospectConstraint m event query mutation subscription, + EncodeCon QUERY event m (query (Resolver QUERY event m)), + EncodeCon MUTATION event m (mutation (Resolver MUTATION event m)), + EncodeCon + SUBSCRIPTION + event + m + (subscription (Resolver SUBSCRIPTION event m)) + ) + +statelessResolver :: + (Monad m, RootResCon m event query mut sub) => + GQLRootResolver m event query mut sub -> + GQLRequest -> + m GQLResponse +statelessResolver root req = + 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 request = + validRequest + >>= execOperator + where + validRequest :: + Monad m => ResponseStream event m Schema + validRequest = cleanEvents $ ResultT $ pure $ fullSchema $ Identity root + -------------------------------------- + execOperator schema = runApi schema (deriveModel root) request + +fullSchema :: + forall proxy m event query mutation subscription. + (IntrospectConstraint m event query mutation subscription) => + proxy (GQLRootResolver m event query mutation subscription) -> + Eventless Schema +fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema + where + querySchema = + resolveUpdates (initTypeLib (operatorType fields "Query")) types + where + (fields, types) = + introspectObjectFields + (Proxy @(CUSTOM (query (Resolver QUERY event m)))) + ("type for query", OutputType, Proxy @(query (Resolver QUERY event m))) + ------------------------------ + mutationSchema lib = + resolveUpdates + (lib {mutation = maybeOperator fields "Mutation"}) + types + where + (fields, types) = + introspectObjectFields + (Proxy @(CUSTOM (mutation (Resolver MUTATION event m)))) + ( "type for mutation", + OutputType, + Proxy @(mutation (Resolver MUTATION event m)) + ) + ------------------------------ + subscriptionSchema lib = + resolveUpdates + (lib {subscription = maybeOperator fields "Subscription"}) + types + where + (fields, types) = + introspectObjectFields + (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m)))) + ( "type for subscription", + OutputType, + Proxy @(subscription (Resolver SUBSCRIPTION event m)) + ) + maybeOperator :: FieldsDefinition OUT -> TypeName -> Maybe (TypeDefinition OUT) + maybeOperator fields + | null fields = const Nothing + | otherwise = Just . operatorType fields + ------------------------------------------------- + operatorType :: FieldsDefinition OUT -> TypeName -> TypeDefinition OUT + operatorType fields typeName = + TypeDefinition + { typeContent = DataObject [] fields, + typeName, + typeFingerprint = DataFingerprint typeName [], + typeMeta = Nothing + } diff --git a/src/Data/Morpheus/Server/Deriving/Utils.hs b/src/Data/Morpheus/Server/Deriving/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Utils.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Server.Deriving.Utils + ( EnumRep (..), + datatypeNameProxy, + conNameProxy, + selNameProxy, + isRecordProxy, + ) +where + +import Data.Morpheus.Types.Internal.AST + ( FieldName, + FieldName (..), + TypeName (..), + convertToJSONName, + ) +import Data.Proxy (Proxy (..)) +import Data.Text + ( Text, + pack, + ) +import GHC.Generics + +-- MORPHEUS +class EnumRep (f :: * -> *) where + enumTags :: Proxy f -> [Text] + +instance EnumRep f => EnumRep (M1 D c f) where + enumTags _ = enumTags (Proxy @f) + +instance (Constructor c) => EnumRep (M1 C c U1) where + enumTags _ = [pack $ conName (undefined :: (M1 C c U1 x))] + +instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where + enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b) + +datatypeNameProxy :: forall f (d :: Meta). Datatype d => f d -> TypeName +datatypeNameProxy _ = TypeName $ pack $ datatypeName (undefined :: (M1 D d f a)) + +conNameProxy :: forall f (c :: Meta). Constructor c => f c -> TypeName +conNameProxy _ = TypeName $ pack $ conName (undefined :: M1 C c U1 a) + +selNameProxy :: forall f (s :: Meta). Selector s => f s -> FieldName +selNameProxy _ = convertToJSONName $ FieldName $ pack $ selName (undefined :: M1 S s f a) + +isRecordProxy :: forall f (c :: Meta). Constructor c => f c -> Bool +isRecordProxy _ = conIsRecord (undefined :: (M1 C c f a)) diff --git a/src/Data/Morpheus/Server/Document/Compile.hs b/src/Data/Morpheus/Server/Document/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/Compile.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Server.Document.Compile + ( compileDocument, + gqlDocument, + gqlDocumentNamespace, + ) +where + +-- +-- Morpheus + +import Data.Morpheus.Core + ( parseTypeDefinitions, + ) +import Data.Morpheus.Error + ( gqlWarnings, + renderGQLErrors, + ) +import Data.Morpheus.Server.Document.Convert + ( toTHDefinitions, + ) +import Data.Morpheus.Server.Document.Declare + ( declare, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Result (..), + ) +import qualified Data.Text as T + ( pack, + ) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +gqlDocumentNamespace :: QuasiQuoter +gqlDocumentNamespace = + QuasiQuoter + { quoteExp = notHandled "Expressions", + quotePat = notHandled "Patterns", + quoteType = notHandled "Types", + quoteDec = compileDocument True + } + where + notHandled things = + error $ things ++ " are not supported by the GraphQL QuasiQuoter" + +gqlDocument :: QuasiQuoter +gqlDocument = + QuasiQuoter + { quoteExp = notHandled "Expressions", + quotePat = notHandled "Patterns", + quoteType = notHandled "Types", + quoteDec = compileDocument False + } + where + notHandled things = + error $ things ++ " are not supported by the GraphQL QuasiQuoter" + +compileDocument :: Bool -> String -> Q [Dec] +compileDocument namespace documentTXT = + case parseTypeDefinitions (T.pack documentTXT) of + Failure errors -> fail (renderGQLErrors errors) + Success {result = schema, warnings} -> + gqlWarnings warnings >> toTHDefinitions namespace schema >>= declare namespace diff --git a/src/Data/Morpheus/Server/Document/Convert.hs b/src/Data/Morpheus/Server/Document/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/Convert.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Server.Document.Convert + ( toTHDefinitions, + ) +where + +-- MORPHEUS +import Data.Morpheus.Internal.TH + ( infoTyVars, + mkTypeName, + ) +import Data.Morpheus.Internal.Utils + ( capitalTypeName, + elems, + singleton, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + ConsD, + DataTypeKind (..), + FieldDefinition (..), + FieldName, + FieldsDefinition, + GQLTypeD (..), + OUT, + TRUE, + TypeContent (..), + TypeD (..), + TypeDefinition (..), + TypeName, + TypeRef (..), + argumentsToFields, + hasArguments, + hsTypeName, + kindOf, + lookupWith, + mkCons, + mkConsEnum, + toFieldName, + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH + +m_ :: TypeName +m_ = "m" + +getTypeArgs :: TypeName -> [TypeDefinition ANY] -> Q (Maybe TypeName) +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 <$> lookupWith typeName key lib of + Just x -> pure (kindToTyArgs x) + Nothing -> getTyArgs <$> reify (mkTypeName key) + +getTyArgs :: Info -> Maybe TypeName +getTyArgs x + | null (infoTyVars x) = Nothing + | otherwise = Just m_ + +kindToTyArgs :: TypeContent TRUE ANY -> Maybe TypeName +kindToTyArgs DataObject {} = Just m_ +kindToTyArgs DataUnion {} = Just m_ +kindToTyArgs DataInterface {} = Just m_ +kindToTyArgs _ = Nothing + +toTHDefinitions :: Bool -> [TypeDefinition ANY] -> Q [GQLTypeD] +toTHDefinitions namespace lib = traverse renderTHType lib + where + renderTHType :: TypeDefinition ANY -> Q GQLTypeD + renderTHType x = generateType x + where + genArgsTypeName :: FieldName -> TypeName + genArgsTypeName fieldName + | namespace = hsTypeName (typeName x) <> argTName + | otherwise = argTName + where + argTName = capitalTypeName (fieldName <> "Args") + --------------------------------------------------------------------------------------------- + genResField :: FieldDefinition OUT -> Q (FieldDefinition OUT) + genResField field@FieldDefinition {fieldName, fieldArgs, fieldType = typeRef@TypeRef {typeConName}} = + do + typeArgs <- getTypeArgs typeConName lib + pure $ + field + { fieldType = typeRef {typeConName = hsTypeName typeConName, typeArgs}, + fieldArgs = fieldArguments + } + where + fieldArguments + | hasArguments fieldArgs = fieldArgs {argumentsTypename = Just $ genArgsTypeName fieldName} + | otherwise = fieldArgs + -------------------------------------------- + generateType :: TypeDefinition ANY -> Q GQLTypeD + generateType typeOriginal@TypeDefinition {typeName, typeContent, typeMeta} = + genType + typeContent + where + buildType :: [ConsD] -> TypeD + buildType tCons = + TypeD + { tName = hsTypeName typeName, + tMeta = typeMeta, + tNamespace = [], + tCons, + tKind + } + buildObjectCons :: FieldsDefinition cat -> [ConsD] + buildObjectCons fields = [mkCons typeName fields] + tKind = kindOf typeOriginal + genType :: TypeContent TRUE ANY -> Q GQLTypeD + genType (DataEnum tags) = + pure + GQLTypeD + { typeD = + TypeD + { tName = hsTypeName typeName, + tNamespace = [], + tCons = map mkConsEnum tags, + tMeta = typeMeta, + tKind + }, + typeArgD = [], + .. + } + genType DataScalar {} = fail "Scalar Types should defined By Native Haskell Types" + genType DataInputUnion {} = fail "Input Unions not Supported" + genType DataInterface {interfaceFields} = do + typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (elems interfaceFields) + objCons <- buildObjectCons <$> traverse genResField interfaceFields + pure + GQLTypeD + { typeD = buildType objCons, + typeArgD, + .. + } + genType (DataInputObject fields) = + pure + GQLTypeD + { typeD = buildType $ buildObjectCons fields, + typeArgD = [], + .. + } + genType DataObject {objectFields} = do + typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (elems objectFields) + objCons <- buildObjectCons <$> traverse genResField objectFields + pure + GQLTypeD + { typeD = buildType objCons, + typeArgD, + .. + } + genType (DataUnion members) = + pure + GQLTypeD + { typeD = buildType (map unionCon members), + typeArgD = [], + .. + } + where + unionCon memberName = + mkCons + cName + ( singleton + FieldDefinition + { fieldName = "un" <> toFieldName cName, + fieldType = + TypeRef + { typeConName = utName, + typeArgs = Just m_, + typeWrappers = [] + }, + fieldMeta = Nothing, + fieldArgs = NoArguments + } + ) + where + cName = hsTypeName typeName <> utName + utName = hsTypeName memberName + +genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT -> Q [TypeD] +genArgumentType _ FieldDefinition {fieldArgs = NoArguments} = pure [] +genArgumentType namespaceWith FieldDefinition {fieldName, fieldArgs} = + pure + [ TypeD + { tName, + tNamespace = [], + tCons = + [ mkCons tName (argumentsToFields fieldArgs) + ], + tMeta = Nothing, + tKind = KindInputObject + } + ] + where + tName = hsTypeName (namespaceWith fieldName) diff --git a/src/Data/Morpheus/Server/Document/Declare.hs b/src/Data/Morpheus/Server/Document/Declare.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/Declare.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Server.Document.Declare + ( declare, + ) +where + +-- MORPHEUS + +import Data.Morpheus.Internal.TH + ( Scope (..), + declareType, + ) +import Data.Morpheus.Server.Document.Decode + ( deriveDecode, + ) +import Data.Morpheus.Server.Document.Encode + ( deriveEncode, + ) +import Data.Morpheus.Server.Document.GQLType + ( deriveGQLType, + ) +import Data.Morpheus.Server.Document.Introspect + ( deriveObjectRep, + instanceIntrospect, + ) +import Data.Morpheus.Types.Internal.AST + ( GQLTypeD (..), + TypeD (..), + isInput, + isObject, + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH + +class Declare a where + type DeclareCtx a :: * + declare :: DeclareCtx a -> a -> Q [Dec] + +instance Declare a => Declare [a] where + type DeclareCtx [a] = DeclareCtx a + declare namespace = fmap concat . traverse (declare namespace) + +instance Declare GQLTypeD where + type DeclareCtx GQLTypeD = Bool + declare namespace gqlType@GQLTypeD {typeD = typeD@TypeD {tKind}, typeArgD, typeOriginal} = + do + mainType <- declareMainType + argTypes <- declareArgTypes + gqlInstances <- deriveGQLInstances + typeClasses <- deriveGQLType gqlType + introspectEnum <- instanceIntrospect typeOriginal + pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum + where + deriveGQLInstances = concat <$> sequence gqlInstances + where + gqlInstances + | isObject tKind && isInput tKind = + [deriveObjectRep (typeD, Just typeOriginal, Nothing), deriveDecode typeD] + | isObject tKind = + [deriveObjectRep (typeD, Just typeOriginal, Just tKind), deriveEncode typeD] + | otherwise = + [] + -------------------------------------------------- + declareArgTypes = do + introspectArgs <- concat <$> traverse deriveArgsRep typeArgD + decodeArgs <- concat <$> traverse deriveDecode typeArgD + return $ argsTypeDecs <> decodeArgs <> introspectArgs + where + deriveArgsRep args = deriveObjectRep (args, Nothing, Nothing) + ---------------------------------------------------- + argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD + -------------------------------------------------- + declareMainType = declareT + where + declareT = + pure [declareType SERVER namespace (Just tKind) derivingClasses typeD] + derivingClasses + | isInput tKind = [''Show] + | otherwise = [] diff --git a/src/Data/Morpheus/Server/Document/Decode.hs b/src/Data/Morpheus/Server/Document/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/Decode.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Server.Document.Decode + ( deriveDecode, + ) +where + +-- +-- MORPHEUS + +import Data.Morpheus.Internal.TH + ( instanceHeadT, + nameVarP, + ) +import Data.Morpheus.Server.Deriving.Decode + ( Decode (..), + DecodeType (..), + ) +import Data.Morpheus.Server.Internal.TH.Decode + ( decodeFieldWith, + decodeObjectExpQ, + withObject, + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + TypeD (..), + ValidValue, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Language.Haskell.TH + +(.:) :: Decode a => ValidValue -> FieldName -> Eventless a +value .: selectorName = withObject (decodeFieldWith decode selectorName) value + +deriveDecode :: TypeD -> Q [Dec] +deriveDecode TypeD {tName, tCons = [cons]} = + pure <$> instanceD (cxt []) appHead methods + where + appHead = instanceHeadT ''DecodeType tName [] + methods = [funD 'decodeType [clause argsE (normalB body) []]] + where + argsE = map nameVarP ["o"] + body = decodeObjectExpQ [|(.:)|] cons +deriveDecode _ = pure [] diff --git a/src/Data/Morpheus/Server/Document/Encode.hs b/src/Data/Morpheus/Server/Document/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/Encode.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Server.Document.Encode + ( deriveEncode, + ) +where + +-- +-- MORPHEUS + +import Data.Morpheus.Internal.TH + ( applyT, + destructRecord, + instanceHeadMultiT, + mkTypeName, + nameStringE, + nameVarE, + nameVarP, + nameVarT, + typeT, + ) +import Data.Morpheus.Server.Deriving.Encode + ( Encode (..), + ExploreResolvers (..), + ) +import Data.Morpheus.Server.Types.GQLType (TRUE) +import Data.Morpheus.Types.Internal.AST + ( ConsD (..), + FieldDefinition (..), + QUERY, + SUBSCRIPTION, + TypeD (..), + TypeName (..), + isSubscription, + ) +import Data.Morpheus.Types.Internal.Resolving + ( LiftOperation, + MapStrategy (..), + ObjectResModel (..), + ResModel (..), + Resolver, + ) +import Data.Semigroup ((<>)) +import Data.Typeable (Typeable) +import Language.Haskell.TH + +m_ :: TypeName +m_ = "m" + +fo_ :: TypeName +fo_ = "fieldOperationKind" + +po_ :: TypeName +po_ = "parentOparation" + +e_ :: TypeName +e_ = "encodeEvent" + +encodeVars :: [TypeName] +encodeVars = [e_, m_] + +encodeVarsT :: [TypeQ] +encodeVarsT = map nameVarT encodeVars + +deriveEncode :: TypeD -> Q [Dec] +deriveEncode TypeD {tName, tCons = [ConsD {cFields}], tKind} = + pure <$> instanceD (cxt constrains) appHead methods + where + subARgs = conT ''SUBSCRIPTION : encodeVarsT + instanceArgs + | isSubscription tKind = subARgs + | otherwise = map nameVarT (po_ : encodeVars) + mainType = applyT (mkTypeName tName) [mainTypeArg] + where + mainTypeArg + | isSubscription tKind = applyT ''Resolver subARgs + | otherwise = typeT ''Resolver (fo_ : encodeVars) + ----------------------------------------------------------------------------------------- + typeables + | isSubscription tKind = + [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]] + | otherwise = + [ iLiftOp po_, + iLiftOp fo_, + typeT ''MapStrategy [fo_, po_], + iTypeable fo_, + iTypeable po_ + ] + ------------------------- + iLiftOp op = applyT ''LiftOperation [nameVarT op] + ------------------------- + iTypeable name = typeT ''Typeable [name] + ------------------------------------------- + -- defines Constraint: (Typeable m, Monad m) + constrains = + typeables + <> [ typeT ''Monad [m_], + applyT ''Encode (mainType : instanceArgs), + iTypeable e_, + iTypeable m_ + ] + ------------------------------------------------------------------- + -- defines: instance => ObjectResolvers ('TRUE) ( (ResolveT m)) (ResolveT m value) where + appHead = + instanceHeadMultiT + ''ExploreResolvers + (conT ''TRUE) + (mainType : instanceArgs) + ------------------------------------------------------------------ + -- defines: objectResolvers = [("field1",encode field1),("field2",encode field2), ...] + methods = [funD 'exploreResolvers [clause argsE (normalB body) []]] + where + argsE = [nameVarP "_", destructRecord tName varNames] + body = + appE (varE 'pure) + $ appE + (conE 'ResObject) + $ appE + ( appE + (conE 'ObjectResModel) + (nameStringE tName) + ) + (listE $ map decodeVar varNames) + decodeVar name = [|(name, encode $(varName))|] + where + varName = nameVarE name + varNames = map fieldName cFields +deriveEncode _ = pure [] diff --git a/src/Data/Morpheus/Server/Document/GQLType.hs b/src/Data/Morpheus/Server/Document/GQLType.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/GQLType.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Server.Document.GQLType + ( deriveGQLType, + ) +where + +-- +-- MORPHEUS +import Data.Morpheus.Internal.TH + ( instanceHeadT, + instanceProxyFunD, + mkTypeName, + tyConArgs, + typeInstanceDec, + typeT, + ) +import Data.Morpheus.Kind + ( ENUM, + INPUT, + INTERFACE, + OUTPUT, + SCALAR, + WRAPPER, + ) +import Data.Morpheus.Server.Types.GQLType + ( GQLType (..), + TRUE, + ) +import Data.Morpheus.Types (Resolver, interface) +import Data.Morpheus.Types.Internal.AST + ( ANY, + DataTypeKind (..), + GQLTypeD (..), + Meta (..), + QUERY, + TypeContent (..), + TypeD (..), + TypeDefinition (..), + TypeName, + isObject, + ) +import Data.Proxy (Proxy (..)) +import Data.Semigroup ((<>)) +import Data.Typeable (Typeable) +import Language.Haskell.TH + +interfaceF :: Name -> ExpQ +interfaceF name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|] + +introspectInterface :: TypeName -> ExpQ +introspectInterface = interfaceF . mkTypeName + +deriveGQLType :: GQLTypeD -> Q [Dec] +deriveGQLType GQLTypeD {typeD = TypeD {tName, tMeta, tKind}, typeOriginal} = + pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies) + where + functions = + map + instanceProxyFunD + [ ('__typeName, [|tName|]), + ('description, descriptionValue), + ('implements, implementsFunc) + ] + where + implementsFunc = listE $ map introspectInterface (interfacesFrom (Just typeOriginal)) + descriptionValue = case tMeta >>= metaDescription of + Nothing -> [|Nothing|] + Just desc -> [|Just desc|] + -------------------------------- + typeArgs = tyConArgs tKind + -------------------------------- + iHead = instanceHeadT ''GQLType tName typeArgs + headSig = typeT (mkTypeName tName) typeArgs + --------------------------------------------------- + constrains = map conTypeable typeArgs + where + conTypeable name = typeT ''Typeable [name] + ------------------------------------------------- + typeFamilies + | isObject tKind = [deriveKIND, deriveCUSTOM] + | otherwise = [deriveKIND] + where + deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE + deriveKIND = deriveInstance ''KIND (kindName tKind) + ------------------------------------------------------- + deriveInstance :: Name -> Name -> Q Dec + deriveInstance insName tyName = do + typeN <- headSig + 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 +kindName KindInterface = ''INTERFACE + +interfacesFrom :: Maybe (TypeDefinition ANY) -> [TypeName] +interfacesFrom (Just TypeDefinition {typeContent = DataObject {objectImplements}}) = objectImplements +interfacesFrom _ = [] diff --git a/src/Data/Morpheus/Server/Document/Introspect.hs b/src/Data/Morpheus/Server/Document/Introspect.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Document/Introspect.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Server.Document.Introspect + ( deriveObjectRep, + instanceIntrospect, + ) +where + +import Data.Maybe (maybeToList) +-- MORPHEUS +import Data.Morpheus.Internal.TH + ( instanceFunD, + instanceHeadMultiT, + instanceHeadT, + instanceProxyFunD, + mkTypeName, + nameConT, + nameVarT, + tyConArgs, + typeT, + ) +import Data.Morpheus.Server.Deriving.Introspect + ( DeriveTypeContent (..), + Introspect (..), + deriveCustomInputObjectType, + ) +import Data.Morpheus.Server.Types.GQLType + ( GQLType (__typeName, implements), + TRUE, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + ConsD (..), + DataTypeKind (..), + FieldDefinition (..), + TypeContent (..), + TypeD (..), + TypeDefinition (..), + TypeName, + TypeRef (..), + TypeUpdater, + insertType, + unsafeFromFields, + ) +import Data.Morpheus.Types.Internal.Resolving + ( resolveUpdates, + ) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Language.Haskell.TH + +instanceIntrospect :: TypeDefinition cat -> 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 typeName [] + defineIntrospect = instanceProxyFunD ('introspect, body) + where + body = [|insertType TypeDefinition {typeContent = DataEnum enumType, ..}|] +instanceIntrospect _ = pure [] + +-- [(FieldDefinition, TypeUpdater)] +deriveObjectRep :: (TypeD, Maybe (TypeDefinition ANY), Maybe DataTypeKind) -> Q [Dec] +deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, _, tKind) = + pure <$> instanceD (cxt constrains) iHead methods + where + mainTypeName = typeT (mkTypeName tName) typeArgs + typeArgs = concatMap tyConArgs (maybeToList tKind) + constrains = map conTypeable typeArgs + where + conTypeable name = typeT ''Typeable [name] + ----------------------------------------------- + iHead = instanceHeadMultiT ''DeriveTypeContent (conT ''TRUE) [mainTypeName] + methods = [instanceFunD 'deriveTypeContent ["_proxy1", "_proxy2"] body] + where + body + | tKind == Just KindInputObject || null tKind = + [| + ( DataInputObject + (unsafeFromFields $(buildFields cFields)), + $(typeUpdates) + ) + |] + | otherwise = + [| + ( DataObject + (interfaceNames $(proxy)) + (unsafeFromFields $(buildFields cFields)), + interfaceTypes $(proxy) + : $(typeUpdates) + ) + |] + ------------------------------------------------------------- + typeUpdates = buildTypes cFields + proxy = [|(Proxy :: Proxy $(mainTypeName))|] +deriveObjectRep _ = pure [] + +interfaceNames :: GQLType a => Proxy a -> [TypeName] +interfaceNames = map fst . implements + +interfaceTypes :: GQLType a => Proxy a -> TypeUpdater +interfaceTypes = flip resolveUpdates . map snd . implements + +buildTypes :: [FieldDefinition cat] -> ExpQ +buildTypes = listE . concatMap introspectField + +introspectField :: FieldDefinition cat -> [ExpQ] +introspectField FieldDefinition {fieldType, fieldArgs} = + [|introspect $(proxyT fieldType)|] : inputTypes fieldArgs + where + inputTypes :: ArgumentsDefinition -> [ExpQ] + inputTypes ArgumentsDefinition {argumentsTypename = Just argsTypeName} + | argsTypeName /= "()" = [[|deriveCustomInputObjectType (argsTypeName, $(proxyT tAlias))|]] + where + tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing} + inputTypes _ = [] + +proxyT :: TypeRef -> Q Exp +proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|] + where + genSig (Just m) = appT (nameConT typeConName) (nameVarT m) + genSig _ = nameConT typeConName + +buildFields :: [FieldDefinition cat] -> ExpQ +buildFields = listE . map buildField + where + buildField f@FieldDefinition {fieldType} = [|f {fieldType = fieldType {typeConName = __typeName $(proxyT fieldType)}}|] diff --git a/src/Data/Morpheus/Server/Internal/TH/Decode.hs b/src/Data/Morpheus/Server/Internal/TH/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Internal/TH/Decode.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Server.Internal.TH.Decode + ( withObject, + withMaybe, + withList, + withEnum, + withUnion, + decodeFieldWith, + decodeObjectExpQ, + ) +where + +-- MORPHEUS +import Data.Morpheus.Error + ( internalTypeMismatch, + ) +import Data.Morpheus.Internal.TH + ( nameConE, + nameVarE, + ) +import Data.Morpheus.Internal.Utils + ( empty, + selectBy, + selectOr, + ) +import Data.Morpheus.Types.Internal.AST + ( ConsD (..), + FieldDefinition (..), + FieldName, + Message, + ObjectEntry (..), + TypeName (..), + ValidObject, + ValidValue, + Value (..), + toFieldName, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Failure (..), + ) +import Language.Haskell.TH + ( ExpQ, + uInfixE, + varE, + ) + +decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ +decodeObjectExpQ fieldDecoder ConsD {cName, cFields} = handleFields cFields + where + consName = nameConE cName + ---------------------------------------------------------------------------------- + handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames) + where + applyFields [] = fail "No Empty fields" + applyFields [x] = defField x + applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs) + ------------------------------------------------------------------------ + defField FieldDefinition {fieldName} = + uInfixE + (nameVarE "o") + fieldDecoder + [|fieldName|] + +withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a +withObject f (Object object) = f object +withObject _ isType = internalTypeMismatch "Object" isType + +withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a) +withMaybe _ Null = pure Nothing +withMaybe decode x = Just <$> decode x + +withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a] +withList decode (List li) = traverse decode li +withList _ isType = internalTypeMismatch "List" isType + +withEnum :: (TypeName -> Eventless a) -> ValidValue -> Eventless a +withEnum decode (Enum value) = decode value +withEnum _ isType = internalTypeMismatch "Enum" isType + +withUnion :: (TypeName -> 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 (toFieldName key) unions + where + notfound = withObject (decoder key unions) (Object empty) + onFound = withObject (decoder key unions) . entryValue + _ -> failure ("__typename must be Enum" :: Message) + +decodeFieldWith :: (ValidValue -> Eventless a) -> FieldName -> ValidObject -> Eventless a +decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue) diff --git a/src/Data/Morpheus/Server/Types/GQLScalar.hs b/src/Data/Morpheus/Server/Types/GQLScalar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Types/GQLScalar.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Server.Types.GQLScalar + ( GQLScalar (..), + toScalar, + ) +where + +import Data.Morpheus.Types.Internal.AST + ( ScalarDefinition (..), + ScalarValue (..), + ValidValue, + Value (..), + ) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) + +toScalar :: ValidValue -> Either Text ScalarValue +toScalar (Scalar x) = pure x +toScalar _ = Left "" + +-- | GraphQL Scalar +-- +-- 'parseValue' and 'serialize' should be provided for every instances manually +class GQLScalar a where + -- | value parsing and validating + -- + -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean' + -- + -- invalid values can be reported with 'Left' constructor : + -- + -- @ + -- parseValue String _ = Left "" -- without error message + -- -- or + -- parseValue String _ = Left "Error Message" + -- @ + parseValue :: ScalarValue -> Either Text a + + -- | serialization of haskell type into scalar value + serialize :: a -> ScalarValue + + scalarValidator :: Proxy a -> ScalarDefinition + scalarValidator _ = ScalarDefinition {validateValue = validator} + where + validator value = do + scalarValue' <- toScalar value + (_ :: a) <- parseValue scalarValue' + return value + +instance GQLScalar Text where + parseValue (String x) = pure x + parseValue _ = Left "" + serialize = String + +instance GQLScalar Bool where + parseValue (Boolean x) = pure x + parseValue _ = Left "" + serialize = Boolean + +instance GQLScalar Int where + parseValue (Int x) = pure x + parseValue _ = Left "" + serialize = Int + +instance GQLScalar Float where + parseValue (Float x) = pure x + parseValue (Int x) = pure $ fromInteger $ toInteger x + parseValue _ = Left "" + serialize = Float diff --git a/src/Data/Morpheus/Server/Types/GQLType.hs b/src/Data/Morpheus/Server/Types/GQLType.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Types/GQLType.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Server.Types.GQLType + ( GQLType (..), + TRUE, + FALSE, + ) +where + +import Data.Map (Map) +-- MORPHEUS +import Data.Morpheus.Kind +import Data.Morpheus.Server.Types.Types + ( MapKind, + Pair, + Undefined (..), + ) +import Data.Morpheus.Types.Internal.AST + ( DataFingerprint (..), + QUERY, + TypeName (..), + TypeUpdater, + internalFingerprint, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Resolver, + ) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.Text + ( Text, + intercalate, + pack, + ) +import Data.Typeable + ( TyCon, + TypeRep, + Typeable, + splitTyConApp, + tyConFingerprint, + tyConName, + typeRep, + typeRepTyCon, + ) + +type TRUE = 'True + +type FALSE = 'False + +resolverCon :: TyCon +resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe) + +-- | replaces typeName (A,B) with Pair_A_B +replacePairCon :: TyCon -> TyCon +replacePairCon x | hsPair == x = gqlPair + where + hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int) + gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int) +replacePairCon x = x + +-- Ignores Resolver name from typeName +ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon] +ignoreResolver (con, _) | con == resolverCon = [] +ignoreResolver (con, args) = + con : concatMap (ignoreResolver . splitTyConApp) args + +-- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. +-- +-- @ +-- ... deriving (Generic, GQLType) +-- @ +-- +-- if you want to add description +-- +-- @ +-- ... deriving (Generic) +-- +-- instance GQLType ... where +-- description = const "your description ..." +-- @ +class IsObject (a :: GQL_KIND) where + isObject :: Proxy a -> Bool + +instance IsObject SCALAR where + isObject _ = False + +instance IsObject ENUM where + isObject _ = False + +instance IsObject WRAPPER where + isObject _ = False + +instance IsObject INPUT where + isObject _ = True + +instance IsObject OUTPUT where + isObject _ = True + +instance IsObject INTERFACE where + isObject _ = True + +class IsObject (KIND a) => GQLType a where + type KIND a :: GQL_KIND + type KIND a = OUTPUT + + type CUSTOM a :: Bool + type CUSTOM a = FALSE + + implements :: Proxy a -> [(TypeName, TypeUpdater)] + implements _ = [] + + description :: Proxy a -> Maybe Text + description _ = Nothing + + isObjectKind :: Proxy a -> Bool + isObjectKind _ = isObject (Proxy @(KIND a)) + + __typeName :: Proxy a -> TypeName + default __typeName :: + (Typeable a) => + Proxy a -> + TypeName + __typeName _ = TypeName $ intercalate "_" (getName $ Proxy @a) + where + getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep) + + __typeFingerprint :: Proxy a -> DataFingerprint + default __typeFingerprint :: + (Typeable a) => + Proxy a -> + DataFingerprint + __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a) + where + conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep) + +instance GQLType () where + type KIND () = WRAPPER + type CUSTOM () = 'False + +instance Typeable m => GQLType (Undefined m) where + type KIND (Undefined m) = WRAPPER + type CUSTOM (Undefined m) = 'False + +instance GQLType Int where + type KIND Int = SCALAR + __typeFingerprint _ = internalFingerprint "Int" [] + +instance GQLType Float where + type KIND Float = SCALAR + __typeFingerprint _ = internalFingerprint "Float" [] + +instance GQLType Text where + type KIND Text = SCALAR + __typeName _ = "String" + __typeFingerprint _ = internalFingerprint "String" [] + +instance GQLType Bool where + type KIND Bool = SCALAR + __typeName _ = "Boolean" + __typeFingerprint _ = internalFingerprint "Boolean" [] + +instance GQLType a => GQLType (Maybe a) where + type KIND (Maybe a) = WRAPPER + __typeName _ = __typeName (Proxy @a) + __typeFingerprint _ = __typeFingerprint (Proxy @a) + +instance GQLType a => GQLType [a] where + type KIND [a] = WRAPPER + __typeName _ = __typeName (Proxy @a) + __typeFingerprint _ = __typeFingerprint (Proxy @a) + +instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where + type KIND (a, b) = WRAPPER + __typeName _ = __typeName $ Proxy @(Pair a b) + +instance GQLType a => GQLType (Set a) where + type KIND (Set a) = WRAPPER + __typeName _ = __typeName (Proxy @a) + __typeFingerprint _ = __typeFingerprint (Proxy @a) + +instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where + type KIND (Pair a b) = OUTPUT + +instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where + type KIND (MapKind a b m) = OUTPUT + __typeName _ = __typeName (Proxy @(Map a b)) + __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b)) + +instance (Typeable k, Typeable v) => GQLType (Map k v) where + type KIND (Map k v) = WRAPPER + +instance GQLType a => GQLType (Either s a) where + type KIND (Either s a) = WRAPPER + __typeName _ = __typeName (Proxy @a) + __typeFingerprint _ = __typeFingerprint (Proxy @a) + +instance GQLType a => GQLType (Resolver o e m a) where + type KIND (Resolver o e m a) = WRAPPER + __typeName _ = __typeName (Proxy @a) + __typeFingerprint _ = __typeFingerprint (Proxy @a) + +instance GQLType b => GQLType (a -> b) where + type KIND (a -> b) = WRAPPER + __typeName _ = __typeName (Proxy @b) + __typeFingerprint _ = __typeFingerprint (Proxy @b) diff --git a/src/Data/Morpheus/Server/Types/ID.hs b/src/Data/Morpheus/Server/Types/ID.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Types/ID.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Server.Types.ID + ( ID (..), + ) +where + +import qualified Data.Aeson as A +import Data.Morpheus.Kind (SCALAR) +import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..)) +import Data.Morpheus.Server.Types.GQLType (GQLType (..)) +import Data.Morpheus.Types.Internal.AST + ( ScalarValue (..), + internalFingerprint, + ) +import Data.Text + ( Text, + pack, + ) +import GHC.Generics (Generic) + +-- | default GraphQL type, +-- parses only 'String' and 'Int' values, +-- serialized always as 'String' +newtype ID = ID + { unpackID :: Text + } + deriving (Show, Generic) + +instance GQLType ID where + type KIND ID = SCALAR + __typeFingerprint _ = internalFingerprint "ID" [] + +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) + parseValue (String x) = return (ID x) + parseValue _ = Left "" + serialize (ID x) = String x diff --git a/src/Data/Morpheus/Server/Types/Types.hs b/src/Data/Morpheus/Server/Types/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Types/Types.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} + +module Data.Morpheus.Server.Types.Types + ( Undefined (..), + Pair (..), + MapKind (..), + MapArgs (..), + mapKindFromList, + ) +where + +import GHC.Generics (Generic) + +data Undefined (m :: * -> *) = Undefined deriving (Show, Generic) + +data Pair k v = Pair + { key :: k, + value :: v + } + deriving (Generic) + +newtype MapArgs k = MapArgs + { oneOf :: Maybe [k] + } + deriving (Generic) + +data MapKind k v m = MapKind + { size :: Int, + pairs :: MapArgs k -> m [Pair k v] + } + deriving (Generic) + +mapKindFromList :: (Eq k, Applicative m) => [(k, v)] -> MapKind k v m +mapKindFromList inputPairs = + MapKind + { size = length inputPairs, + pairs = resolvePairs + } + where + filterBy MapArgs {oneOf = Just list} = + filter ((`elem` list) . fst) inputPairs + filterBy _ = inputPairs + resolvePairs = pure . (map toGQLTuple . filterBy) + toGQLTuple (x, y) = Pair x y 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 @@ -1,104 +1,181 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + -- | GQL Types module Data.Morpheus.Types - ( Event(..) - -- Type Classes - , GQLType(KIND, description) - , GQLScalar(parseValue, serialize) - , GQLRequest(..) - , GQLResponse(..) - , ID(..) - , ScalarValue(..) - , GQLRootResolver(..) - , constRes - , constMutRes - , Undefined(..) - , Res - , MutRes - , SubRes - , IORes - , IOMutRes - , IOSubRes - , Resolver - , QUERY - , MUTATION - , SUBSCRIPTION - , lift - , liftEither - , ResolveQ - , ResolveM - , ResolveS - , failRes - , WithOperation - , publish - , subscribe - , unsafeInternalContext - , SubField - , Input - , Stream + ( Event (..), + GQLType (KIND, description, implements), + GQLScalar (parseValue, serialize), + GQLRequest (..), + GQLResponse (..), + ID (..), + ScalarValue (..), + GQLRootResolver (..), + constRes, + constMutRes, + Undefined (..), + Resolver, + QUERY, + MUTATION, + SUBSCRIPTION, + lift, + liftEither, + failRes, + WithOperation, + publish, + subscribe, + unsafeInternalContext, + Context (..), + SubField, + ComposedSubField, + Input, + Stream, + WS, + HTTP, + -- Resolvers + ResolverO, + ComposedResolver, + ResolverQ, + ResolverM, + ResolverS, + -- Resolvers Deprecated + ResolveQ, + ResolveM, + ResolveS, + Res, + MutRes, + SubRes, + IORes, + IOMutRes, + IOSubRes, + interface, ) where -import Data.Text ( pack ) -import Data.Either (either) -import Control.Monad.Trans.Class ( MonadTrans(..) ) - +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Either (either) -- MORPHEUS -import Data.Morpheus.Types.GQLScalar ( GQLScalar - ( parseValue - , serialize - ) - ) -import Data.Morpheus.Types.GQLType ( GQLType(KIND, description) ) -import Data.Morpheus.Types.ID ( ID(..) ) -import Data.Morpheus.Types.Internal.AST - ( MUTATION - , QUERY - , SUBSCRIPTION - , ScalarValue(..) - , Message - ) -import Data.Morpheus.Types.Internal.Resolving - ( Event(..) - , GQLRootResolver(..) - , Resolver - , WithOperation - , lift - , failure - , Failure - , pushEvents - , PushEvents(..) - , subscribe - , unsafeInternalContext - , UnSubResolver - ) -import Data.Morpheus.Types.IO ( GQLRequest(..) - , GQLResponse(..) - ) -import Data.Morpheus.Types.Types ( Undefined(..) ) -import Data.Morpheus.Types.Internal.Subscription - ( Stream - , Input - ) +import Data.Morpheus.Server.Deriving.Introspect (Introspect (..)) +import Data.Morpheus.Server.Types.GQLScalar + ( GQLScalar + ( parseValue, + serialize + ), + ) +import Data.Morpheus.Server.Types.GQLType (GQLType (..)) +import Data.Morpheus.Server.Types.ID (ID (..)) +import Data.Morpheus.Server.Types.Types (Undefined (..)) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + GQLResponse (..), + ) +import Data.Morpheus.Types.Internal.AST + ( MUTATION, + Message, + QUERY, + SUBSCRIPTION, + ScalarValue (..), + TypeName, + TypeUpdater, + msg, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Context (..), + Event (..), + Failure, + PushEvents (..), + Resolver, + UnSubResolver, + WithOperation, + failure, + lift, + pushEvents, + subscribe, + unsafeInternalContext, + ) +import Data.Morpheus.Types.Internal.Subscription + ( HTTP, + Input, + Stream, + WS, + ) +import Data.Proxy (Proxy (..)) + +class FlexibleResolver (f :: * -> *) (a :: k) where + type Flexible (m :: * -> *) a :: * + type Composed (m :: * -> *) f a :: * + +instance FlexibleResolver f (a :: *) where + type Flexible m a = m a + type Composed m f a = m (f a) + +instance FlexibleResolver f (a :: (* -> *) -> *) where + type Flexible m a = m (a m) + type Composed m f a = m (f (a m)) + +-- Recursive Resolvers +type ResolverO o e m a = + (WithOperation o) => + Flexible (Resolver o e m) a + +type ComposedResolver o e m f a = + (WithOperation o) => + Composed (Resolver o e m) f a + +type ResolverQ e m a = Flexible (Resolver QUERY e m) a + +type ResolverM e m a = Flexible (Resolver MUTATION e m) a + +type ResolverS e m a = Resolver SUBSCRIPTION e m (a (Resolver QUERY e m)) + +{-# DEPRECATED Res "use ResolverQ" #-} + type Res = Resolver QUERY + +{-# DEPRECATED MutRes "use ResolverM" #-} + type MutRes = Resolver MUTATION + +{-# DEPRECATED SubRes "use ResolverS" #-} + type SubRes = Resolver SUBSCRIPTION +{-# DEPRECATED IORes "use ResolverQ" #-} + type IORes e = Res e IO + +{-# DEPRECATED IOMutRes "use ResolverM" #-} + type IOMutRes e = MutRes e IO + +{-# DEPRECATED IOSubRes "use ResolverS" #-} + type IOSubRes e = SubRes e IO --- Recursive Resolvers -type ResolveQ e m a = Res e m (a (Res e m)) -type ResolveM e m a = MutRes e m (a (MutRes e m)) -type ResolveS e m a = SubRes e m (a (Res e m)) +{-# DEPRECATED ResolveQ "use ResolverQ" #-} +type ResolveQ e m a = ResolverQ e m a + +{-# DEPRECATED ResolveM "use ResolverM" #-} + +type ResolveM e m a = ResolverM e m a + +{-# DEPRECATED ResolveS "use ResolverS" #-} + +type ResolveS e m a = ResolverS e m a + -- Subsciption Object Resolver Fields -type SubField m a = (m (a (UnSubResolver m))) +type SubField m a = (m (a (UnSubResolver m))) +type ComposedSubField m f a = (m (f (a (UnSubResolver m)))) + publish :: Monad m => [e] -> Resolver MUTATION e m () publish = pushEvents @@ -106,13 +183,31 @@ constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b constRes = const . pure -constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a -constMutRes events value = const $ do - publish events +constMutRes :: Monad m => [e] -> a -> args -> ResolverM e m a +constMutRes events value = const $ do + publish events pure value -failRes :: (WithOperation o, Monad m) => String -> Resolver o e m a -failRes = failure . pack +{-# DEPRECATED failRes "use \"fail\" from \"MonadFail\"" #-} +failRes :: + ( Monad m, + WithOperation o + ) => + String -> + Resolver o e m a +failRes = fail liftEither :: (MonadTrans t, Monad (t m), Failure Message (t m)) => Monad m => m (Either String a) -> t m a -liftEither x = lift x >>= either (failure . pack) pure +liftEither x = lift x >>= either (failure . msg) pure + +-- | GraphQL Root resolver, also the interpreter generates a GQL schema from it. +-- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional, +-- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it. +data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *) = GQLRootResolver + { queryResolver :: query (Resolver QUERY event m), + mutationResolver :: mut (Resolver MUTATION event m), + subscriptionResolver :: sub (Resolver SUBSCRIPTION event m) + } + +interface :: (GQLType a, Introspect a) => Proxy a -> (TypeName, TypeUpdater) +interface x = (__typeName x, introspect x) diff --git a/src/Data/Morpheus/Types/GQLScalar.hs b/src/Data/Morpheus/Types/GQLScalar.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/GQLScalar.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Morpheus.Types.GQLScalar - ( GQLScalar(..) - , toScalar - ) -where - -import Data.Morpheus.Types.Internal.AST.Data - ( ScalarDefinition(..) ) -import Data.Morpheus.Types.Internal.AST - ( ScalarValue(..) - , ValidValue - , Value(..) - ) -import Data.Proxy ( Proxy(..) ) -import Data.Text ( Text ) - -toScalar :: ValidValue -> Either Text ScalarValue -toScalar (Scalar x) = pure x -toScalar _ = Left "" - --- | GraphQL Scalar --- --- 'parseValue' and 'serialize' should be provided for every instances manually -class GQLScalar a where - -- | value parsing and validating - -- - -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean' - -- - -- invalid values can be reported with 'Left' constructor : - -- - -- @ - -- parseValue String _ = Left "" -- without error message - -- -- or - -- parseValue String _ = Left "Error Message" - -- @ - -- - parseValue :: ScalarValue -> Either Text a - -- | serialization of haskell type into scalar value - serialize :: a -> ScalarValue - scalarValidator :: Proxy a -> ScalarDefinition - scalarValidator _ = ScalarDefinition {validateValue = validator} - where - validator value = do - scalarValue' <- toScalar value - (_ :: a) <- parseValue scalarValue' - return value - -instance GQLScalar Text where - parseValue (String x) = pure x - parseValue _ = Left "" - serialize = String - -instance GQLScalar Bool where - parseValue (Boolean x) = pure x - parseValue _ = Left "" - serialize = Boolean - -instance GQLScalar Int where - parseValue (Int x) = pure x - parseValue _ = Left "" - serialize = Int - -instance GQLScalar Float where - parseValue (Float x) = pure x - parseValue (Int x) = pure $ fromInteger $ toInteger x - parseValue _ = Left "" - serialize = Float diff --git a/src/Data/Morpheus/Types/GQLType.hs b/src/Data/Morpheus/Types/GQLType.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/GQLType.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Morpheus.Types.GQLType - ( GQLType(..) - , TRUE - , FALSE - ) -where - -import Data.Map ( Map ) -import Data.Proxy ( Proxy(..) ) -import Data.Set ( Set ) -import Data.Text ( Text - , intercalate - , pack - ) -import Data.Typeable ( TyCon - , TypeRep - , Typeable - , splitTyConApp - , tyConFingerprint - , tyConName - , typeRep - , typeRepTyCon - ) - --- MORPHEUS -import Data.Morpheus.Kind -import Data.Morpheus.Types.Types ( MapKind - , Pair - , Undefined(..) - ) -import Data.Morpheus.Types.Internal.AST - ( DataFingerprint(..) - , QUERY - ) -import Data.Morpheus.Types.Internal.Resolving - ( Resolver ) - -type TRUE = 'True - -type FALSE = 'False - -resolverCon :: TyCon -resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe) - --- | replaces typeName (A,B) with Pair_A_B -replacePairCon :: TyCon -> TyCon -replacePairCon x | hsPair == x = gqlPair - where - hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int) - gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int) -replacePairCon x = x - --- Ignores Resolver name from typeName -ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon] -ignoreResolver (con, _) | con == resolverCon = [] -ignoreResolver (con, args) = - con : concatMap (ignoreResolver . splitTyConApp) args - --- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. --- --- @ --- ... deriving (Generic, GQLType) --- @ --- --- if you want to add description --- --- @ --- ... deriving (Generic) --- --- instance GQLType ... where --- description = const "your description ..." --- @ - -class IsObject (a :: GQL_KIND) where - isObject :: Proxy a -> Bool - -instance IsObject SCALAR where - isObject _ = False - -instance IsObject ENUM where - isObject _ = False - -instance IsObject WRAPPER where - isObject _ = False - -instance IsObject INPUT where - isObject _ = True - -instance IsObject OUTPUT where - isObject _ = True - -class IsObject (KIND a) => GQLType a where - type KIND a :: GQL_KIND - type KIND a = OUTPUT - type CUSTOM a :: Bool - type CUSTOM a = FALSE - description :: Proxy a -> Maybe Text - description _ = Nothing - isObjectKind :: Proxy a -> Bool - isObjectKind _ = isObject (Proxy @(KIND a)) - __typeName :: Proxy a -> Text - default __typeName :: (Typeable a) => - Proxy a -> Text - __typeName _ = intercalate "_" (getName $ Proxy @a) - where - getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep) - __typeFingerprint :: Proxy a -> DataFingerprint - default __typeFingerprint :: (Typeable a) => - Proxy a -> DataFingerprint - __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a) - where - conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep) - -instance GQLType () where - type KIND () = WRAPPER - type CUSTOM () = 'False - -instance Typeable m => GQLType (Undefined m) where - type KIND (Undefined m) = WRAPPER - type CUSTOM (Undefined m) = 'False - -instance GQLType Int where - type KIND Int = SCALAR - -instance GQLType Float where - type KIND Float = SCALAR - -instance GQLType Text where - type KIND Text = SCALAR - __typeName = const "String" - -instance GQLType Bool where - type KIND Bool = SCALAR - __typeName = const "Boolean" - -instance GQLType a => GQLType (Maybe a) where - type KIND (Maybe a) = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) - - -instance GQLType a => GQLType [a] where - type KIND [a] = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) - -instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where - type KIND (a, b) = WRAPPER - __typeName _ = __typeName $ Proxy @(Pair a b) - -instance GQLType a => GQLType (Set a) where - type KIND (Set a) = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) - -instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where - type KIND (Pair a b) = OUTPUT - -instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where - type KIND (MapKind a b m) = OUTPUT - __typeName _ = __typeName (Proxy @(Map a b)) - __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b)) - -instance (Typeable k, Typeable v) => GQLType (Map k v) where - type KIND (Map k v) = WRAPPER - -instance GQLType a => GQLType (Either s a) where - type KIND (Either s a) = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) - -instance GQLType a => GQLType (Resolver o e m a) where - type KIND (Resolver o e m a) = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) - -instance GQLType b => GQLType (a -> b) where - type KIND (a -> b) = WRAPPER - __typeName _ = __typeName (Proxy @b) - __typeFingerprint _ = __typeFingerprint (Proxy @b) diff --git a/src/Data/Morpheus/Types/ID.hs b/src/Data/Morpheus/Types/ID.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/ID.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Morpheus.Types.ID - ( ID(..) - ) -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) ) -import Data.Morpheus.Types.Internal.AST - ( ScalarValue(..) ) -import Data.Text ( Text - , pack - ) -import GHC.Generics ( Generic ) - --- | default GraphQL type, --- parses only 'String' and 'Int' values, --- serialized always as 'String' -newtype ID = ID - { unpackID :: Text - } deriving (Show, Generic) - -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) - parseValue (String x) = return (ID x) - parseValue _ = Left "" - serialize (ID x) = String x diff --git a/src/Data/Morpheus/Types/IO.hs b/src/Data/Morpheus/Types/IO.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/IO.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# 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.Error.Utils ( badRequestError ) -import Data.Morpheus.Types.Internal.AST - ( Key - , GQLError(..) - , ValidValue - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( Result(..) - , Failure(..) - ) - - -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 - -instance FromJSON a => FromJSON (JSONResponse a) where - parseJSON = withObject "JSONResponse" objectParser - where objectParser o = JSONResponse <$> o .:? "data" <*> o .:? "errors" - -data JSONResponse a = JSONResponse - { responseData :: Maybe a - , responseErrors :: Maybe [GQLError] - } deriving (Generic, Show, ToJSON) - --- | GraphQL HTTP Request Body -data GQLRequest = GQLRequest - { query :: Key - , operationName :: Maybe Key - , variables :: Maybe Aeson.Value - } deriving (Show, Generic, FromJSON, ToJSON) - --- | GraphQL Response -data GQLResponse - = Data ValidValue - | Errors [GQLError] - deriving (Show, Generic) - -instance FromJSON GQLResponse where - parseJSON (Aeson.Object hm) = case LH.toList hm of - [("data" , value)] -> Data <$> parseJSON value - [("errors", value)] -> Errors <$> parseJSON value - _ -> fail "Invalid GraphQL Response" - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Types.Internal.AST - ( - -- BASE - Key - , Ref(..) - , Position(..) - , Message - , anonymousRef - , Name - , Description - , Stage - , RESOLVED - , VALID - , RAW - , VALIDATION_MODE(..) - - -- VALUE - , Value(..) - , ScalarValue(..) - , Object - , GQLValue(..) - , replaceValue - , decodeScientific - , convertToJSONName - , convertToHaskellName - , RawValue - , ValidValue - , RawObject - , ValidObject - , ResolvedObject - , ResolvedValue - , Named - , splitDuplicates - , removeDuplicates - -- Selection - , Argument(..) - , Arguments - , SelectionSet - , SelectionContent(..) - , Selection(..) - , Fragments - , Fragment(..) - , isOutputType - -- OPERATION - , Operation(..) - , Variable(..) - , VariableDefinitions - , DefaultValue - , getOperationName - , getOperationDataType - -- DSL - , ScalarDefinition(..) - , DataEnum - , FieldsDefinition(..) - , ArgumentDefinition - , DataUnion - , ArgumentsDefinition(..) - , FieldDefinition(..) - , InputFieldsDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , Schema(..) - , DataTypeWrapper(..) - , DataTypeKind(..) - , DataFingerprint(..) - , TypeWrapper(..) - , TypeRef(..) - , DataEnumValue(..) - , OperationType(..) - , QUERY - , MUTATION - , SUBSCRIPTION - , Meta(..) - , Directive(..) - , TypeUpdater - , TypeD(..) - , ConsD(..) - , ClientQuery(..) - , GQLTypeD(..) - , ClientType(..) - , DataInputUnion - , VariableContent(..) - , TypeLib - , isTypeDefined - , initTypeLib - , defineType - , isFieldNullable - , allDataTypes - , lookupDataType - , kindOf - , toNullableField - , toListField - , isObject - , isInput - , toHSWrappers - , isNullable - , toGQLWrapper - , isWeaker - , isSubscription - , isOutputObject - , sysTypes - , isDefaultTypeName - , isSchemaTypeName - , isPrimitiveTypeName - , isEntNode - , createField - , createArgument - , createDataTypeLib - , createEnumType - , createScalarType - , createType - , createUnionType - , createAlias - , createInputUnionFields - , fieldVisibility - , createEnumValue - , insertType - , lookupDeprecated - , lookupDeprecatedReason - , 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 ) - --- Morpheus -import Data.Morpheus.Types.Internal.AST.Base -import Data.Morpheus.Types.Internal.AST.Value -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 :: Fragments - , operation :: Operation RAW - , inputVariables :: [(Key, ResolvedValue)] - } deriving (Show,Lift) diff --git a/src/Data/Morpheus/Types/Internal/AST/Base.hs b/src/Data/Morpheus/Types/Internal/AST/Base.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/Base.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Data.Morpheus.Types.Internal.AST.Base - ( Key - , Ref(..) - , Position(..) - , Message - , Name - , Named - , Description - , VALID - , RAW - , TypeWrapper(..) - , Stage(..) - , RESOLVED - , TypeRef(..) - , 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 () - - -type Key = Text -type Message = Text -type Name = Key -type Description = Key -data Stage = RAW | RESOLVED | VALID - -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 GQLError = GQLError - { message :: Message - , locations :: [Position] - } deriving ( Show, Generic, FromJSON, ToJSON) - -type GQLErrors = [GQLError] - - -type RAW = 'RAW -type RESOLVED = 'RESOLVED -type VALID = 'VALID - -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 --- -data Ref = Ref - { refName :: Key - , refPosition :: Position - } deriving (Show,Lift, Eq) - -instance Ord Ref where - compare (Ref x _) (Ref y _) = compare x y - -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) - -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 - -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] = [] - -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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/Data.hs +++ /dev/null @@ -1,592 +0,0 @@ -{-# 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 - ( Arguments - , ScalarDefinition(..) - , DataEnum - , FieldsDefinition(..) - , ArgumentDefinition - , DataUnion - , ArgumentsDefinition(..) - , FieldDefinition(..) - , InputFieldsDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , Schema(..) - , DataEnumValue(..) - , TypeLib - , Meta(..) - , Directive(..) - , TypeUpdater - , TypeD(..) - , ConsD(..) - , ClientQuery(..) - , GQLTypeD(..) - , ClientType(..) - , DataInputUnion - , Argument(..) - , allDataTypes - , createField - , createArgument - , createDataTypeLib - , createEnumType - , createScalarType - , createType - , createUnionType - , createAlias - , createInputUnionFields - , createEnumValue - , defineType - , isTypeDefined - , initTypeLib - , isFieldNullable - , insertType - , fieldVisibility - , kindOf - , toNullableField - , toListField - , toHSFieldDefinition - , isEntNode - , lookupDataType - , lookupDeprecated - , lookupDeprecatedReason - , lookupWith - , hasArguments - , unsafeFromFields - , isInputDataType - , unsafeFromInputFields - , __inputname - ) -where - -import Data.HashMap.Lazy ( HashMap - , union - , elems - ) -import qualified Data.HashMap.Lazy as HM -import Data.Semigroup ( Semigroup(..), (<>) ) -import Language.Haskell.TH.Syntax ( Lift(..) ) -import Instances.TH.Lift ( ) -import Data.List ( find) - --- MORPHEUS -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(..) - , 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 - ( Failure(..) - , LibUpdater - , resolveUpdates - ) -import Data.Morpheus.Types.Internal.AST.Value - ( Value(..) - , ValidValue - , ScalarValue(..) - ) -import Data.Morpheus.Error.Schema ( nameCollisionError ) - - -type DataEnum = [DataEnumValue] -type DataUnion = [Key] -type DataInputUnion = [(Key, Bool)] - --- scalar ------------------------------------------------------------------- -newtype ScalarDefinition = ScalarDefinition - { validateValue :: ValidValue -> Either Key ValidValue } - -instance Show ScalarDefinition where - show _ = "ScalarDefinition" - -data Argument (valid :: Stage) = Argument - { argumentName :: Name - , argumentValue :: Value valid - , argumentPosition :: Position - } deriving ( Show, Eq, Lift ) - - -instance KeyOf (Argument stage) where - keyOf = argumentName - -instance NameCollision (Argument s) where - nameCollision _ Argument { argumentName, argumentPosition } - = GQLError - { message = "There can Be only One Argument Named \"" <> argumentName <> "\"", - locations = [argumentPosition] - } - -type Arguments s = OrderedMap (Argument s) - --- directive ------------------------------------------------------------------- -data Directive = Directive { - directiveName :: Name, - directiveArgs :: OrderedMap (Argument VALID) -} deriving (Show,Lift) - -lookupDeprecated :: Meta -> Maybe Directive -lookupDeprecated Meta { metaDirectives } = find isDeprecation metaDirectives - where - isDeprecation Directive { directiveName = "deprecated" } = True - isDeprecation _ = False - -lookupDeprecatedReason :: Directive -> Maybe Key -lookupDeprecatedReason Directive { directiveArgs } = - selectOr Nothing (Just . maybeString) "reason" directiveArgs - where - maybeString :: Argument VALID -> Name - maybeString Argument { argumentValue = (Scalar (String x)) } = x - maybeString _ = "can't read deprecated Reason Value" - --- 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) - --- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema ---------------------------------------------------------------------------- --- SchemaDefinition : --- schema Directives[Const](opt) { RootOperationTypeDefinition(list)} --- --- RootOperationTypeDefinition : --- OperationType: NamedType - -data Schema = Schema - { types :: TypeLib - , query :: TypeDefinition - , mutation :: Maybe TypeDefinition - , subscription :: Maybe TypeDefinition - } deriving (Show) - -type TypeLib = HashMap Key TypeDefinition - -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 - } - - -allDataTypes :: Schema -> [TypeDefinition] -allDataTypes = elems . typeRegister - -typeRegister :: Schema -> TypeLib -typeRegister Schema { types, query, mutation, subscription } = - types `union` HM.fromList - (concatMap fromOperation [Just query, mutation, subscription]) - -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} - - --- 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 :: TypeContent - } deriving (Show) - -data TypeContent - = DataScalar { dataScalar :: ScalarDefinition - } - | DataEnum { enumMembers :: DataEnum - } - | DataInputObject { inputObjectFields :: InputFieldsDefinition - } - | DataObject { objectImplements :: [Name], - objectFields :: FieldsDefinition - } - | DataUnion { unionMembers :: DataUnion - } - | DataInputUnion { inputUnionMembers :: [(Key,Bool)] - } - | DataInterface { interfaceFields :: FieldsDefinition - } - deriving (Show) - -createType :: Key -> TypeContent -> TypeDefinition -createType typeName typeContent = TypeDefinition - { typeName - , typeMeta = Nothing - , typeFingerprint = DataFingerprint typeName [] - , typeContent - } - -createScalarType :: Name -> TypeDefinition -createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) - -createEnumType :: Name -> [Key] -> TypeDefinition -createEnumType typeName typeData = createType typeName (DataEnum enumValues) - where enumValues = map createEnumValue typeData - -createEnumValue :: Name -> DataEnumValue -createEnumValue enumName = DataEnumValue { enumName, enumMeta = Nothing } - -createUnionType :: Key -> [Key] -> TypeDefinition -createUnionType typeName typeData = createType typeName (DataUnion typeData) - -isEntNode :: TypeContent -> Bool -isEntNode DataScalar{} = True -isEntNode DataEnum{} = True -isEntNode _ = False - -isInputDataType :: TypeDefinition -> Bool -isInputDataType TypeDefinition { typeContent } = __isInput typeContent - where - __isInput DataScalar{} = True - __isInput DataEnum{} = True - __isInput DataInputObject{} = True - __isInput DataInputUnion{} = True - __isInput _ = False - -kindOf :: TypeDefinition -> DataTypeKind -kindOf TypeDefinition { typeName, typeContent } = __kind typeContent - where - __kind DataScalar {} = KindScalar - __kind DataEnum {} = KindEnum - __kind DataInputObject {} = KindInputObject - __kind DataObject {} = KindObject (toOperationType typeName) - __kind DataUnion {} = KindUnion - __kind DataInputUnion {} = KindInputUnion - -- TODO: - -- __kind DataInterface {} = KindInterface - -fromOperation :: Maybe TypeDefinition -> [(Name, TypeDefinition)] -fromOperation (Just datatype) = [(typeName datatype,datatype)] -fromOperation Nothing = [] - -lookupDataType :: Key -> Schema -> Maybe TypeDefinition -lookupDataType name = HM.lookup name . typeRegister - -isTypeDefined :: Key -> Schema -> Maybe DataFingerprint -isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib - -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) } - -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 - -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) - --- 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) } --- - -newtype FieldsDefinition = FieldsDefinition - { unFieldsDefinition :: OrderedMap FieldDefinition } - deriving (Show, Empty) - -unsafeFromFields :: [FieldDefinition] -> FieldsDefinition -unsafeFromFields = FieldsDefinition . unsafeFromValues - -instance Merge FieldsDefinition where - merge path (FieldsDefinition x) (FieldsDefinition y) = FieldsDefinition <$> merge path x y - -instance Selectable FieldsDefinition FieldDefinition where - selectOr fb f name (FieldsDefinition lib) = selectOr fb f name lib - -instance Singleton FieldsDefinition FieldDefinition where - singleton = FieldsDefinition . singleton - -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) - -instance KeyOf FieldDefinition where - keyOf = fieldName - -instance Selectable FieldDefinition ArgumentDefinition where - selectOr fb f key FieldDefinition { fieldArgs } = selectOr fb f key fieldArgs - -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 - 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 - } - | NoArguments - deriving (Show, Lift) - -type ArgumentDefinition = FieldDefinition - - -instance Selectable ArgumentsDefinition ArgumentDefinition where - selectOr fb _ _ NoArguments = fb - selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args - -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 - -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 = FieldDefinition - { fieldName = __inputname - , fieldArgs = NoArguments - , fieldType = createAlias (name <> "Tags") - , fieldMeta = Nothing - } - unionField memberName = FieldDefinition - { fieldArgs = NoArguments - , fieldName = memberName - , fieldType = TypeRef { typeConName = memberName - , typeWrappers = [TypeMaybe] - , typeArgs = Nothing - } - , fieldMeta = Nothing - } --- --- OTHER --------------------------------------------------------------------------------------------------- - -createAlias :: Key -> TypeRef -createAlias typeConName = - TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing } - -type TypeUpdater = LibUpdater Schema - --- TEMPLATE HASKELL DATA TYPES -data ClientQuery = ClientQuery - { queryText :: String - , queryTypes :: [ClientType] - , queryArgsType :: Maybe TypeD - } deriving (Show) - -data ClientType = ClientType { - clientType :: TypeD, - clientKind :: DataTypeKind -} deriving (Show) - --- Document -data GQLTypeD = GQLTypeD - { typeD :: TypeD - , typeKindD :: DataTypeKind - , typeArgD :: [TypeD] - , typeOriginal:: TypeDefinition - } deriving (Show) - -data TypeD = TypeD - { tName :: Name - , tNamespace :: [Name] - , tCons :: [ConsD] - , tMeta :: Maybe Meta - } deriving (Show) - -data ConsD = ConsD - { cName :: Name - , cFields :: [FieldDefinition] - } deriving (Show) diff --git a/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs b/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/Selection.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Data.Morpheus.Types.Internal.AST.Selection - ( Selection(..) - , SelectionContent(..) - , SelectionSet - , UnionTag(..) - , UnionSelection - , Fragment(..) - , Fragments - , Operation(..) - , Variable(..) - , VariableDefinitions - , DefaultValue - , getOperationName - , getOperationDataType - ) -where - - -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.Operation ( mutationIsNotDefined - , subscriptionIsNotDefined - ) -import Data.Morpheus.Types.Internal.AST.Base - ( Key - , Position - , Ref(..) - , Name - , VALID - , RAW - , Stage - , OperationType(..) - , GQLError(..) - , GQLErrors - , Message - ) -import Data.Morpheus.Types.Internal.AST.Data - ( Schema(..) - , TypeDefinition(..) - , Arguments - ) -import Data.Morpheus.Types.Internal.AST.Value - ( 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 - { fragmentName :: Name - , fragmentType :: Name - , fragmentPosition :: Position - , fragmentSelection :: SelectionSet RAW - } deriving ( Show, Eq, Lift) - --- ERRORs -instance NameCollision Fragment where - nameCollision _ Fragment { fragmentName , fragmentPosition } = GQLError - { message = "There can be only one fragment named \"" <> fragmentName <> "\"." - , locations = [fragmentPosition] - } - -instance KeyOf Fragment where - keyOf = fragmentName - -type Fragments = OrderedMap Fragment - -data SelectionContent (s :: Stage) where - SelectionField :: SelectionContent s - SelectionSet :: SelectionSet s -> SelectionContent s - UnionSelection :: UnionSelection -> SelectionContent VALID - -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 - } - ] - -deriving instance Show (SelectionContent a) -deriving instance Eq (SelectionContent a) -deriving instance Lift (SelectionContent a) - -data UnionTag = UnionTag { - unionTagName :: Name, - unionTagSelection :: SelectionSet VALID -} deriving (Show, Eq, Lift) - - -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 - -instance Merge UnionTag where - merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) - = UnionTag oldTag <$> merge path oldSel currentSel - -instance KeyOf UnionTag where - keyOf = unionTagName - -type UnionSelection = MergeSet UnionTag - -type SelectionSet s = MergeSet (Selection s) - -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 - -instance KeyOf (Selection s) where - keyOf Selection { selectionName , selectionAlias } = fromMaybe selectionName selectionAlias - keyOf InlineFragment {} = "" - keyOf Spread {} = "" - -useDufferentAliases :: Message -useDufferentAliases - = "Use different aliases on the " - <> "fields to fetch both if this was intentional." - -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) - -type DefaultValue = Maybe ResolvedValue - -data Operation (s:: Stage) = Operation - { operationName :: Maybe Key - , operationType :: OperationType - , operationArguments :: VariableDefinitions s - , operationSelection :: SelectionSet s - , operationPosition :: Position - } deriving (Show,Lift) - -getOperationName :: Maybe Key -> Key -getOperationName = fromMaybe "AnonymousOperation" - -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 x -> pure x - Nothing -> failure $ mutationIsNotDefined operationPosition -getOperationDataType Operation { operationType = Subscription, operationPosition } lib - = case subscription lib of - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/Value.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Morpheus.Types.Internal.AST.Value - ( Value(..) - , ScalarValue(..) - , Object - , GQLValue(..) - , replaceValue - , decodeScientific - , convertToJSONName - , convertToHaskellName - , RawValue - , ValidValue - , RawObject - , ValidObject - , Variable(..) - , ResolvedValue - , ResolvedObject - , VariableContent(..) - , ObjectEntry(..) - , VariableDefinitions - ) -where - -import qualified Data.Aeson as A - ( FromJSON(..) - , ToJSON(..) - , Value(..) - , object - , pairs - , (.=) - ) -import qualified Data.HashMap.Strict as M - ( toList ) -import Data.Scientific ( Scientific - , floatingOrInteger - ) -import Data.Semigroup ( (<>) ) -import Data.Text ( Text - , unpack - ) -import qualified Data.Text as T -import qualified Data.Vector as V - ( toList ) -import GHC.Generics ( Generic ) -import Instances.TH.Lift ( ) -import Language.Haskell.TH.Syntax ( Lift(..) ) - --- MORPHEUS -import Data.Morpheus.Error.NameCollision - ( NameCollision(..) ) -import Data.Morpheus.Types.Internal.AST.Base - ( Ref(..) - , Name - , RAW - , VALID - , Position - , 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 -isReserved "class" = True -isReserved "data" = True -isReserved "default" = True -isReserved "deriving" = True -isReserved "do" = True -isReserved "else" = True -isReserved "foreign" = True -isReserved "if" = True -isReserved "import" = True -isReserved "in" = True -isReserved "infix" = True -isReserved "infixl" = True -isReserved "infixr" = True -isReserved "instance" = True -isReserved "let" = True -isReserved "module" = True -isReserved "newtype" = True -isReserved "of" = True -isReserved "then" = True -isReserved "type" = True -isReserved "where" = True -isReserved "_" = True -isReserved _ = False - -{-# INLINE isReserved #-} -convertToJSONName :: Text -> Text -convertToJSONName hsName - | not (T.null hsName) && isReserved name && (T.last hsName == '\'') = name - | otherwise = hsName - where name = T.init hsName - -convertToHaskellName :: Text -> Text -convertToHaskellName name | isReserved name = name <> "'" - | otherwise = name - --- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'. --- for performance reason type 'Text' represents GraphQl 'String' value -data ScalarValue - = Int Int - | Float Float - | String Text - | Boolean Bool - deriving (Show, Eq, Generic,Lift) - -instance A.ToJSON ScalarValue where - toJSON (Float x) = A.toJSON x - toJSON (Int x) = A.toJSON x - toJSON (Boolean x) = A.toJSON x - toJSON (String x) = A.toJSON x - -instance A.FromJSON ScalarValue where - parseJSON (A.Bool v) = pure $ Boolean v - parseJSON (A.Number v) = pure $ decodeScientific v - parseJSON (A.String v) = pure $ String v - parseJSON notScalar = fail $ "Expected Scalar got :" <> show notScalar - -type family VAR (a:: Stage) :: Stage -type instance VAR RAW = RESOLVED -type instance VAR RESOLVED = RESOLVED -type instance VAR VALID = VALID - -data VariableContent (stage:: Stage) where - DefaultValue ::Maybe ResolvedValue -> VariableContent RESOLVED - ValidVariableValue ::{ validVarContent::ValidValue }-> VariableContent VALID - -instance Lift (VariableContent a) where - lift (DefaultValue x) = [| DefaultValue x |] - lift (ValidVariableValue x) = [| ValidVariableValue x |] - -deriving instance Show (VariableContent a) -deriving instance Eq (VariableContent a) - -data Variable (stage :: Stage) = Variable - { variableName :: Name - , variableType :: TypeRef - , variablePosition :: Position - , variableValue :: VariableContent (VAR stage) - } deriving (Show, Eq, Lift) - -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 stage -> Value stage - List ::[Value stage] -> Value stage - Enum ::Name -> Value stage - Scalar ::ScalarValue -> Value stage - Null ::Value stage - -deriving instance Eq (Value s) - -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 -type RawValue = Value RAW -type ValidValue = Value VALID -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 - show (Scalar x) = show x - show (ResolvedVariable Ref { refName } Variable { variableValue }) = - "($" <> unpack refName <> ": " <> show variableValue <> ") " - show (VariableValue Ref { refName }) = "$" <> unpack refName <> " " - show (Object keys ) = "{" <> foldWithKey toEntry "" keys <> "}" - where - 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 - toEntry "" value = show value - toEntry txt value = txt <> ", " <> show value - -instance A.ToJSON (Value a) where - toJSON (ResolvedVariable _ Variable { variableValue = ValidVariableValue x }) - = A.toJSON x - toJSON (VariableValue Ref { refName }) = - A.String $ "($ref:" <> refName <> ")" - toJSON Null = A.Null - toJSON (Enum x ) = A.String x - toJSON (Scalar x ) = A.toJSON x - toJSON (List x ) = A.toJSON x - toJSON (Object fields) = A.object $ map toEntry (toList fields) - where toEntry (ObjectEntry key value) = key A..= A.toJSON value - ------------------------------------------- - toEncoding (ResolvedVariable _ Variable { variableValue = ValidVariableValue x }) - = A.toEncoding x - toEncoding (VariableValue Ref { refName }) = - A.toEncoding $ "($ref:" <> refName <> ")" - toEncoding Null = A.toEncoding A.Null - toEncoding (Enum x ) = A.toEncoding x - toEncoding (Scalar x ) = A.toEncoding x - toEncoding (List x ) = A.toEncoding x - 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 - Left float -> Float float - Right int -> Int int - -replaceValue :: A.Value -> Value a -replaceValue (A.Bool v) = gqlBoolean v -replaceValue (A.Number v) = Scalar $ decodeScientific v -replaceValue (A.String v) = gqlString v -replaceValue (A.Object v) = gqlObject $ map replace (M.toList v) - where - --replace :: (a, A.Value) -> (a, Value a) - replace (key, val) = (key, replaceValue val) -replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li)) -replaceValue A.Null = gqlNull - -instance A.FromJSON (Value a) where - parseJSON = pure . replaceValue - --- DEFAULT VALUES -class GQLValue a where - gqlNull :: a - gqlScalar :: ScalarValue -> a - gqlBoolean :: Bool -> a - gqlString :: Text -> a - gqlList :: [a] -> a - gqlObject :: [(Name, a)] -> a - --- build GQL Values for Subscription Resolver -instance GQLValue (Value a) where - gqlNull = Null - gqlScalar = Scalar - gqlBoolean = Scalar . Boolean - gqlString = Scalar . String - gqlList = List - gqlObject = Object . unsafeFromValues . map toEntry - where - toEntry (key,value) = ObjectEntry key value diff --git a/src/Data/Morpheus/Types/Internal/Operation.hs b/src/Data/Morpheus/Types/Internal/Operation.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Operation.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Resolving.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Data.Morpheus.Types.Internal.Resolving - ( Event(..) - , GQLRootResolver(..) - , UnSubResolver - , Resolver - , MapStrategy(..) - , LiftOperation - , runResolverModel - , toResolver - , lift - , SubEvent - , Eventless - , Failure(..) - , GQLChannel(..) - , ResponseEvent(..) - , ResponseStream - , cleanEvents - , Result(..) - , ResultT(..) - , unpackEvents - , LibUpdater - , resolveUpdates - , setTypeName - , ObjectDeriving(..) - , Deriving(..) - , FieldRes - , WithOperation - , PushEvents(..) - , subscribe - , Context(..) - , unsafeInternalContext - , ResolverModel(..) - , unsafeBind - , liftStateless - ) -where - -import Data.Morpheus.Types.Internal.Resolving.Resolver -import Data.Morpheus.Types.Internal.Resolving.Core diff --git a/src/Data/Morpheus/Types/Internal/Resolving/Core.hs b/src/Data/Morpheus/Types/Internal/Resolving/Core.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Resolving/Core.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -module Data.Morpheus.Types.Internal.Resolving.Core - ( Eventless - , Result(..) - , Failure(..) - , ResultT(..) - , unpackEvents - , LibUpdater - , resolveUpdates - , mapEvent - , cleanEvents - , Event(..) - , Channel(..) - , GQLChannel(..) - , PushEvents(..) - , statelessToResultT - ) -where - -import Control.Monad ( foldM ) -import Data.Function ( (&) ) -import Control.Monad.Trans.Class ( MonadTrans(..) ) -import Control.Applicative ( liftA2 ) -import Data.Morpheus.Types.Internal.Operation - ( - Failure(..) - ) -import Data.Morpheus.Types.Internal.AST.Base - ( GQLErrors - , GQLError(..) - ) -import Data.Text ( Text - , pack - ) -import Data.Semigroup ( (<>) ) - - -type Eventless = Result () - --- EVENTS -class PushEvents e m where - pushEvents :: [e] -> m () - --- Channel -newtype Channel event = Channel { - _unChannel :: StreamChannel event -} - -instance (Eq (StreamChannel event)) => Eq (Channel event) where - Channel x == Channel y = x == y - -class GQLChannel a where - type StreamChannel a :: * - streamChannels :: a -> [Channel a] - -instance GQLChannel () where - type StreamChannel () = () - streamChannels _ = [] - -instance GQLChannel (Event channel content) where - type StreamChannel (Event channel content) = channel - streamChannels Event { channels } = map Channel channels - -data Event e c = Event - { channels :: [e], content :: c} - - -unpackEvents :: Result event a -> [event] -unpackEvents Success { events } = events -unpackEvents _ = [] - --- --- Result --- --- -data Result events a - = Success { result :: a , warnings :: GQLErrors , events:: [events] } - | Failure { errors :: GQLErrors } deriving (Functor) - -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) 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 [GQLError] (Result ev) where - failure = Failure - -instance Failure Text Eventless where - failure text = - Failure [GQLError { message = "INTERNAL: " <> text, locations = [] }] - -instance PushEvents events (Result events) where - pushEvents events = Success { result = (), warnings = [], events } - --- ResultT -newtype ResultT event (m :: * -> * ) a - = ResultT - { - runResultT :: m (Result event a) - } - deriving (Functor) - -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 m) where - return = pure - (ResultT m1) >>= mFunc = ResultT $ do - result1 <- m1 - case result1 of - Failure errors -> pure $ Failure errors - Success value1 w1 e1 -> do - result2 <- runResultT (mFunc value1) - case result2 of - Failure errors -> pure $ Failure (errors <> w1) - Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2) - -instance MonadTrans (ResultT event) where - lift = ResultT . fmap pure - -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 m) where - failure = ResultT . pure . failure - -instance Applicative m => PushEvents event (ResultT event m) where - pushEvents = ResultT . pure . pushEvents - -cleanEvents - :: Functor m - => ResultT e m a - -> ResultT e' m a -cleanEvents resT = ResultT $ replace <$> runResultT resT - where - replace (Success v w _) = Success v w [] - replace (Failure e ) = Failure e - -mapEvent - :: Monad m - => (e -> e') - -> ResultT e m value - -> ResultT e' m value -mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma - where - mapEv Success { result, warnings, events } = - Success { result, warnings, events = map func events } - mapEv (Failure err) = Failure err - --- Helper Functions -type LibUpdater lib = lib -> Eventless 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +++ /dev/null @@ -1,571 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Data.Morpheus.Types.Internal.Resolving.Resolver - ( Event(..) - , GQLRootResolver(..) - , UnSubResolver - , Resolver - , MapStrategy(..) - , LiftOperation - , unsafeBind - , toResolver - , lift - , subscribe - , SubEvent - , GQLChannel(..) - , ResponseEvent(..) - , ResponseStream - , ObjectDeriving(..) - , Deriving(..) - , FieldRes - , WithOperation - , 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 ( maybe ) -import Data.Semigroup ( (<>) - , Semigroup(..) - ) -import Control.Monad.Trans.Reader (ReaderT(..), ask,mapReaderT, withReaderT) -import Data.Text (pack) - --- MORPHEUS -import Data.Morpheus.Error.Internal ( internalResolvingError ) -import Data.Morpheus.Error.Selection ( subfieldsNotSelected ) -import Data.Morpheus.Types.Internal.AST.Selection - ( Selection(..) - , SelectionContent(..) - , SelectionSet - , UnionTag(..) - , UnionSelection - , Operation(..) - ) -import Data.Morpheus.Types.Internal.AST.Base - ( Message - , Name - , OperationType - , QUERY - , MUTATION - , SUBSCRIPTION - , 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 - ( Eventless - , Result(..) - , Failure(..) - , ResultT(..) - , cleanEvents - , mapEvent - , Event(..) - , Channel(..) - , StreamChannel - , GQLChannel(..) - , PushEvents(..) - , statelessToResultT - ) -import Data.Morpheus.Types.Internal.AST.Value - ( GQLValue(..) - , ValidValue - , ObjectEntry(..) - , Value(..) - , ScalarValue(..) - ) -import Data.Morpheus.Types.IO ( renderResponse - , GQLResponse - ) - -type WithOperation (o :: OperationType) = LiftOperation o - -type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m - -data ResponseEvent event (m :: * -> *) - = Publish event - | Subscribe (SubEvent event m) - -type SubEvent event m = Event (Channel event) (event -> m GQLResponse) - -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 m) a - } - deriving - ( Functor - , Applicative - , Monad - ) - -instance Monad m => MonadFail (ResolverState event m) where - fail = failure . pack - -instance MonadTrans (ResolverState e) where - lift = ResolverState . lift . lift - -instance (Monad m) => Failure Message (ResolverState e m) where - failure message = ResolverState $ do - selection <- currentSelection <$> ask - lift $ failure [resolverFailureMessage selection message] - -instance (Monad m) => Failure GQLErrors (ResolverState e m) where - failure = ResolverState . lift . failure - -instance (Monad m) => PushEvents e (ResolverState e m) where - pushEvents = ResolverState . lift . pushEvents - -mapResolverState :: - ( 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 (Selection VALID) -getState = ResolverState $ currentSelection <$> ask - -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 e m a -> ResolverState e' m a -clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents) - -resolverFailureMessage :: Selection VALID -> Message -> GQLError -resolverFailureMessage Selection { selectionName, selectionPosition } message = GQLError - { message = "Failure on Resolving Field \"" <> selectionName <> "\": " <> message - , locations = [selectionPosition] - } - --- --- GraphQL Field Resolver --- ---------------------------------------------------------------- -data Resolver (o::OperationType) event (m :: * -> * ) value where - ResolverQ :: { runResolverQ :: ResolverState () m value } -> Resolver QUERY event m value - 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 -instance (LiftOperation o ,Monad m) => Applicative (Resolver o e m) where - pure = packResolver . pure - ResolverQ r1 <*> ResolverQ r2 = ResolverQ $ r1 <*> r2 - ResolverM r1 <*> ResolverM r2 = ResolverM $ r1 <*> r2 - ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2 - --- Monad -instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where - return = pure - (>>=) = unsafeBind - --- MonadIO -instance (MonadIO m) => MonadIO (Resolver QUERY e m) where - liftIO = lift . liftIO - -instance (MonadIO m) => MonadIO (Resolver MUTATION e m) where - liftIO = lift . liftIO - --- Monad Transformers -instance MonadTrans (Resolver QUERY e) where - lift = packResolver . lift - -instance MonadTrans (Resolver MUTATION e) where - lift = packResolver . lift - --- Failure -instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where - 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 - -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 - --- packResolver -instance LiftOperation QUERY where - packResolver = ResolverQ . clearStateResolverEvents - withResolver ctxRes toRes = ResolverQ $ do - v <- clearStateResolverEvents ctxRes - runResolverQ $ toRes v - -instance LiftOperation MUTATION where - packResolver = ResolverM - withResolver ctxRes toRes = ResolverM $ ctxRes >>= runResolverM . toRes - -instance LiftOperation SUBSCRIPTION where - packResolver = ResolverS . pure . lift . packResolver - withResolver ctxRes toRes = ResolverS $ do - value <- clearStateResolverEvents ctxRes - runResolverS $ toRes value - - -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 $ 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 --- channel does it want to listen -unsafeBind - :: forall o e m a b - . Monad m - => Resolver o e m a - -> (a -> Resolver o e m b) - -> Resolver o e m b -unsafeBind (ResolverQ x) m2 = ResolverQ (x >>= runResolverQ . m2) -unsafeBind (ResolverM x) m2 = ResolverM (x >>= runResolverM . m2) -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 - (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 ch res = ResolverS $ do - pushEvents (map Channel ch :: [Channel e]) - (eventRes :: e -> Resolver QUERY e m a) <- clearStateResolverEvents (runResolverQ res) - pure $ ReaderT eventRes - -unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m Context -unsafeInternalContext = packResolver $ ResolverState ask - --- Converts Subscription Resolver Type to Query Resolver -type family UnSubResolver (a :: * -> * ) :: (* -> *) -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 (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 . 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 -toResolver - :: forall o e m a b. (LiftOperation o, Monad m) - => (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 - let resT = ResultT $ pure $ toArgs selectionArguments - ResolverState $ lift $ cleanEvents resT - --- DataResolver -type FieldRes o e m - = (Name, Resolver o e m (Deriving o e m)) - -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" - -instance Merge (ObjectDeriving o e m) where - merge _ (ObjectDeriving tyname x) (ObjectDeriving _ y) - = pure $ ObjectDeriving tyname (x <> y) - - -pickSelection :: Name -> UnionSelection -> SelectionSet VALID -pickSelection = selectOr empty unionTagSelection - -withObject - :: (LiftOperation o, Monad m) - => (SelectionSet VALID -> Resolver o e m value) - -> Selection VALID - -> Resolver o e m value -withObject f Selection { selectionName, selectionContent , selectionPosition } = checkContent selectionContent - where - checkContent (SelectionSet selection) = f selection - checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition) - -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) - => SelectionSet VALID - -> Deriving o e m - -> Resolver o e m ValidValue -resolveObject selectionSet (DerivingObject drv@ObjectDeriving { __typename }) = - Object . toOrderedMap <$> traverse resolver selectionSet - where - 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 (ReaderT subRes) sel event = do - value <- runResultT $ runReaderT (runResolverState $ runResolverQ (subRes event)) sel - pure $ renderResponse value - - -runDataResolver :: (Monad m, LiftOperation o) => Deriving o e m -> Resolver o e m ValidValue -runDataResolver = withResolver getState . __encode - where - __encode obj sel@Selection { selectionContent } = encodeNode obj selectionContent - where - -- LIST - encodeNode (DerivingList x) _ = List <$> traverse runDataResolver x - -- Object ----------------- - 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 - => Resolver o event m ValidValue - -> 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 (ResolverS resT) sel = ResultT $ do - (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 - let eventRes = toEventResolver result sel - Success { - events = [Subscribe $ Event channels eventRes], - warnings, - 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, --- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it. -data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> * ) (mut :: (* -> *) -> * ) (sub :: (* -> *) -> * ) = GQLRootResolver - { queryResolver :: query (Resolver QUERY event m) - , 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 --- a/src/Data/Morpheus/Types/Internal/Subscription.hs +++ b/src/Data/Morpheus/Types/Internal/Subscription.hs @@ -1,72 +1,87 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Subscription - ( connectionThread - , toOutStream - , runStreamWS - , runStreamHTTP - , Stream - , Scope(..) - , Input(..) - , WS - , HTTP - , acceptApolloRequest - , publish - , Store(..) - , initDefaultStore - , publishEventWith + ( connect, + disconnect, + connectionThread, + toOutStream, + runStreamWS, + runStreamHTTP, + Stream, + Scope (..), + Input (..), + WS, + HTTP, + acceptApolloRequest, + publish, + Store (..), + initDefaultStore, + publishEventWith, + GQLChannel (..), + ClientConnectionStore, + empty, + toList, + connectionSessionIds, + SessionID, ) where +import Control.Concurrent + ( modifyMVar_, + newMVar, + readMVar, + ) +import Control.Exception (finally) +import Control.Monad (forever) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Unlift + ( MonadUnliftIO, + withRunInIO, + ) +-- MORPHEUS -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 - ) +import Data.Morpheus.Internal.Utils + ( empty, + ) +import Data.Morpheus.Types.Internal.Resolving + ( GQLChannel (..), + ) +import Data.Morpheus.Types.Internal.Subscription.Apollo + ( acceptApolloRequest, + ) +import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore + ( ClientConnectionStore, + SessionID, + connectionSessionIds, + delete, + publish, + toList, + ) +import Data.Morpheus.Types.Internal.Subscription.Stream + ( HTTP, + Input (..), + Scope (..), + Stream, + WS, + runStreamHTTP, + runStreamWS, + toOutStream, + ) +import Data.UUID.V4 (nextRandom) --- 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) +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, @@ -74,58 +89,59 @@ -- 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 () +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 :: + ( 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 :: + ( MonadIO m, + MonadIO m2, + (Eq (StreamChannel event)), + (GQLChannel event) + ) => + m2 (Store event m) initDefaultStore = do - store <- newMVar empty - pure Store - { readStore = liftIO $ readMVar store - , writeStore = \changes -> liftIO $ modifyMVar_ store (return . changes) - } - + store <- liftIO $ 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 :: + ( MonadUnliftIO m + ) => + (Input WS -> Stream WS e m) -> + Scope WS e m -> + m () connectionThread api scope = do - input <- connect + 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 - +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 --- a/src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs +++ b/src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs @@ -1,59 +1,67 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# 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 - ) + ( ApolloAction (..), + apolloFormat, + acceptApolloRequest, + toApolloResponse, + Validation, + ) +where +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.Maybe (maybe) -- MORPHEUS -import Data.Morpheus.Types.IO ( GQLResponse - , GQLRequest (..) - ) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + GQLResponse, + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + Token, + ) +import Data.Semigroup ((<>)) +import Data.Text + ( Text, + unpack, + ) +import GHC.Generics (Generic) +import Network.WebSockets + ( AcceptRequest (..), + Connection, + PendingConnection, + RequestHead, + acceptRequestWith, + getRequestSubprotocols, + pendingRequest, + ) type ID = Text -data ApolloSubscription payload = - ApolloSubscription - { apolloId :: Maybe ID - , apolloType :: Text - , apolloPayload :: Maybe payload - } +data ApolloSubscription payload = ApolloSubscription + { apolloId :: Maybe ID, + apolloType :: Text, + apolloPayload :: Maybe payload + } deriving (Show, Generic) instance FromJSON a => FromJSON (ApolloSubscription a) where @@ -62,34 +70,33 @@ objectParser o = ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload" -data RequestPayload = - RequestPayload - { payloadOperationName :: Maybe Text - , payloadQuery :: Maybe Text - , payloadVariables :: Maybe Value - } +data RequestPayload = RequestPayload + { payloadOperationName :: Maybe FieldName, + payloadQuery :: Maybe Token, + payloadVariables :: Maybe Value + } deriving (Show, Generic) instance FromJSON RequestPayload where parseJSON = withObject "ApolloPayload" objectParser where objectParser o = - RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*> - o .:? "variables" + 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)) +acceptApolloRequest :: + MonadIO m => + PendingConnection -> + m Connection +acceptApolloRequest pending = + liftIO $ + acceptRequestWith + pending + (acceptApolloSubProtocol (pendingRequest pending)) acceptApolloSubProtocol :: RequestHead -> AcceptRequest acceptApolloSubProtocol reqHead = @@ -117,28 +124,29 @@ 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 + 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 + 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) <> "\"." + 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} + 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 --- a/src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs +++ b/src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs @@ -1,162 +1,178 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} module Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore - ( ID - , Session - , ClientConnectionStore - , Updates(..) - , startSession - , endSession - , empty - , insert - , delete - , publish + ( ID, + Session, + SessionID, + ClientConnectionStore, + ClientConnection, + Updates (..), + startSession, + endSession, + empty, + insert, + delete, + publish, + toList, + connectionSessionIds, ) 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 - ) - - +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Foldable (traverse_) +import Data.HashMap.Lazy (HashMap, keys) +import qualified Data.HashMap.Lazy as HM + ( adjust, + delete, + elems, + empty, + insert, + insertWith, + keys, + toList, + ) +import Data.List (intersect) -- 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 +import Data.Morpheus.Internal.Utils + ( Collection (..), + KeyOf (..), + ) +import Data.Morpheus.Types.Internal.Resolving + ( Event (..), + GQLChannel (..), + SubEvent, + ) +import Data.Morpheus.Types.Internal.Subscription.Apollo + ( toApolloResponse, + ) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.UUID (UUID) -type SesionID = Text +type ID = UUID -type Session = (ID, SesionID) +type SessionID = Text +type Session = (ID, SessionID) -data ClientConnection e ( m :: * -> * ) = - ClientConnection - { connectionId :: ID - , connectionCallback :: ByteString -> m () +data ClientConnection e (m :: * -> *) = ClientConnection + { connectionId :: ID, + connectionCallback :: ByteString -> m (), -- one connection can have multiple subsciprion session - , connectionSessions :: HashMap SesionID (SubEvent e m) - } + connectionSessions :: HashMap SessionID (SubEvent e m) + } +connectionSessionIds :: ClientConnection e m -> [SessionID] +connectionSessionIds = HM.keys . connectionSessions + instance Show (ClientConnection e m) where - show ClientConnection { connectionId, connectionSessions } = + 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 :: + ( 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 - - + 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 - } +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) +updateClient :: + (ClientConnection e m -> ClientConnection e m) -> + ID -> + Updates e m +updateClient f cid = Updates (adjust f cid) -endSession :: Session -> Updates e m +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) } - + 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) +newtype ClientConnectionStore e (m :: * -> *) = ClientConnectionStore + { unpackStore :: HashMap ID (ClientConnection e m) + } + deriving (Show) -type StoreMap e m - = ClientConnectionStore e m - -> ClientConnectionStore e m +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 :: + ( 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 :: ClientConnectionStore e m -> [ClientConnection e m] elems = HM.elems . unpackStore -instance Empty (ClientConnectionStore e m) where - empty = ClientConnectionStore HM.empty +toList :: ClientConnectionStore e m -> [(UUID, ClientConnection e m)] +toList = HM.toList . unpackStore -insert - :: ID - -> (ByteString -> m ()) - -> StoreMap e m -insert connectionId connectionCallback = mapStore (HM.insert connectionId c) +instance KeyOf (ClientConnection e m) where + type KEY (ClientConnection e m) = ID + keyOf = connectionId + +instance Collection (ClientConnection e m) (ClientConnectionStore e m) where + empty = ClientConnectionStore empty + singleton = ClientConnectionStore . singleton + +-- returns original store, if connection with same id already exist +insert :: + ID -> + (ByteString -> m ()) -> + StoreMap e m +insert connectionId connectionCallback = mapStore (HM.insertWith (curry snd) connectionId c) where - c = ClientConnection { connectionId , connectionCallback, connectionSessions = HM.empty } + c = ClientConnection {connectionId, connectionCallback, connectionSessions = HM.empty} -adjust - :: (ClientConnection e m -> ClientConnection e m ) - -> ID - -> StoreMap e m +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 :: + 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 --- a/src/Data/Morpheus/Types/Internal/Subscription/Stream.hs +++ b/src/Data/Morpheus/Types/Internal/Subscription/Stream.hs @@ -1,235 +1,242 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Subscription.Stream - ( toOutStream - , runStreamWS - , runStreamHTTP - , Stream - , Scope(..) - , Input(..) - , API(..) - , HTTP - , WS + ( toOutStream, + runStreamWS, + runStreamHTTP, + Stream, + Scope (..), + Input (..), + API (..), + HTTP, + WS, ) where -import Data.Foldable ( traverse_ ) -import Data.ByteString.Lazy.Char8 (ByteString) - +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Foldable (traverse_) -- 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 - ) - +import Data.Morpheus.Error + ( globalErrorMessage, + ) +import Data.Morpheus.Internal.Utils + ( failure, + ) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + GQLResponse (..), + ) +import Data.Morpheus.Types.Internal.AST + ( GQLErrors, + Message, + VALID, + Value (..), + ) +import Data.Morpheus.Types.Internal.Resolving + ( GQLChannel (..), + ResponseEvent (..), + ResponseStream, + Result (..), + ResultT (..), + runResultT, + ) +import Data.Morpheus.Types.Internal.Subscription.Apollo + ( ApolloAction (..), + apolloFormat, + toApolloResponse, + ) +import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore + ( ClientConnectionStore, + ID, + Session, + Updates (..), + endSession, + insert, + startSession, + ) + data API = HTTP | WS type WS = 'WS -type HTTP = 'HTTP +type HTTP = 'HTTP -data Input - (api:: API) +data + Input + (api :: API) where - Init :: ID -> Input WS - Request :: GQLRequest -> Input HTTP + Init :: ID -> Input WS + Request :: GQLRequest -> Input HTTP run :: Scope WS e m -> Updates e m -> m () -run ScopeWS { update } (Updates changes) = update changes +run ScopeWS {update} (Updates changes) = update changes -data Scope (api :: API ) event (m :: * -> * ) where - ScopeHTTP :: +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 - + } -> + 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 :: * -> * ) +data + Stream + (api :: API) + e + (m :: * -> *) where - StreamWS - :: - { streamWS :: Scope WS e m -> m (Either ByteString [Updates e m]) - } -> Stream WS e m - StreamHTTP - :: + 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 + } -> + 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 +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 :: + ( 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 + 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)] + 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 +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 +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 +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 :: + ( 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 - :: ( Eq (StreamChannel e) - , GQLChannel e - , Monad m - ) - => ResponseStream e m (Value VALID) - -> Scope HTTP e m - -> m GQLResponse -handleResponseHTTP res - ScopeHTTP { httpCallback } = do + ScopeHTTP {httpCallback} = do x <- runResultT (handleRes res execute) - case x of - Success r _ events-> do + case x of + Success r _ events -> do traverse_ httpCallback events - pure $ Data r + pure $ Data r Failure err -> pure (Errors err) where - execute (Publish event) = pure event - execute Subscribe {} = failure ("http can't handle subscription" :: String) + execute (Publish event) = pure event + execute Subscribe {} = failure ("http can't handle subscription" :: Message) -handleRes - :: ( Eq (StreamChannel e) - , GQLChannel e - , Monad m - ) - => ResponseStream e m a - -> (ResponseEvent e m -> ResultT e' m e') - -> ResultT e' m a +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 +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 } + ResultT $ pure $ + Success + { result, + warnings, + events = events' + } +unfoldRes _ Failure {errors} = ResultT $ pure $ Failure {errors} diff --git a/src/Data/Morpheus/Types/Internal/TH.hs b/src/Data/Morpheus/Types/Internal/TH.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/TH.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - - -module Data.Morpheus.Types.Internal.TH where - -import Language.Haskell.TH -import Data.Text (Text,unpack) - -apply :: Name -> [Q Exp] -> Q Exp -apply n = foldl appE (conE n) - -applyT :: Name -> [Q Type] -> Q Type -applyT name = foldl appT (conT name) - -typeT :: Name -> [Text] -> Q Type -typeT name li = applyT name (map (varT . mkName . unpack) li) - -instanceHeadT :: Name -> Text -> [Text] -> Q Type -instanceHeadT cName iType tArgs = applyT cName [applyT (mkName $ unpack iType) (map (varT . mkName . unpack) tArgs)] - -instanceProxyFunD :: (Name,ExpQ) -> DecQ -instanceProxyFunD (name,body) = instanceFunD name ["_"] body - -instanceFunD :: Name -> [Text] -> ExpQ -> Q Dec -instanceFunD name args body = funD name [clause (map (varP . mkName. unpack) args) (normalB body) []] - -instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type -instanceHeadMultiT className iType li = applyT className (iType : li) - - --- "User" -> ["name","id"] -> (User name id) -destructRecord :: Text -> [Text] -> PatQ -destructRecord conName fields = conP (mkName $ unpack conName) (map (varP . mkName .unpack) fields) - -typeInstanceDec :: Name -> Type -> Type -> Dec -#if MIN_VERSION_template_haskell(2,15,0) --- fix breaking changes -typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res) -#else --- -typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res) -#endif - - -infoTyVars :: Info -> [TyVarBndr] -infoTyVars (TyConI x) = decArgs x -infoTyVars _ = [] - -decArgs :: Dec -> [TyVarBndr] -decArgs (DataD _ _ args _ _ _) = args -decArgs (NewtypeD _ _ args _ _ _) = args -decArgs (TySynD _ args _) = args -decArgs _ = [] diff --git a/src/Data/Morpheus/Types/Internal/Validation.hs b/src/Data/Morpheus/Types/Internal/Validation.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Validation.hs +++ /dev/null @@ -1,354 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Validation/Error.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/Validation/Validator.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# 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/Types.hs b/src/Data/Morpheus/Types/Types.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Types.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} - -module Data.Morpheus.Types.Types - ( Undefined(..) - , Pair(..) - , MapKind(..) - , MapArgs(..) - , mapKindFromList - ) -where - -import GHC.Generics ( Generic ) - -data Undefined (m :: * -> *) = Undefined deriving (Show, Generic) - -data Pair k v = - Pair - { key :: k - , value :: v - } - deriving (Generic) - -newtype MapArgs k = - MapArgs - { oneOf :: Maybe [k] - } - deriving (Generic) - -data MapKind k v m = - MapKind - { size :: Int - , pairs :: MapArgs k -> m [Pair k v] - } - deriving (Generic) - -mapKindFromList :: (Eq k, Applicative m) => [(k, v)] -> MapKind k v m -mapKindFromList inputPairs = MapKind { size = length inputPairs - , pairs = resolvePairs - } - where - filterBy MapArgs { oneOf = Just list } = - filter ((`elem` list) . fst) inputPairs - filterBy _ = inputPairs - resolvePairs = pure . (map toGQLTuple . filterBy) - toGQLTuple (x, y) = Pair x y diff --git a/src/Data/Morpheus/Validation/Document/Validation.hs b/src/Data/Morpheus/Validation/Document/Validation.hs deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Document/Validation.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Validation.Document.Validation - ( validatePartialDocument - ) -where - -import Data.Maybe - --- --- Morpheus -import Data.Morpheus.Error.Document.Interface - ( ImplementsError(..) - , partialImplements - , unknownInterface - ) -import Data.Morpheus.Rendering.RenderGQL - ( RenderGQL(..) ) -import Data.Morpheus.Types.Internal.AST - ( Name - , FieldDefinition(..) - , TypeDefinition(..) - , FieldsDefinition(..) - , TypeContent(..) - , TypeRef(..) - , isWeaker - , lookupWith - ) -import Data.Morpheus.Types.Internal.Operation - ( Selectable(..) - , Listable(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless - , Failure(..) - ) - -validatePartialDocument :: [TypeDefinition] -> Eventless [TypeDefinition] -validatePartialDocument lib = catMaybes <$> traverse validateType lib - where - 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 dt) - errors -> failure $ partialImplements typeName errors - validateType TypeDefinition { typeContent = DataInterface {}} = pure Nothing - validateType x = pure (Just x) - mustBeSubset - :: FieldsDefinition -> (Name, FieldsDefinition) -> [(Name, Name, ImplementsError)] - mustBeSubset objFields (typeName, fields) = concatMap checkField (toList fields) - where - 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 , fieldName - , UnexpectedType { expectedType = render interfaceT - , foundType = render objT - } - ) - ] - ------------------------------- - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Internal/Value.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Validation.Internal.Value - ( 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 ( typeViolation ) -import Data.Morpheus.Types.Internal.AST - ( FieldDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , ScalarDefinition(..) - , TypeRef(..) - , TypeWrapper(..) - , DataEnumValue(..) - , Value(..) - , ValidValue - , Variable(..) - , Ref(..) - , Message - , Name - , ResolvedValue - , VALID - , VariableContent(..) - , TypeRef(..) - , isWeaker - , isNullableWrapper - , ObjectEntry(..) - , RESOLVED - , InputFieldsDefinition(..) - , Variable(..) - ) -import Data.Morpheus.Types.Internal.AST.OrderedMap - ( unsafeFromValues ) -import Data.Morpheus.Types.Internal.Operation - ( Failure(..) ) -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 - -> InputValidator ValidValue -checkTypeEquality (tyConName, tyWrappers) ref var@Variable { variableValue = ValidVariableValue value, variableType } - | typeConName variableType == tyConName && not - (isWeaker (typeWrappers variableType) tyWrappers) - = pure value - | otherwise - = failure $ incompatibleVariableType - ref - var - TypeRef - { typeConName = tyConName - , typeWrappers = tyWrappers - , typeArgs = Nothing - } - --- Validate Variable Argument or all Possible input Values -validateInput - :: [TypeWrapper] - -> TypeDefinition - -> ObjectEntry RESOLVED - -> InputValidator ValidValue -validateInput tyWrappers TypeDefinition { typeContent = tyCont, typeName } = - withScopeType typeName - . validateWrapped tyWrappers tyCont - where - mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue - mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing - -- VALIDATION - validateWrapped - :: [TypeWrapper] - -> TypeContent - -> ObjectEntry RESOLVED - -> InputValidator ValidValue - -- Validate Null. value = null ? - validateWrapped wrappers _ ObjectEntry { entryValue = ResolvedVariable ref variable} = - checkTypeEquality (typeName, wrappers) ref variable - validateWrapped wrappers _ ObjectEntry { entryValue = Null} - | isNullableWrapper wrappers = return Null - | otherwise = mismatchError wrappers Null - -- Validate LIST - validateWrapped (TypeMaybe : wrappers) _ value = - validateWrapped wrappers tyCont value - validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) = - List <$> traverse validateElement list - where - validateElement = validateWrapped wrappers tyCont . ObjectEntry key - {-- 2. VALIDATE TYPES, all wrappers are already Processed --} - {-- VALIDATE OBJECT--} - validateWrapped [] dt v = validate dt v - where - validate - :: TypeContent -> ObjectEntry RESOLVED -> InputValidator ValidValue - validate (DataInputObject parentFields) ObjectEntry { entryValue = Object fields} = do - traverse_ requiredFieldsDefined (unInputFieldsDefinition parentFields) - Object <$> traverse validateField fields - where - requiredFieldsDefined :: FieldDefinition -> InputValidator (ObjectEntry RESOLVED) - requiredFieldsDefined fieldDef@FieldDefinition { fieldName} - = selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields - validateField - :: 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 - getField = selectKnown entry parentFields - -- VALIDATE INPUT UNION - -- 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 - 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) ObjectEntry { entryValue } = - validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue - {-- VALIDATE SCALAR --} - 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 _ ObjectEntry { entryValue } = mismatchError wrappers entryValue - -validateScalar - :: ScalarDefinition - -> ResolvedValue - -> (Maybe Message -> ResolvedValue -> InputValidator ValidValue) - -> InputValidator ValidValue -validateScalar ScalarDefinition { validateValue } value err = do - scalarValue <- toScalar value - case validateValue scalarValue of - Right _ -> return scalarValue - Left "" -> err Nothing value - Left message -> err (Just message) value - where - toScalar :: ResolvedValue -> InputValidator ValidValue - toScalar (Scalar x) = pure (Scalar x) - toScalar scValue = err Nothing scValue - -validateEnum - :: (ResolvedValue -> InputValidator ValidValue) - -> [DataEnumValue] - -> ResolvedValue - -> InputValidator ValidValue -validateEnum err enumValues value@(Enum enumValue) - | enumValue `elem` tags = pure (Enum enumValue) - | otherwise = err value - where tags = map enumName enumValues -validateEnum err _ value = err value diff --git a/src/Data/Morpheus/Validation/Query/Arguments.hs b/src/Data/Morpheus/Validation/Query/Arguments.hs deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Query/Arguments.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -module Data.Morpheus.Validation.Query.Arguments - ( validateArguments - ) -where - -import Data.Foldable (traverse_) -import Data.Morpheus.Types.Internal.AST - ( Argument(..) - , ArgumentsDefinition(..) - , Arguments - , ArgumentDefinition - , FieldDefinition(..) - , TypeRef(..) - , Value(..) - , RawValue - , ResolvedValue - , RESOLVED - , VALID - , ObjectEntry(..) - , RAW - ) -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 - ( validateInput ) - --- only Resolves , doesnot checks the types -resolveObject :: RawValue -> SelectionValidator ResolvedValue -resolveObject = resolve - where - 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 resolveEntry obj - resolve (VariableValue ref) = - variables <$> askContext - >>= fmap (ResolvedVariable ref) - . selectRequired ref - -resolveArgumentVariables - :: Arguments RAW - -> SelectionValidator (Arguments RESOLVED) -resolveArgumentVariables - = traverse resolveVariable - where - resolveVariable :: Argument RAW -> SelectionValidator (Argument RESOLVED) - resolveVariable (Argument key val position) = do - constValue <- resolveObject val - pure $ Argument key constValue position - -validateArgument - :: 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 - ------------------------------------------------------------------------- - 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 - :: FieldDefinition - -> Arguments RAW - -> SelectionValidator (Arguments VALID) -validateArguments - fieldDef@FieldDefinition { fieldArgs } - rawArgs - = do - args <- resolveArgumentVariables rawArgs - traverse_ checkUnknown (toList args) - traverse (validateArgument args) argsDef - where - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Query/Fragment.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.Morpheus.Validation.Query.Fragment - ( validateFragments - , castFragmentType - , resolveSpread - ) -where - -import Data.Semigroup ( (<>) ) -import Data.Foldable (traverse_) - --- MORPHEUS -import Data.Morpheus.Error.Fragment ( cannotBeSpreadOnType - , cannotSpreadWithinItself - ) -import Data.Morpheus.Types.Internal.AST - ( Name - , Fragment(..) - , Fragments - , SelectionContent(..) - , Selection(..) - , Ref(..) - , Position - , SelectionSet - , RAW - ) -import Data.Morpheus.Types.Internal.Operation - ( selectOr - , toList - , Failure(..) - ) -import Data.Morpheus.Types.Internal.Validation - ( BaseValidator - , askSchema - , askFragments - , selectKnown - , constraint - , Constraint(..) - , Validator - , checkUnused - ) - -validateFragments :: SelectionSet RAW -> BaseValidator () -validateFragments selectionSet - = fragmentsCycleChecking - *> checkUnusedFragments selectionSet - *> fragmentsConditionTypeChecking - -checkUnusedFragments :: SelectionSet RAW -> BaseValidator () -checkUnusedFragments selectionSet = do - fragments <- askFragments - checkUnused - (usedFragments fragments (toList selectionSet)) - (toList fragments) - -castFragmentType - :: 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 :: [Name] -> Ref -> Validator ctx Fragment -resolveSpread allowedTargets ref@Ref { refName, refPosition } - = askFragments - >>= selectKnown ref - >>= castFragmentType (Just refName) refPosition allowedTargets - -usedFragments :: Fragments -> [Selection RAW] -> [Node] -usedFragments fragments = concatMap findAllUses - where - findAllUses :: Selection RAW -> [Node] - findAllUses Selection { selectionContent = SelectionField } = [] - findAllUses Selection { selectionContent = SelectionSet selectionSet } = - concatMap findAllUses selectionSet - findAllUses (InlineFragment Fragment { fragmentSelection }) = - concatMap findAllUses fragmentSelection - findAllUses (Spread Ref { refName, refPosition }) = - [Ref refName refPosition] <> searchInFragment - where - searchInFragment = selectOr - [] - (concatMap findAllUses . fragmentSelection) - refName - fragments - -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 }) = - concatMap scanForSpread fragmentSelection -scanForSpread (Spread Ref { refName, refPosition }) = - [Ref refName refPosition] - -type Node = Ref - -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] -> BaseValidator Graph -checkForCycle lib parentNode history = case lookup parentNode lib of - Just node -> concat <$> traverse checkNode node - Nothing -> pure [] - where - checkNode x = if x `elem` history then cycleError x else recurse x - recurse node = checkForCycle lib node $ history ++ [node] - cycleError n = failure $ cannotSpreadWithinItself (n : history) diff --git a/src/Data/Morpheus/Validation/Query/Selection.hs b/src/Data/Morpheus/Validation/Query/Selection.hs deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Query/Selection.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Data.Morpheus.Validation.Query.Selection - ( validateOperation - ) -where - - -import Data.Semigroup ( (<>) ) - --- MORPHEUS -import Data.Morpheus.Error.Selection ( hasNoSubfields - , subfieldsNotSelected - ) -import Data.Morpheus.Types.Internal.AST - ( Selection(..) - , SelectionContent(..) - , Fragment(..) - , SelectionSet - , FieldDefinition(..) - , FieldsDefinition(..) - , TypeContent(..) - , TypeDefinition(..) - , Operation(..) - , Ref(..) - , Name - , RAW - , VALID - , Arguments - , isEntNode - , getOperationDataType - , GQLError(..) - , OperationType(..) - ) -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 - ( castFragmentType - , resolveSpread - ) - -type TypeDef = (Name, FieldsDefinition) - - -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" - - -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 - :: TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID) -validateSelectionSet dataType@(typeName,fieldsDef) = - concatTraverse validateSelection - where - -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet - 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 - 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 - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Query/UnionSelection.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Query/Validation.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Validation.Query.Validation - ( validateRequest - ) -where - -import Data.Map ( fromList ) -import Data.Morpheus.Types.Internal.AST - ( Operation(..) - , VALID - , Schema(..) - , GQLQuery(..) - , VALIDATION_MODE - ) -import Data.Morpheus.Types.Internal.Validation - ( Context(..) - , runValidator - , SelectionContext(..) - ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless ) -import Data.Morpheus.Validation.Query.Fragment - ( validateFragments ) -import Data.Morpheus.Validation.Query.Selection - ( validateOperation ) -import Data.Morpheus.Validation.Query.Variable - ( resolveOperationVariables ) - - -validateRequest - :: Schema - -> VALIDATION_MODE - -> GQLQuery - -> Eventless (Operation VALID) -validateRequest - schema - validationMode - GQLQuery - { fragments - , inputVariables, - operation = operation@Operation - { operationName - , operationSelection - , operationPosition - } - } - = do - 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 deleted file mode 100644 --- a/src/Data/Morpheus/Validation/Query/Variable.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Data.Morpheus.Validation.Query.Variable - ( resolveOperationVariables - ) -where - - -import qualified Data.Map as M - ( lookup ) -import Data.Maybe ( maybe ) -import Data.Semigroup ( (<>) ) - ---- MORPHEUS -import Data.Morpheus.Error.Variable ( uninitializedVariable) -import Data.Morpheus.Types.Internal.AST - ( DefaultValue - , Operation(..) - , Variable(..) - , VariableDefinitions - , Fragment(..) - , Argument(..) - , Selection(..) - , SelectionContent(..) - , SelectionSet - , Ref(..) - , TypeDefinition - , Variables - , Value(..) - , ValidValue - , RawValue - , ResolvedValue - , VALID - , RAW - , VariableContent(..) - , isNullable - , TypeRef(..) - , VALIDATION_MODE(..) - , ObjectEntry(..) - ) -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 - ( validateInput ) - -class ExploreRefs a where - exploreRefs :: a -> [Ref] - -instance ExploreRefs RawValue where - exploreRefs (VariableValue ref ) = [ref] - exploreRefs (Object fields) = concatMap (exploreRefs . entryValue) fields - exploreRefs (List ls ) = concatMap exploreRefs ls - exploreRefs _ = [] - -instance ExploreRefs (Argument RAW) where - exploreRefs = exploreRefs . argumentValue - -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 :: Selection RAW -> BaseValidator [Ref] - searchRefs Selection { selectionArguments, selectionContent = SelectionField } - = return $ concatMap exploreRefs selectionArguments - searchRefs Selection { selectionArguments, selectionContent = SelectionSet selSet } - = getArgs <$> mapSelection searchRefs selSet - where - getArgs :: [Ref] -> [Ref] - getArgs x = concatMap exploreRefs selectionArguments <> x - searchRefs (InlineFragment Fragment { fragmentSelection }) - = mapSelection searchRefs fragmentSelection - searchRefs (Spread reference) - = askFragments - >>= selectKnown reference - >>= mapSelection searchRefs - . fragmentSelection - -resolveOperationVariables - :: Variables - -> VALIDATION_MODE - -> Operation RAW - -> BaseValidator (VariableDefinitions VALID) -resolveOperationVariables - root - validationMode - Operation - { operationSelection - , operationArguments - } - = checkUnusedVariables *> - traverse (lookupAndValidateValueOnBody root validationMode) operationArguments - where - checkUnusedVariables :: BaseValidator () - checkUnusedVariables = do - uses <- allVariableRefs [operationSelection] - checkUnused uses (toList operationArguments) - -lookupAndValidateValueOnBody - :: Variables - -> VALIDATION_MODE - -> 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 x = var { variableValue = ValidVariableValue x } - getVariable :: Maybe ResolvedValue - getVariable = M.lookup variableName bodyVariables - ------------------------------------------------------------------ - -- checkType :: - checkType - :: Maybe ResolvedValue - -> DefaultValue - -> 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 var - | otherwise - = returnNull - where - returnNull = - maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables) - ----------------------------------------------------------------------------------------------- - 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 @@ -1,42 +1,43 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Feature.Holistic.API - ( api - , rootResolver + ( api, + rootResolver, ) where -import Data.Morpheus ( interpreter ) -import Data.Morpheus.Document ( importGQLDocument ) -import Data.Morpheus.Kind ( SCALAR ) -import Data.Morpheus.Types ( Event - , GQLRequest - , GQLResponse - , GQLRootResolver(..) - , GQLScalar(..) - , GQLType(..) - , ID(..) - , ScalarValue(..) - , failRes - , liftEither - , subscribe - ) -import Data.Text ( Text ) -import GHC.Generics ( Generic ) - +import Data.Morpheus (interpreter) +import Data.Morpheus.Document (importGQLDocument) +import Data.Morpheus.Kind (SCALAR) +import Data.Morpheus.Types + ( Event, + GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLScalar (..), + GQLType (..), + ID (..), + ScalarValue (..), + liftEither, + subscribe, + ) +import Data.Text (Text) +import GHC.Generics (Generic) -data TestScalar = - TestScalar Int - Int +data TestScalar + = TestScalar + Int + Int deriving (Show, Generic) instance GQLType TestScalar where @@ -46,8 +47,8 @@ parseValue _ = pure (TestScalar 1 0) serialize (TestScalar x y) = Int (x * 100 + y) -data Channel = - Channel +data Channel + = Channel deriving (Show, Eq) type EVENT = Event Channel () @@ -57,34 +58,45 @@ alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either" - rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription -rootResolver = GQLRootResolver - { queryResolver = Query { user - , 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) - , newAddress = subscribe [Channel] (pure resolveAddress) +rootResolver = + GQLRootResolver + { queryResolver = + Query + { user, + testUnion = Just . TestUnionUser <$> user, + fail1 = liftEither alwaysFail, + fail2 = fail "fail with MonadFail", + person = pure Person {name = pure (Just "test Person Name")}, + type' = \TypeArgs {in' = TypeInput {data'}} -> pure data' + }, + mutationResolver = Mutation {createUser = const user}, + subscriptionResolver = + Subscription + { newUser = subscribe [Channel] (pure $ const user), + newAddress = subscribe [Channel] (pure resolveAddress) + } } - } - where - user :: Applicative m => m (User m) - user = pure User { name = pure "testName" - , email = pure "" - , address = resolveAddress - , office = resolveAddress - , friend = pure Nothing - } - ----------------------------------------------------- - resolveAddress :: Applicative m => a -> m (Address m) - resolveAddress _ = pure Address { city = pure "" - , houseNumber = pure 0 - , street = const $ pure Nothing - } + where + user :: Applicative m => m (User m) + user = + pure + User + { name = pure "testName", + email = pure "", + address = resolveAddress, + office = resolveAddress, + friend = pure Nothing + } + ----------------------------------------------------- + resolveAddress :: Applicative m => a -> m (Address m) + resolveAddress _ = + pure + Address + { city = pure "", + houseNumber = pure 0, + street = const $ pure Nothing + } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver 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 @@ -5,7 +5,7 @@ "locations": [ { "line": 3, - "column": 13 + "column": 5 } ] } 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 @@ -116,6 +116,10 @@ "description": "returns on a query that pads all '!' chars with whitespace" }, { + "path": "introspection/interface", + "description": "interface must be visible in introspection" + }, + { "path": "introspection/schemaTypes/__Type", "description": "benchmark __Type" }, @@ -244,6 +248,10 @@ "description": "check if deprecated works with enumValue" }, { + "path": "introspection/directives/default", + "description": "default directives must be defined" + }, + { "path": "introspection/deprecated/field", "description": "check if deprecated works with object fields" }, @@ -266,5 +274,57 @@ { "path": "selection/subscription/singleTopLevelField/failAnonymous", "description": "fail if subscription selects more then one top level field. (for anonymous subscription)" + }, + { + "path": "selection/directives/default/resolve", + "description": "test skip include resolving" + }, + { + "path": "selection/directives/default/requiredArgument", + "description": "fail: if skip include does not have argument \"if\"" + }, + { + "path": "selection/directives/default/wrongArgumentType", + "description": "fail: if skip include has argument \"if\", but with wrong value" + }, + { + "path": "selection/directives/default/withVariable", + "description": "api allowes use of variable inside directives" + }, + { + "path": "selection/directives/default/withMerge", + "description": "@skip and @include are evaluated before selection is merged" + }, + { + "path": "selection/directives/default/variablesOnFragment", + "description": "@skip and @include are evaluated before selection is merged" + }, + { + "path": "selection/directives/validation/invalidPlace/query", + "description": "directive on invalid place must be rejected" + }, + { + "path": "selection/directives/validation/invalidPlace/mutation", + "description": "directive on invalid place must be rejected" + }, + { + "path": "selection/directives/validation/invalidPlace/subscription", + "description": "directive on invalid place must be rejected" + }, + { + "path": "selection/directives/validation/invalidPlace/field", + "description": "directive on invalid place must be rejected" + }, + { + "path": "selection/directives/validation/invalidPlace/fragmentSpread", + "description": "directive on invalid place must be rejected" + }, + { + "path": "selection/directives/validation/invalidPlace/inlineFragment", + "description": "directive on invalid place must be rejected" + }, + { + "path": "reservedNames", + "description": "morpheus should handle reserved names" } ] diff --git a/test/Feature/Holistic/failure/resolveFailure/response.json b/test/Feature/Holistic/failure/resolveFailure/response.json --- a/test/Feature/Holistic/failure/resolveFailure/response.json +++ b/test/Feature/Holistic/failure/resolveFailure/response.json @@ -5,7 +5,7 @@ "locations": [{ "line": 2, "column": 3 }] }, { - "message": "Failure on Resolving Field \"fail2\": fail with failRes", + "message": "Failure on Resolving Field \"fail2\": fail with MonadFail", "locations": [{ "line": 3, "column": 3 }] } ] diff --git a/test/Feature/Holistic/fragment/loopingFragment/response.json b/test/Feature/Holistic/fragment/loopingFragment/response.json --- a/test/Feature/Holistic/fragment/loopingFragment/response.json +++ b/test/Feature/Holistic/fragment/loopingFragment/response.json @@ -1,95 +1,45 @@ { "errors": [ { - "message": "Cannot spread fragment \"A\" within itself via A, A, C.", + "message": "Cannot spread fragment \"A\" within itself via \"A\", \"A\", \"C\".", "locations": [ - { - "line": 17, - "column": 3 - }, - { - "line": 7, - "column": 10 - }, - { - "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.", + "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 - } + { "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.", + "message": "Cannot spread fragment \"C\" within itself via \"C\", \"C\", \"A\".", "locations": [ - { - "line": 9, - "column": 3 - }, - { - "line": 16, - "column": 10 - }, - { - "line": 17, - "column": 3 - } + { "line": 9, "column": 3 }, + { "line": 16, "column": 10 }, + { "line": 17, "column": 3 } ] }, { "message": "Fragment \"A\" is never used.", - "locations": [ - { - "line": 7, - "column": 10 - } - ] + "locations": [{ "line": 7, "column": 10 }] }, { "message": "Fragment \"B\" is never used.", - "locations": [ - { - "line": 12, - "column": 10 - } - ] + "locations": [{ "line": 12, "column": 10 }] }, { "message": "Fragment \"C\" is never used.", - "locations": [ - { - "line": 16, - "column": 10 - } - ] + "locations": [{ "line": 16, "column": 10 }] }, { "message": "Fragment \"D\" is never used.", - "locations": [ - { - "line": 20, - "column": 10 - } - ] + "locations": [{ "line": 20, "column": 10 }] } ] } diff --git a/test/Feature/Holistic/introspection/directives/default/query.gql b/test/Feature/Holistic/introspection/directives/default/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/introspection/directives/default/query.gql @@ -0,0 +1,54 @@ +# introspect directives +query Get__Type { + __schema { + directives { + name + description + locations + args { + ...InputValue + } + } + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/Holistic/introspection/directives/default/response.json b/test/Feature/Holistic/introspection/directives/default/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/introspection/directives/default/response.json @@ -0,0 +1,60 @@ +{ + "data": { + "__schema": { + "directives": [ + { + "name": "skip", + "description": "Directs the executor to skip this field or fragment when the `if` argument is true.", + "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"], + "args": [ + { + "name": "if", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { + "kind": "SCALAR", + "name": "Boolean", + "ofType": null + } + }, + "defaultValue": null + } + ] + }, + { + "name": "include", + "description": "Directs the executor to include this field or fragment only when the `if` argument is true.", + "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"], + "args": [ + { + "name": "if", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { + "kind": "SCALAR", + "name": "Boolean", + "ofType": null + } + }, + "defaultValue": null + } + ] + }, + { + "name": "deprecated", + "description": "Marks an element of a GraphQL schema as no longer supported.", + "locations": ["FIELD_DEFINITION", "ENUM_VALUE"], + "args": [ + { + "name": "reason", + "type": { "kind": "SCALAR", "name": "String", "ofType": null }, + "defaultValue": null + } + ] + } + ] + } + } +} diff --git a/test/Feature/Holistic/introspection/interface/query.gql b/test/Feature/Holistic/introspection/interface/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/introspection/interface/query.gql @@ -0,0 +1,82 @@ +query Get__Type { + person { + name + } + interface: __type(name: "Person") { + ...FullType + } + user: __type(name: "User") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/Feature/Holistic/introspection/interface/response.json b/test/Feature/Holistic/introspection/interface/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/introspection/interface/response.json @@ -0,0 +1,125 @@ +{ + "data": { + "person": { "name": "test Person Name" }, + "interface": { + "kind": "INTERFACE", + "name": "Person", + "fields": [ + { + "name": "name", + "args": [], + "type": { "kind": "SCALAR", "name": "String", "ofType": null }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": null, + "enumValues": null, + "possibleTypes": [{ "kind": "OBJECT", "name": "User", "ofType": null }] + }, + "user": { + "kind": "OBJECT", + "name": "User", + "fields": [ + { + "name": "name", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "email", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "address", + "args": [ + { + "name": "coordinates", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { + "kind": "INPUT_OBJECT", + "name": "Coordinates", + "ofType": null + } + }, + "defaultValue": null + }, + { + "name": "comment", + "type": { "kind": "SCALAR", "name": "String", "ofType": null }, + "defaultValue": null + } + ], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "OBJECT", "name": "Address", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "office", + "args": [ + { + "name": "zipCode", + "type": { + "kind": "LIST", + "name": null, + "ofType": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "Int", "ofType": null } + } + }, + "defaultValue": null + }, + { + "name": "cityID", + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "ENUM", "name": "TestEnum", "ofType": null } + }, + "defaultValue": null + } + ], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "OBJECT", "name": "Address", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "friend", + "args": [], + "type": { "kind": "OBJECT", "name": "User", "ofType": null }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [{ "kind": "INTERFACE", "name": "Person", "ofType": null }], + "enumValues": null, + "possibleTypes": null + } + } +} 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 @@ -2,66 +2,31 @@ "errors": [ { "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null,[[],[{\"uid\":\"1\"}]]].", - "locations": [ - { - "line": 8, - "column": 23 - } - ] + "locations": [{ "line": 8, "column": 23 }] }, { "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [].", - "locations": [ - { - "line": 11, - "column": 23 - } - ] + "locations": [{ "line": 11, "column": 23 }] }, { "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found \"HH\".", - "locations": [ - { - "line": 15, - "column": 25 - } - ] + "locations": [{ "line": 15, "column": 25 }] }, { "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".", - "locations": [ - { - "line": 15, - "column": 21 - } - ] + "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": 5 }] }, { "message": "Cannot query field \"myUnion\" on type \"User\".", - "locations": [ - { - "line": 32, - "column": 18 - } - ] + "locations": [{ "line": 32, "column": 5 }] } ] } diff --git a/test/Feature/Holistic/parsing/directive/operation/query.gql b/test/Feature/Holistic/parsing/directive/operation/query.gql --- a/test/Feature/Holistic/parsing/directive/operation/query.gql +++ b/test/Feature/Holistic/parsing/directive/operation/query.gql @@ -1,5 +1,5 @@ -query Foo @someDirective (name: "testName" ) { - user { - name - } +query Foo @someDirective(name: "testName") @test2 { + user { + name + } } diff --git a/test/Feature/Holistic/parsing/directive/operation/response.json b/test/Feature/Holistic/parsing/directive/operation/response.json --- a/test/Feature/Holistic/parsing/directive/operation/response.json +++ b/test/Feature/Holistic/parsing/directive/operation/response.json @@ -1,7 +1,12 @@ { - "data": { - "user": { - "name": "testName" + "errors": [ + { + "message": "Unknown Directive \"someDirective\".", + "locations": [{ "line": 1, "column": 11 }] + }, + { + "message": "Unknown Directive \"test2\".", + "locations": [{ "line": 1, "column": 44 }] } - } + ] } diff --git a/test/Feature/Holistic/parsing/directive/selection/query.gql b/test/Feature/Holistic/parsing/directive/selection/query.gql --- a/test/Feature/Holistic/parsing/directive/selection/query.gql +++ b/test/Feature/Holistic/parsing/directive/selection/query.gql @@ -1,6 +1,6 @@ query Foo { - user { - name @skip(name:"") @deprecated - email @someDir - } + user { + name @skip(if: false) @deprecated @do(id: 1) + email @someDir + } } diff --git a/test/Feature/Holistic/parsing/directive/selection/response.json b/test/Feature/Holistic/parsing/directive/selection/response.json --- a/test/Feature/Holistic/parsing/directive/selection/response.json +++ b/test/Feature/Holistic/parsing/directive/selection/response.json @@ -1,8 +1,16 @@ { - "data": { - "user": { - "name": "testName", - "email": "" + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on FIELD", + "locations": [{ "line": 3, "column": 27 }] + }, + { + "message": "Unknown Directive \"do\".", + "locations": [{ "line": 3, "column": 39 }] + }, + { + "message": "Unknown Directive \"someDir\".", + "locations": [{ "line": 4, "column": 11 }] } - } + ] } diff --git a/test/Feature/Holistic/parsing/generousSpaces/response.json b/test/Feature/Holistic/parsing/generousSpaces/response.json --- a/test/Feature/Holistic/parsing/generousSpaces/response.json +++ b/test/Feature/Holistic/parsing/generousSpaces/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 4, - "column": 5 + "column": 2 } ] } diff --git a/test/Feature/Holistic/parsing/invalidFields/response.json b/test/Feature/Holistic/parsing/invalidFields/response.json --- a/test/Feature/Holistic/parsing/invalidFields/response.json +++ b/test/Feature/Holistic/parsing/invalidFields/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, body, digit, letter, or white space\n", + "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, SelectionContent, digit, letter, or white space\n", "locations": [{ "line": 1, "column": 27 }] } ] diff --git a/test/Feature/Holistic/parsing/notNullSpacing/response.json b/test/Feature/Holistic/parsing/notNullSpacing/response.json --- a/test/Feature/Holistic/parsing/notNullSpacing/response.json +++ b/test/Feature/Holistic/parsing/notNullSpacing/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 2, - "column": 6 + "column": 3 } ] } diff --git a/test/Feature/Holistic/reservedNames/query.gql b/test/Feature/Holistic/reservedNames/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/reservedNames/query.gql @@ -0,0 +1,18 @@ +{ + type(in: { data: "some data" }) + + query: __type(name: "Query") { + fields { + name + args { + name + } + } + } + + input: __type(name: "TypeInput") { + inputFields { + name + } + } +} diff --git a/test/Feature/Holistic/reservedNames/response.json b/test/Feature/Holistic/reservedNames/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/reservedNames/response.json @@ -0,0 +1,16 @@ +{ + "data": { + "type": "some data", + "query": { + "fields": [ + { "name": "user", "args": [] }, + { "name": "testUnion", "args": [] }, + { "name": "fail1", "args": [] }, + { "name": "fail2", "args": [] }, + { "name": "person", "args": [] }, + { "name": "type", "args": [{ "name": "in" }] } + ] + }, + "input": { "inputFields": [{ "name": "data" }] } + } +} 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 @@ -68,6 +68,10 @@ """ union TestUnion = User | Address +interface Person { + name: String +} + """ User @@ -75,7 +79,7 @@ Test """ -type User { +type User implements Person { """ field description: name """ @@ -89,11 +93,17 @@ friend: User } +input TypeInput { + data: String! +} + type Query { user: User! testUnion: TestUnion fail1: String! fail2: Int! + person: Person! + type(in: TypeInput!): String! } type Mutation { diff --git a/test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql b/test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql @@ -0,0 +1,6 @@ +{ + user { + name @include + name2: name @skip + } +} diff --git a/test/Feature/Holistic/selection/directives/default/requiredArgument/response.json b/test/Feature/Holistic/selection/directives/default/requiredArgument/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/requiredArgument/response.json @@ -0,0 +1,12 @@ +{ + "errors": [ + { + "message": "Directive \"@include\" argument \"if\" is required but not provided.", + "locations": [{ "line": 3, "column": 10 }] + }, + { + "message": "Directive \"@skip\" argument \"if\" is required but not provided.", + "locations": [{ "line": 4, "column": 17 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/default/resolve/query.gql b/test/Feature/Holistic/selection/directives/default/resolve/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/resolve/query.gql @@ -0,0 +1,17 @@ +{ + user { + no_directives: name + + include_false: name @include(if: false) + include_true: name @include(if: true) + + skip_false: name @skip(if: false) + skip_true: name @skip(if: true) + + skip_true_include_true: name @skip(if: true) @include(if: true) + skip_true_include_false: name @skip(if: true) @include(if: false) + + skip_false_include_true: name @skip(if: false) @include(if: true) + skip_false_include_false: name @skip(if: false) @include(if: false) + } +} diff --git a/test/Feature/Holistic/selection/directives/default/resolve/response.json b/test/Feature/Holistic/selection/directives/default/resolve/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/resolve/response.json @@ -0,0 +1,10 @@ +{ + "data": { + "user": { + "no_directives": "testName", + "include_true": "testName", + "skip_false": "testName", + "skip_false_include_true": "testName" + } + } +} diff --git a/test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql b/test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql @@ -0,0 +1,17 @@ +{ + user { + no_directives: name + + include_false: name @include(if: false) + include_true: name @include(if: true) + + skip_false: name @skip(if: false) + skip_true: name @skip(if: true) + + skip_true_include_true: name @skip(if: true) @include(if: true) + skip_true_include_false: name @skip(if: true) @include(if: false) + + skip_false_include_true: name @skip(if: false) @include(if: true) + skip_false_include_false: name @skip(if: false) @include(if: false) + } +} diff --git a/test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json b/test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json @@ -0,0 +1,10 @@ +{ + "data": { + "user": { + "no_directives": "testName", + "include_true": "testName", + "skip_false": "testName", + "skip_false_include_true": "testName" + } + } +} diff --git a/test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql b/test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql @@ -0,0 +1,13 @@ +query TestFragments($x: Boolean! = false, $y: Boolean! = false) { + user { + name + ...UserName @skip(if: $x) + ... on User @include(if: $y) { + name2: name + } + } +} + +fragment UserName on User { + name1: name +} diff --git a/test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json b/test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json @@ -0,0 +1,1 @@ +{ "data": { "user": { "name": "testName", "name1": "testName" } } } diff --git a/test/Feature/Holistic/selection/directives/default/withMerge/query.gql b/test/Feature/Holistic/selection/directives/default/withMerge/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/withMerge/query.gql @@ -0,0 +1,15 @@ +query bla($x: Boolean! = false, $y: Boolean! = true) { + user @skip(if: $x) { + case1: name + } + user @include(if: $x) { + case2: name + } + + user2: user @skip(if: $y) { + case1: name + } + user2: user @include(if: $y) { + case2: name + } +} diff --git a/test/Feature/Holistic/selection/directives/default/withMerge/response.json b/test/Feature/Holistic/selection/directives/default/withMerge/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/withMerge/response.json @@ -0,0 +1,3 @@ +{ + "data": { "user": { "case1": "testName" }, "user2": { "case2": "testName" } } +} diff --git a/test/Feature/Holistic/selection/directives/default/withVariable/query.gql b/test/Feature/Holistic/selection/directives/default/withVariable/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/withVariable/query.gql @@ -0,0 +1,15 @@ +query bla($x: Boolean! = true, $y: Boolean! = false, $z: Boolean! = true) { + user1: user { + case1: name @skip(if: $x) + case2: name @include(if: $x) + } + + user2: user { + case1: name @skip(if: $y) + case2: name @include(if: $y) + } + + user3: user @skip(if: $z) { + case1: name + } +} diff --git a/test/Feature/Holistic/selection/directives/default/withVariable/response.json b/test/Feature/Holistic/selection/directives/default/withVariable/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/withVariable/response.json @@ -0,0 +1,3 @@ +{ + "data": { "user1": { "case2": "testName" }, "user2": { "case1": "testName" } } +} diff --git a/test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql b/test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql @@ -0,0 +1,12 @@ +{ + user { + testNull: name @include(if: null) + testNoolean: name @include(if: true) + testInt: name @include(if: 232) + tetsFloat: name @include(if: 232.1324) + testString: name @include(if: "some string") + testEnum: name @include(if: SomeEnum) + testObject: name @include(if: {}) + testList: name @include(if: []) + } +} diff --git a/test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json b/test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json @@ -0,0 +1,32 @@ +{ + "errors": [ + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found null.", + "locations": [{ "line": 3, "column": 29 }] + }, + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found 232.", + "locations": [{ "line": 5, "column": 28 }] + }, + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found 232.1324.", + "locations": [{ "line": 6, "column": 30 }] + }, + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found \"some string\".", + "locations": [{ "line": 7, "column": 31 }] + }, + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found \"SomeEnum\".", + "locations": [{ "line": 8, "column": 29 }] + }, + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found {}.", + "locations": [{ "line": 9, "column": 31 }] + }, + { + "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found [].", + "locations": [{ "line": 10, "column": 29 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql b/test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql @@ -0,0 +1,15 @@ +query bla($x: Boolean! = false, $y: Boolean! = true) { + user @skip(if: $x) @deprecated { + case1: name + } + user @include(if: $x) @deprecated { + case2: name + } + + user2: user @skip(if: $y) @deprecated { + case1: name + } + user2: user @include(if: $y) @deprecated { + case2: name + } +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json b/test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json @@ -0,0 +1,20 @@ +{ + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on FIELD", + "locations": [{ "line": 2, "column": 22 }] + }, + { + "message": "Directive \"deprecated\" may not to be used on FIELD", + "locations": [{ "line": 5, "column": 25 }] + }, + { + "message": "Directive \"deprecated\" may not to be used on FIELD", + "locations": [{ "line": 9, "column": 29 }] + }, + { + "message": "Directive \"deprecated\" may not to be used on FIELD", + "locations": [{ "line": 12, "column": 32 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql b/test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql @@ -0,0 +1,9 @@ +query { + user { + ...UserName @deprecated @include(if: false) @skip(if: true) + } +} + +fragment UserName on User { + name +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json b/test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json @@ -0,0 +1,8 @@ +{ + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on FRAGMENT_SPREAD", + "locations": [{ "line": 3, "column": 17 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql b/test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql @@ -0,0 +1,7 @@ +query { + user { + ... on User @deprecated @include(if: false) @skip(if: true) { + name + } + } +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json b/test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json @@ -0,0 +1,8 @@ +{ + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on INLINE_FRAGMENT", + "locations": [{ "line": 3, "column": 17 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql b/test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql @@ -0,0 +1,5 @@ +mutation SomeMutation @deprecated @skip(if: true) @include(if: true) { + createUser(userID: "test_id") { + name + } +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json b/test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on MUTATION", + "locations": [{ "line": 1, "column": 23 }] + }, + { + "message": "Directive \"skip\" may not to be used on MUTATION", + "locations": [{ "line": 1, "column": 35 }] + }, + { + "message": "Directive \"include\" may not to be used on MUTATION", + "locations": [{ "line": 1, "column": 51 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql b/test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql @@ -0,0 +1,5 @@ +query SomeQUery @deprecated @skip(if: true) @include(if: true) { + user { + name + } +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json b/test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on QUERY", + "locations": [{ "line": 1, "column": 17 }] + }, + { + "message": "Directive \"skip\" may not to be used on QUERY", + "locations": [{ "line": 1, "column": 29 }] + }, + { + "message": "Directive \"include\" may not to be used on QUERY", + "locations": [{ "line": 1, "column": 45 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/query.gql b/test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/query.gql @@ -0,0 +1,5 @@ +subscription SomeSubscription @deprecated @skip(if: true) @include(if: true) { + newUser { + name + } +} diff --git a/test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/response.json b/test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Directive \"deprecated\" may not to be used on SUBSCRIPTION", + "locations": [{ "line": 1, "column": 31 }] + }, + { + "message": "Directive \"skip\" may not to be used on SUBSCRIPTION", + "locations": [{ "line": 1, "column": 43 }] + }, + { + "message": "Directive \"include\" may not to be used on SUBSCRIPTION", + "locations": [{ "line": 1, "column": 59 }] + } + ] +} diff --git a/test/Feature/Holistic/selection/hasNoSubFields/response.json b/test/Feature/Holistic/selection/hasNoSubFields/response.json --- a/test/Feature/Holistic/selection/hasNoSubFields/response.json +++ b/test/Feature/Holistic/selection/hasNoSubFields/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 3, - "column": 10 + "column": 5 } ] } diff --git a/test/Feature/Holistic/selection/mergeConflict/alias/query.gql b/test/Feature/Holistic/selection/mergeConflict/alias/query.gql --- a/test/Feature/Holistic/selection/mergeConflict/alias/query.gql +++ b/test/Feature/Holistic/selection/mergeConflict/alias/query.gql @@ -3,17 +3,15 @@ bla: email email bla: email - address(coordinates: {latitude:"", longitude: []}) { + address(coordinates: { latitude: "", longitude: 1 }) { city - bla : city + bla: city } } user { - address(coordinates: {latitude:"", longitude: []}) { - street + address(coordinates: { latitude: "", longitude: 1 }) { 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 --- a/test/Feature/Holistic/selection/mergeConflict/alias/response.json +++ b/test/Feature/Holistic/selection/mergeConflict/alias/response.json @@ -5,18 +5,18 @@ "locations": [ { "line": 2, - "column": 8 + "column": 3 }, { "line": 6, - "column": 56 + "column": 5 }, { "line": 8, - "column": 25 + "column": 7 }, { - "line": 14, + "line": 13, "column": 7 } ] diff --git a/test/Feature/Holistic/selection/mergeConflict/arguments/response.json b/test/Feature/Holistic/selection/mergeConflict/arguments/response.json --- a/test/Feature/Holistic/selection/mergeConflict/arguments/response.json +++ b/test/Feature/Holistic/selection/mergeConflict/arguments/response.json @@ -5,19 +5,19 @@ "locations": [ { "line": 2, - "column": 8 + "column": 3 }, { "line": 6, - "column": 55 + "column": 5 }, { "line": 6, - "column": 55 + "column": 5 }, { "line": 12, - "column": 55 + "column": 5 } ] } diff --git a/test/Feature/Holistic/selection/mergeConflict/union/response.json b/test/Feature/Holistic/selection/mergeConflict/union/response.json --- a/test/Feature/Holistic/selection/mergeConflict/union/response.json +++ b/test/Feature/Holistic/selection/mergeConflict/union/response.json @@ -1,16 +1,11 @@ { "errors": [ { - "message": "\"name\" and \"email\" are different fields. Use different aliases on the fields to fetch both if this was intentional.", + "message": "Fields \"testUnion\" conflict because \"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 - } + { "line": 2, "column": 3 }, + { "line": 4, "column": 7 }, + { "line": 14, "column": 7 } ] } ] diff --git a/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json b/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json --- a/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json +++ b/test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 5, - "column": 14 + "column": 3 } ] } diff --git a/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json b/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json --- a/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json +++ b/test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 5, - "column": 14 + "column": 3 } ] }, @@ -14,7 +14,7 @@ "locations": [ { "line": 8, - "column": 24 + "column": 3 } ] } diff --git a/test/Feature/Input/Enum/API.hs b/test/Feature/Input/Enum/API.hs --- a/test/Feature/Input/Enum/API.hs +++ b/test/Feature/Input/Enum/API.hs @@ -1,17 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.Input.Enum.API - ( api - ) where + ( api, + ) +where -import Data.Morpheus (interpreter) -import Data.Morpheus.Kind (ENUM) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) -import GHC.Generics (Generic) +import Data.Morpheus (interpreter) +import Data.Morpheus.Kind (ENUM) +import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) +import GHC.Generics (Generic) data TwoCon = LA @@ -37,7 +38,8 @@ -- types & args newtype TestArgs a = TestArgs { level :: a - } deriving (Generic, Show) + } + deriving (Generic, Show) instance GQLType Level where type KIND Level = ENUM @@ -54,17 +56,18 @@ -- resolver data Query m = Query - { test :: TestArgs Level -> m Level - , test2 :: TestArgs TwoCon -> m TwoCon - , test3 :: TestArgs ThreeCon -> m ThreeCon - } deriving (Generic, GQLType) + { test :: TestArgs Level -> m Level, + test2 :: TestArgs TwoCon -> m TwoCon, + test3 :: TestArgs ThreeCon -> m ThreeCon + } + deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = Query {test = testRes, test2 = testRes, test3 = testRes} - , mutationResolver = Undefined - , subscriptionResolver = Undefined + { queryResolver = Query {test = testRes, test2 = testRes, test3 = testRes}, + mutationResolver = Undefined, + subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse 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 @@ -1,33 +1,35 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.Input.Object.API - ( api + ( api, ) where -import Data.Morpheus ( interpreter ) -import Data.Morpheus.Types ( GQLRequest - , GQLResponse - , GQLRootResolver(..) - , GQLType(..) - , Undefined(..) - ) -import GHC.Generics ( Generic ) -import Data.Morpheus.Kind ( INPUT ) -import Data.Text ( Text - , pack - ) - +import Data.Morpheus (interpreter) +import Data.Morpheus.Kind (INPUT) +import Data.Morpheus.Types + ( GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLType (..), + Undefined (..), + ) +import Data.Text + ( Text, + pack, + ) +import GHC.Generics (Generic) -data InputObject = InputObject { - field :: Text, - nullableField :: Maybe Int, - recursive :: Maybe InputObject -} deriving (Generic, Show) +data InputObject = InputObject + { field :: Text, + nullableField :: Maybe Int, + recursive :: Maybe InputObject + } + deriving (Generic, Show) instance GQLType InputObject where type KIND InputObject = INPUT @@ -35,22 +37,26 @@ -- types & args newtype Arg a = Arg { value :: a - } deriving (Generic, Show) + } + deriving (Generic, Show) -- query testRes :: Show a => Applicative m => Arg a -> m Text -testRes Arg { value } = pure $ pack $ show value +testRes Arg {value} = pure $ pack $ show value -- resolver newtype Query m = Query - { input :: Arg InputObject -> m Text - } deriving (Generic, GQLType) + { input :: Arg InputObject -> m Text + } + deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = GQLRootResolver { queryResolver = Query { input = testRes } - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } +rootResolver = + GQLRootResolver + { queryResolver = Query {input = testRes}, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/Input/Scalar/API.hs b/test/Feature/Input/Scalar/API.hs --- a/test/Feature/Input/Scalar/API.hs +++ b/test/Feature/Input/Scalar/API.hs @@ -1,44 +1,48 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.Input.Scalar.API - ( api + ( api, ) where -import Data.Morpheus ( interpreter ) -import Data.Morpheus.Types ( GQLRequest - , GQLResponse - , GQLRootResolver(..) - , GQLType(..) - , Undefined(..) - ) -import GHC.Generics ( Generic ) +import Data.Morpheus (interpreter) +import Data.Morpheus.Types + ( GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLType, + Undefined (..), + ) +import GHC.Generics (Generic) -- types & args newtype Arg a = Arg { value :: a - } deriving (Generic, Show) + } + deriving (Generic, Show) -- query testRes :: Applicative m => Arg a -> m a -testRes Arg { value } = pure value +testRes Arg {value} = pure value -- resolver data Query m = Query - { testFloat :: Arg Float -> m Float - , testInt :: Arg Int -> m Int - } deriving (Generic, GQLType) + { testFloat :: Arg Float -> m Float, + testInt :: Arg Int -> m Int + } + deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = GQLRootResolver - { queryResolver = Query { testFloat = testRes, testInt = testRes } - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } +rootResolver = + GQLRootResolver + { queryResolver = Query {testFloat = testRes, testInt = testRes}, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/InputType/API.hs b/test/Feature/InputType/API.hs --- a/test/Feature/InputType/API.hs +++ b/test/Feature/InputType/API.hs @@ -1,54 +1,63 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.InputType.API - ( api + ( api, ) where -import Data.Morpheus ( interpreter ) -import Data.Morpheus.Types ( GQLRequest - , GQLResponse - , GQLRootResolver(..) - , GQLType(..) - , IORes - , Undefined(..) - ) -import Data.Text ( Text ) -import GHC.Generics ( Generic ) +import Data.Morpheus (interpreter) +import Data.Morpheus.Types + ( GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLType (..), + ResolverQ, + Undefined (..), + ) +import Data.Text (Text) +import GHC.Generics (Generic) data F1Args = F1Args - { arg1 :: Text - , arg2 :: Maybe Int - } deriving (Generic) + { arg1 :: Text, + arg2 :: Maybe Int + } + deriving (Generic, GQLType) data F2Args = F2Args - { argList :: [Text] - , argNestedList :: [Maybe [[Int]]] - } deriving (Generic) + { argList :: [Text], + argNestedList :: [Maybe [[Int]]] + } + deriving (Generic, GQLType) data A = A - { a1 :: F1Args -> IORes () Text - , a2 :: F2Args -> IORes () Int - } deriving (Generic, GQLType) + { a1 :: F1Args -> ResolverQ () IO Text, + a2 :: F2Args -> ResolverQ () IO Int + } + deriving (Generic, GQLType) newtype Query (m :: * -> *) = Query { q1 :: A - } deriving (Generic, GQLType) + } + deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = GQLRootResolver - { queryResolver = Query - { q1 = A { a1 = const $ return "a1Test" - , a2 = const $ return 1 - } - } - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } +rootResolver = + GQLRootResolver + { queryResolver = + Query + { q1 = + A + { a1 = const $ return "a1Test", + a2 = const $ return 1 + } + }, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/Schema/A2.hs b/test/Feature/Schema/A2.hs --- a/test/Feature/Schema/A2.hs +++ b/test/Feature/Schema/A2.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module Feature.Schema.A2 - ( A(..) - ) where + ( A (..), + ) +where -import Data.Morpheus.Types (GQLType) -import GHC.Generics (Generic) +import Data.Morpheus.Types (GQLType) +import GHC.Generics (Generic) newtype A = A { bla :: Int - } deriving (Generic, GQLType) + } + deriving (Generic, GQLType) diff --git a/test/Feature/Schema/API.hs b/test/Feature/Schema/API.hs --- a/test/Feature/Schema/API.hs +++ b/test/Feature/Schema/API.hs @@ -1,35 +1,38 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.Schema.API - ( api - ) where + ( api, + ) +where -import Data.Morpheus (interpreter) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) -import Data.Text (Text) -import qualified Feature.Schema.A2 as A2 (A (..)) -import GHC.Generics (Generic) +import Data.Morpheus (interpreter) +import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) +import Data.Text (Text) +import qualified Feature.Schema.A2 as A2 (A (..)) +import GHC.Generics (Generic) data A = A - { aText :: Text - , aInt :: Int - } deriving (Generic, GQLType) + { aText :: Text, + aInt :: Int + } + deriving (Generic, GQLType) -data Query (m :: * -> * ) = Query - { a1 :: A - , a2 :: A2.A - } deriving (Generic, GQLType) +data Query (m :: * -> *) = Query + { a1 :: A, + a2 :: A2.A + } + deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = Query {a1 = A "" 0, a2 = A2.A 0} - , mutationResolver = Undefined - , subscriptionResolver = Undefined + { queryResolver = Query {a1 = A "" 0, a2 = A2.A 0}, + mutationResolver = Undefined, + subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse 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 @@ -1,105 +1,111 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.TypeInference.API - ( api + ( api, ) where -import Data.Morpheus ( interpreter ) -import Data.Morpheus.Kind ( INPUT ) -import Data.Morpheus.Types ( GQLRequest - , GQLResponse - , GQLRootResolver(..) - , GQLType(..) - , Undefined(..) - ) -import Data.Text ( Text - , pack - ) -import GHC.Generics ( Generic ) +import Data.Morpheus (interpreter) +import Data.Morpheus.Kind (INPUT) +import Data.Morpheus.Types + ( GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLType (..), + Undefined (..), + ) +import Data.Text + ( Text, + pack, + ) +import GHC.Generics (Generic) data Power = Thunderbolts | Shapeshift | Hurricanes - deriving (Generic,GQLType) + deriving (Generic, GQLType) -data Deity (m :: * -> *) = Deity { - name :: Text , - power :: Power -} deriving(Generic,GQLType) +data Deity (m :: * -> *) = Deity + { name :: Text, + power :: Power + } + deriving (Generic, GQLType) deityRes :: Deity m -deityRes = Deity { name = "Morpheus", power = Shapeshift } +deityRes = Deity {name = "Morpheus", power = Shapeshift} -data Hydra = Hydra { - name :: Text, - age :: Int -} deriving (Show,Generic) +data Hydra = Hydra + { name :: Text, + age :: Int + } + deriving (Show, Generic) instance GQLType Hydra where type KIND Hydra = INPUT -data Monster = - MonsterHydra Hydra - | Cerberus { name :: Text } +data Monster + = MonsterHydra Hydra + | Cerberus {name :: Text} | UnidentifiedMonster deriving (Show, Generic) instance GQLType Monster where type KIND Monster = INPUT -data Character (m :: * -> *) = - CharacterDeity (Deity m) -- Only should generate direct link - -- RECORDS - | Creature { creatureName :: Text, creatureAge :: Int } - | BoxedDeity { boxedDeity :: Deity m} - | ScalarRecord { scalarText :: Text } - --- Types - | CharacterInt Int -- all scalars mus be boxed - -- Types +data Character (m :: * -> *) + = CharacterDeity (Deity m) -- Only should generate direct link + -- RECORDS + | Creature {creatureName :: Text, creatureAge :: Int} + | BoxedDeity {boxedDeity :: Deity m} + | ScalarRecord {scalarText :: Text} + | --- Types + CharacterInt Int -- all scalars mus be boxed + -- Types | SomeDeity (Deity m) | SomeMutli Int Text - --- ENUMS - | Zeus - | Cronus deriving (Generic, GQLType) - + | --- ENUMS + Zeus + | Cronus + deriving (Generic, GQLType) -newtype MonsterArgs = MonsterArgs { - monster :: Monster -} deriving (Generic) +newtype MonsterArgs = MonsterArgs + { monster :: Monster + } + deriving (Generic) data Query (m :: * -> *) = Query { deity :: Deity m, character :: [Character m], showMonster :: MonsterArgs -> m Text - } deriving (Generic, GQLType) - -rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = GQLRootResolver - { queryResolver = Query { deity = deityRes, character, showMonster } - , mutationResolver = Undefined - , subscriptionResolver = Undefined } - where - showMonster MonsterArgs { monster } = pure (pack $ show monster) - character :: [Character m] - character = - [ CharacterDeity deityRes - , Creature { creatureName = "Lamia", creatureAge = 205 } - , BoxedDeity { boxedDeity = deityRes } - , ScalarRecord { scalarText = "Some Text" } - --- - , SomeDeity deityRes - , CharacterInt 12 - , SomeMutli 21 "some text" - , Zeus - , Cronus - ] + deriving (Generic, GQLType) +rootResolver :: GQLRootResolver IO () Query Undefined Undefined +rootResolver = + GQLRootResolver + { queryResolver = Query {deity = deityRes, character, showMonster}, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } + where + showMonster MonsterArgs {monster} = pure (pack $ show monster) + character :: [Character m] + character = + [ CharacterDeity deityRes, + Creature {creatureName = "Lamia", creatureAge = 205}, + BoxedDeity {boxedDeity = deityRes}, + ScalarRecord {scalarText = "Some Text"}, + --- + SomeDeity deityRes, + CharacterInt 12, + SomeMutli 21 "some text", + Zeus, + Cronus + ] api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/UnionType/API.hs b/test/Feature/UnionType/API.hs --- a/test/Feature/UnionType/API.hs +++ b/test/Feature/UnionType/API.hs @@ -1,39 +1,43 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.UnionType.API - ( api + ( api, ) where -import Data.Morpheus ( interpreter ) -import Data.Morpheus.Types ( GQLRequest - , GQLResponse - , GQLRootResolver(..) - , GQLType(..) - , IORes - , Undefined(..) - ) -import Data.Text ( Text ) -import GHC.Generics ( Generic ) +import Data.Morpheus (interpreter) +import Data.Morpheus.Types + ( GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLType (..), + ResolverQ, + Undefined (..), + ) +import Data.Text (Text) +import GHC.Generics (Generic) data A = A - { aText :: Text - , aInt :: Int - } deriving (Generic, GQLType) + { aText :: Text, + aInt :: Int + } + deriving (Generic, GQLType) data B = B - { bText :: Text - , bInt :: Int - } deriving (Generic, GQLType) + { bText :: Text, + bInt :: Int + } + deriving (Generic, GQLType) data C = C - { cText :: Text - , cInt :: Int - } deriving (Generic, GQLType) + { cText :: Text, + cInt :: Int + } + deriving (Generic, GQLType) data Sum = SumA A @@ -41,22 +45,26 @@ deriving (Generic, GQLType) data Query m = Query - { union :: () -> m [Sum] - , fc :: C - } deriving (Generic, GQLType) + { union :: () -> m [Sum], + fc :: C + } + deriving (Generic, GQLType) -resolveUnion :: () -> IORes () [Sum] +resolveUnion :: () -> ResolverQ () IO [Sum] resolveUnion _ = - return [SumA A { aText = "at", aInt = 1 }, SumB B { bText = "bt", bInt = 2 }] + return [SumA A {aText = "at", aInt = 1}, SumB B {bText = "bt", bInt = 2}] rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = GQLRootResolver - { queryResolver = Query { union = resolveUnion - , fc = C { cText = "", cInt = 3 } - } - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } +rootResolver = + GQLRootResolver + { queryResolver = + Query + { union = resolveUnion, + fc = C {cText = "", cInt = 3} + }, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/UnionType/cannotBeSpreadOnType/response.json b/test/Feature/UnionType/cannotBeSpreadOnType/response.json --- a/test/Feature/UnionType/cannotBeSpreadOnType/response.json +++ b/test/Feature/UnionType/cannotBeSpreadOnType/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "Fragment \"FC\" cannot be spread here as objects of type \"A, B\" can never be of type \"C\".", + "message": "Fragment \"FC\" cannot be spread here as objects of type \"A\", \"B\" can never be of type \"C\".", "locations": [ { "line": 3, diff --git a/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json --- a/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json +++ b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json @@ -1,13 +1,8 @@ { "errors": [ { - "message": "Fragment cannot be spread here as objects of type \"A, B\" can never be of type \"C\".", - "locations": [ - { - "line": 3, - "column": 5 - } - ] + "message": "Fragment cannot be spread here as objects of type \"A\", \"B\" can never be of type \"C\".", + "locations": [{ "line": 3, "column": 5 }] } ] } diff --git a/test/Feature/WrappedTypeName/API.hs b/test/Feature/WrappedTypeName/API.hs --- a/test/Feature/WrappedTypeName/API.hs +++ b/test/Feature/WrappedTypeName/API.hs @@ -1,63 +1,82 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Feature.WrappedTypeName.API - ( api - ) where + ( api, + ) +where -import Data.Morpheus (interpreter) -import Data.Morpheus.Types (Event, GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes, - constRes, subscribe) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Morpheus (interpreter) +import Data.Morpheus.Types + ( ComposedSubField, + Event, + GQLRequest, + GQLResponse, + GQLRootResolver (..), + GQLType (..), + constRes, + subscribe, + ) +import Data.Text (Text) +import GHC.Generics (Generic) data Wrapped a b = Wrapped - { fieldA :: a - , fieldB :: b - } deriving (Generic, GQLType) + { fieldA :: a, + fieldB :: b + } + deriving (Generic, GQLType) data WA m = WA - { aText :: () -> m Text - , aInt :: Int - } deriving (Generic,GQLType) + { aText :: () -> m Text, + aInt :: Int + } + deriving (Generic, GQLType) +type Wrapped1 = Wrapped Int Int + +type Wrapped2 = Wrapped (Wrapped Text Int) Text + data Query m = Query - { a1 :: WA m - , a2 :: Maybe (Wrapped Int Int) - , a3 :: Maybe (Wrapped (Wrapped Text Int) Text) - } deriving (Generic, GQLType) + { a1 :: WA m, + a2 :: Maybe Wrapped1, + a3 :: Maybe Wrapped2 + } + deriving (Generic, GQLType) data Mutation m = Mutation - { mut1 :: Maybe (WA m) - , mut2 :: Maybe (Wrapped Int Int) - , mut3 :: Maybe (Wrapped (Wrapped Text Int) Text) - } deriving (Generic, GQLType) + { mut1 :: Maybe (WA m), + mut2 :: Maybe Wrapped1, + mut3 :: Maybe Wrapped2 + } + deriving (Generic, GQLType) -data Channel = - Channel +data Channel + = Channel deriving (Show, Eq) -type EVENT = Event Channel () +type EVENT = Event Channel () data Subscription (m :: * -> *) = Subscription - { sub1 :: m (Maybe (WA (IORes EVENT))) - , sub2 :: m (Maybe (Wrapped Int Int)) - , sub3 :: m (Maybe (Wrapped (Wrapped Text Int) Text)) - } deriving (Generic, GQLType) + { sub1 :: ComposedSubField m Maybe WA, + sub2 :: m (Maybe Wrapped1), + sub3 :: m (Maybe Wrapped2) + } + deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver - { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing} - , mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing} - , subscriptionResolver = Subscription - { sub1 = subscribe [Channel] (pure $ constRes Nothing) - , sub2 = subscribe [Channel] (pure $ constRes Nothing) - , sub3 = subscribe [Channel] (pure $ constRes Nothing) - } + { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing}, + mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing}, + subscriptionResolver = + Subscription + { sub1 = subscribe [Channel] (pure $ constRes Nothing), + sub2 = subscribe [Channel] (pure $ constRes Nothing), + sub3 = subscribe [Channel] (pure $ constRes Nothing) + } } api :: GQLRequest -> IO GQLResponse diff --git a/test/Lib.hs b/test/Lib.hs --- a/test/Lib.hs +++ b/test/Lib.hs @@ -1,18 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} module Lib - ( getGQLBody - , getResponseBody - , getCases - , maybeVariables - ) where + ( getGQLBody, + getResponseBody, + getCases, + maybeVariables, + ) +where -import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON, Value (..), decode) -import qualified Data.ByteString.Lazy as L (readFile) -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Maybe (fromMaybe) -import Data.Text (Text, unpack) +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON, Value (..), decode) +import qualified Data.ByteString.Lazy as L (readFile) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Maybe (fromMaybe) +import Data.Text (Text, unpack) path :: Text -> String path name = "test/" ++ unpack name diff --git a/test/Rendering/Schema.hs b/test/Rendering/Schema.hs --- a/test/Rendering/Schema.hs +++ b/test/Rendering/Schema.hs @@ -1,29 +1,36 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Rendering.Schema - ( schemaProxy - ) where + ( schemaProxy, + ) +where -import Data.Morpheus.Document (importGQLDocumentWithNamespace) -import Data.Morpheus.Kind (SCALAR) -import Data.Morpheus.Types (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), ScalarValue (..), - Undefined (..)) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Morpheus.Document (importGQLDocumentWithNamespace) +import Data.Morpheus.Kind (SCALAR) +import Data.Morpheus.Types + ( GQLRootResolver (..), + GQLScalar (..), + GQLType (..), + ID (..), + ScalarValue (..), + Undefined (..), + ) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import GHC.Generics (Generic) -data TestScalar = - TestScalar +data TestScalar + = TestScalar deriving (Show, Generic) instance GQLType TestScalar where @@ -35,5 +42,5 @@ importGQLDocumentWithNamespace "test/Rendering/schema.gql" -schemaProxy :: Proxy (GQLRootResolver IO () Query Undefined Undefined) -schemaProxy = Proxy @(GQLRootResolver IO () Query Undefined Undefined) +schemaProxy :: Proxy (GQLRootResolver IO () Query Undefined Undefined) +schemaProxy = Proxy @(GQLRootResolver IO () Query Undefined Undefined) diff --git a/test/Rendering/TestSchemaRendering.hs b/test/Rendering/TestSchemaRendering.hs --- a/test/Rendering/TestSchemaRendering.hs +++ b/test/Rendering/TestSchemaRendering.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Rendering.TestSchemaRendering - ( testSchemaRendering - ) where + ( testSchemaRendering, + ) +where -import Data.Morpheus.Document (toGraphQLDocument) -import Rendering.Schema (schemaProxy) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (assertEqual, testCase) +import Data.Morpheus.Document (toGraphQLDocument) +import Rendering.Schema (schemaProxy) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertEqual, testCase) -- TODO: better Test testSchemaRendering :: TestTree @@ -16,4 +16,4 @@ where schema = toGraphQLDocument schemaProxy expected = - "enum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\ntype Query { \n user: User!\n testUnion: TestUnion\n}\n\nunion TestUnion =\n User\n | Address\n\nscalar TestScalar" + "enum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\ntype Query { \n user: User!\n testUnion: TestUnion\n}\n\nunion TestUnion =\n User\n | Address\n\nscalar TestScalar" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,57 +1,70 @@ {-# LANGUAGE OverloadedStrings #-} module Main - ( main + ( main, ) where -import qualified Feature.Holistic.API as Holistic - ( api ) -import qualified Feature.Input.Enum.API as InputEnum - ( api ) -import qualified Feature.Input.Scalar.API as InputScalar - ( api ) -import qualified Feature.Input.Object.API as InputObject - ( api ) -import qualified Feature.InputType.API as InputType - ( api ) -import qualified Feature.Schema.API as Schema - ( api ) -import qualified Feature.UnionType.API as UnionType - ( api ) -import qualified Feature.WrappedTypeName.API as TypeName - ( api ) -import qualified Feature.TypeInference.API as Inference - ( api ) -import Rendering.TestSchemaRendering ( testSchemaRendering ) -import Test.Tasty ( defaultMain - , testGroup - ) -import TestFeature ( testFeature ) +import qualified Feature.Holistic.API as Holistic + ( api, + ) +import qualified Feature.Input.Enum.API as InputEnum + ( api, + ) +import qualified Feature.Input.Object.API as InputObject + ( api, + ) +import qualified Feature.Input.Scalar.API as InputScalar + ( api, + ) +import qualified Feature.InputType.API as InputType + ( api, + ) +import qualified Feature.Schema.API as Schema + ( api, + ) +import qualified Feature.TypeInference.API as Inference + ( api, + ) +import qualified Feature.UnionType.API as UnionType + ( api, + ) +import qualified Feature.WrappedTypeName.API as TypeName + ( api, + ) +import Rendering.TestSchemaRendering (testSchemaRendering) +import Subscription.Test (testSubsriptions) +import Test.Tasty + ( defaultMain, + testGroup, + ) +import TestFeature (testFeature) main :: IO () main = do - ioTests <- testFeature Holistic.api "Feature/Holistic" - unionTest <- testFeature UnionType.api "Feature/UnionType" - inputTest <- testFeature InputType.api "Feature/InputType" - schemaTest <- testFeature Schema.api "Feature/Schema" - typeName <- testFeature TypeName.api "Feature/WrappedTypeName" - inputEnum <- testFeature InputEnum.api "Feature/Input/Enum" + ioTests <- testFeature Holistic.api "Feature/Holistic" + unionTest <- testFeature UnionType.api "Feature/UnionType" + inputTest <- testFeature InputType.api "Feature/InputType" + schemaTest <- testFeature Schema.api "Feature/Schema" + typeName <- testFeature TypeName.api "Feature/WrappedTypeName" + inputEnum <- testFeature InputEnum.api "Feature/Input/Enum" inputScalar <- testFeature InputScalar.api "Feature/Input/Scalar" inputObject <- testFeature InputObject.api "Feature/Input/Object" - inference <- testFeature Inference.api "Feature/TypeInference" + inference <- testFeature Inference.api "Feature/TypeInference" + subscription <- testSubsriptions defaultMain - (testGroup - "Morpheus Graphql Tests" - [ ioTests - , unionTest - , inputTest - , schemaTest - , typeName - , inputEnum - , inputScalar - , inputObject - , testSchemaRendering - , inference - ] + ( testGroup + "Morpheus Graphql Tests" + [ ioTests, + unionTest, + inputTest, + schemaTest, + typeName, + inputEnum, + inputScalar, + inputObject, + testSchemaRendering, + inference, + subscription + ] ) diff --git a/test/Subscription/API.hs b/test/Subscription/API.hs new file mode 100644 --- /dev/null +++ b/test/Subscription/API.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Subscription.API (api, EVENT, Channel (..), Info (..)) where + +import Data.Morpheus (interpreter) +import Data.Morpheus.Document (importGQLDocument) +import Data.Morpheus.Types + ( Event (..), + GQLRootResolver (..), + Input, + Stream, + subscribe, + ) +import Data.Text (Text) +import Subscription.Utils (SubM) + +data Channel + = DEITY + | HUMAN + deriving (Show, Eq) + +importGQLDocument "test/Subscription/schema.gql" + +type EVENT = Event Channel Info + +character :: Applicative m => m (Character m) +character = + pure + Character + { name = pure "testName", + age = pure 1 + } + +characterSub :: Applicative m => EVENT -> m (Character m) +characterSub (Event _ Info {name, age}) = + pure + Character + { name = pure name, + age = pure age + } + +rootResolver :: GQLRootResolver (SubM EVENT) EVENT Query Mutation Subscription +rootResolver = + GQLRootResolver + { queryResolver = + Query + { queryField = pure "" + }, + mutationResolver = + Mutation + { createDeity = const character, + createHuman = const character + }, + subscriptionResolver = + Subscription + { newDeity = subscribe [DEITY] (pure characterSub), + newHuman = subscribe [HUMAN] (pure characterSub) + } + } + +api :: Input api -> Stream api EVENT (SubM EVENT) +api = interpreter rootResolver diff --git a/test/Subscription/Case/ApolloRequest.hs b/test/Subscription/Case/ApolloRequest.hs new file mode 100644 --- /dev/null +++ b/test/Subscription/Case/ApolloRequest.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Subscription.Case.ApolloRequest + ( testApolloRequest, + SubM, + ) +where + +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Morpheus.Types + ( Input, + Stream, + ) +import Data.Morpheus.Types.Internal.Subscription + ( GQLChannel (..), + WS, + ) +import Subscription.Utils + ( SimulationState (..), + SubM, + apolloInit, + apolloStart, + apolloStop, + inputsAreConsumed, + storeIsEmpty, + storeSubscriptions, + stored, + storedSingle, + testResponse, + testSimulation, + ) +import Test.Tasty + ( TestTree, + testGroup, + ) + +testUnknownType :: + ( Eq (StreamChannel e), + GQLChannel e + ) => + (Input WS -> Stream WS e (SubM e)) -> + IO TestTree +testUnknownType = + testSimulation + test + ["{ \"type\":\"bla\" }"] + where + test _ SimulationState {inputs, outputs, store} = + testGroup + "unknown request type" + [ inputsAreConsumed inputs, + testResponse + ["Unknown Request type \"bla\"."] + outputs, + storeIsEmpty store + ] + +testConnectionInit :: + ( Eq (StreamChannel e), + GQLChannel e + ) => + (Input WS -> Stream WS e (SubM e)) -> + IO TestTree +testConnectionInit = testSimulation test [apolloInit] + where + test input SimulationState {inputs, outputs, store} = + testGroup + "connection init" + [ inputsAreConsumed inputs, + testResponse + [] + outputs, + stored input store, + storedSingle store + ] + +startSub :: ByteString -> ByteString +startSub = apolloStart "subscription MySubscription { newDeity { name }}" + +testSubscriptionStart :: + ( Eq (StreamChannel e), + GQLChannel e + ) => + (Input WS -> Stream WS e (SubM e)) -> + IO TestTree +testSubscriptionStart = + testSimulation + test + [ apolloInit, + startSub "1", + startSub "5" + ] + where + test input SimulationState {inputs, outputs, store} = + testGroup + "subscription start" + [ inputsAreConsumed inputs, + testResponse + [] + outputs, + storeSubscriptions + input + ["1", "5"] + store + ] + +testSubscriptionStop :: + ( Eq (StreamChannel e), + GQLChannel e + ) => + (Input WS -> Stream WS e (SubM e)) -> + IO TestTree +testSubscriptionStop = + testSimulation + test + [ apolloInit, + startSub "1", + startSub "5", + apolloStop "1" + ] + where + test input SimulationState {inputs, outputs, store} = + testGroup + "stop subscription" + [ inputsAreConsumed inputs, + testResponse + [] + outputs, + storeSubscriptions + input + ["5"] + store + ] + +testApolloRequest :: + ( Eq (StreamChannel e), + GQLChannel e + ) => + (Input WS -> Stream WS e (SubM e)) -> + IO TestTree +testApolloRequest api = do + unknownType <- testUnknownType api + connection_init <- testConnectionInit api + start <- testSubscriptionStart api + stop <- testSubscriptionStop api + return $ testGroup "ApolloRequest" [unknownType, connection_init, start, stop] diff --git a/test/Subscription/Case/Publishing.hs b/test/Subscription/Case/Publishing.hs new file mode 100644 --- /dev/null +++ b/test/Subscription/Case/Publishing.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Subscription.Case.Publishing + ( testPublishing, + ) +where + +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.Morpheus.Types + ( Event (..), + Input, + ) +import Data.Morpheus.Types.Internal.Subscription + ( WS, + connect, + empty, + ) +import Subscription.API + ( Channel (..), + EVENT, + Info (..), + api, + ) +import Subscription.Utils + ( SimulationState (..), + apolloInit, + apolloRes, + apolloStart, + apolloStop, + inputsAreConsumed, + simulate, + simulatePublish, + storeSubscriptions, + testResponse, + ) +import Test.Tasty + ( TestTree, + testGroup, + ) + +startNewDeity :: ByteString -> ByteString +startNewDeity = apolloStart "subscription MySubscription { newDeity { name , age }}" + +startNewHuman :: ByteString -> ByteString +startNewHuman = apolloStart "subscription MySubscription { newHuman { name , age }}" + +simulateSubscriptions :: IO (Input WS, SimulationState EVENT) +simulateSubscriptions = do + input <- connect + state <- + simulate + api + input + ( SimulationState + [ apolloInit, + startNewDeity "1", + startNewDeity "2", + startNewDeity "3", + startNewHuman "4", + apolloStop "1" + ] + [] + empty + ) + pure (input, state) + +triggerSubsciption :: + IO TestTree +triggerSubsciption = do + (input, state) <- simulateSubscriptions + SimulationState {inputs, outputs, store} <- + simulatePublish (Event [DEITY] Info {name = "Zeus", age = 1200}) state + >>= simulatePublish (Event [HUMAN] Info {name = "Hercules", age = 18}) + pure $ + testGroup + "publish event" + [ inputsAreConsumed inputs, + testResponse + -- triggers subscriptions by channels + [ apolloRes + "2" + "{\"newDeity\":{\"name\":\"Zeus\",\"age\":1200}}", + apolloRes + "3" + "{\"newDeity\":{\"name\":\"Zeus\",\"age\":1200}}", + apolloRes + "4" + "{\"newHuman\":{\"name\":\"Hercules\",\"age\":18}}" + ] + outputs, + storeSubscriptions + input + ["2", "3", "4"] + store + ] + +testPublishing :: IO TestTree +testPublishing = do + trigger <- triggerSubsciption + return $ testGroup "Publishing" [trigger] diff --git a/test/Subscription/Test.hs b/test/Subscription/Test.hs new file mode 100644 --- /dev/null +++ b/test/Subscription/Test.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Subscription.Test (testSubsriptions) where + +import qualified Subscription.API as TS +import Subscription.Case.ApolloRequest (testApolloRequest) +import Subscription.Case.Publishing (testPublishing) +import Test.Tasty (TestTree, testGroup) + +testSubsriptions :: IO TestTree +testSubsriptions = do + subscription <- testApolloRequest TS.api + publishing <- testPublishing + return $ testGroup "Subscription" [subscription, publishing] diff --git a/test/Subscription/Utils.hs b/test/Subscription/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Subscription/Utils.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module Subscription.Utils + ( SimulationState (..), + simulate, + expectedResponse, + SubM, + testResponse, + inputsAreConsumed, + storeIsEmpty, + storedSingle, + stored, + storeSubscriptions, + simulatePublish, + apolloStart, + apolloStop, + apolloRes, + apolloInit, + testSimulation, + ) +where + +import Control.Monad.State.Lazy + ( StateT, + runStateT, + state, + ) +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.List + ( sort, + ) +import Data.Maybe + ( isJust, + ) +import Data.Morpheus.Types + ( Input, + Stream, + ) +import Data.Morpheus.Types.Internal.Subscription + ( ClientConnectionStore, + GQLChannel (..), + Input (..), + Scope (..), + SessionID, + WS, + connect, + connectionSessionIds, + empty, + publish, + runStreamWS, + toList, + ) +import Data.Semigroup + ( (<>), + ) +import Test.Tasty + ( TestTree, + ) +import Test.Tasty.HUnit + ( assertEqual, + assertFailure, + testCase, + ) + +data SimulationState e = SimulationState + { inputs :: [ByteString], + outputs :: [ByteString], + store :: ClientConnectionStore e (SubM e) + } + +type Store e = ClientConnectionStore e (SubM e) + +type SubM e = StateT (SimulationState e) IO + +addOutput :: ByteString -> SimulationState e -> ((), SimulationState e) +addOutput x (SimulationState i xs st) = ((), SimulationState i (xs <> [x]) st) + +updateStore :: (Store e -> Store e) -> SimulationState e -> ((), SimulationState e) +updateStore up (SimulationState i o st) = ((), SimulationState i o (up st)) + +readInput :: SimulationState e -> (ByteString, SimulationState e) +readInput (SimulationState (i : ins) o s) = (i, SimulationState ins o s) +readInput (SimulationState [] o s) = ("", SimulationState [] o s) + +wsApp :: + (Input WS -> Stream WS e (SubM e)) -> + Input WS -> + SubM e () +wsApp api input = + runStreamWS + ScopeWS + { update = state . updateStore, + listener = state readInput, + callback = state . addOutput + } + (api input) + +simulatePublish :: + (GQLChannel e, Eq (StreamChannel e)) => + e -> + SimulationState e -> + IO (SimulationState e) +simulatePublish event s = snd <$> runStateT (publish event (store s)) s + +simulate :: + (Input WS -> Stream WS e (SubM e)) -> + Input WS -> + SimulationState e -> + IO (SimulationState e) +simulate _ _ s@SimulationState {inputs = []} = pure s +simulate api input s = snd <$> runStateT (wsApp api input) s >>= simulate api input + +testSimulation :: + (Input WS -> SimulationState e -> TestTree) -> + [ByteString] -> + (Input WS -> Stream WS e (SubM e)) -> + IO TestTree +testSimulation test simInputs api = do + input <- connect + s <- simulate api input (SimulationState simInputs [] empty) + pure $ test input s + +expectedResponse :: [ByteString] -> [ByteString] -> IO () +expectedResponse expected value + | expected == value = return () + | otherwise = + assertFailure $ "expected: \n " <> show expected <> " \n but got: \n " <> show value + +testResponse :: [ByteString] -> [ByteString] -> TestTree +testResponse expected = + testCase + "expected response" + . expectedResponse + expected + +inputsAreConsumed :: [ByteString] -> TestTree +inputsAreConsumed = + testCase "inputs are consumed" + . assertEqual + "input stream should be consumed" + [] + +storeIsEmpty :: Store e -> TestTree +storeIsEmpty cStore + | null (toList cStore) = + testCase "connectionStore: is empty" $ return () + | otherwise = + testCase "connectionStore: is empty" + $ assertFailure + $ " must be empty but " + <> show + cStore + +storedSingle :: Store e -> TestTree +storedSingle cStore + | length (toList cStore) == 1 = + testCase "stored single connection" $ return () + | otherwise = + testCase "stored single connection" + $ assertFailure + $ "connectionStore must store single connection" + <> show + cStore + +stored :: Input WS -> Store e -> TestTree +stored (Init uuid) cStore + | isJust (lookup uuid (toList cStore)) = + testCase "stored connection" $ return () + | otherwise = + testCase "stored connection" + $ assertFailure + $ " must store connection \"" <> show uuid <> "\" but stored: " + <> show + cStore + +storeSubscriptions :: + Input WS -> + [SessionID] -> + Store e -> + TestTree +storeSubscriptions + (Init uuid) + sids + cStore = + checkSession (lookup uuid (toList cStore)) + where + checkSession (Just conn) + | sort sids == sort (connectionSessionIds conn) = + testCase "stored subscriptions" $ return () + | otherwise = + testCase "stored subscriptions" + $ assertFailure + $ " must store subscriptions with id \"" <> show sids <> "\" but stored: " + <> show + (connectionSessionIds conn) + checkSession _ = + testCase "stored connection" + $ assertFailure + $ " must store connection \"" <> show uuid <> "\" but: " + <> show + cStore + +apolloStart :: ByteString -> ByteString -> ByteString +apolloStart query sid = "{\"id\":\"" <> sid <> "\",\"type\":\"start\",\"payload\":{\"variables\":{},\"operationName\":\"MySubscription\",\"query\":\"" <> query <> "\"}}" + +apolloStop :: ByteString -> ByteString +apolloStop x = "{\"id\":\"" <> x <> "\",\"type\":\"stop\"}" + +apolloRes :: ByteString -> ByteString -> ByteString +apolloRes sid value = "{\"id\":\"" <> sid <> "\",\"type\":\"data\",\"payload\":{\"data\":" <> value <> "}}" + +apolloInit :: ByteString +apolloInit = "{ \"type\":\"connection_init\" }" diff --git a/test/Subscription/schema.gql b/test/Subscription/schema.gql new file mode 100644 --- /dev/null +++ b/test/Subscription/schema.gql @@ -0,0 +1,25 @@ +input Info + { name: String! + , age: Int! + } + +type Character { + name: String! + age: Int! +} + +type Query { + queryField: String! +} + +type Mutation { + createDeity + ( input: Info! ): Character! + createHuman + ( input: Info! ): Character! +} + +type Subscription { + newDeity: Character! + newHuman: Character! +} diff --git a/test/TestFeature.hs b/test/TestFeature.hs --- a/test/TestFeature.hs +++ b/test/TestFeature.hs @@ -1,44 +1,38 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module TestFeature - ( testFeature - ) where - -import qualified Data.Text.Lazy as LT (toStrict) -import Data.Text.Lazy.Encoding (decodeUtf8) + ( testFeature, + ) +where -import Data.Aeson (FromJSON, Value, decode, encode) -import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Aeson (Value, decode, encode) +import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB (unpack) -import Data.Morpheus.Types (GQLRequest (..), GQLResponse (..)) -import Data.Semigroup ((<>)) -import Data.Text (Text, unpack) -import qualified Data.Text as T (concat) -import GHC.Generics -import Lib (getCases, getGQLBody, getResponseBody, maybeVariables) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase) +import Data.Morpheus.Types (GQLRequest (..), GQLResponse (..)) +import Data.Semigroup ((<>)) +import Data.Text (unpack) +import qualified Data.Text.Lazy as LT (toStrict) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Lib (getGQLBody, getResponseBody, maybeVariables) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase) +import Types + ( Case (..), + Name, + testWith, + ) packGQLRequest :: ByteString -> Maybe Value -> GQLRequest -packGQLRequest queryBS variables = GQLRequest - { operationName = Nothing - , query = LT.toStrict $ decodeUtf8 queryBS - , variables - } - -data Case = Case - { path :: Text - , description :: String - } deriving (Generic, FromJSON) +packGQLRequest queryBS variables = + GQLRequest + { operationName = Nothing, + query = LT.toStrict $ decodeUtf8 queryBS, + variables + } -testFeature :: (GQLRequest -> IO GQLResponse) -> Text -> IO TestTree -testFeature api dir = do - cases' <- getCases (unpack dir) - test' <- sequence $ testByFiles api <$> map (\x -> x {path = T.concat [dir, "/", path x]}) cases' - return $ testGroup (unpack dir) test' +testFeature :: (GQLRequest -> IO GQLResponse) -> Name -> IO TestTree +testFeature api = testWith (testByFiles api) testByFiles :: (GQLRequest -> IO GQLResponse) -> Case -> IO TestTree testByFiles testApi Case {path, description} = do @@ -49,7 +43,8 @@ case decode actualResponse of Nothing -> assertFailure "Bad Response" Just response -> return $ testCase (unpack path ++ " | " ++ description) $ customTest expectedResponse response - where customTest expected value - | expected == value = return () - | otherwise = - assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse + where + customTest expected value + | expected == value = return () + | otherwise = + assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse diff --git a/test/Types.hs b/test/Types.hs new file mode 100644 --- /dev/null +++ b/test/Types.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Types + ( Case (..), + Name, + testWith, + ) +where + +import Data.Aeson (FromJSON) +import Data.Text (Text, unpack) +import qualified Data.Text as T (concat) +import GHC.Generics +import Lib (getCases) +import Test.Tasty (TestTree, testGroup) + +type Name = Text + +data Case = Case + { path :: Text, + description :: String + } + deriving (Generic, FromJSON) + +testWith :: (Case -> IO TestTree) -> Name -> IO TestTree +testWith f dir = do + cases <- getCases (unpack dir) + test <- sequence $ f <$> map (\x -> x {path = T.concat [dir, "/", path x]}) cases + return $ testGroup (unpack dir) test