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

@@ -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

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
 

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

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
 

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

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

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

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