Skip to content

Commit e5cd0bc

Browse files
f-fwing328
f-f
authored and
wing328
committed
Upgrade haskell-servant generator to latest LTS (OpenAPITools#1469)
* [Haskell Servant] Upgrade to lts-12 - Upgrade Servant to the latest version - Add Maybe for optional values - Add UUID, UTCTime and Day types - Fix the URL configuration so that it has one param with all data - Add Data and ToSchema instances to models - Switch to TLS http manager so it can connect to https urls - Add nicer API to call the endpoints - Add Nix support * [Haskell Servant] Upgrade Petstore * [Haskell Servant] Delete old swagger-petstore samples * [Haskell Servant] Use generics for ToForm and FromForm instances * [Haskell Servant] Generate ToSchema instance only if it's safe to do
1 parent d4ca134 commit e5cd0bc

File tree

15 files changed

+463
-774
lines changed

15 files changed

+463
-774
lines changed

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

Lines changed: 41 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -179,12 +179,13 @@ public HaskellServantCodegen() {
179179
typeMapping.put("char", "Char");
180180
typeMapping.put("float", "Float");
181181
typeMapping.put("double", "Double");
182-
typeMapping.put("DateTime", "Integer");
182+
typeMapping.put("DateTime", "UTCTime");
183+
typeMapping.put("Date", "Day");
183184
typeMapping.put("file", "FilePath");
184185
typeMapping.put("binary", "FilePath");
185186
typeMapping.put("number", "Double");
186187
typeMapping.put("any", "Value");
187-
typeMapping.put("UUID", "Text");
188+
typeMapping.put("UUID", "UUID");
188189
typeMapping.put("ByteArray", "Text");
189190
typeMapping.put("object", "Value");
190191

@@ -294,9 +295,44 @@ public void preprocessOpenAPI(OpenAPI openAPI) {
294295
}
295296
additionalProperties.put("specialCharReplacements", replacements);
296297

298+
// See docstring for setGenerateToSchema for why we do this
299+
additionalProperties.put("generateToSchema", true);
300+
297301
super.preprocessOpenAPI(openAPI);
298302
}
299303

304+
/**
305+
* Internal method to set the generateToSchema parameter.
306+
*
307+
* Basically we're generating ToSchema instances (generically) for all schemas.
308+
* However, if any of the contained datatypes doesn't have the ToSchema instance,
309+
* we cannot generate it for its "ancestor" type.
310+
* This is the case with the "Data.Aeson.Value" type: it doesn't (and cannot) have
311+
* a Swagger-compatible ToSchema instance. So we have to detect its presence "downstream"
312+
* the current schema, and if we find it we just don't generate any ToSchema instance.
313+
* @param model
314+
*/
315+
private void setGenerateToSchema(CodegenModel model) {
316+
for (CodegenProperty var : model.vars) {
317+
LOGGER.warn(var.dataType);
318+
if (var.dataType.contentEquals("Value") || var.dataType.contains(" Value")) {
319+
additionalProperties.put("generateToSchema", false);
320+
}
321+
if (var.items != null) {
322+
if (var.items.dataType.contentEquals("Value") || var.dataType.contains(" Value")) {
323+
additionalProperties.put("generateToSchema", false);
324+
}
325+
}
326+
}
327+
328+
List<CodegenModel> children = model.getChildren();
329+
if (children != null) {
330+
for(CodegenModel child : children) {
331+
setGenerateToSchema(child);
332+
}
333+
}
334+
}
335+
300336

301337
/**
302338
* Optional - type declaration. This is a String which is used by the templates to instantiate your
@@ -312,7 +348,7 @@ public String getTypeDeclaration(Schema p) {
312348
return "[" + getTypeDeclaration(inner) + "]";
313349
} else if (ModelUtils.isMapSchema(p)) {
314350
Schema inner = ModelUtils.getAdditionalProperties(p);
315-
return "Map.Map String " + getTypeDeclaration(inner);
351+
return "(Map.Map String " + getTypeDeclaration(inner) + ")";
316352
}
317353
return fixModelChars(super.getTypeDeclaration(p));
318354
}
@@ -565,6 +601,8 @@ private String fixModelChars(String string) {
565601
public CodegenModel fromModel(String name, Schema mod, Map<String, Schema> allDefinitions) {
566602
CodegenModel model = super.fromModel(name, mod, allDefinitions);
567603

604+
setGenerateToSchema(model);
605+
568606
// Clean up the class name to remove invalid characters
569607
model.classname = fixModelChars(model.classname);
570608
if (typeMapping.containsValue(model.classname)) {

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

Lines changed: 105 additions & 84 deletions
Original file line numberDiff line numberDiff line change
@@ -1,93 +1,76 @@
1-
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DeriveGeneric #-}
3-
{-# LANGUAGE DeriveTraversable #-}
4-
{-# LANGUAGE FlexibleContexts #-}
5-
{-# LANGUAGE FlexibleInstances #-}
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveDataTypeable #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DeriveTraversable #-}
5+
{-# LANGUAGE FlexibleContexts #-}
6+
{-# LANGUAGE FlexibleInstances #-}
67
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7-
{-# LANGUAGE OverloadedStrings #-}
8-
{-# LANGUAGE RecordWildCards #-}
9-
{-# LANGUAGE TypeFamilies #-}
10-
{-# LANGUAGE TypeOperators #-}
11-
{-# LANGUAGE ViewPatterns #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE RecordWildCards #-}
10+
{-# LANGUAGE TypeFamilies #-}
11+
{-# LANGUAGE TypeOperators #-}
12+
{-# LANGUAGE ViewPatterns #-}
1213
{-# OPTIONS_GHC
13-
-fno-warn-unused-binds -fno-warn-unused-imports -fcontext-stack=328 #-}
14+
-fno-warn-unused-binds -fno-warn-unused-imports -freduction-depth=328 #-}
1415

1516
module {{title}}.API
1617
-- * Client and Server
17-
( ServerConfig(..)
18-
, {{title}}Backend
18+
( Config(..)
19+
, {{title}}Backend(..)
1920
, create{{title}}Client
2021
, run{{title}}Server
2122
, run{{title}}Client
2223
, run{{title}}ClientWithManager
24+
, call{{title}}
2325
, {{title}}Client
26+
, {{title}}ClientError(..)
2427
-- ** Servant
2528
, {{title}}API
2629
) where
2730

28-
import {{title}}.Types
29-
30-
import Control.Monad.Except (ExceptT)
31-
import Control.Monad.IO.Class
32-
import Data.Aeson (Value)
33-
import Data.Coerce (coerce)
34-
import Data.Function ((&))
35-
import qualified Data.Map as Map
36-
import Data.Monoid ((<>))
37-
import Data.Proxy (Proxy(..))
38-
import Data.Text (Text)
39-
import qualified Data.Text as T
40-
import GHC.Exts (IsString(..))
41-
import GHC.Generics (Generic)
42-
import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
43-
import Network.HTTP.Types.Method (methodOptions)
44-
import qualified Network.Wai.Handler.Warp as Warp
45-
import Servant (ServantErr, serve)
46-
import Servant.API
47-
import Servant.API.Verbs (StdMethod(..), Verb)
48-
import Servant.Client (Scheme(Http), ServantError, client)
49-
import Servant.Common.BaseUrl (BaseUrl(..))
50-
import Web.HttpApiData
31+
import {{title}}.Types
32+
33+
import Control.Monad.Catch (Exception, MonadThrow, throwM)
34+
import Control.Monad.Except (ExceptT, runExceptT)
35+
import Control.Monad.IO.Class
36+
import Control.Monad.Trans.Reader (ReaderT (..))
37+
import Data.Aeson (Value)
38+
import Data.Coerce (coerce)
39+
import Data.Data (Data)
40+
import Data.Function ((&))
41+
import qualified Data.Map as Map
42+
import Data.Monoid ((<>))
43+
import Data.Proxy (Proxy (..))
44+
import Data.Text (Text)
45+
import qualified Data.Text as T
46+
import Data.UUID (UUID)
47+
import GHC.Exts (IsString (..))
48+
import GHC.Generics (Generic)
49+
import Network.HTTP.Client (Manager, newManager)
50+
import Network.HTTP.Client.TLS (tlsManagerSettings)
51+
import Network.HTTP.Types.Method (methodOptions)
52+
import qualified Network.Wai.Handler.Warp as Warp
53+
import Servant (ServantErr, serve)
54+
import Servant.API
55+
import Servant.API.Verbs (StdMethod (..), Verb)
56+
import Servant.Client (ClientEnv, Scheme (Http), ServantError, client,
57+
mkClientEnv, parseBaseUrl)
58+
import Servant.Client.Core (baseUrlPort, baseUrlHost)
59+
import Servant.Client.Internal.HttpClient (ClientM (..))
60+
import Servant.Server (Handler (..))
61+
import Web.FormUrlEncoded
62+
import Web.HttpApiData
5163

5264

5365
{{#apiInfo}}{{#apis}}{{#operations}}{{#operation}}{{#hasFormParams}}
5466
data {{vendorExtensions.x-formName}} = {{vendorExtensions.x-formName}}
5567
{ {{#formParams}}{{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} :: {{dataType}}{{#hasMore}}
5668
, {{/hasMore}}{{/formParams}}
57-
} deriving (Show, Eq, Generic)
58-
59-
instance FromFormUrlEncoded {{vendorExtensions.x-formName}} where
60-
fromFormUrlEncoded inputs = {{vendorExtensions.x-formName}} <$> {{#formParams}}lookupEither "{{baseName}}" inputs{{#hasMore}} <*> {{/hasMore}}{{/formParams}}
61-
62-
instance ToFormUrlEncoded {{vendorExtensions.x-formName}} where
63-
toFormUrlEncoded value =
64-
[ {{#formParams}}("{{baseName}}", toQueryParam $ {{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} value){{#hasMore}}
65-
, {{/hasMore}}{{/formParams}}
66-
]{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
67-
68-
-- For the form data code generation.
69-
lookupEither :: FromHttpApiData b => Text -> [(Text, Text)] -> Either String b
70-
lookupEither key assocs =
71-
case lookup key assocs of
72-
Nothing -> Left $ "Could not find parameter " <> (T.unpack key) <> " in form data"
73-
Just value ->
74-
case parseQueryParam value of
75-
Left result -> Left $ T.unpack result
76-
Right result -> Right $ result
69+
} deriving (Show, Eq, Generic, Data)
7770

78-
{{#apiInfo}}
79-
-- | Servant type-level API, generated from the OpenAPI spec for {{title}}.
80-
type {{title}}API
81-
= {{#apis}}{{#operations}}{{#operation}}{{& vendorExtensions.x-routeType}} -- '{{operationId}}' route{{#hasMore}}
82-
:<|> {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
83-
:<|> {{/hasMore}}{{/apis}}
84-
{{/apiInfo}}
85-
86-
-- | Server or client configuration, specifying the host and port to query or serve on.
87-
data ServerConfig = ServerConfig
88-
{ configHost :: String -- ^ Hostname to serve on, e.g. "127.0.0.1"
89-
, configPort :: Int -- ^ Port to serve on, e.g. 8080
90-
} deriving (Eq, Ord, Show, Read)
71+
instance FromForm {{vendorExtensions.x-formName}}
72+
instance ToForm {{vendorExtensions.x-formName}}
73+
{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
9174

9275
-- | List of elements parsed from a query.
9376
newtype QueryList (p :: CollectionFormat) a = QueryList
@@ -139,6 +122,27 @@ formatSeparatedQueryList :: ToHttpApiData a => Char -> QueryList p a -> Text
139122
formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList
140123

141124

125+
{{#apiInfo}}
126+
-- | Servant type-level API, generated from the OpenAPI spec for {{title}}.
127+
type {{title}}API
128+
= {{#apis}}{{#operations}}{{#operation}}{{& vendorExtensions.x-routeType}} -- '{{operationId}}' route{{#hasMore}}
129+
:<|> {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
130+
:<|> {{/hasMore}}{{/apis}}
131+
{{/apiInfo}}
132+
133+
134+
-- | Server or client configuration, specifying the host and port to query or serve on.
135+
data Config = Config
136+
{ configUrl :: String -- ^ scheme://hostname:port/path, e.g. "http://localhost:8080/"
137+
} deriving (Eq, Ord, Show, Read)
138+
139+
140+
-- | Custom exception type for our errors.
141+
newtype {{title}}ClientError = {{title}}ClientError ServantError
142+
deriving (Show, Exception)
143+
-- | Configuration, specifying the full url of the service.
144+
145+
142146
{{#apiInfo}}
143147
-- | Backend for {{title}}.
144148
-- The backend can be used both for the client and the server. The client generated from the {{title}} OpenAPI spec
@@ -151,22 +155,22 @@ data {{title}}Backend m = {{title}}Backend
151155
}
152156

153157
newtype {{title}}Client a = {{title}}Client
154-
{ runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a
158+
{ runClient :: ClientEnv -> ExceptT ServantError IO a
155159
} deriving Functor
156160

157161
instance Applicative {{title}}Client where
158-
pure x = {{title}}Client (\_ _ -> pure x)
162+
pure x = {{title}}Client (\_ -> pure x)
159163
({{title}}Client f) <*> ({{title}}Client x) =
160-
{{title}}Client (\manager url -> f manager url <*> x manager url)
164+
{{title}}Client (\env -> f env <*> x env)
161165

162166
instance Monad {{title}}Client where
163167
({{title}}Client a) >>= f =
164-
{{title}}Client (\manager url -> do
165-
value <- a manager url
166-
runClient (f value) manager url)
168+
{{title}}Client (\env -> do
169+
value <- a env
170+
runClient (f value) env)
167171

168172
instance MonadIO {{title}}Client where
169-
liftIO io = {{title}}Client (\_ _ -> liftIO io)
173+
liftIO io = {{title}}Client (\_ -> liftIO io)
170174
{{/apiInfo}}
171175

172176
{{#apiInfo}}
@@ -178,24 +182,41 @@ create{{title}}Client = {{title}}Backend{..}
178182
{{/hasMore}}{{/apis}}) = client (Proxy :: Proxy {{title}}API)
179183

180184
-- | Run requests in the {{title}}Client monad.
181-
run{{title}}Client :: ServerConfig -> {{title}}Client a -> ExceptT ServantError IO a
185+
run{{title}}Client :: Config -> {{title}}Client a -> ExceptT ServantError IO a
182186
run{{title}}Client clientConfig cl = do
183-
manager <- liftIO $ newManager defaultManagerSettings
187+
manager <- liftIO $ newManager tlsManagerSettings
184188
run{{title}}ClientWithManager manager clientConfig cl
185189

186190
-- | Run requests in the {{title}}Client monad using a custom manager.
187-
run{{title}}ClientWithManager :: Manager -> ServerConfig -> {{title}}Client a -> ExceptT ServantError IO a
188-
run{{title}}ClientWithManager manager clientConfig cl =
189-
runClient cl manager $ BaseUrl Http (configHost clientConfig) (configPort clientConfig) ""
191+
run{{title}}ClientWithManager :: Manager -> Config -> {{title}}Client a -> ExceptT ServantError IO a
192+
run{{title}}ClientWithManager manager Config{..} cl = do
193+
url <- parseBaseUrl configUrl
194+
runClient cl $ mkClientEnv manager url
195+
196+
-- | Like @runClient@, but returns the response or throws
197+
-- a {{title}}ClientError
198+
call{{title}}
199+
:: (MonadIO m, MonadThrow m)
200+
=> ClientEnv -> {{title}}Client a -> m a
201+
call{{title}} env f = do
202+
res <- liftIO $ runExceptT $ runClient f env
203+
case res of
204+
Left err -> throwM ({{title}}ClientError err)
205+
Right response -> pure response
190206
{{/apiInfo}}
191207

192208
{{#apiInfo}}
193209
-- | Run the {{title}} server at the provided host and port.
194-
run{{title}}Server :: MonadIO m => ServerConfig -> {{title}}Backend (ExceptT ServantErr IO) -> m ()
195-
run{{title}}Server ServerConfig{..} backend =
210+
run{{title}}Server
211+
:: (MonadIO m, MonadThrow m)
212+
=> Config -> {{title}}Backend (ExceptT ServantErr IO) -> m ()
213+
run{{title}}Server Config{..} backend = do
214+
url <- parseBaseUrl configUrl
215+
let warpSettings = Warp.defaultSettings
216+
& Warp.setPort (baseUrlPort url)
217+
& Warp.setHost (fromString $ baseUrlHost url)
196218
liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend)
197219
where
198-
warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
199220
serverFromBackend {{title}}Backend{..} =
200221
({{#apis}}{{#operations}}{{#operation}}coerce {{operationId}}{{#hasMore}} :<|>
201222
{{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}} :<|>

0 commit comments

Comments
 (0)