From 728c80abeaf4cc704c1ae9875900a23e35fa42ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=20B=C3=A4rwinkel?= Date: Wed, 6 Jul 2022 19:13:06 +0200 Subject: [PATCH] Add option to use custom a monad (#12618) --- docs/generators/haskell.md | 1 + .../languages/HaskellServantCodegen.java | 6 ++++++ .../resources/haskell-servant/API.mustache | 19 +++++++++++-------- .../HaskellServantOptionsProvider.java | 1 + .../lib/OpenAPIPetstore/API.hs | 4 ++-- 5 files changed, 21 insertions(+), 10 deletions(-) diff --git a/docs/generators/haskell.md b/docs/generators/haskell.md index 47b891a1eb2..59cef6a6bde 100644 --- a/docs/generators/haskell.md +++ b/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 diff --git a/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java b/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java index 97c1cbf77a2..b4e91b2a5a0 100644 --- a/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java +++ b/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); } /** diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache index 84f19738f9d..67ae8f4d8a4 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache +++ b/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 () -run{{title}}Server config {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = run{{title}}MiddlewareServer config requestMiddlewareId {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend + => 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 {{#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 () -run{{title}}MiddlewareServer Config{..} middleware{{#hasAuthMethods}} auth{{/hasAuthMethods}} backend = do + => 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{{#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}} {{#hasAuthMethods}}auth {{/hasAuthMethods}}backend = serveWithContext (Proxy :: Proxy {{title}}API) context (serverFromBackend backend) +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}} {{#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{..} = diff --git a/modules/openapi-generator/src/test/java/org/openapitools/codegen/options/HaskellServantOptionsProvider.java b/modules/openapi-generator/src/test/java/org/openapitools/codegen/options/HaskellServantOptionsProvider.java index 892a753ce90..b6cb61abc19 100644 --- a/modules/openapi-generator/src/test/java/org/openapitools/codegen/options/HaskellServantOptionsProvider.java +++ b/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(); } diff --git a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs index bdb61723535..e788e559566 100644 --- a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs +++ b/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{..} =