From f83005362629bbb7874e91fca772f063f82222c5 Mon Sep 17 00:00:00 2001 From: David Nalchevanidze Date: Mon, 15 Apr 2024 13:33:13 +0200 Subject: [PATCH] Feature: disable introspection (#849) * config * disableINtrospetion * validation * config * fix * format-lint * update cabal * no-warnings * fix-test * update * disableIntrospection * update App * disableIntrospection * introspection fields * update * query * update * disable-introspection * update * update * update query * queries * fix tests * __type * format fix --- config/stack.yaml | 6 +- .../morpheus-graphql-examples-client.cabal | 2 +- ...rpheus-graphql-examples-scotty-fraxl.cabal | 41 ------------ examples/scotty/src/Server/MonadIO/API.hs | 11 ++-- .../morpheus-graphql-examples-servant.cabal | 2 +- .../examples-subscription-extpubsub.cabal | 63 ------------------- .../morpheus-graphql-app.cabal | 11 +++- morpheus-graphql-app/src/Data/Morpheus/App.hs | 23 ++++--- .../Internal/Resolving/RootResolverValue.hs | 21 ++++--- .../test/DisableIntrospection.hs | 42 +++++++++++++ morpheus-graphql-app/test/Spec.hs | 5 +- .../test/disable-introspection/name/query.gql | 3 + .../disable-introspection/name/response.json | 3 + .../test/disable-introspection/resolvers.json | 5 ++ .../test/disable-introspection/schema.gql | 3 + .../disable-introspection/schema/query.gql | 12 ++++ .../schema/response.json | 3 + .../test/disable-introspection/type/query.gql | 5 ++ .../disable-introspection/type/response.json | 3 + .../morpheus-graphql-benchmarks.cabal | 54 ---------------- .../Client/CodeGen/Interpreting/Core.hs | 7 ++- .../test/Case/ResponseTypes/Test.hs | 1 + .../CodeGen/Server/Interpreting/Transform.hs | 28 ++++----- .../src/Data/Morpheus/Parser.hs | 7 +-- .../Morpheus/Parsing/Document/TypeSystem.hs | 20 +++--- .../src/Data/Morpheus/Schema/DSL.hs | 4 +- .../Data/Morpheus/Types/Internal/Config.hs | 9 ++- .../src/Data/Morpheus/Server.hs | 4 +- .../src/Data/Morpheus/Subscriptions/Apollo.hs | 11 ++-- .../test/Subscription/Case/ApolloRequest.hs | 3 +- .../test/Subscription/Case/Publishing.hs | 1 - stack.yaml | 7 ++- 32 files changed, 186 insertions(+), 234 deletions(-) delete mode 100644 examples/scotty-fraxl/morpheus-graphql-examples-scotty-fraxl.cabal delete mode 100644 examples/subscription-extpubsub/examples-subscription-extpubsub.cabal create mode 100644 morpheus-graphql-app/test/DisableIntrospection.hs create mode 100644 morpheus-graphql-app/test/disable-introspection/name/query.gql create mode 100644 morpheus-graphql-app/test/disable-introspection/name/response.json create mode 100644 morpheus-graphql-app/test/disable-introspection/resolvers.json create mode 100644 morpheus-graphql-app/test/disable-introspection/schema.gql create mode 100644 morpheus-graphql-app/test/disable-introspection/schema/query.gql create mode 100644 morpheus-graphql-app/test/disable-introspection/schema/response.json create mode 100644 morpheus-graphql-app/test/disable-introspection/type/query.gql create mode 100644 morpheus-graphql-app/test/disable-introspection/type/response.json delete mode 100644 morpheus-graphql-benchmarks/morpheus-graphql-benchmarks.cabal diff --git a/config/stack.yaml b/config/stack.yaml index b9462382ba..cc1d9d7df6 100644 --- a/config/stack.yaml +++ b/config/stack.yaml @@ -74,6 +74,9 @@ rules: aeson: - 1.4.4 - 3.0.0 + attoparsec-aeson: + - 2.1.0 + - '3' base: - 4.7.0 - 5.0.0 @@ -158,7 +161,4 @@ rules: yaml: - 0.8.32 - 1.0.0 - attoparsec-aeson: - - 2.1.0 - - 3 version: 0.27.3 diff --git a/examples/client/morpheus-graphql-examples-client.cabal b/examples/client/morpheus-graphql-examples-client.cabal index 01f92b4f2b..1d39d01f29 100644 --- a/examples/client/morpheus-graphql-examples-client.cabal +++ b/examples/client/morpheus-graphql-examples-client.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack diff --git a/examples/scotty-fraxl/morpheus-graphql-examples-scotty-fraxl.cabal b/examples/scotty-fraxl/morpheus-graphql-examples-scotty-fraxl.cabal deleted file mode 100644 index d1202ac5c0..0000000000 --- a/examples/scotty-fraxl/morpheus-graphql-examples-scotty-fraxl.cabal +++ /dev/null @@ -1,41 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.35.0. --- --- see: https://github.com/sol/hpack - -name: morpheus-graphql-examples-scotty-fraxl -version: 0.1.0 -synopsis: examples -description: Fraxl example of GraphQL APIs -category: web, graphql -homepage: https://github.com/nalchevanidze/morpheus-graphql#readme -bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues -author: Daviti Nalchevanidze -maintainer: Daviti Nalchevanidze -copyright: (c) 2019 Daviti Nalchevanidze -license: MIT -build-type: Simple - -source-repository head - type: git - location: https://github.com/nalchevanidze/morpheus-graphql - -executable scotty-server-fraxl - main-is: Main.hs - other-modules: - Fraxl.API - Fraxl.FakeDB - Paths_morpheus_graphql_examples_scotty_fraxl - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - base >=4.7 && <5 - , containers >=0.4.2.1 && <0.7 - , fraxl - , morpheus-graphql - , mtl >=2.0 && <=2.3 - , scotty - , text >=1.2.3.0 && <1.3 - default-language: Haskell2010 diff --git a/examples/scotty/src/Server/MonadIO/API.hs b/examples/scotty/src/Server/MonadIO/API.hs index 998f57e5d4..39934ec2a6 100644 --- a/examples/scotty/src/Server/MonadIO/API.hs +++ b/examples/scotty/src/Server/MonadIO/API.hs @@ -18,6 +18,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Server.MonadIO.API where @@ -221,7 +222,7 @@ addDogResolver (Arg name) = do dogResolver dogToAdd ------------------------------------------------------------------------------- -userResolver :: RESOLVER t => UserRow -> Value t User +userResolver :: (RESOLVER t) => UserRow -> Value t User userResolver UserRow {userId = thisUserId, userFullName} = pure $ User @@ -233,7 +234,7 @@ userResolver UserRow {userId = thisUserId, userFullName} = where idResolver = pure thisUserId nameResolver = pure userFullName - favoriteDogResolver :: RESOLVER t => Wrapped t Maybe Dog + favoriteDogResolver :: (RESOLVER t) => Wrapped t Maybe Dog favoriteDogResolver = do dogs <- fmap dogTable getDB -- the 1st dog is the favorite dog @@ -242,7 +243,7 @@ userResolver UserRow {userId = thisUserId, userFullName} = dog <- dogResolver dogRow return . Just $ dog Nothing -> return Nothing - followsResolver :: RESOLVER t => Wrapped t [] User + followsResolver :: (RESOLVER t) => Wrapped t [] User followsResolver = do follows <- fmap followTable getDB users <- fmap userTable getDB @@ -251,13 +252,13 @@ userResolver UserRow {userId = thisUserId, userFullName} = let userFollowees = filter ((`elem` userFolloweeIds) . userId) users traverse userResolver userFollowees -dogResolver :: RESOLVER t => DogRow -> Value t Dog +dogResolver :: (RESOLVER t) => DogRow -> Value t Dog dogResolver (DogRow dogId dogName ownerId) = pure $ Dog {id = idResolver, name = nameResolver, owner = ownerResolver} where idResolver = pure dogId nameResolver = pure dogName - ownerResolver :: RESOLVER t => Value t User + ownerResolver :: (RESOLVER t) => Value t User ownerResolver = do users <- fmap userTable getDB let userRow = fromJust . find ((== ownerId) . userId) $ users diff --git a/examples/servant/morpheus-graphql-examples-servant.cabal b/examples/servant/morpheus-graphql-examples-servant.cabal index c1345c37a7..b11fbbd6e7 100644 --- a/examples/servant/morpheus-graphql-examples-servant.cabal +++ b/examples/servant/morpheus-graphql-examples-servant.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack diff --git a/examples/subscription-extpubsub/examples-subscription-extpubsub.cabal b/examples/subscription-extpubsub/examples-subscription-extpubsub.cabal deleted file mode 100644 index aa3670aa1d..0000000000 --- a/examples/subscription-extpubsub/examples-subscription-extpubsub.cabal +++ /dev/null @@ -1,63 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.4. --- --- see: https://github.com/sol/hpack - -name: examples-subscription-extpubsub -version: 0.1.0 -synopsis: examples of external pub-sub -description: examples of a GraphQL server using postgresql/rabbitmq as a pusub -category: web, graphql -homepage: https://github.com/nalchevanidze/morpheus-graphql#readme -bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues -author: Théophile Batoz -maintainer: Théophile Batoz -copyright: (c) 2019 Théophile Batoz -license: MIT -build-type: Simple - -source-repository head - type: git - location: https://github.com/nalchevanidze/morpheus-graphql - -library - exposed-modules: - Server - other-modules: - Paths_examples_subscription_extpubsub - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - , hasql - , hasql-notifications - , morpheus-graphql - , morpheus-graphql-core - , scotty >=0.11 - , text - , wai-websockets - , warp - , websockets >=0.12 - default-language: Haskell2010 - -executable examples-subscription-extpubsub-exe - main-is: Main.hs - other-modules: - Paths_examples_subscription_extpubsub - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , examples-subscription-extpubsub - , hasql - , hasql-notifications - , morpheus-graphql - , morpheus-graphql-core - , scotty >=0.11 - , text - , wai-websockets - , warp - , websockets >=0.12 - default-language: Haskell2010 diff --git a/morpheus-graphql-app/morpheus-graphql-app.cabal b/morpheus-graphql-app/morpheus-graphql-app.cabal index d2a3de6fa2..f3f1420ae0 100644 --- a/morpheus-graphql-app/morpheus-graphql-app.cabal +++ b/morpheus-graphql-app/morpheus-graphql-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -46,6 +46,10 @@ data-files: test/batching/objects-fields/query.gql test/batching/objects-lists-fields/query.gql test/batching/schema.gql + test/disable-introspection/name/query.gql + test/disable-introspection/schema.gql + test/disable-introspection/schema/query.gql + test/disable-introspection/type/query.gql test/execution/many/query.gql test/execution/schema.gql test/execution/single/query.gql @@ -99,6 +103,10 @@ data-files: test/batching/objects-fields/response.json test/batching/objects-lists-fields/batching.json test/batching/objects-lists-fields/response.json + test/disable-introspection/name/response.json + test/disable-introspection/resolvers.json + test/disable-introspection/schema/response.json + test/disable-introspection/type/response.json test/execution/many/response.json test/execution/single/response.json test/merge/schema/query-subscription-mutation/app-1.json @@ -176,6 +184,7 @@ test-suite morpheus-graphql-app-test other-modules: APIConstraints Batching + DisableIntrospection Execution NamedResolvers Paths_morpheus_graphql_app diff --git a/morpheus-graphql-app/src/Data/Morpheus/App.hs b/morpheus-graphql-app/src/Data/Morpheus/App.hs index b8e1a6ee41..1bd1f4cb0e 100644 --- a/morpheus-graphql-app/src/Data/Morpheus/App.hs +++ b/morpheus-graphql-app/src/Data/Morpheus/App.hs @@ -15,6 +15,7 @@ module Data.Morpheus.App AppData (..), runApp, withDebugger, + disableIntrospection, mkApp, runAppStream, MapAPI (..), @@ -74,7 +75,7 @@ import Data.Morpheus.Types.Internal.AST import qualified Data.Morpheus.Types.Internal.AST as AST import Relude hiding (ByteString, empty) -mkApp :: ValidateSchema s => Schema s -> RootResolverValue e m -> App e m +mkApp :: (ValidateSchema s) => Schema s -> RootResolverValue e m -> App e m mkApp appSchema appResolvers = resultOr FailApp @@ -89,7 +90,7 @@ instance RenderGQL (App e m) where renderGQL App {app} = renderGQL app renderGQL FailApp {appErrors} = renderGQL $ A.encode $ toList appErrors -instance Monad m => Semigroup (App e m) where +instance (Monad m) => Semigroup (App e m) where (FailApp err1) <> (FailApp err2) = FailApp (err1 <> err2) FailApp {appErrors} <> App {} = FailApp appErrors App {} <> FailApp {appErrors} = FailApp appErrors @@ -107,7 +108,7 @@ data AppData event (m :: Type -> Type) s = AppData instance RenderGQL (AppData e m s) where renderGQL = renderGQL . appSchema -instance Monad m => Stitching (AppData e m s) where +instance (Monad m) => Stitching (AppData e m s) where stitch x y = AppData (appConfig y) @@ -177,12 +178,12 @@ rootType OPERATION_MUTATION = mutation rootType OPERATION_SUBSCRIPTION = subscription stateless :: - Functor m => + (Functor m) => ResponseStream event m (Value VALID) -> m GQLResponse stateless = fmap (renderResponse . fmap snd) . runResultT -runAppStream :: Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID) +runAppStream :: (Monad m) => App event m -> GQLRequest -> ResponseStream event m (Value VALID) runAppStream App {app} = runAppData app runAppStream FailApp {appErrors} = const $ throwErrors appErrors @@ -194,10 +195,16 @@ mapApp f App {app} = App {app = f app} mapApp _ x = x -withDebugger :: App e m -> App e m -withDebugger = mapApp f +mapConfig :: (Config -> Config) -> App e m -> App e m +mapConfig g = mapApp f where - f AppData {appConfig = Config {..}, ..} = AppData {appConfig = Config {debug = True, ..}, ..} + f AppData {appConfig, ..} = AppData {appConfig = g appConfig, ..} + +withDebugger :: App e m -> App e m +withDebugger = mapConfig (\c -> c {debug = True}) + +disableIntrospection :: App e m -> App e m +disableIntrospection = mapConfig (\c -> c {introspection = False}) withConstraint :: APIConstraint -> App e m -> App e m withConstraint constraint = mapApp f diff --git a/morpheus-graphql-app/src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs b/morpheus-graphql-app/src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs index 6c7907fb27..2ba09bb0f2 100644 --- a/morpheus-graphql-app/src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs +++ b/morpheus-graphql-app/src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs @@ -35,6 +35,7 @@ import Data.Morpheus.App.Internal.Resolving.Types import Data.Morpheus.App.Internal.Resolving.Utils ( lookupResJSON, ) +import Data.Morpheus.Core (Config (..)) import Data.Morpheus.Types.Internal.AST ( MUTATION, Operation (..), @@ -89,34 +90,36 @@ runRootResolverValue subscriptionResolver, channelMap } - ctx@ResolverContext {operation = Operation {..}} = + ctx@ResolverContext {operation = Operation {..}, config} = selectByOperation operationType where selectByOperation OPERATION_QUERY = - runResolver channelMap (rootResolver (withIntroFields <$> queryResolver) operationSelection) ctx + runResolver channelMap (rootResolver (withIntroFields config <$> queryResolver) operationSelection) ctx selectByOperation OPERATION_MUTATION = runResolver channelMap (rootResolver mutationResolver operationSelection) ctx selectByOperation OPERATION_SUBSCRIPTION = runResolver channelMap (rootResolver subscriptionResolver operationSelection) ctx runRootResolverValue NamedResolversValue {queryResolverMap} - ctx@ResolverContext {operation = Operation {..}} = + ctx@ResolverContext {operation = Operation {..}, config} = selectByOperation operationType where selectByOperation OPERATION_QUERY = runResolver Nothing queryResolver ctx where queryResolver = do name <- asks (typeName . query . schema) - resolveNamedRoot name (withNamedIntroFields name queryResolverMap) operationSelection + resolveNamedRoot name (withNamedIntroFields config name queryResolverMap) operationSelection selectByOperation _ = throwError "mutation and subscription is not supported for namedResolvers" -withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverMap m -> ResolverMap m -withNamedIntroFields = adjust updateNamed +withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => Config -> TypeName -> ResolverMap m -> ResolverMap m +withNamedIntroFields config = adjust updateNamed where updateNamed NamedResolver {..} = NamedResolver {resolverFun = const (updateResult <$> resolverFun ["ROOT"]), ..} where - updateResult [NamedObjectResolver obj] = [NamedObjectResolver (withIntroFields obj)] + updateResult [NamedObjectResolver obj] = [NamedObjectResolver (withIntroFields config obj)] updateResult value = value -withIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m -withIntroFields (ObjectTypeResolver fields) = ObjectTypeResolver (fields <> objectFields schemaAPI) +withIntroFields :: Config -> (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m +withIntroFields config (ObjectTypeResolver fields) + | introspection config = ObjectTypeResolver (fields <> objectFields schemaAPI) + | otherwise = ObjectTypeResolver fields diff --git a/morpheus-graphql-app/test/DisableIntrospection.hs b/morpheus-graphql-app/test/DisableIntrospection.hs new file mode 100644 index 0000000000..8e594f6195 --- /dev/null +++ b/morpheus-graphql-app/test/DisableIntrospection.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module DisableIntrospection + ( runNamedDisableIntrospectionTest, + runDisableIntrospectionTest, + ) +where + +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Morpheus.App (disableIntrospection, mkApp, runApp) +import Data.Morpheus.App.Internal.Resolving (resultOr) +import Data.Morpheus.App.NamedResolvers (object, queryResolvers) +import Data.Morpheus.Core (parseSchema) +import Data.Morpheus.Internal.Ext (toEither) +import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse) +import Relude hiding (ByteString) +import Test.Morpheus + ( FileUrl, + file, + getAppsBy, + testApi, + ) +import Test.Tasty (TestTree) + +runNamedDisableIntrospectionTest :: FileUrl -> FileUrl -> TestTree +runNamedDisableIntrospectionTest url = testApi api + where + api :: GQLRequest -> IO GQLResponse + api req = do + schema <- LBS.readFile (toString (file url "schema.gql")) >>= resultOr (fail . show) pure . parseSchema + let resolvers = queryResolvers [("Query", traverse (const $ object [("name", pure "Morpheus")]))] + let app = disableIntrospection (mkApp schema resolvers) + runApp app req + +runDisableIntrospectionTest :: FileUrl -> FileUrl -> TestTree +runDisableIntrospectionTest url = testApi api + where + api :: GQLRequest -> IO GQLResponse + api req = do + app <- getAppsBy (toEither . parseSchema, mkApp) url + runApp (disableIntrospection app) req diff --git a/morpheus-graphql-app/test/Spec.hs b/morpheus-graphql-app/test/Spec.hs index ec30d9c415..7e6e179cc4 100644 --- a/morpheus-graphql-app/test/Spec.hs +++ b/morpheus-graphql-app/test/Spec.hs @@ -25,6 +25,7 @@ import Data.Morpheus.Types.IO ( GQLRequest (..), GQLResponse, ) +import DisableIntrospection (runDisableIntrospectionTest, runNamedDisableIntrospectionTest) import Execution (runExecutionTest) import NamedResolvers (runNamedResolversTest) import Relude hiding (ByteString) @@ -68,5 +69,7 @@ main = deepScan (map . runNamedResolversTest) (mkUrl "named-resolvers"), deepScan (map . runAPIConstraints) (mkUrl "api-constraints"), deepScan (map . runBatchingTest) (mkUrl "batching"), - deepScan (map . runExecutionTest) (mkUrl "execution") + deepScan (map . runExecutionTest) (mkUrl "execution"), + deepScan (map . runNamedDisableIntrospectionTest) (mkUrl "disable-introspection"), + deepScan (map . runDisableIntrospectionTest) (mkUrl "disable-introspection") ] diff --git a/morpheus-graphql-app/test/disable-introspection/name/query.gql b/morpheus-graphql-app/test/disable-introspection/name/query.gql new file mode 100644 index 0000000000..79f76e236a --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/name/query.gql @@ -0,0 +1,3 @@ +query { + name +} diff --git a/morpheus-graphql-app/test/disable-introspection/name/response.json b/morpheus-graphql-app/test/disable-introspection/name/response.json new file mode 100644 index 0000000000..530a6bf609 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/name/response.json @@ -0,0 +1,3 @@ +{ + "data": { "name": "Morpheus" } +} diff --git a/morpheus-graphql-app/test/disable-introspection/resolvers.json b/morpheus-graphql-app/test/disable-introspection/resolvers.json new file mode 100644 index 0000000000..9771b3a4d8 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/resolvers.json @@ -0,0 +1,5 @@ +{ + "query": { + "name": "Morpheus" + } +} diff --git a/morpheus-graphql-app/test/disable-introspection/schema.gql b/morpheus-graphql-app/test/disable-introspection/schema.gql new file mode 100644 index 0000000000..6efd090a52 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/schema.gql @@ -0,0 +1,3 @@ +type Query { + name: String +} diff --git a/morpheus-graphql-app/test/disable-introspection/schema/query.gql b/morpheus-graphql-app/test/disable-introspection/schema/query.gql new file mode 100644 index 0000000000..b94a791998 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/schema/query.gql @@ -0,0 +1,12 @@ +query Get__Type { + __schema { + types { + name + } + directives { + name + description + locations + } + } +} diff --git a/morpheus-graphql-app/test/disable-introspection/schema/response.json b/morpheus-graphql-app/test/disable-introspection/schema/response.json new file mode 100644 index 0000000000..e15f9ff778 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/schema/response.json @@ -0,0 +1,3 @@ +{ + "data": { "__schema": null } +} diff --git a/morpheus-graphql-app/test/disable-introspection/type/query.gql b/morpheus-graphql-app/test/disable-introspection/type/query.gql new file mode 100644 index 0000000000..8b50ad4af2 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/type/query.gql @@ -0,0 +1,5 @@ +query Get__Type { + __type(name: "Query") { + name + } +} diff --git a/morpheus-graphql-app/test/disable-introspection/type/response.json b/morpheus-graphql-app/test/disable-introspection/type/response.json new file mode 100644 index 0000000000..836376c7c0 --- /dev/null +++ b/morpheus-graphql-app/test/disable-introspection/type/response.json @@ -0,0 +1,3 @@ +{ + "data": { "__type": null } +} diff --git a/morpheus-graphql-benchmarks/morpheus-graphql-benchmarks.cabal b/morpheus-graphql-benchmarks/morpheus-graphql-benchmarks.cabal deleted file mode 100644 index 2b3ec17ba2..0000000000 --- a/morpheus-graphql-benchmarks/morpheus-graphql-benchmarks.cabal +++ /dev/null @@ -1,54 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.35.0. --- --- see: https://github.com/sol/hpack - -name: morpheus-graphql-benchmarks -version: 0.1.0 -synopsis: Morpheus GraphQL Benchmarks -description: Build GraphQL APIs with your favorite functional language! -category: web, graphql -homepage: https://morpheusgraphql.com -bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues -author: Daviti Nalchevanidze -maintainer: d.nalchevanidze@gmail.com -copyright: (c) 2019 Daviti Nalchevanidze -license: MIT -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md -data-files: - samples/descriptions.gql - samples/github.gql - samples/huge-string.gql - samples/mythology.gql - samples/starwars.gql - samples/wrappers.gql - -source-repository head - type: git - location: https://github.com/nalchevanidze/morpheus-graphql - -benchmark morpheus-graphql-bench - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Parser.GraphQL - Parser.Morpheus - Paths_morpheus_graphql_benchmarks - hs-source-dirs: - src - ghc-options: -eventlog -threaded -rtsopts -with-rtsopts=-N6 -O2 - build-depends: - base >=4.7 && <5 - , bytestring >=0.10.4 && <0.12 - , criterion - , graphql >=0.11 - , megaparsec >=7.0.0 && <10.0.0 - , morpheus-graphql-core - , relude >=0.3.0 - , text >=1.2.3.0 && <1.3 - , unordered-containers >=0.2.8.0 && <0.3 - default-language: Haskell2010 diff --git a/morpheus-graphql-client/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs b/morpheus-graphql-client/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs index 03d0d19045..62dc45b372 100644 --- a/morpheus-graphql-client/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs +++ b/morpheus-graphql-client/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs @@ -81,7 +81,12 @@ import Data.Set (insert, member) import Relude hiding (empty) clientConfig :: Config -clientConfig = Config {debug = False, validationMode = WITHOUT_VARIABLES} +clientConfig = + Config + { debug = False, + introspection = True, + validationMode = WITHOUT_VARIABLES + } data LocalContext = LocalContext { ctxSchema :: Schema VALID, diff --git a/morpheus-graphql-client/test/Case/ResponseTypes/Test.hs b/morpheus-graphql-client/test/Case/ResponseTypes/Test.hs index fe5272c6f5..1212fcfe65 100644 --- a/morpheus-graphql-client/test/Case/ResponseTypes/Test.hs +++ b/morpheus-graphql-client/test/Case/ResponseTypes/Test.hs @@ -6,6 +6,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} module Case.ResponseTypes.Test diff --git a/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs b/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs index 800efeaaab..bc25bab013 100755 --- a/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs +++ b/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs @@ -96,7 +96,7 @@ import Data.Morpheus.Types.Internal.AST ) import Relude hiding (ByteString, get) -parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags) +parseServerTypeDefinitions :: (CodeGenMonad m) => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags) parseServerTypeDefinitions ctx txt = case parseDefinitions txt of Failure errors -> fail (renderGQLErrors errors) @@ -108,7 +108,7 @@ getExternals xs = <> [FlagExternal (unpackName $ getFullName $ typeClassTarget v) | GQLTypeInstance Scalar v <- xs] toTHDefinitions :: - CodeGenMonad m => + (CodeGenMonad m) => Bool -> [RawTypeDefinition] -> m ([ServerDeclaration], Flags) @@ -118,7 +118,7 @@ toTHDefinitions namespace defs = do where typeDefinitions = [td | RawTypeDefinition td <- defs] directiveDefinitions = [td | RawDirectiveDefinition td <- defs] - generateTypes :: CodeGenMonad m => RawTypeDefinition -> m ([ServerDeclaration], Flags) + generateTypes :: (CodeGenMonad m) => RawTypeDefinition -> m ([ServerDeclaration], Flags) generateTypes (RawTypeDefinition typeDef) = runCodeGenT (genTypeDefinition typeDef) @@ -149,7 +149,7 @@ mkInterfaceName = ("Interface" <>) mkPossibleTypesName :: TypeName -> TypeName mkPossibleTypesName = ("PossibleTypes" <>) -genDirectiveDefinition :: CodeGenM m => DirectiveDefinition CONST -> m [ServerDeclaration] +genDirectiveDefinition :: (CodeGenM m) => DirectiveDefinition CONST -> m [ServerDeclaration] genDirectiveDefinition DirectiveDefinition {..} = do fields <- traverse (renderDataField . argument) (toList directiveDefinitionArgs) let typename = coerce directiveDefinitionName @@ -179,7 +179,7 @@ genDirectiveDefinition DirectiveDefinition {..} = do ] genTypeDefinition :: - CodeGenM m => + (CodeGenM m) => TypeDefinition ANY CONST -> m [ServerDeclaration] genTypeDefinition @@ -235,7 +235,7 @@ mkArgsTypeName namespace typeName fieldName argTName = camelCaseTypeName [fieldName] "Args" mkObjectField :: - CodeGenM m => + (CodeGenM m) => FieldDefinition OUT CONST -> m CodeGenField mkObjectField @@ -263,7 +263,7 @@ mkObjectField .. } -mkFieldArguments :: CodeGenM m => FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> m [FIELD_TYPE_WRAPPER] +mkFieldArguments :: (CodeGenM m) => FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> m [FIELD_TYPE_WRAPPER] mkFieldArguments _ _ [] = pure [] mkFieldArguments _ @@ -297,7 +297,7 @@ gqlTypeToInstance GQLTypeDefinition {..} = ] } -genInterfaceUnion :: CodeGenM m => TypeName -> m [ServerDeclaration] +genInterfaceUnion :: (CodeGenM m) => TypeName -> m [ServerDeclaration] genInterfaceUnion interfaceName = asks typeDefinitions >>= mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName) where @@ -325,12 +325,12 @@ genInterfaceUnion interfaceName = mkGuardWithPossibleType = InterfaceType . InterfaceDefinition interfaceName (mkInterfaceName interfaceName) tName = mkPossibleTypesName interfaceName -mkConsEnum :: CodeGenM m => DataEnumValue CONST -> m CodeGenConstructor +mkConsEnum :: (CodeGenM m) => DataEnumValue CONST -> m CodeGenConstructor mkConsEnum DataEnumValue {enumName} = do constructorName <- getEnumName enumName pure CodeGenConstructor {constructorName, constructorFields = []} -renderDataField :: CodeGenM m => FieldDefinition c CONST -> m CodeGenField +renderDataField :: (CodeGenM m) => FieldDefinition c CONST -> m CodeGenField renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do fieldName <- getFieldName fName let wrappers = [GQL_WRAPPER typeWrappers] @@ -338,7 +338,7 @@ renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers} let fieldIsNullable = isNullable typeWrappers pure CodeGenField {..} -genTypeContent :: CodeGenM m => TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan +genTypeContent :: (CodeGenM m) => TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan genTypeContent _ DataScalar {} = pure (ConsIN []) genTypeContent _ (DataEnum tags) = ConsIN <$> traverse mkConsEnum tags genTypeContent typeName (DataInputObject fields) = @@ -366,7 +366,7 @@ genTypeContent typeName (DataUnion members) = do where unionCon UnionMember {memberName} = mkUnionFieldDefinition typeName memberName -mkUnionFieldDefinition :: CodeGenM m => TypeName -> TypeName -> m CodeGenConstructor +mkUnionFieldDefinition :: (CodeGenM m) => TypeName -> TypeName -> m CodeGenConstructor mkUnionFieldDefinition typeName memberName = do fieldType <- getFieldTypeName memberName pure $ @@ -384,10 +384,10 @@ mkUnionFieldDefinition typeName memberName = do where constructorName = CodeGenTypeName [coerce typeName] [] memberName -genArgumentTypes :: CodeGenM m => FieldsDefinition OUT CONST -> m [ServerDeclaration] +genArgumentTypes :: (CodeGenM m) => FieldsDefinition OUT CONST -> m [ServerDeclaration] genArgumentTypes = fmap concat . traverse genArgumentType . toList -genArgumentType :: CodeGenM m => FieldDefinition OUT CONST -> m [ServerDeclaration] +genArgumentType :: (CodeGenM m) => FieldDefinition OUT CONST -> m [ServerDeclaration] genArgumentType FieldDefinition { fieldName, diff --git a/morpheus-graphql-core/src/Data/Morpheus/Parser.hs b/morpheus-graphql-core/src/Data/Morpheus/Parser.hs index 6d1f2b8325..341e81b978 100644 --- a/morpheus-graphql-core/src/Data/Morpheus/Parser.hs +++ b/morpheus-graphql-core/src/Data/Morpheus/Parser.hs @@ -17,11 +17,9 @@ import Data.Morpheus.Ext.Result import Data.Morpheus.Internal.Utils ((<:>)) import Data.Morpheus.Parsing.Document.TypeSystem ( parseDefinitions, + parseSchemaWithoutValidation, parseTypeDefinitions, ) -import qualified Data.Morpheus.Parsing.Document.TypeSystem as P - ( parseSchema, - ) import Data.Morpheus.Parsing.Request.Parser ( parseRequest, ) @@ -50,11 +48,12 @@ parseSchema :: ByteString -> GQLResult (Schema VALID) parseSchema = sortErrors - . ( P.parseSchema + . ( parseSchemaWithoutValidation >=> validateSchema True Config { debug = False, + introspection = True, validationMode = FULL_VALIDATION } ) diff --git a/morpheus-graphql-core/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/morpheus-graphql-core/src/Data/Morpheus/Parsing/Document/TypeSystem.hs index 9bfc276e54..2b6fbbf31c 100644 --- a/morpheus-graphql-core/src/Data/Morpheus/Parsing/Document/TypeSystem.hs +++ b/morpheus-graphql-core/src/Data/Morpheus/Parsing/Document/TypeSystem.hs @@ -8,7 +8,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Parsing.Document.TypeSystem - ( parseSchema, + ( parseSchemaWithoutValidation, parseTypeDefinitions, parseDefinitions, ) @@ -106,7 +106,7 @@ mkObject typeDescription typeName objectImplements typeDirectives objectFields = -- Description(opt) scalar Name Directives(Const)(opt) -- scalarTypeDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (TypeDefinition ANY s) scalarTypeDefinition typeDescription = @@ -133,7 +133,7 @@ scalarTypeDefinition typeDescription = -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- objectTypeDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (TypeDefinition ANY s) objectTypeDefinition typeDescription = @@ -158,7 +158,7 @@ optionalImplementsInterfaces = implements <|> pure [] -- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) -- interfaceTypeDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (TypeDefinition ANY s) interfaceTypeDefinition typeDescription = @@ -179,7 +179,7 @@ interfaceTypeDefinition typeDescription = -- UnionMemberTypes | NamedType -- unionTypeDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (TypeDefinition ANY s) unionTypeDefinition typeDescription = @@ -207,7 +207,7 @@ unionTypeDefinition typeDescription = -- Description(opt) EnumValue Directives(Const)(opt) -- enumTypeDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (TypeDefinition ANY s) enumTypeDefinition typeDescription = @@ -227,7 +227,7 @@ enumTypeDefinition typeDescription = -- { InputValueDefinition(list) } -- inputObjectTypeDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (TypeDefinition ANY s) inputObjectTypeDefinition typeDescription = @@ -248,7 +248,7 @@ inputObjectTypeDefinition typeDescription = -- DirectiveLocations | DirectiveLocation -- |[opt] DirectiveLocation parseDirectiveDefinition :: - Parse (Value s) => + (Parse (Value s)) => Maybe Description -> Parser (DirectiveDefinition s) parseDirectiveDefinition directiveDefinitionDescription = @@ -372,5 +372,5 @@ parseDefinitions = processParser parseRawTypeDefinitions parseTypeDefinitions :: ByteString -> GQLResult [TypeDefinition ANY CONST] parseTypeDefinitions = fmap (\d -> [td | RawTypeDefinition td <- d]) . parseDefinitions -parseSchema :: ByteString -> GQLResult (Schema CONST) -parseSchema = typeSystemDefinition >=> buildSchema +parseSchemaWithoutValidation :: ByteString -> GQLResult (Schema CONST) +parseSchemaWithoutValidation = typeSystemDefinition >=> buildSchema diff --git a/morpheus-graphql-core/src/Data/Morpheus/Schema/DSL.hs b/morpheus-graphql-core/src/Data/Morpheus/Schema/DSL.hs index d5586f3335..6535bc7748 100644 --- a/morpheus-graphql-core/src/Data/Morpheus/Schema/DSL.hs +++ b/morpheus-graphql-core/src/Data/Morpheus/Schema/DSL.hs @@ -21,7 +21,7 @@ import Data.Morpheus.Ext.Result ( Result (..), ) import Data.Morpheus.Parsing.Document.TypeSystem - ( parseSchema, + ( parseSchemaWithoutValidation, ) import Language.Haskell.TH import Language.Haskell.TH.Quote @@ -39,6 +39,6 @@ dsl = notHandled things = error $ things <> " are not supported by the GraphQL QuasiQuoter" dslExpression :: ByteString -> Q Exp -dslExpression doc = case parseSchema doc of +dslExpression doc = case parseSchemaWithoutValidation doc of Failure errors -> fail (renderGQLErrors errors) Success {result, warnings} -> gqlWarnings warnings >> [|result|] diff --git a/morpheus-graphql-core/src/Data/Morpheus/Types/Internal/Config.hs b/morpheus-graphql-core/src/Data/Morpheus/Types/Internal/Config.hs index 5c610e29dd..c350aebf2f 100644 --- a/morpheus-graphql-core/src/Data/Morpheus/Types/Internal/Config.hs +++ b/morpheus-graphql-core/src/Data/Morpheus/Types/Internal/Config.hs @@ -17,7 +17,8 @@ data VALIDATION_MODE data Config = Config { debug :: Bool, - validationMode :: VALIDATION_MODE + validationMode :: VALIDATION_MODE, + introspection :: Bool } deriving (Show) @@ -25,12 +26,14 @@ defaultConfig :: Config defaultConfig = Config { debug = False, - validationMode = FULL_VALIDATION + validationMode = FULL_VALIDATION, + introspection = True } debugConfig :: Config debugConfig = Config { debug = True, - validationMode = FULL_VALIDATION + validationMode = FULL_VALIDATION, + introspection = True } diff --git a/morpheus-graphql-server/src/Data/Morpheus/Server.hs b/morpheus-graphql-server/src/Data/Morpheus/Server.hs index c52a5fb87e..f1018dc73f 100644 --- a/morpheus-graphql-server/src/Data/Morpheus/Server.hs +++ b/morpheus-graphql-server/src/Data/Morpheus/Server.hs @@ -21,6 +21,7 @@ module Data.Morpheus.Server deriveApp, runApp, withDebugger, + disableIntrospection, ) where @@ -31,6 +32,7 @@ import Data.ByteString.Lazy.Char8 import Data.Morpheus.App ( App (..), MapAPI, + disableIntrospection, runApp, withDebugger, ) @@ -56,7 +58,7 @@ import Relude hiding (ByteString) -- | Generates schema.gql file from 'RootResolver' printSchema :: - RootResolverConstraint m event query mut sub => + (RootResolverConstraint m event query mut sub) => proxy (RootResolver m event query mut sub) -> ByteString printSchema = diff --git a/morpheus-graphql-subscriptions/src/Data/Morpheus/Subscriptions/Apollo.hs b/morpheus-graphql-subscriptions/src/Data/Morpheus/Subscriptions/Apollo.hs index 65f8e478c7..b4c76485c3 100644 --- a/morpheus-graphql-subscriptions/src/Data/Morpheus/Subscriptions/Apollo.hs +++ b/morpheus-graphql-subscriptions/src/Data/Morpheus/Subscriptions/Apollo.hs @@ -20,7 +20,6 @@ import Control.Monad.Fail (fail) import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson ( FromJSON (..), - Series, ToJSON (..), Value (..), eitherDecode, @@ -87,7 +86,7 @@ data ApolloSubscription payload = ApolloSubscription } deriving (Show, Generic) -instance FromJSON a => FromJSON (ApolloSubscription a) where +instance (FromJSON a) => FromJSON (ApolloSubscription a) where parseJSON = withObject "ApolloSubscription" objectParser where objectParser o = @@ -112,7 +111,7 @@ instance FromJSON RequestPayload where <*> o .:? "query" <*> o .:? "variables" -instance ToJSON a => ToJSON (ApolloSubscription a) where +instance (ToJSON a) => ToJSON (ApolloSubscription a) where toEncoding (ApolloSubscription id' type' payload') = pairs $ encodeMaybe "id" id' @@ -124,11 +123,11 @@ instance ToJSON a => ToJSON (ApolloSubscription a) where -- extraneous data in the payload. -- Aeson < 2.0.0 has Keys as Text, >= 2.0.0 has Data.Aeson.Key.Key -- encodeMaybe :: ToJSON b => Text -> Maybe b -> Series - encodeMaybe k Nothing = Prelude.mempty + encodeMaybe _ Nothing = Prelude.mempty encodeMaybe k (Just v) = k .= v acceptApolloRequest :: - MonadIO m => + (MonadIO m) => PendingConnection -> m Connection acceptApolloRequest pending = @@ -177,7 +176,7 @@ instance FromJSON ApolloMessageType where txtParser "subscribe" = return GqlSubscribe txtParser "ping" = return GqlPing txtParser "pong" = return GqlPong - txtParser other = fail "Invalid type encountered." + txtParser _ = fail "Invalid type encountered." instance ToJSON ApolloMessageType where toEncoding = toEncoding . apolloResponseToProtocolMsgType diff --git a/morpheus-graphql/test/Subscription/Case/ApolloRequest.hs b/morpheus-graphql/test/Subscription/Case/ApolloRequest.hs index 00cc3ba91a..690e27b187 100644 --- a/morpheus-graphql/test/Subscription/Case/ApolloRequest.hs +++ b/morpheus-graphql/test/Subscription/Case/ApolloRequest.hs @@ -19,7 +19,6 @@ import Subscription.Utils ( SimulationState (..), SubM, apolloConnectionAck, - apolloConnectionErr, apolloInit, apolloPing, apolloPong, @@ -82,7 +81,7 @@ testPingPong :: IO TestTree testPingPong = testSimulation test [apolloInit, apolloPing] where - test input SimulationState {inputs, outputs, store} = + test _ SimulationState {inputs, outputs} = testGroup "ping pong" [ inputsAreConsumed inputs, diff --git a/morpheus-graphql/test/Subscription/Case/Publishing.hs b/morpheus-graphql/test/Subscription/Case/Publishing.hs index 05a96a7570..af8747e1cb 100644 --- a/morpheus-graphql/test/Subscription/Case/Publishing.hs +++ b/morpheus-graphql/test/Subscription/Case/Publishing.hs @@ -29,7 +29,6 @@ import Subscription.API import Subscription.Utils ( SimulationState (..), apolloConnectionAck, - apolloConnectionErr, apolloInit, apolloRes, apolloStart, diff --git a/stack.yaml b/stack.yaml index 5ba6c21ad2..1353c873bc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,4 @@ -allow-newer: true -resolver: nightly-2023-04-23 +resolver: lts-19.28 save-hackage-creds: false packages: - examples/client @@ -7,9 +6,9 @@ packages: - examples/code-gen-docs - examples/scotty - examples/scotty-haxl + - examples/scotty-freer-simple - examples/servant - examples/yesod-pubsub - - morpheus-graphql-benchmarks - morpheus-graphql-tests - morpheus-graphql-core - morpheus-graphql-code-gen-utils @@ -20,6 +19,8 @@ packages: - morpheus-graphql-server - morpheus-graphql extra-deps: + - dependent-map-0.2.4.0 + - dependent-sum-0.4 - fraxl-0.3.0.0 - haxl-2.4.0.0 - type-aligned-0.9.6