valitydev/openapi-generator
14
0
Fork 0
mirror of https://github.com/valitydev/openapi-generator.git synced 2024-11-07 10:58:55 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upgrade haskell-servant generator to latest LTS (#1469)

Browse Source 
* [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
This commit is contained in:
Fabrizio Ferrai 2018-12-04 13:03:08 +02:00 committed by William Cheng
parent d75392e056
commit 6976a8c775
15 changed files with 461 additions and 772 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -179,12 +179,13 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
typeMapping.put("char", "Char"); typeMapping.put("char", "Char");
typeMapping.put("float", "Float"); typeMapping.put("float", "Float");
typeMapping.put("double", "Double"); typeMapping.put("double", "Double");
typeMapping.put("DateTime", "Integer"); typeMapping.put("DateTime", "UTCTime");
typeMapping.put("Date", "Day");
typeMapping.put("file", "FilePath"); typeMapping.put("file", "FilePath");
typeMapping.put("binary", "FilePath"); typeMapping.put("binary", "FilePath");
typeMapping.put("number", "Double"); typeMapping.put("number", "Double");
typeMapping.put("any", "Value"); typeMapping.put("any", "Value");
typeMapping.put("UUID", "Text"); typeMapping.put("UUID", "UUID");
typeMapping.put("ByteArray", "Text"); typeMapping.put("ByteArray", "Text");
typeMapping.put("object", "Value"); typeMapping.put("object", "Value");
@ -294,9 +295,44 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
} }
additionalProperties.put("specialCharReplacements", replacements); additionalProperties.put("specialCharReplacements", replacements);
// See docstring for setGenerateToSchema for why we do this
additionalProperties.put("generateToSchema", true);
super.preprocessOpenAPI(openAPI); super.preprocessOpenAPI(openAPI);
} }
/**
* Internal method to set the generateToSchema parameter.
*
* Basically we're generating ToSchema instances (generically) for all schemas.
* However, if any of the contained datatypes doesn't have the ToSchema instance,
* we cannot generate it for its "ancestor" type.
* This is the case with the "Data.Aeson.Value" type: it doesn't (and cannot) have
* a Swagger-compatible ToSchema instance. So we have to detect its presence "downstream"
* the current schema, and if we find it we just don't generate any ToSchema instance.
* @param model
*/
private void setGenerateToSchema(CodegenModel model) {
for (CodegenProperty var : model.vars) {
LOGGER.warn(var.dataType);
if (var.dataType.contentEquals("Value") || var.dataType.contains(" Value")) {
additionalProperties.put("generateToSchema", false);
}
if (var.items != null) {
if (var.items.dataType.contentEquals("Value") || var.dataType.contains(" Value")) {
additionalProperties.put("generateToSchema", false);
}
}
}
List<CodegenModel> children = model.getChildren();
if (children != null) {
for(CodegenModel child : children) {
setGenerateToSchema(child);
}
}
}
/** /**
* Optional - type declaration. This is a String which is used by the templates to instantiate your * Optional - type declaration. This is a String which is used by the templates to instantiate your
@ -312,7 +348,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
return "[" + getTypeDeclaration(inner) + "]"; return "[" + getTypeDeclaration(inner) + "]";
} else if (ModelUtils.isMapSchema(p)) { } else if (ModelUtils.isMapSchema(p)) {
Schema inner = ModelUtils.getAdditionalProperties(p); Schema inner = ModelUtils.getAdditionalProperties(p);
return "Map.Map String " + getTypeDeclaration(inner); return "(Map.Map String " + getTypeDeclaration(inner) + ")";
} }
return fixModelChars(super.getTypeDeclaration(p)); return fixModelChars(super.getTypeDeclaration(p));
} }
@ -565,6 +601,8 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
public CodegenModel fromModel(String name, Schema mod, Map<String, Schema> allDefinitions) { public CodegenModel fromModel(String name, Schema mod, Map<String, Schema> allDefinitions) {
CodegenModel model = super.fromModel(name, mod, allDefinitions); CodegenModel model = super.fromModel(name, mod, allDefinitions);
setGenerateToSchema(model);
// Clean up the class name to remove invalid characters // Clean up the class name to remove invalid characters
model.classname = fixModelChars(model.classname); model.classname = fixModelChars(model.classname);
if (typeMapping.containsValue(model.classname)) { if (typeMapping.containsValue(model.classname)) {

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

@ -1,93 +1,76 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC {-# OPTIONS_GHC
-fno-warn-unused-binds -fno-warn-unused-imports -fcontext-stack=328 #-} -fno-warn-unused-binds -fno-warn-unused-imports -freduction-depth=328 #-}
module {{title}}.API module {{title}}.API
-- * Client and Server -- * Client and Server
( ServerConfig(..) ( Config(..)
, {{title}}Backend , {{title}}Backend(..)
, create{{title}}Client , create{{title}}Client
, run{{title}}Server , run{{title}}Server
, run{{title}}Client , run{{title}}Client
, run{{title}}ClientWithManager , run{{title}}ClientWithManager
, call{{title}}
, {{title}}Client , {{title}}Client
, {{title}}ClientError(..)
-- ** Servant -- ** Servant
, {{title}}API , {{title}}API
) where ) where
import {{title}}.Types import {{title}}.Types
import Control.Monad.Except (ExceptT) import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Control.Monad.IO.Class import Control.Monad.Except (ExceptT, runExceptT)
import Data.Aeson (Value) import Control.Monad.IO.Class
import Data.Coerce (coerce) import Control.Monad.Trans.Reader (ReaderT (..))
import Data.Function ((&)) import Data.Aeson (Value)
import qualified Data.Map as Map import Data.Coerce (coerce)
import Data.Monoid ((<>)) import Data.Data (Data)
import Data.Proxy (Proxy(..)) import Data.Function ((&))
import Data.Text (Text) import qualified Data.Map as Map
import qualified Data.Text as T import Data.Monoid ((<>))
import GHC.Exts (IsString(..)) import Data.Proxy (Proxy (..))
import GHC.Generics (Generic) import Data.Text (Text)
import Network.HTTP.Client (Manager, defaultManagerSettings, newManager) import qualified Data.Text as T
import Network.HTTP.Types.Method (methodOptions) import Data.UUID (UUID)
import qualified Network.Wai.Handler.Warp as Warp import GHC.Exts (IsString (..))
import Servant (ServantErr, serve) import GHC.Generics (Generic)
import Servant.API import Network.HTTP.Client (Manager, newManager)
import Servant.API.Verbs (StdMethod(..), Verb) import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client (Scheme(Http), ServantError, client) import Network.HTTP.Types.Method (methodOptions)
import Servant.Common.BaseUrl (BaseUrl(..)) import qualified Network.Wai.Handler.Warp as Warp
import Web.HttpApiData import Servant (ServantErr, serve)
import Servant.API
import Servant.API.Verbs (StdMethod (..), Verb)
import Servant.Client (ClientEnv, Scheme (Http), ServantError, client,
mkClientEnv, parseBaseUrl)
import Servant.Client.Core (baseUrlPort, baseUrlHost)
import Servant.Client.Internal.HttpClient (ClientM (..))
import Servant.Server (Handler (..))
import Web.FormUrlEncoded
import Web.HttpApiData
{{#apiInfo}}{{#apis}}{{#operations}}{{#operation}}{{#hasFormParams}} {{#apiInfo}}{{#apis}}{{#operations}}{{#operation}}{{#hasFormParams}}
data {{vendorExtensions.x-formName}} = {{vendorExtensions.x-formName}} data {{vendorExtensions.x-formName}} = {{vendorExtensions.x-formName}}
{ {{#formParams}}{{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} :: {{dataType}}{{#hasMore}} { {{#formParams}}{{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} :: {{dataType}}{{#hasMore}}
, {{/hasMore}}{{/formParams}} , {{/hasMore}}{{/formParams}}
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromFormUrlEncoded {{vendorExtensions.x-formName}} where instance FromForm {{vendorExtensions.x-formName}}
fromFormUrlEncoded inputs = {{vendorExtensions.x-formName}} <$> {{#formParams}}lookupEither "{{baseName}}" inputs{{#hasMore}} <*> {{/hasMore}}{{/formParams}} instance ToForm {{vendorExtensions.x-formName}}
{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
instance ToFormUrlEncoded {{vendorExtensions.x-formName}} where
toFormUrlEncoded value =
[ {{#formParams}}("{{baseName}}", toQueryParam $ {{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} value){{#hasMore}}
, {{/hasMore}}{{/formParams}}
]{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
-- For the form data code generation.
lookupEither :: FromHttpApiData b => Text -> [(Text, Text)] -> Either String b
lookupEither key assocs =
case lookup key assocs of
Nothing -> Left $ "Could not find parameter " <> (T.unpack key) <> " in form data"
Just value ->
case parseQueryParam value of
Left result -> Left $ T.unpack result
Right result -> Right $ result
{{#apiInfo}}
-- | Servant type-level API, generated from the OpenAPI spec for {{title}}.
type {{title}}API
= {{#apis}}{{#operations}}{{#operation}}{{& vendorExtensions.x-routeType}} -- '{{operationId}}' route{{#hasMore}}
:<|> {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
:<|> {{/hasMore}}{{/apis}}
{{/apiInfo}}
-- | Server or client configuration, specifying the host and port to query or serve on.
data ServerConfig = ServerConfig
{ configHost :: String -- ^ Hostname to serve on, e.g. "127.0.0.1"
, configPort :: Int -- ^ Port to serve on, e.g. 8080
} deriving (Eq, Ord, Show, Read)
-- | List of elements parsed from a query. -- | List of elements parsed from a query.
newtype QueryList (p :: CollectionFormat) a = QueryList newtype QueryList (p :: CollectionFormat) a = QueryList
@ -139,6 +122,27 @@ formatSeparatedQueryList :: ToHttpApiData a => Char -> QueryList p a -> Text
formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList
{{#apiInfo}}
-- | Servant type-level API, generated from the OpenAPI spec for {{title}}.
type {{title}}API
= {{#apis}}{{#operations}}{{#operation}}{{& vendorExtensions.x-routeType}} -- '{{operationId}}' route{{#hasMore}}
:<|> {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
:<|> {{/hasMore}}{{/apis}}
{{/apiInfo}}
-- | Server or client configuration, specifying the host and port to query or serve on.
data Config = Config
{ configUrl :: String -- ^ scheme://hostname:port/path, e.g. "http://localhost:8080/"
} deriving (Eq, Ord, Show, Read)
-- | Custom exception type for our errors.
newtype {{title}}ClientError = {{title}}ClientError ServantError
deriving (Show, Exception)
-- | Configuration, specifying the full url of the service.
{{#apiInfo}} {{#apiInfo}}
-- | Backend for {{title}}. -- | Backend for {{title}}.
-- The backend can be used both for the client and the server. The client generated from the {{title}} OpenAPI spec -- 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
} }
newtype {{title}}Client a = {{title}}Client newtype {{title}}Client a = {{title}}Client
{ runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a { runClient :: ClientEnv -> ExceptT ServantError IO a
} deriving Functor } deriving Functor
instance Applicative {{title}}Client where instance Applicative {{title}}Client where
pure x = {{title}}Client (\_ _ -> pure x) pure x = {{title}}Client (\_ -> pure x)
({{title}}Client f) <*> ({{title}}Client x) = ({{title}}Client f) <*> ({{title}}Client x) =
{{title}}Client (\manager url -> f manager url <*> x manager url) {{title}}Client (\env -> f env <*> x env)
instance Monad {{title}}Client where instance Monad {{title}}Client where
({{title}}Client a) >>= f = ({{title}}Client a) >>= f =
{{title}}Client (\manager url -> do {{title}}Client (\env -> do
value <- a manager url value <- a env
runClient (f value) manager url) runClient (f value) env)
instance MonadIO {{title}}Client where instance MonadIO {{title}}Client where
liftIO io = {{title}}Client (\_ _ -> liftIO io) liftIO io = {{title}}Client (\_ -> liftIO io)
{{/apiInfo}} {{/apiInfo}}
{{#apiInfo}} {{#apiInfo}}
@ -178,24 +182,41 @@ create{{title}}Client = {{title}}Backend{..}
{{/hasMore}}{{/apis}}) = client (Proxy :: Proxy {{title}}API) {{/hasMore}}{{/apis}}) = client (Proxy :: Proxy {{title}}API)
-- | Run requests in the {{title}}Client monad. -- | Run requests in the {{title}}Client monad.
run{{title}}Client :: ServerConfig -> {{title}}Client a -> ExceptT ServantError IO a run{{title}}Client :: Config -> {{title}}Client a -> ExceptT ServantError IO a
run{{title}}Client clientConfig cl = do run{{title}}Client clientConfig cl = do
manager <- liftIO $ newManager defaultManagerSettings manager <- liftIO $ newManager tlsManagerSettings
run{{title}}ClientWithManager manager clientConfig cl run{{title}}ClientWithManager manager clientConfig cl
-- | Run requests in the {{title}}Client monad using a custom manager. -- | Run requests in the {{title}}Client monad using a custom manager.
run{{title}}ClientWithManager :: Manager -> ServerConfig -> {{title}}Client a -> ExceptT ServantError IO a run{{title}}ClientWithManager :: Manager -> Config -> {{title}}Client a -> ExceptT ServantError IO a
run{{title}}ClientWithManager manager clientConfig cl = run{{title}}ClientWithManager manager Config{..} cl = do
runClient cl manager $ BaseUrl Http (configHost clientConfig) (configPort clientConfig) "" url <- parseBaseUrl configUrl
runClient cl $ mkClientEnv manager url
-- | Like @runClient@, but returns the response or throws
-- a {{title}}ClientError
call{{title}}
:: (MonadIO m, MonadThrow m)
=> ClientEnv -> {{title}}Client a -> m a
call{{title}} env f = do
res <- liftIO $ runExceptT $ runClient f env
case res of
Left err -> throwM ({{title}}ClientError err)
Right response -> pure response
{{/apiInfo}} {{/apiInfo}}
{{#apiInfo}} {{#apiInfo}}
-- | Run the {{title}} server at the provided host and port. -- | Run the {{title}} server at the provided host and port.
run{{title}}Server :: MonadIO m => ServerConfig -> {{title}}Backend (ExceptT ServantErr IO) -> m () run{{title}}Server
run{{title}}Server ServerConfig{..} backend = :: (MonadIO m, MonadThrow m)
=> Config -> {{title}}Backend (ExceptT ServantErr IO) -> m ()
run{{title}}Server Config{..} backend = do
url <- parseBaseUrl configUrl
let warpSettings = Warp.defaultSettings
& Warp.setPort (baseUrlPort url)
& Warp.setHost (fromString $ baseUrlHost url)
liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend) liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend)
where where
warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
serverFromBackend {{title}}Backend{..} = serverFromBackend {{title}}Backend{..} =
({{#apis}}{{#operations}}{{#operation}}coerce {{operationId}}{{#hasMore}} :<|> ({{#apis}}{{#operations}}{{#operation}}coerce {{operationId}}{{#hasMore}} :<|>
{{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}} :<|> {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}} :<|>

66
modules/openapi-generator/src/main/resources/haskell-servant/README.mustache
View File

@ -9,6 +9,14 @@ Installation follows the standard approach to installing Stack-based projects.
1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). 1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README).
2. Run `stack install` to install this package. 2. Run `stack install` to install this package.
Otherwise, if you already have a Stack project, you can include this package under the `packages` key in your `stack.yaml`:
```yaml
packages:
- location:
git: https://github.com/yourGitOrg/yourGitRepo
commit: somecommit
```
## Main Interface ## Main Interface
The main interface to this library is in the `{{title}}.API` module, which exports the {{title}}Backend type. The {{title}}Backend The main interface to this library is in the `{{title}}.API` module, which exports the {{title}}Backend type. The {{title}}Backend
@ -16,20 +24,36 @@ type can be used to create and define servers and clients for the API.
## Creating a Client ## Creating a Client
A client can be created via the `create{{title}}Client` function, which, if provided with a hostname and a port, will generate A client can be created via the `create{{title}}Client` function, which will generate a function for every endpoint of the API.
a client that can be used to access the API if it is being served at that hostname / port combination. For example, if Then these functions can be invoked with `run{{title}}ClientWithManager` or more conveniently with `call{{title}}Client`
`localhost:8080` is serving the {{title}} API, you can write: (depending if you want an `Either` back or you want to catch) to access the API endpoint they refer to, if the API is served
at the `url` you specified.
For example, if `localhost:8080` is serving the {{title}} API, you can write:
```haskell ```haskell
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
import {{title}}.API import {{title}}.API as API
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client (ClientEnv, mkClientEnv, parseBaseUrl)
main :: IO () main :: IO ()
main = do main = do
{{title}}Backend{..} <- create{{title}}Client (ServerConfig "localhost" 8080) -- Configure the BaseUrl for the client
-- Any {{title}} API call can go here. url <- parseBaseUrl "http://localhost:8080/"
return ()
-- You probably want to reuse the Manager across calls, for performance reasons
manager <- newManager tlsManagerSettings
-- Create the client (all endpoint functions will be available)
{{title}}Backend{..} <- API.create{{title}}Client
-- Any {{title}} API call can go here, e.g. here we call `getSomeEndpoint`
API.call{{title}} (mkClientEnv manager url) getSomeEndpoint
``` ```
## Creating a Server ## Creating a Server
@ -50,30 +74,6 @@ import {{title}}.Handlers
main :: IO () main :: IO ()
main = do main = do
let server = {{title}}Backend{..} let server = {{title}}Backend{..}
run{{title}}Server (ServerConfig "localhost" 8080) server config = Config "http://localhost:8080/"
``` run{{title}}Server config server
You could use `optparse-applicative` or a similar library to read the host and port from command-line arguments:
```
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import {{title}}.API (run{{title}}Server, {{title}}Backend(..), ServerConfig(..))
import Control.Applicative ((<$>), (<*>))
import Options.Applicative (execParser, option, str, auto, long, metavar, help)
main :: IO ()
main = do
config <- parseArguments
run{{title}}Server config {{title}}Backend{}
-- | Parse host and port from the command line arguments.
parseArguments :: IO ServerConfig
parseArguments =
execParser $
ServerConfig
<$> option str (long "host" <> metavar "HOST" <> help "Host to serve on")
<*> option auto (long "port" <> metavar "PORT" <> help "Port to serve on")
``` ```

30
modules/openapi-generator/src/main/resources/haskell-servant/Types.mustache
View File

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
module {{title}}.Types ( module {{title}}.Types (
@ -10,11 +11,17 @@ module {{title}}.Types (
{{/models}} {{/models}}
) where ) where
import Data.Data (Data)
import Data.UUID (UUID)
import Data.List (stripPrefix) import Data.List (stripPrefix)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON) import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions) import Data.Aeson.Types (Options(..), defaultOptions)
import Data.Text (Text) import Data.Text (Text)
import Data.Time
import Data.Swagger (ToSchema, declareNamedSchema)
import qualified Data.Swagger as Swagger
import qualified Data.Char as Char
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as Map import qualified Data.Map as Map
import GHC.Generics (Generic) import GHC.Generics (Generic)
@ -29,18 +36,25 @@ import Data.Function ((&))
{{^vendorExtensions.x-customNewtype}} {{^vendorExtensions.x-customNewtype}}
{{^parent}} {{^parent}}
{{vendorExtensions.x-data}} {{classname}} = {{classname}} {{vendorExtensions.x-data}} {{classname}} = {{classname}}
{ {{#vars}}{{& name}} :: {{dataType}} -- ^ {{& description}}{{#hasMore}} { {{#vars}}{{& name}} :: {{^required}}Maybe {{/required}}{{dataType}} -- ^ {{& description}}{{#hasMore}}
, {{/hasMore}}{{/vars}} , {{/hasMore}}{{/vars}}
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON {{classname}} where instance FromJSON {{classname}} where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}") parseJSON = genericParseJSON (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}")
instance ToJSON {{classname}} where instance ToJSON {{classname}} where
toJSON = genericToJSON (removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}") toJSON = genericToJSON (removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}")
{{#generateToSchema}}
instance ToSchema {{classname}} where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}"
{{/generateToSchema}}
{{/parent}} {{/parent}}
{{#parent}} {{#parent}}
newtype {{classname}} = {{classname}} { un{{classname}} :: {{parent}} } newtype {{classname}} = {{classname}} { un{{classname}} :: {{parent}} }
deriving (Show, Eq, FromJSON, ToJSON, Generic) deriving (Show, Eq, FromJSON, ToJSON, Generic, Data)
{{/parent}} {{/parent}}
{{/vendorExtensions.x-customNewtype}} {{/vendorExtensions.x-customNewtype}}
{{#vendorExtensions.x-customNewtype}} {{#vendorExtensions.x-customNewtype}}
@ -49,12 +63,18 @@ newtype {{classname}} = {{classname}} {{vendorExtensions.x-customNewtype}} deriv
{{/model}} {{/model}}
{{/models}} {{/models}}
uncapitalize :: String -> String
uncapitalize (first:rest) = Char.toLower first : rest
uncapitalize [] = []
-- Remove a field label prefix during JSON parsing. -- Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters. -- Also perform any replacements for special characters.
removeFieldLabelPrefix :: Bool -> String -> Options removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix = removeFieldLabelPrefix forParsing prefix =
defaultOptions defaultOptions
{fieldLabelModifier = fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars} { omitNothingFields = True
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
}
where where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars = specialChars =

7
modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache
View File

@ -19,15 +19,22 @@ library
, aeson , aeson
, text , text
, containers , containers
, exceptions
, network-uri , network-uri
, servant , servant
, http-api-data , http-api-data
, servant
, servant-client , servant-client
, servant-client-core
, servant-server , servant-server
, servant , servant
, warp , warp
, transformers , transformers
, mtl , mtl
, time
, http-client , http-client
, http-client-tls
, http-types , http-types
, swagger2
, uuid
default-language: Haskell2010 default-language: Haskell2010

12
modules/openapi-generator/src/main/resources/haskell-servant/stack.mustache
View File

@ -1,8 +1,8 @@
resolver: lts-8.5 resolver: lts-12.18
extra-deps: extra-deps: []
- servant-0.9.1.1
- servant-client-0.9.1.1
- servant-server-0.9.1.1
- http-api-data-0.3.5
packages: packages:
- '.' - '.'
nix:
enable: false
packages:
- zlib

2
samples/server/petstore/haskell-servant/.openapi-generator/VERSION
View File

@ -1 +1 @@
3.3.0-SNAPSHOT 4.0.0-SNAPSHOT

66
samples/server/petstore/haskell-servant/README.md
View File

@ -9,6 +9,14 @@ Installation follows the standard approach to installing Stack-based projects.
1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). 1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README).
2. Run `stack install` to install this package. 2. Run `stack install` to install this package.
Otherwise, if you already have a Stack project, you can include this package under the `packages` key in your `stack.yaml`:
```yaml
packages:
- location:
git: https://github.com/yourGitOrg/yourGitRepo
commit: somecommit
```
## Main Interface ## Main Interface
The main interface to this library is in the `OpenAPIPetstore.API` module, which exports the OpenAPIPetstoreBackend type. The OpenAPIPetstoreBackend The main interface to this library is in the `OpenAPIPetstore.API` module, which exports the OpenAPIPetstoreBackend type. The OpenAPIPetstoreBackend
@ -16,20 +24,36 @@ type can be used to create and define servers and clients for the API.
## Creating a Client ## Creating a Client
A client can be created via the `createOpenAPIPetstoreClient` function, which, if provided with a hostname and a port, will generate A client can be created via the `createOpenAPIPetstoreClient` function, which will generate a function for every endpoint of the API.
a client that can be used to access the API if it is being served at that hostname / port combination. For example, if Then these functions can be invoked with `runOpenAPIPetstoreClientWithManager` or more conveniently with `callOpenAPIPetstoreClient`
`localhost:8080` is serving the OpenAPIPetstore API, you can write: (depending if you want an `Either` back or you want to catch) to access the API endpoint they refer to, if the API is served
at the `url` you specified.
For example, if `localhost:8080` is serving the OpenAPIPetstore API, you can write:
```haskell ```haskell
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
import OpenAPIPetstore.API import OpenAPIPetstore.API as API
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client (ClientEnv, mkClientEnv, parseBaseUrl)
main :: IO () main :: IO ()
main = do main = do
OpenAPIPetstoreBackend{..} <- createOpenAPIPetstoreClient (ServerConfig "localhost" 8080) -- Configure the BaseUrl for the client
-- Any OpenAPIPetstore API call can go here. url <- parseBaseUrl "http://localhost:8080/"
return ()
-- You probably want to reuse the Manager across calls, for performance reasons
manager <- newManager tlsManagerSettings
-- Create the client (all endpoint functions will be available)
OpenAPIPetstoreBackend{..} <- API.createOpenAPIPetstoreClient
-- Any OpenAPIPetstore API call can go here, e.g. here we call `getSomeEndpoint`
API.callOpenAPIPetstore (mkClientEnv manager url) getSomeEndpoint
``` ```
## Creating a Server ## Creating a Server
@ -50,30 +74,6 @@ import OpenAPIPetstore.Handlers
main :: IO () main :: IO ()
main = do main = do
let server = OpenAPIPetstoreBackend{..} let server = OpenAPIPetstoreBackend{..}
runOpenAPIPetstoreServer (ServerConfig "localhost" 8080) server config = Config "http://localhost:8080/"
``` runOpenAPIPetstoreServer config server
You could use `optparse-applicative` or a similar library to read the host and port from command-line arguments:
```
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import OpenAPIPetstore.API (runOpenAPIPetstoreServer, OpenAPIPetstoreBackend(..), ServerConfig(..))
import Control.Applicative ((<$>), (<*>))
import Options.Applicative (execParser, option, str, auto, long, metavar, help)
main :: IO ()
main = do
config <- parseArguments
runOpenAPIPetstoreServer config OpenAPIPetstoreBackend{}
-- | Parse host and port from the command line arguments.
parseArguments :: IO ServerConfig
parseArguments =
execParser $
ServerConfig
<$> option str (long "host" <> metavar "HOST" <> help "Host to serve on")
<*> option auto (long "port" <> metavar "PORT" <> help "Port to serve on")
``` ```

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

@ -1,121 +1,84 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC {-# OPTIONS_GHC
-fno-warn-unused-binds -fno-warn-unused-imports -fcontext-stack=328 #-} -fno-warn-unused-binds -fno-warn-unused-imports -freduction-depth=328 #-}
module OpenAPIPetstore.API module OpenAPIPetstore.API
-- * Client and Server -- * Client and Server
( ServerConfig(..) ( Config(..)
, OpenAPIPetstoreBackend , OpenAPIPetstoreBackend(..)
, createOpenAPIPetstoreClient , createOpenAPIPetstoreClient
, runOpenAPIPetstoreServer , runOpenAPIPetstoreServer
, runOpenAPIPetstoreClient , runOpenAPIPetstoreClient
, runOpenAPIPetstoreClientWithManager , runOpenAPIPetstoreClientWithManager
, callOpenAPIPetstore
, OpenAPIPetstoreClient , OpenAPIPetstoreClient
, OpenAPIPetstoreClientError(..)
-- ** Servant -- ** Servant
, OpenAPIPetstoreAPI , OpenAPIPetstoreAPI
) where ) where
import OpenAPIPetstore.Types import OpenAPIPetstore.Types
import Control.Monad.Except (ExceptT) import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Control.Monad.IO.Class import Control.Monad.Except (ExceptT, runExceptT)
import Data.Aeson (Value) import Control.Monad.IO.Class
import Data.Coerce (coerce) import Control.Monad.Trans.Reader (ReaderT (..))
import Data.Function ((&)) import Data.Aeson (Value)
import qualified Data.Map as Map import Data.Coerce (coerce)
import Data.Monoid ((<>)) import Data.Data (Data)
import Data.Proxy (Proxy(..)) import Data.Function ((&))
import Data.Text (Text) import qualified Data.Map as Map
import qualified Data.Text as T import Data.Monoid ((<>))
import GHC.Exts (IsString(..)) import Data.Proxy (Proxy (..))
import GHC.Generics (Generic) import Data.Text (Text)
import Network.HTTP.Client (Manager, defaultManagerSettings, newManager) import qualified Data.Text as T
import Network.HTTP.Types.Method (methodOptions) import Data.UUID (UUID)
import qualified Network.Wai.Handler.Warp as Warp import GHC.Exts (IsString (..))
import Servant (ServantErr, serve) import GHC.Generics (Generic)
import Servant.API import Network.HTTP.Client (Manager, newManager)
import Servant.API.Verbs (StdMethod(..), Verb) import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client (Scheme(Http), ServantError, client) import Network.HTTP.Types.Method (methodOptions)
import Servant.Common.BaseUrl (BaseUrl(..)) import qualified Network.Wai.Handler.Warp as Warp
import Web.HttpApiData import Servant (ServantErr, serve)
import Servant.API
import Servant.API.Verbs (StdMethod (..), Verb)
import Servant.Client (ClientEnv, Scheme (Http), ServantError, client,
mkClientEnv, parseBaseUrl)
import Servant.Client.Core (baseUrlPort, baseUrlHost)
import Servant.Client.Internal.HttpClient (ClientM (..))
import Servant.Server (Handler (..))
import Web.FormUrlEncoded
import Web.HttpApiData
data FormUpdatePetWithForm = FormUpdatePetWithForm data FormUpdatePetWithForm = FormUpdatePetWithForm
{ updatePetWithFormName :: Text { updatePetWithFormName :: Text
, updatePetWithFormStatus :: Text , updatePetWithFormStatus :: Text
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromFormUrlEncoded FormUpdatePetWithForm where instance FromForm FormUpdatePetWithForm
fromFormUrlEncoded inputs = FormUpdatePetWithForm <$> lookupEither "name" inputs <*> lookupEither "status" inputs instance ToForm FormUpdatePetWithForm
instance ToFormUrlEncoded FormUpdatePetWithForm where
toFormUrlEncoded value =
[ ("name", toQueryParam $ updatePetWithFormName value)
, ("status", toQueryParam $ updatePetWithFormStatus value)
]
data FormUploadFile = FormUploadFile data FormUploadFile = FormUploadFile
{ uploadFileAdditionalMetadata :: Text { uploadFileAdditionalMetadata :: Text
, uploadFileFile :: FilePath , uploadFileFile :: FilePath
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromFormUrlEncoded FormUploadFile where instance FromForm FormUploadFile
fromFormUrlEncoded inputs = FormUploadFile <$> lookupEither "additionalMetadata" inputs <*> lookupEither "file" inputs instance ToForm FormUploadFile
instance ToFormUrlEncoded FormUploadFile where
toFormUrlEncoded value =
[ ("additionalMetadata", toQueryParam $ uploadFileAdditionalMetadata value)
, ("file", toQueryParam $ uploadFileFile value)
]
-- For the form data code generation.
lookupEither :: FromHttpApiData b => Text -> [(Text, Text)] -> Either String b
lookupEither key assocs =
case lookup key assocs of
Nothing -> Left $ "Could not find parameter " <> (T.unpack key) <> " in form data"
Just value ->
case parseQueryParam value of
Left result -> Left $ T.unpack result
Right result -> Right $ result
-- | Servant type-level API, generated from the OpenAPI spec for OpenAPIPetstore.
type OpenAPIPetstoreAPI
= "pet" :> ReqBody '[JSON] Pet :> Verb 'POST 200 '[JSON] () -- 'addPet' route
:<|> "pet" :> Capture "petId" Integer :> Header "api_key" Text :> Verb 'DELETE 200 '[JSON] () -- 'deletePet' route
:<|> "pet" :> "findByStatus" :> QueryParam "status" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByStatus' route
:<|> "pet" :> "findByTags" :> QueryParam "tags" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByTags' route
:<|> "pet" :> Capture "petId" Integer :> Verb 'GET 200 '[JSON] Pet -- 'getPetById' route
:<|> "pet" :> ReqBody '[JSON] Pet :> Verb 'PUT 200 '[JSON] () -- 'updatePet' route
:<|> "pet" :> Capture "petId" Integer :> ReqBody '[FormUrlEncoded] FormUpdatePetWithForm :> Verb 'POST 200 '[JSON] () -- 'updatePetWithForm' route
:<|> "pet" :> Capture "petId" Integer :> "uploadImage" :> ReqBody '[FormUrlEncoded] FormUploadFile :> Verb 'POST 200 '[JSON] ApiResponse -- 'uploadFile' route
:<|> "store" :> "order" :> Capture "orderId" Text :> Verb 'DELETE 200 '[JSON] () -- 'deleteOrder' route
:<|> "store" :> "inventory" :> Verb 'GET 200 '[JSON] (Map.Map String Int) -- 'getInventory' route
:<|> "store" :> "order" :> Capture "orderId" Integer :> Verb 'GET 200 '[JSON] Order -- 'getOrderById' route
:<|> "store" :> "order" :> ReqBody '[JSON] Order :> Verb 'POST 200 '[JSON] Order -- 'placeOrder' route
:<|> "user" :> ReqBody '[JSON] User :> Verb 'POST 200 '[JSON] () -- 'createUser' route
:<|> "user" :> "createWithArray" :> ReqBody '[JSON] [User] :> Verb 'POST 200 '[JSON] () -- 'createUsersWithArrayInput' route
:<|> "user" :> "createWithList" :> ReqBody '[JSON] [User] :> Verb 'POST 200 '[JSON] () -- 'createUsersWithListInput' route
:<|> "user" :> Capture "username" Text :> Verb 'DELETE 200 '[JSON] () -- 'deleteUser' route
:<|> "user" :> Capture "username" Text :> Verb 'GET 200 '[JSON] User -- 'getUserByName' route
:<|> "user" :> "login" :> QueryParam "username" Text :> QueryParam "password" Text :> Verb 'GET 200 '[JSON] Text -- 'loginUser' route
:<|> "user" :> "logout" :> Verb 'GET 200 '[JSON] () -- 'logoutUser' route
:<|> "user" :> Capture "username" Text :> ReqBody '[JSON] User :> Verb 'PUT 200 '[JSON] () -- 'updateUser' route
-- | Server or client configuration, specifying the host and port to query or serve on.
data ServerConfig = ServerConfig
{ configHost :: String -- ^ Hostname to serve on, e.g. "127.0.0.1"
, configPort :: Int -- ^ Port to serve on, e.g. 8080
} deriving (Eq, Ord, Show, Read)
-- | List of elements parsed from a query. -- | List of elements parsed from a query.
newtype QueryList (p :: CollectionFormat) a = QueryList newtype QueryList (p :: CollectionFormat) a = QueryList
@ -167,6 +130,42 @@ formatSeparatedQueryList :: ToHttpApiData a => Char -> QueryList p a -> Text
formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList
-- | Servant type-level API, generated from the OpenAPI spec for OpenAPIPetstore.
type OpenAPIPetstoreAPI
= "pet" :> ReqBody '[JSON] Pet :> Verb 'POST 200 '[JSON] () -- 'addPet' route
:<|> "pet" :> Capture "petId" Integer :> Header "api_key" Text :> Verb 'DELETE 200 '[JSON] () -- 'deletePet' route
:<|> "pet" :> "findByStatus" :> QueryParam "status" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByStatus' route
:<|> "pet" :> "findByTags" :> QueryParam "tags" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByTags' route
:<|> "pet" :> Capture "petId" Integer :> Verb 'GET 200 '[JSON] Pet -- 'getPetById' route
:<|> "pet" :> ReqBody '[JSON] Pet :> Verb 'PUT 200 '[JSON] () -- 'updatePet' route
:<|> "pet" :> Capture "petId" Integer :> ReqBody '[FormUrlEncoded] FormUpdatePetWithForm :> Verb 'POST 200 '[JSON] () -- 'updatePetWithForm' route
:<|> "pet" :> Capture "petId" Integer :> "uploadImage" :> ReqBody '[FormUrlEncoded] FormUploadFile :> Verb 'POST 200 '[JSON] ApiResponse -- 'uploadFile' route
:<|> "store" :> "order" :> Capture "orderId" Text :> Verb 'DELETE 200 '[JSON] () -- 'deleteOrder' route
:<|> "store" :> "inventory" :> Verb 'GET 200 '[JSON] ((Map.Map String Int)) -- 'getInventory' route
:<|> "store" :> "order" :> Capture "orderId" Integer :> Verb 'GET 200 '[JSON] Order -- 'getOrderById' route
:<|> "store" :> "order" :> ReqBody '[JSON] Order :> Verb 'POST 200 '[JSON] Order -- 'placeOrder' route
:<|> "user" :> ReqBody '[JSON] User :> Verb 'POST 200 '[JSON] () -- 'createUser' route
:<|> "user" :> "createWithArray" :> ReqBody '[JSON] [User] :> Verb 'POST 200 '[JSON] () -- 'createUsersWithArrayInput' route
:<|> "user" :> "createWithList" :> ReqBody '[JSON] [User] :> Verb 'POST 200 '[JSON] () -- 'createUsersWithListInput' route
:<|> "user" :> Capture "username" Text :> Verb 'DELETE 200 '[JSON] () -- 'deleteUser' route
:<|> "user" :> Capture "username" Text :> Verb 'GET 200 '[JSON] User -- 'getUserByName' route
:<|> "user" :> "login" :> QueryParam "username" Text :> QueryParam "password" Text :> Verb 'GET 200 '[JSON] Text -- 'loginUser' route
:<|> "user" :> "logout" :> Verb 'GET 200 '[JSON] () -- 'logoutUser' route
:<|> "user" :> Capture "username" Text :> ReqBody '[JSON] User :> Verb 'PUT 200 '[JSON] () -- 'updateUser' route
-- | Server or client configuration, specifying the host and port to query or serve on.
data Config = Config
{ configUrl :: String -- ^ scheme://hostname:port/path, e.g. "http://localhost:8080/"
} deriving (Eq, Ord, Show, Read)
-- | Custom exception type for our errors.
newtype OpenAPIPetstoreClientError = OpenAPIPetstoreClientError ServantError
deriving (Show, Exception)
-- | Configuration, specifying the full url of the service.
-- | Backend for OpenAPIPetstore. -- | Backend for OpenAPIPetstore.
-- The backend can be used both for the client and the server. The client generated from the OpenAPIPetstore OpenAPI spec -- The backend can be used both for the client and the server. The client generated from the OpenAPIPetstore OpenAPI spec
-- is a backend that executes actions by sending HTTP requests (see @createOpenAPIPetstoreClient@). Alternatively, provided -- is a backend that executes actions by sending HTTP requests (see @createOpenAPIPetstoreClient@). Alternatively, provided
@ -181,7 +180,7 @@ data OpenAPIPetstoreBackend m = OpenAPIPetstoreBackend
, updatePetWithForm :: Integer -> FormUpdatePetWithForm -> m (){- ^ -} , updatePetWithForm :: Integer -> FormUpdatePetWithForm -> m (){- ^ -}
, uploadFile :: Integer -> FormUploadFile -> m ApiResponse{- ^ -} , uploadFile :: Integer -> FormUploadFile -> m ApiResponse{- ^ -}
, deleteOrder :: Text -> m (){- ^ For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors -} , deleteOrder :: Text -> m (){- ^ For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors -}
, getInventory :: m (Map.Map String Int){- ^ Returns a map of status codes to quantities -} , getInventory :: m ((Map.Map String Int)){- ^ Returns a map of status codes to quantities -}
, getOrderById :: Integer -> m Order{- ^ For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions -} , getOrderById :: Integer -> m Order{- ^ For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions -}
, placeOrder :: Order -> m Order{- ^ -} , placeOrder :: Order -> m Order{- ^ -}
, createUser :: User -> m (){- ^ This can only be done by the logged in user. -} , createUser :: User -> m (){- ^ This can only be done by the logged in user. -}
@ -195,22 +194,22 @@ data OpenAPIPetstoreBackend m = OpenAPIPetstoreBackend
} }
newtype OpenAPIPetstoreClient a = OpenAPIPetstoreClient newtype OpenAPIPetstoreClient a = OpenAPIPetstoreClient
{ runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a { runClient :: ClientEnv -> ExceptT ServantError IO a
} deriving Functor } deriving Functor
instance Applicative OpenAPIPetstoreClient where instance Applicative OpenAPIPetstoreClient where
pure x = OpenAPIPetstoreClient (\_ _ -> pure x) pure x = OpenAPIPetstoreClient (\_ -> pure x)
(OpenAPIPetstoreClient f) <*> (OpenAPIPetstoreClient x) = (OpenAPIPetstoreClient f) <*> (OpenAPIPetstoreClient x) =
OpenAPIPetstoreClient (\manager url -> f manager url <*> x manager url) OpenAPIPetstoreClient (\env -> f env <*> x env)
instance Monad OpenAPIPetstoreClient where instance Monad OpenAPIPetstoreClient where
(OpenAPIPetstoreClient a) >>= f = (OpenAPIPetstoreClient a) >>= f =
OpenAPIPetstoreClient (\manager url -> do OpenAPIPetstoreClient (\env -> do
value <- a manager url value <- a env
runClient (f value) manager url) runClient (f value) env)
instance MonadIO OpenAPIPetstoreClient where instance MonadIO OpenAPIPetstoreClient where
liftIO io = OpenAPIPetstoreClient (\_ _ -> liftIO io) liftIO io = OpenAPIPetstoreClient (\_ -> liftIO io)
createOpenAPIPetstoreClient :: OpenAPIPetstoreBackend OpenAPIPetstoreClient createOpenAPIPetstoreClient :: OpenAPIPetstoreBackend OpenAPIPetstoreClient
createOpenAPIPetstoreClient = OpenAPIPetstoreBackend{..} createOpenAPIPetstoreClient = OpenAPIPetstoreBackend{..}
@ -237,22 +236,39 @@ createOpenAPIPetstoreClient = OpenAPIPetstoreBackend{..}
(coerce -> updateUser)) = client (Proxy :: Proxy OpenAPIPetstoreAPI) (coerce -> updateUser)) = client (Proxy :: Proxy OpenAPIPetstoreAPI)
-- | Run requests in the OpenAPIPetstoreClient monad. -- | Run requests in the OpenAPIPetstoreClient monad.
runOpenAPIPetstoreClient :: ServerConfig -> OpenAPIPetstoreClient a -> ExceptT ServantError IO a runOpenAPIPetstoreClient :: Config -> OpenAPIPetstoreClient a -> ExceptT ServantError IO a
runOpenAPIPetstoreClient clientConfig cl = do runOpenAPIPetstoreClient clientConfig cl = do
manager <- liftIO $ newManager defaultManagerSettings manager <- liftIO $ newManager tlsManagerSettings
runOpenAPIPetstoreClientWithManager manager clientConfig cl runOpenAPIPetstoreClientWithManager manager clientConfig cl
-- | Run requests in the OpenAPIPetstoreClient monad using a custom manager. -- | Run requests in the OpenAPIPetstoreClient monad using a custom manager.
runOpenAPIPetstoreClientWithManager :: Manager -> ServerConfig -> OpenAPIPetstoreClient a -> ExceptT ServantError IO a runOpenAPIPetstoreClientWithManager :: Manager -> Config -> OpenAPIPetstoreClient a -> ExceptT ServantError IO a
runOpenAPIPetstoreClientWithManager manager clientConfig cl = runOpenAPIPetstoreClientWithManager manager Config{..} cl = do
runClient cl manager $ BaseUrl Http (configHost clientConfig) (configPort clientConfig) "" url <- parseBaseUrl configUrl
runClient cl $ mkClientEnv manager url
-- | Like @runClient@, but returns the response or throws
-- a OpenAPIPetstoreClientError
callOpenAPIPetstore
:: (MonadIO m, MonadThrow m)
=> ClientEnv -> OpenAPIPetstoreClient a -> m a
callOpenAPIPetstore env f = do
res <- liftIO $ runExceptT $ runClient f env
case res of
Left err -> throwM (OpenAPIPetstoreClientError err)
Right response -> pure response
-- | Run the OpenAPIPetstore server at the provided host and port. -- | Run the OpenAPIPetstore server at the provided host and port.
runOpenAPIPetstoreServer :: MonadIO m => ServerConfig -> OpenAPIPetstoreBackend (ExceptT ServantErr IO) -> m () runOpenAPIPetstoreServer
runOpenAPIPetstoreServer ServerConfig{..} backend = :: (MonadIO m, MonadThrow m)
=> Config -> OpenAPIPetstoreBackend (ExceptT ServantErr IO) -> m ()
runOpenAPIPetstoreServer Config{..} backend = do
url <- parseBaseUrl configUrl
let warpSettings = Warp.defaultSettings
& Warp.setPort (baseUrlPort url)
& Warp.setHost (fromString $ baseUrlHost url)
liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy OpenAPIPetstoreAPI) (serverFromBackend backend) liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy OpenAPIPetstoreAPI) (serverFromBackend backend)
where where
warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
serverFromBackend OpenAPIPetstoreBackend{..} = serverFromBackend OpenAPIPetstoreBackend{..} =
(coerce addPet :<|> (coerce addPet :<|>
coerce deletePet :<|> coerce deletePet :<|>

109
samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/Types.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
module OpenAPIPetstore.Types ( module OpenAPIPetstore.Types (
@ -11,11 +12,17 @@ module OpenAPIPetstore.Types (
User (..), User (..),
) where ) where
import Data.Data (Data)
import Data.UUID (UUID)
import Data.List (stripPrefix) import Data.List (stripPrefix)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON) import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions) import Data.Aeson.Types (Options(..), defaultOptions)
import Data.Text (Text) import Data.Text (Text)
import Data.Time
import Data.Swagger (ToSchema, declareNamedSchema)
import qualified Data.Swagger as Swagger
import qualified Data.Char as Char
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as Map import qualified Data.Map as Map
import GHC.Generics (Generic) import GHC.Generics (Generic)
@ -24,91 +31,127 @@ import Data.Function ((&))
-- | Describes the result of uploading an image resource -- | Describes the result of uploading an image resource
data ApiResponse = ApiResponse data ApiResponse = ApiResponse
{ apiResponseCode :: Int -- ^ { apiResponseCode :: Maybe Int -- ^
, apiResponseType :: Text -- ^ , apiResponseType :: Maybe Text -- ^
, apiResponseMessage :: Text -- ^ , apiResponseMessage :: Maybe Text -- ^
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON ApiResponse where instance FromJSON ApiResponse where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "apiResponse") parseJSON = genericParseJSON (removeFieldLabelPrefix True "apiResponse")
instance ToJSON ApiResponse where instance ToJSON ApiResponse where
toJSON = genericToJSON (removeFieldLabelPrefix False "apiResponse") toJSON = genericToJSON (removeFieldLabelPrefix False "apiResponse")
instance ToSchema ApiResponse where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "apiResponse"
-- | A category for a pet -- | A category for a pet
data Category = Category data Category = Category
{ categoryId :: Integer -- ^ { categoryId :: Maybe Integer -- ^
, categoryName :: Text -- ^ , categoryName :: Maybe Text -- ^
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON Category where instance FromJSON Category where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "category") parseJSON = genericParseJSON (removeFieldLabelPrefix True "category")
instance ToJSON Category where instance ToJSON Category where
toJSON = genericToJSON (removeFieldLabelPrefix False "category") toJSON = genericToJSON (removeFieldLabelPrefix False "category")
instance ToSchema Category where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "category"
-- | An order for a pets from the pet store -- | An order for a pets from the pet store
data Order = Order data Order = Order
{ orderId :: Integer -- ^ { orderId :: Maybe Integer -- ^
, orderPetId :: Integer -- ^ , orderPetId :: Maybe Integer -- ^
, orderQuantity :: Int -- ^ , orderQuantity :: Maybe Int -- ^
, orderShipDate :: Integer -- ^ , orderShipDate :: Maybe UTCTime -- ^
, orderStatus :: Text -- ^ Order Status , orderStatus :: Maybe Text -- ^ Order Status
, orderComplete :: Bool -- ^ , orderComplete :: Maybe Bool -- ^
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON Order where instance FromJSON Order where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "order") parseJSON = genericParseJSON (removeFieldLabelPrefix True "order")
instance ToJSON Order where instance ToJSON Order where
toJSON = genericToJSON (removeFieldLabelPrefix False "order") toJSON = genericToJSON (removeFieldLabelPrefix False "order")
instance ToSchema Order where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "order"
-- | A pet for sale in the pet store -- | A pet for sale in the pet store
data Pet = Pet data Pet = Pet
{ petId :: Integer -- ^ { petId :: Maybe Integer -- ^
, petCategory :: Category -- ^ , petCategory :: Maybe Category -- ^
, petName :: Text -- ^ , petName :: Text -- ^
, petPhotoUrls :: [Text] -- ^ , petPhotoUrls :: [Text] -- ^
, petTags :: [Tag] -- ^ , petTags :: Maybe [Tag] -- ^
, petStatus :: Text -- ^ pet status in the store , petStatus :: Maybe Text -- ^ pet status in the store
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON Pet where instance FromJSON Pet where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "pet") parseJSON = genericParseJSON (removeFieldLabelPrefix True "pet")
instance ToJSON Pet where instance ToJSON Pet where
toJSON = genericToJSON (removeFieldLabelPrefix False "pet") toJSON = genericToJSON (removeFieldLabelPrefix False "pet")
instance ToSchema Pet where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "pet"
-- | A tag for a pet -- | A tag for a pet
data Tag = Tag data Tag = Tag
{ tagId :: Integer -- ^ { tagId :: Maybe Integer -- ^
, tagName :: Text -- ^ , tagName :: Maybe Text -- ^
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON Tag where instance FromJSON Tag where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "tag") parseJSON = genericParseJSON (removeFieldLabelPrefix True "tag")
instance ToJSON Tag where instance ToJSON Tag where
toJSON = genericToJSON (removeFieldLabelPrefix False "tag") toJSON = genericToJSON (removeFieldLabelPrefix False "tag")
instance ToSchema Tag where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "tag"
-- | A User who is purchasing from the pet store -- | A User who is purchasing from the pet store
data User = User data User = User
{ userId :: Integer -- ^ { userId :: Maybe Integer -- ^
, userUsername :: Text -- ^ , userUsername :: Maybe Text -- ^
, userFirstName :: Text -- ^ , userFirstName :: Maybe Text -- ^
, userLastName :: Text -- ^ , userLastName :: Maybe Text -- ^
, userEmail :: Text -- ^ , userEmail :: Maybe Text -- ^
, userPassword :: Text -- ^ , userPassword :: Maybe Text -- ^
, userPhone :: Text -- ^ , userPhone :: Maybe Text -- ^
, userUserStatus :: Int -- ^ User Status , userUserStatus :: Maybe Int -- ^ User Status
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Data)
instance FromJSON User where instance FromJSON User where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "user") parseJSON = genericParseJSON (removeFieldLabelPrefix True "user")
instance ToJSON User where instance ToJSON User where
toJSON = genericToJSON (removeFieldLabelPrefix False "user") toJSON = genericToJSON (removeFieldLabelPrefix False "user")
instance ToSchema User where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "user"
uncapitalize :: String -> String
uncapitalize (first:rest) = Char.toLower first : rest
uncapitalize [] = []
-- Remove a field label prefix during JSON parsing. -- Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters. -- Also perform any replacements for special characters.
removeFieldLabelPrefix :: Bool -> String -> Options removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix = removeFieldLabelPrefix forParsing prefix =
defaultOptions defaultOptions
{fieldLabelModifier = fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars} { omitNothingFields = True
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
}
where where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars = specialChars =

276
samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs
View File

@ -1,276 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC
-fno-warn-unused-binds -fno-warn-unused-imports -fcontext-stack=328 #-}
module SwaggerPetstore.API
-- * Client and Server
( ServerConfig(..)
, SwaggerPetstoreBackend
, createSwaggerPetstoreClient
, runSwaggerPetstoreServer
, runSwaggerPetstoreClient
, runSwaggerPetstoreClientWithManager
, SwaggerPetstoreClient
-- ** Servant
, SwaggerPetstoreAPI
) where
import SwaggerPetstore.Types
import Control.Monad.Except (ExceptT)
import Control.Monad.IO.Class
import Data.Aeson (Value)
import Data.Coerce (coerce)
import Data.Function ((&))
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Exts (IsString(..))
import GHC.Generics (Generic)
import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
import Network.HTTP.Types.Method (methodOptions)
import qualified Network.Wai.Handler.Warp as Warp
import Servant (ServantErr, serve)
import Servant.API
import Servant.API.Verbs (StdMethod(..), Verb)
import Servant.Client (Scheme(Http), ServantError, client)
import Servant.Common.BaseUrl (BaseUrl(..))
import Web.HttpApiData
data FormUpdatePetWithForm = FormUpdatePetWithForm
{ updatePetWithFormName :: Text
, updatePetWithFormStatus :: Text
} deriving (Show, Eq, Generic)
instance FromFormUrlEncoded FormUpdatePetWithForm where
fromFormUrlEncoded inputs = FormUpdatePetWithForm <$> lookupEither "name" inputs <*> lookupEither "status" inputs
instance ToFormUrlEncoded FormUpdatePetWithForm where
toFormUrlEncoded value =
[ ("name", toQueryParam $ updatePetWithFormName value)
, ("status", toQueryParam $ updatePetWithFormStatus value)
]
data FormUploadFile = FormUploadFile
{ uploadFileAdditionalMetadata :: Text
, uploadFileFile :: FilePath
} deriving (Show, Eq, Generic)
instance FromFormUrlEncoded FormUploadFile where
fromFormUrlEncoded inputs = FormUploadFile <$> lookupEither "additionalMetadata" inputs <*> lookupEither "file" inputs
instance ToFormUrlEncoded FormUploadFile where
toFormUrlEncoded value =
[ ("additionalMetadata", toQueryParam $ uploadFileAdditionalMetadata value)
, ("file", toQueryParam $ uploadFileFile value)
]
-- For the form data code generation.
lookupEither :: FromHttpApiData b => Text -> [(Text, Text)] -> Either String b
lookupEither key assocs =
case lookup key assocs of
Nothing -> Left $ "Could not find parameter " <> (T.unpack key) <> " in form data"
Just value ->
case parseQueryParam value of
Left result -> Left $ T.unpack result
Right result -> Right $ result
-- | Servant type-level API, generated from the Swagger spec for SwaggerPetstore.
type SwaggerPetstoreAPI
= "pet" :> ReqBody '[JSON] Pet :> Verb 'POST 200 '[JSON] () -- 'addPet' route
:<|> "pet" :> Capture "petId" Integer :> Header "api_key" Text :> Verb 'DELETE 200 '[JSON] () -- 'deletePet' route
:<|> "pet" :> "findByStatus" :> QueryParam "status" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByStatus' route
:<|> "pet" :> "findByTags" :> QueryParam "tags" (QueryList 'CommaSeparated (Text)) :> Verb 'GET 200 '[JSON] [Pet] -- 'findPetsByTags' route
:<|> "pet" :> Capture "petId" Integer :> Verb 'GET 200 '[JSON] Pet -- 'getPetById' route
:<|> "pet" :> ReqBody '[JSON] Pet :> Verb 'PUT 200 '[JSON] () -- 'updatePet' route
:<|> "pet" :> Capture "petId" Integer :> ReqBody '[FormUrlEncoded] FormUpdatePetWithForm :> Verb 'POST 200 '[JSON] () -- 'updatePetWithForm' route
:<|> "pet" :> Capture "petId" Integer :> "uploadImage" :> ReqBody '[FormUrlEncoded] FormUploadFile :> Verb 'POST 200 '[JSON] ApiResponse -- 'uploadFile' route
:<|> "store" :> "order" :> Capture "orderId" Text :> Verb 'DELETE 200 '[JSON] () -- 'deleteOrder' route
:<|> "store" :> "inventory" :> Verb 'GET 200 '[JSON] (Map.Map String Int) -- 'getInventory' route
:<|> "store" :> "order" :> Capture "orderId" Integer :> Verb 'GET 200 '[JSON] Order -- 'getOrderById' route
:<|> "store" :> "order" :> ReqBody '[JSON] Order :> Verb 'POST 200 '[JSON] Order -- 'placeOrder' route
:<|> "user" :> ReqBody '[JSON] User :> Verb 'POST 200 '[JSON] () -- 'createUser' route
:<|> "user" :> "createWithArray" :> ReqBody '[JSON] [User] :> Verb 'POST 200 '[JSON] () -- 'createUsersWithArrayInput' route
:<|> "user" :> "createWithList" :> ReqBody '[JSON] [User] :> Verb 'POST 200 '[JSON] () -- 'createUsersWithListInput' route
:<|> "user" :> Capture "username" Text :> Verb 'DELETE 200 '[JSON] () -- 'deleteUser' route
:<|> "user" :> Capture "username" Text :> Verb 'GET 200 '[JSON] User -- 'getUserByName' route
:<|> "user" :> "login" :> QueryParam "username" Text :> QueryParam "password" Text :> Verb 'GET 200 '[JSON] Text -- 'loginUser' route
:<|> "user" :> "logout" :> Verb 'GET 200 '[JSON] () -- 'logoutUser' route
:<|> "user" :> Capture "username" Text :> ReqBody '[JSON] User :> Verb 'PUT 200 '[JSON] () -- 'updateUser' route
-- | Server or client configuration, specifying the host and port to query or serve on.
data ServerConfig = ServerConfig
{ configHost :: String -- ^ Hostname to serve on, e.g. "127.0.0.1"
, configPort :: Int -- ^ Port to serve on, e.g. 8080
} deriving (Eq, Ord, Show, Read)
-- | List of elements parsed from a query.
newtype QueryList (p :: CollectionFormat) a = QueryList
{ fromQueryList :: [a]
} deriving (Functor, Applicative, Monad, Foldable, Traversable)
-- | Formats in which a list can be encoded into a HTTP path.
data CollectionFormat
= CommaSeparated -- ^ CSV format for multiple parameters.
| SpaceSeparated -- ^ Also called "SSV"
| TabSeparated -- ^ Also called "TSV"
| PipeSeparated -- ^ `value1|value2|value2`
| MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. Only for GET params.
instance FromHttpApiData a => FromHttpApiData (QueryList 'CommaSeparated a) where
parseQueryParam = parseSeparatedQueryList ','
instance FromHttpApiData a => FromHttpApiData (QueryList 'TabSeparated a) where
parseQueryParam = parseSeparatedQueryList '\t'
instance FromHttpApiData a => FromHttpApiData (QueryList 'SpaceSeparated a) where
parseQueryParam = parseSeparatedQueryList ' '
instance FromHttpApiData a => FromHttpApiData (QueryList 'PipeSeparated a) where
parseQueryParam = parseSeparatedQueryList '|'
instance FromHttpApiData a => FromHttpApiData (QueryList 'MultiParamArray a) where
parseQueryParam = error "unimplemented FromHttpApiData for MultiParamArray collection format"
parseSeparatedQueryList :: FromHttpApiData a => Char -> Text -> Either Text (QueryList p a)
parseSeparatedQueryList char = fmap QueryList . mapM parseQueryParam . T.split (== char)
instance ToHttpApiData a => ToHttpApiData (QueryList 'CommaSeparated a) where
toQueryParam = formatSeparatedQueryList ','
instance ToHttpApiData a => ToHttpApiData (QueryList 'TabSeparated a) where
toQueryParam = formatSeparatedQueryList '\t'
instance ToHttpApiData a => ToHttpApiData (QueryList 'SpaceSeparated a) where
toQueryParam = formatSeparatedQueryList ' '
instance ToHttpApiData a => ToHttpApiData (QueryList 'PipeSeparated a) where
toQueryParam = formatSeparatedQueryList '|'
instance ToHttpApiData a => ToHttpApiData (QueryList 'MultiParamArray a) where
toQueryParam = error "unimplemented ToHttpApiData for MultiParamArray collection format"
formatSeparatedQueryList :: ToHttpApiData a => Char -> QueryList p a -> Text
formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList
-- | Backend for SwaggerPetstore.
-- The backend can be used both for the client and the server. The client generated from the SwaggerPetstore Swagger spec
-- is a backend that executes actions by sending HTTP requests (see @createSwaggerPetstoreClient@). Alternatively, provided
-- a backend, the API can be served using @runSwaggerPetstoreServer@.
data SwaggerPetstoreBackend m = SwaggerPetstoreBackend
{ addPet :: Pet -> m (){- ^ -}
, deletePet :: Integer -> Maybe Text -> m (){- ^ -}
, findPetsByStatus :: Maybe [Text] -> m [Pet]{- ^ Multiple status values can be provided with comma separated strings -}
, findPetsByTags :: Maybe [Text] -> m [Pet]{- ^ Multiple tags can be provided with comma separated strings. Use tag1, tag2, tag3 for testing. -}
, getPetById :: Integer -> m Pet{- ^ Returns a single pet -}
, updatePet :: Pet -> m (){- ^ -}
, updatePetWithForm :: Integer -> FormUpdatePetWithForm -> m (){- ^ -}
, uploadFile :: Integer -> FormUploadFile -> m ApiResponse{- ^ -}
, deleteOrder :: Text -> m (){- ^ For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors -}
, getInventory :: m (Map.Map String Int){- ^ Returns a map of status codes to quantities -}
, getOrderById :: Integer -> m Order{- ^ For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions -}
, placeOrder :: Order -> m Order{- ^ -}
, createUser :: User -> m (){- ^ This can only be done by the logged in user. -}
, createUsersWithArrayInput :: [User] -> m (){- ^ -}
, createUsersWithListInput :: [User] -> m (){- ^ -}
, deleteUser :: Text -> m (){- ^ This can only be done by the logged in user. -}
, getUserByName :: Text -> m User{- ^ -}
, loginUser :: Maybe Text -> Maybe Text -> m Text{- ^ -}
, logoutUser :: m (){- ^ -}
, updateUser :: Text -> User -> m (){- ^ This can only be done by the logged in user. -}
}
newtype SwaggerPetstoreClient a = SwaggerPetstoreClient
{ runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a
} deriving Functor
instance Applicative SwaggerPetstoreClient where
pure x = SwaggerPetstoreClient (\_ _ -> pure x)
(SwaggerPetstoreClient f) <*> (SwaggerPetstoreClient x) =
SwaggerPetstoreClient (\manager url -> f manager url <*> x manager url)
instance Monad SwaggerPetstoreClient where
(SwaggerPetstoreClient a) >>= f =
SwaggerPetstoreClient (\manager url -> do
value <- a manager url
runClient (f value) manager url)
instance MonadIO SwaggerPetstoreClient where
liftIO io = SwaggerPetstoreClient (\_ _ -> liftIO io)
createSwaggerPetstoreClient :: SwaggerPetstoreBackend SwaggerPetstoreClient
createSwaggerPetstoreClient = SwaggerPetstoreBackend{..}
where
((coerce -> addPet) :<|>
(coerce -> deletePet) :<|>
(coerce -> findPetsByStatus) :<|>
(coerce -> findPetsByTags) :<|>
(coerce -> getPetById) :<|>
(coerce -> updatePet) :<|>
(coerce -> updatePetWithForm) :<|>
(coerce -> uploadFile) :<|>
(coerce -> deleteOrder) :<|>
(coerce -> getInventory) :<|>
(coerce -> getOrderById) :<|>
(coerce -> placeOrder) :<|>
(coerce -> createUser) :<|>
(coerce -> createUsersWithArrayInput) :<|>
(coerce -> createUsersWithListInput) :<|>
(coerce -> deleteUser) :<|>
(coerce -> getUserByName) :<|>
(coerce -> loginUser) :<|>
(coerce -> logoutUser) :<|>
(coerce -> updateUser)) = client (Proxy :: Proxy SwaggerPetstoreAPI)
-- | Run requests in the SwaggerPetstoreClient monad.
runSwaggerPetstoreClient :: ServerConfig -> SwaggerPetstoreClient a -> ExceptT ServantError IO a
runSwaggerPetstoreClient clientConfig cl = do
manager <- liftIO $ newManager defaultManagerSettings
runSwaggerPetstoreClientWithManager manager clientConfig cl
-- | Run requests in the SwaggerPetstoreClient monad using a custom manager.
runSwaggerPetstoreClientWithManager :: Manager -> ServerConfig -> SwaggerPetstoreClient a -> ExceptT ServantError IO a
runSwaggerPetstoreClientWithManager manager clientConfig cl =
runClient cl manager $ BaseUrl Http (configHost clientConfig) (configPort clientConfig) ""
-- | Run the SwaggerPetstore server at the provided host and port.
runSwaggerPetstoreServer :: MonadIO m => ServerConfig -> SwaggerPetstoreBackend (ExceptT ServantErr IO) -> m ()
runSwaggerPetstoreServer ServerConfig{..} backend =
liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy SwaggerPetstoreAPI) (serverFromBackend backend)
where
warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
serverFromBackend SwaggerPetstoreBackend{..} =
(coerce addPet :<|>
coerce deletePet :<|>
coerce findPetsByStatus :<|>
coerce findPetsByTags :<|>
coerce getPetById :<|>
coerce updatePet :<|>
coerce updatePetWithForm :<|>
coerce uploadFile :<|>
coerce deleteOrder :<|>
coerce getInventory :<|>
coerce getOrderById :<|>
coerce placeOrder :<|>
coerce createUser :<|>
coerce createUsersWithArrayInput :<|>
coerce createUsersWithListInput :<|>
coerce deleteUser :<|>
coerce getUserByName :<|>
coerce loginUser :<|>
coerce logoutUser :<|>
coerce updateUser)

154
samples/server/petstore/haskell-servant/lib/SwaggerPetstore/Types.hs
View File

@ -1,154 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
module SwaggerPetstore.Types (
ApiResponse (..),
Category (..),
Order (..),
Pet (..),
Tag (..),
User (..),
) where
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Data.Function ((&))
-- | Describes the result of uploading an image resource
data ApiResponse = ApiResponse
{ apiResponseCode :: Int -- ^
, apiResponseType :: Text -- ^
, apiResponseMessage :: Text -- ^
} deriving (Show, Eq, Generic)
instance FromJSON ApiResponse where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "apiResponse")
instance ToJSON ApiResponse where
toJSON = genericToJSON (removeFieldLabelPrefix False "apiResponse")
-- | A category for a pet
data Category = Category
{ categoryId :: Integer -- ^
, categoryName :: Text -- ^
} deriving (Show, Eq, Generic)
instance FromJSON Category where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "category")
instance ToJSON Category where
toJSON = genericToJSON (removeFieldLabelPrefix False "category")
-- | An order for a pets from the pet store
data Order = Order
{ orderId :: Integer -- ^
, orderPetId :: Integer -- ^
, orderQuantity :: Int -- ^
, orderShipDate :: Integer -- ^
, orderStatus :: Text -- ^ Order Status
, orderComplete :: Bool -- ^
} deriving (Show, Eq, Generic)
instance FromJSON Order where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "order")
instance ToJSON Order where
toJSON = genericToJSON (removeFieldLabelPrefix False "order")
-- | A pet for sale in the pet store
data Pet = Pet
{ petId :: Integer -- ^
, petCategory :: Category -- ^
, petName :: Text -- ^
, petPhotoUrls :: [Text] -- ^
, petTags :: [Tag] -- ^
, petStatus :: Text -- ^ pet status in the store
} deriving (Show, Eq, Generic)
instance FromJSON Pet where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "pet")
instance ToJSON Pet where
toJSON = genericToJSON (removeFieldLabelPrefix False "pet")
-- | A tag for a pet
data Tag = Tag
{ tagId :: Integer -- ^
, tagName :: Text -- ^
} deriving (Show, Eq, Generic)
instance FromJSON Tag where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "tag")
instance ToJSON Tag where
toJSON = genericToJSON (removeFieldLabelPrefix False "tag")
-- | A User who is purchasing from the pet store
data User = User
{ userId :: Integer -- ^
, userUsername :: Text -- ^
, userFirstName :: Text -- ^
, userLastName :: Text -- ^
, userEmail :: Text -- ^
, userPassword :: Text -- ^
, userPhone :: Text -- ^
, userUserStatus :: Int -- ^ User Status
} deriving (Show, Eq, Generic)
instance FromJSON User where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "user")
instance ToJSON User where
toJSON = genericToJSON (removeFieldLabelPrefix False "user")
-- Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
defaultOptions
{fieldLabelModifier = fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars}
where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars =
[ ("@", "'At")
, ("\\", "'Back_Slash")
, ("<=", "'Less_Than_Or_Equal_To")
, ("\"", "'Double_Quote")
, ("[", "'Left_Square_Bracket")
, ("]", "'Right_Square_Bracket")
, ("^", "'Caret")
, ("_", "'Underscore")
, ("`", "'Backtick")
, ("!", "'Exclamation")
, ("#", "'Hash")
, ("$", "'Dollar")
, ("%", "'Percent")
, ("&", "'Ampersand")
, ("'", "'Quote")
, ("(", "'Left_Parenthesis")
, (")", "'Right_Parenthesis")
, ("*", "'Star")
, ("+", "'Plus")
, (",", "'Comma")
, ("-", "'Dash")
, (".", "'Period")
, ("/", "'Slash")
, (":", "'Colon")
, ("{", "'Left_Curly_Bracket")
, ("|", "'Pipe")
, ("<", "'LessThan")
, ("!=", "'Not_Equal")
, ("=", "'Equal")
, ("}", "'Right_Curly_Bracket")
, (">", "'GreaterThan")
, ("~", "'Tilde")
, ("?", "'Question_Mark")
, (">=", "'Greater_Than_Or_Equal_To")
]
mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack
replacer =
if forParsing
then flip T.replace
else T.replace

7
samples/server/petstore/haskell-servant/openapi-petstore.cabal
View File

@ -19,15 +19,22 @@ library
, aeson , aeson
, text , text
, containers , containers
, exceptions
, network-uri , network-uri
, servant , servant
, http-api-data , http-api-data
, servant
, servant-client , servant-client
, servant-client-core
, servant-server , servant-server
, servant , servant
, warp , warp
, transformers , transformers
, mtl , mtl
, time
, http-client , http-client
, http-client-tls
, http-types , http-types
, swagger2
, uuid
default-language: Haskell2010 default-language: Haskell2010

12
samples/server/petstore/haskell-servant/stack.yaml
View File

@ -1,8 +1,8 @@
resolver: lts-8.5 resolver: lts-12.18
extra-deps: extra-deps: []
- servant-0.9.1.1
- servant-client-0.9.1.1
- servant-server-0.9.1.1
- http-api-data-0.3.5
packages: packages:
- '.' - '.'
nix:
enable: false
packages:
- zlib

33
samples/server/petstore/haskell-servant/swagger-petstore.cabal
View File

@ -1,33 +0,0 @@
name: swagger-petstore
version: 0.1.0.0
synopsis: Auto-generated API bindings for swagger-petstore
description: Please see README.md
homepage: https://github.com/swagger-api/swagger-codegen#readme
author: Author Name Here
maintainer: author.name@email.com
copyright: YEAR - AUTHOR
category: Web
build-type: Simple
cabal-version: >=1.10
library
hs-source-dirs: lib
exposed-modules: SwaggerPetstore.API
, SwaggerPetstore.Types
ghc-options: -Wall
build-depends: base
, aeson
, text
, containers
, network-uri
, servant
, http-api-data
, servant-client
, servant-server
, servant
, warp
, transformers
, mtl
, http-client
, http-types
default-language: Haskell2010