Add option to use custom a monad (#12618)

This commit is contained in:
Tom Bärwinkel 2022-07-06 19:13:06 +02:00 committed by GitHub
parent cb1ba17877
commit 728c80abea
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 21 additions and 10 deletions

View File

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

View File

@ -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);
}
/**

View File

@ -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{..} =

View File

@ -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();
}

View File

@ -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{..} =