Add option to use custom a monad (#12618)

docs/generators/haskell.md

@@ -29,6 +29,7 @@ These options may be applied as additional-properties (cli) or configOptions (pl
 |serveStatic|serve will serve files from the directory 'static'.| |true|
 |sortModelPropertiesByRequiredFlag|Sort model properties to place required parameters before optional parameters.| |true|
 |sortParamsByRequiredFlag|Sort method arguments to place required parameters before optional parameters.| |true|
+|useCustomMonad|use a custom monad instead of the default Handler| |false|
 
 ## IMPORT MAPPING
 

modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java

@@ -49,6 +49,10 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
     public static final String PROP_SERVE_STATIC_DESC = "serve will serve files from the directory 'static'.";
     public static final Boolean PROP_SERVE_STATIC_DEFAULT = Boolean.TRUE;
 
+    public static final String USE_CUSTOM_MONAD = "useCustomMonad";
+    public static final String USE_CUSTOM_MONAD_DESC = "use a custom monad instead of the default Handler";
+    public static final Boolean USE_CUSTOM_MONAD_DEFAULT = Boolean.FALSE;
+
     /**
      * Configures the type of generator.
      *
@@ -214,6 +218,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
         cliOptions.add(new CliOption(CodegenConstants.MODEL_PACKAGE, CodegenConstants.MODEL_PACKAGE_DESC));
         cliOptions.add(new CliOption(CodegenConstants.API_PACKAGE, CodegenConstants.API_PACKAGE_DESC));
         cliOptions.add(new CliOption(PROP_SERVE_STATIC, PROP_SERVE_STATIC_DESC).defaultValue(PROP_SERVE_STATIC_DEFAULT.toString()));
+        cliOptions.add(new CliOption(USE_CUSTOM_MONAD, USE_CUSTOM_MONAD_DESC).defaultValue(USE_CUSTOM_MONAD_DEFAULT.toString()));
     }
 
     public void setBooleanProperty(String property, Boolean defaultValue) {
@@ -233,6 +238,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
         }
 
         setBooleanProperty(PROP_SERVE_STATIC, PROP_SERVE_STATIC_DEFAULT);
+        setBooleanProperty(USE_CUSTOM_MONAD, USE_CUSTOM_MONAD_DEFAULT);
     }
 
     /**

modules/openapi-generator/src/main/resources/haskell-servant/API.mustache

@@ -6,6 +6,9 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{{#useCustomMonad}}
+{-# LANGUAGE RankNTypes                 #-}
+{{/useCustomMonad}}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
@@ -78,7 +81,7 @@ import           Network.Wai.Middleware.HttpAuth    (extractBearerAuth)
 import           Network.Wai.Middleware.HttpAuth    (extractBasicAuth)
 {{/isBasicBasic}}
 {{/authMethods}}
-import           Servant                            (ServerError, serveWithContext{{#hasAuthMethods}}, throwError{{/hasAuthMethods}})
+import           Servant                            (ServerError, serveWithContextT{{#hasAuthMethods}}, throwError{{/hasAuthMethods}})
 import           Servant.API                        hiding (addHeader)
 {{#authMethods}}
 {{#isBasicBasic}}
@@ -284,25 +287,25 @@ requestMiddlewareId a = a
 -- | Run the {{title}} server at the provided host and port.
 run{{title}}Server
   :: (MonadIO m, MonadThrow m)
-  => Config -> {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}(ExceptT ServerError IO) -> m ()
+  => Config -> {{#useCustomMonad}}(forall x . n x -> Handler x) -> {{/useCustomMonad}}{{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}{{^useCustomMonad}}(ExceptT ServerError IO){{/useCustomMonad}}{{#useCustomMonad}}n{{/useCustomMonad}} -> m ()
-run{{title}}Server config {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = run{{title}}MiddlewareServer config requestMiddlewareId {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend
+run{{title}}Server config {{#useCustomMonad}}nat {{/useCustomMonad}}{{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = run{{title}}MiddlewareServer config requestMiddlewareId {{#useCustomMonad}}nat {{/useCustomMonad}}{{#hasAuthMethods}}auth {{/hasAuthMethods}}backend
 
 -- | Run the {{title}} server at the provided host and port.
 run{{title}}MiddlewareServer
   :: (MonadIO m, MonadThrow m)
-  => Config -> Middleware -> {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend{{#hasAuthMethods}} AuthServer{{/hasAuthMethods}} (ExceptT ServerError IO) -> m ()
+  => Config -> Middleware -> {{#useCustomMonad}}(forall x . n x -> Handler x) -> {{/useCustomMonad}}{{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend{{#hasAuthMethods}} AuthServer{{/hasAuthMethods}} {{^useCustomMonad}}(ExceptT ServerError IO){{/useCustomMonad}}{{#useCustomMonad}}n{{/useCustomMonad}} -> m ()
-run{{title}}MiddlewareServer Config{..} middleware{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend = do
+run{{title}}MiddlewareServer Config{..} middleware{{#useCustomMonad}} nat{{/useCustomMonad}}{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend = do
   url <- parseBaseUrl configUrl
   let warpSettings = Warp.defaultSettings
         & Warp.setPort (baseUrlPort url)
         & Warp.setHost (fromString $ baseUrlHost url)
-  liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplication{{title}}{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend
+  liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplication{{title}}{{#useCustomMonad}} nat{{/useCustomMonad}}{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend
 
 -- | Plain "Network.Wai" Application for the {{title}} server.
 --
 -- Can be used to implement e.g. tests that call the API without a full webserver.
-serverWaiApplication{{title}} :: {{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}(ExceptT ServerError IO) -> Application
+serverWaiApplication{{title}} :: {{#useCustomMonad}}(forall x . n x -> Handler x) -> {{/useCustomMonad}}{{#hasAuthMethods}}{{title}}Auth -> {{/hasAuthMethods}}{{title}}Backend {{#hasAuthMethods}}AuthServer {{/hasAuthMethods}}{{^useCustomMonad}}(ExceptT ServerError IO){{/useCustomMonad}}{{#useCustomMonad}}n{{/useCustomMonad}} -> Application
-serverWaiApplication{{title}} {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = serveWithContext (Proxy :: Proxy {{title}}API) context (serverFromBackend backend)
+serverWaiApplication{{title}} {{#useCustomMonad}}nat {{/useCustomMonad}}{{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = serveWithContextT (Proxy :: Proxy {{title}}API) context {{^useCustomMonad}}id {{/useCustomMonad}}{{#useCustomMonad}}nat {{/useCustomMonad}}(serverFromBackend backend)
   where
     context = serverContext{{#hasAuthMethods}} auth{{/hasAuthMethods}}
     serverFromBackend {{title}}Backend{..} =

modules/openapi-generator/src/test/java/org/openapitools/codegen/options/HaskellServantOptionsProvider.java

@@ -52,6 +52,7 @@ public class HaskellServantOptionsProvider implements OptionsProvider {
                 .put(CodegenConstants.LEGACY_DISCRIMINATOR_BEHAVIOR, "true")
                 .put(CodegenConstants.DISALLOW_ADDITIONAL_PROPERTIES_IF_NOT_PRESENT, "true")
                 .put(CodegenConstants.ENUM_UNKNOWN_DEFAULT_CASE, ENUM_UNKNOWN_DEFAULT_CASE_VALUE)
+                .put(HaskellServantCodegen.USE_CUSTOM_MONAD, HaskellServantCodegen.USE_CUSTOM_MONAD_DEFAULT.toString())
                 .build();
     }
 

samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs

@@ -61,7 +61,7 @@ import           Network.HTTP.Client.TLS            (tlsManagerSettings)
 import           Network.HTTP.Types.Method          (methodOptions)
 import           Network.Wai                        (Middleware, Request, requestHeaders)
 import qualified Network.Wai.Handler.Warp           as Warp
-import           Servant                            (ServerError, serveWithContext, throwError)
+import           Servant                            (ServerError, serveWithContextT, throwError)
 import           Servant.API                        hiding (addHeader)
 import           Servant.API.Verbs                  (StdMethod (..), Verb)
 import           Servant.API.Experimental.Auth      (AuthProtect)
@@ -308,7 +308,7 @@ runOpenAPIPetstoreMiddlewareServer Config{..} middleware auth backend = do
 --
 -- Can be used to implement e.g. tests that call the API without a full webserver.
 serverWaiApplicationOpenAPIPetstore :: OpenAPIPetstoreAuth -> OpenAPIPetstoreBackend AuthServer (ExceptT ServerError IO) -> Application
-serverWaiApplicationOpenAPIPetstore auth backend = serveWithContext (Proxy :: Proxy OpenAPIPetstoreAPI) context (serverFromBackend backend)
+serverWaiApplicationOpenAPIPetstore auth backend = serveWithContextT (Proxy :: Proxy OpenAPIPetstoreAPI) context id (serverFromBackend backend)
   where
     context = serverContext auth
     serverFromBackend OpenAPIPetstoreBackend{..} =