mirror of
https://github.com/valitydev/openapi-generator.git
synced 2024-11-07 10:58:55 +00:00
Upgrade haskell-servant generator to latest LTS (#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
This commit is contained in:
Fabrizio Ferrai
William Cheng
parent
d75392e056
commit
6976a8c775
@ -179,12 +179,13 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
|
||||
typeMapping.put("char", "Char");
|
||||
typeMapping.put("float", "Float");
|
||||
typeMapping.put("double", "Double");
|
||||
typeMapping.put("DateTime", "Integer");
|
||||
typeMapping.put("DateTime", "UTCTime");
|
||||
typeMapping.put("Date", "Day");
|
||||
typeMapping.put("file", "FilePath");
|
||||
typeMapping.put("binary", "FilePath");
|
||||
typeMapping.put("number", "Double");
|
||||
typeMapping.put("any", "Value");
|
||||
typeMapping.put("UUID", "Text");
|
||||
typeMapping.put("UUID", "UUID");
|
||||
typeMapping.put("ByteArray", "Text");
|
||||
typeMapping.put("object", "Value");
|
||||
|
||||
@ -294,9 +295,44 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
|
||||
}
|
||||
additionalProperties.put("specialCharReplacements", replacements);
|
||||
|
||||
// See docstring for setGenerateToSchema for why we do this
|
||||
additionalProperties.put("generateToSchema", true);
|
||||
|
||||
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
|
||||
@ -312,7 +348,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
|
||||
return "[" + getTypeDeclaration(inner) + "]";
|
||||
} else if (ModelUtils.isMapSchema(p)) {
|
||||
Schema inner = ModelUtils.getAdditionalProperties(p);
|
||||
return "Map.Map String " + getTypeDeclaration(inner);
|
||||
return "(Map.Map String " + getTypeDeclaration(inner) + ")";
|
||||
}
|
||||
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) {
|
||||
CodegenModel model = super.fromModel(name, mod, allDefinitions);
|
||||
|
||||
setGenerateToSchema(model);
|
||||
|
||||
// Clean up the class name to remove invalid characters
|
||||
model.classname = fixModelChars(model.classname);
|
||||
if (typeMapping.containsValue(model.classname)) {
|
||||
|
||||
@ -1,93 +1,76 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# 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
|
||||
-- * Client and Server
|
||||
( ServerConfig(..)
|
||||
, {{title}}Backend
|
||||
( Config(..)
|
||||
, {{title}}Backend(..)
|
||||
, create{{title}}Client
|
||||
, run{{title}}Server
|
||||
, run{{title}}Client
|
||||
, run{{title}}ClientWithManager
|
||||
, call{{title}}
|
||||
, {{title}}Client
|
||||
, {{title}}ClientError(..)
|
||||
-- ** Servant
|
||||
, {{title}}API
|
||||
) where
|
||||
|
||||
import {{title}}.Types
|
||||
import {{title}}.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
|
||||
import Control.Monad.Catch (Exception, MonadThrow, throwM)
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
import Data.Aeson (Value)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Data (Data)
|
||||
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 Data.UUID (UUID)
|
||||
import GHC.Exts (IsString (..))
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client (Manager, newManager)
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
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 (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}}
|
||||
data {{vendorExtensions.x-formName}} = {{vendorExtensions.x-formName}}
|
||||
{ {{#formParams}}{{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} :: {{dataType}}{{#hasMore}}
|
||||
, {{/hasMore}}{{/formParams}}
|
||||
} deriving (Show, Eq, Generic)
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromFormUrlEncoded {{vendorExtensions.x-formName}} where
|
||||
fromFormUrlEncoded inputs = {{vendorExtensions.x-formName}} <$> {{#formParams}}lookupEither "{{baseName}}" inputs{{#hasMore}} <*> {{/hasMore}}{{/formParams}}
|
||||
|
||||
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)
|
||||
instance FromForm {{vendorExtensions.x-formName}}
|
||||
instance ToForm {{vendorExtensions.x-formName}}
|
||||
{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
|
||||
|
||||
-- | List of elements parsed from a query.
|
||||
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
|
||||
|
||||
|
||||
{{#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}}
|
||||
-- | Backend for {{title}}.
|
||||
-- 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
|
||||
{ runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a
|
||||
{ runClient :: ClientEnv -> ExceptT ServantError IO a
|
||||
} deriving Functor
|
||||
|
||||
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 (\manager url -> f manager url <*> x manager url)
|
||||
{{title}}Client (\env -> f env <*> x env)
|
||||
|
||||
instance Monad {{title}}Client where
|
||||
({{title}}Client a) >>= f =
|
||||
{{title}}Client (\manager url -> do
|
||||
value <- a manager url
|
||||
runClient (f value) manager url)
|
||||
{{title}}Client (\env -> do
|
||||
value <- a env
|
||||
runClient (f value) env)
|
||||
|
||||
instance MonadIO {{title}}Client where
|
||||
liftIO io = {{title}}Client (\_ _ -> liftIO io)
|
||||
liftIO io = {{title}}Client (\_ -> liftIO io)
|
||||
{{/apiInfo}}
|
||||
|
||||
{{#apiInfo}}
|
||||
@ -178,24 +182,41 @@ create{{title}}Client = {{title}}Backend{..}
|
||||
{{/hasMore}}{{/apis}}) = client (Proxy :: Proxy {{title}}API)
|
||||
|
||||
-- | 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
|
||||
manager <- liftIO $ newManager defaultManagerSettings
|
||||
manager <- liftIO $ newManager tlsManagerSettings
|
||||
run{{title}}ClientWithManager manager clientConfig cl
|
||||
|
||||
-- | 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 clientConfig cl =
|
||||
runClient cl manager $ BaseUrl Http (configHost clientConfig) (configPort clientConfig) ""
|
||||
run{{title}}ClientWithManager :: Manager -> Config -> {{title}}Client a -> ExceptT ServantError IO a
|
||||
run{{title}}ClientWithManager manager Config{..} cl = do
|
||||
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}}
|
||||
-- | 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 ServerConfig{..} backend =
|
||||
run{{title}}Server
|
||||
:: (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)
|
||||
where
|
||||
warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
|
||||
serverFromBackend {{title}}Backend{..} =
|
||||
({{#apis}}{{#operations}}{{#operation}}coerce {{operationId}}{{#hasMore}} :<|>
|
||||
{{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}} :<|>
|
||||
|
||||
@ -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).
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
A client can be created via the `create{{title}}Client` function, which, if provided with a hostname and a port, will generate
|
||||
a client that can be used to access the API if it is being served at that hostname / port combination. For example, if
|
||||
`localhost:8080` is serving the {{title}} API, you can write:
|
||||
A client can be created via the `create{{title}}Client` function, which will generate a function for every endpoint of the API.
|
||||
Then these functions can be invoked with `run{{title}}ClientWithManager` or more conveniently with `call{{title}}Client`
|
||||
(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
|
||||
{-# 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 = do
|
||||
{{title}}Backend{..} <- create{{title}}Client (ServerConfig "localhost" 8080)
|
||||
-- Any {{title}} API call can go here.
|
||||
return ()
|
||||
-- Configure the BaseUrl for the client
|
||||
url <- parseBaseUrl "http://localhost:8080/"
|
||||
|
||||
-- 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
|
||||
@ -50,30 +74,6 @@ import {{title}}.Handlers
|
||||
main :: IO ()
|
||||
main = do
|
||||
let server = {{title}}Backend{..}
|
||||
run{{title}}Server (ServerConfig "localhost" 8080) 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")
|
||||
config = Config "http://localhost:8080/"
|
||||
run{{title}}Server config server
|
||||
```
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module {{title}}.Types (
|
||||
@ -10,11 +11,17 @@ module {{title}}.Types (
|
||||
{{/models}}
|
||||
) where
|
||||
|
||||
import Data.Data (Data)
|
||||
import Data.UUID (UUID)
|
||||
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 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.Map as Map
|
||||
import GHC.Generics (Generic)
|
||||
@ -29,18 +36,25 @@ import Data.Function ((&))
|
||||
{{^vendorExtensions.x-customNewtype}}
|
||||
{{^parent}}
|
||||
{{vendorExtensions.x-data}} {{classname}} = {{classname}}
|
||||
{ {{#vars}}{{& name}} :: {{dataType}} -- ^ {{& description}}{{#hasMore}}
|
||||
{ {{#vars}}{{& name}} :: {{^required}}Maybe {{/required}}{{dataType}} -- ^ {{& description}}{{#hasMore}}
|
||||
, {{/hasMore}}{{/vars}}
|
||||
} deriving (Show, Eq, Generic)
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON {{classname}} where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}")
|
||||
instance ToJSON {{classname}} where
|
||||
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}}
|
||||
newtype {{classname}} = {{classname}} { un{{classname}} :: {{parent}} }
|
||||
deriving (Show, Eq, FromJSON, ToJSON, Generic)
|
||||
deriving (Show, Eq, FromJSON, ToJSON, Generic, Data)
|
||||
{{/parent}}
|
||||
{{/vendorExtensions.x-customNewtype}}
|
||||
{{#vendorExtensions.x-customNewtype}}
|
||||
@ -49,12 +63,18 @@ newtype {{classname}} = {{classname}} {{vendorExtensions.x-customNewtype}} deriv
|
||||
{{/model}}
|
||||
{{/models}}
|
||||
|
||||
uncapitalize :: String -> String
|
||||
uncapitalize (first:rest) = Char.toLower first : rest
|
||||
uncapitalize [] = []
|
||||
|
||||
-- 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}
|
||||
{ omitNothingFields = True
|
||||
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
|
||||
}
|
||||
where
|
||||
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
|
||||
specialChars =
|
||||
|
||||
@ -19,15 +19,22 @@ library
|
||||
, aeson
|
||||
, text
|
||||
, containers
|
||||
, exceptions
|
||||
, network-uri
|
||||
, servant
|
||||
, http-api-data
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-client-core
|
||||
, servant-server
|
||||
, servant
|
||||
, warp
|
||||
, transformers
|
||||
, mtl
|
||||
, time
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, http-types
|
||||
, swagger2
|
||||
, uuid
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
resolver: lts-8.5
|
||||
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
|
||||
resolver: lts-12.18
|
||||
extra-deps: []
|
||||
packages:
|
||||
- '.'
|
||||
nix:
|
||||
enable: false
|
||||
packages:
|
||||
- zlib
|
||||
@ -1 +1 @@
|
||||
3.3.0-SNAPSHOT
|
||||
4.0.0-SNAPSHOT
|
||||
@ -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).
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
A client can be created via the `createOpenAPIPetstoreClient` function, which, if provided with a hostname and a port, will generate
|
||||
a client that can be used to access the API if it is being served at that hostname / port combination. For example, if
|
||||
`localhost:8080` is serving the OpenAPIPetstore API, you can write:
|
||||
A client can be created via the `createOpenAPIPetstoreClient` function, which will generate a function for every endpoint of the API.
|
||||
Then these functions can be invoked with `runOpenAPIPetstoreClientWithManager` or more conveniently with `callOpenAPIPetstoreClient`
|
||||
(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
|
||||
{-# 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 = do
|
||||
OpenAPIPetstoreBackend{..} <- createOpenAPIPetstoreClient (ServerConfig "localhost" 8080)
|
||||
-- Any OpenAPIPetstore API call can go here.
|
||||
return ()
|
||||
-- Configure the BaseUrl for the client
|
||||
url <- parseBaseUrl "http://localhost:8080/"
|
||||
|
||||
-- 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
|
||||
@ -50,30 +74,6 @@ import OpenAPIPetstore.Handlers
|
||||
main :: IO ()
|
||||
main = do
|
||||
let server = OpenAPIPetstoreBackend{..}
|
||||
runOpenAPIPetstoreServer (ServerConfig "localhost" 8080) 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")
|
||||
config = Config "http://localhost:8080/"
|
||||
runOpenAPIPetstoreServer config server
|
||||
```
|
||||
|
||||
@ -1,121 +1,84 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# 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
|
||||
-- * Client and Server
|
||||
( ServerConfig(..)
|
||||
, OpenAPIPetstoreBackend
|
||||
( Config(..)
|
||||
, OpenAPIPetstoreBackend(..)
|
||||
, createOpenAPIPetstoreClient
|
||||
, runOpenAPIPetstoreServer
|
||||
, runOpenAPIPetstoreClient
|
||||
, runOpenAPIPetstoreClientWithManager
|
||||
, callOpenAPIPetstore
|
||||
, OpenAPIPetstoreClient
|
||||
, OpenAPIPetstoreClientError(..)
|
||||
-- ** Servant
|
||||
, OpenAPIPetstoreAPI
|
||||
) where
|
||||
|
||||
import OpenAPIPetstore.Types
|
||||
import OpenAPIPetstore.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
|
||||
import Control.Monad.Catch (Exception, MonadThrow, throwM)
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
import Data.Aeson (Value)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Data (Data)
|
||||
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 Data.UUID (UUID)
|
||||
import GHC.Exts (IsString (..))
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client (Manager, newManager)
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
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 (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
|
||||
{ updatePetWithFormName :: Text
|
||||
, updatePetWithFormStatus :: Text
|
||||
} deriving (Show, Eq, Generic)
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromFormUrlEncoded FormUpdatePetWithForm where
|
||||
fromFormUrlEncoded inputs = FormUpdatePetWithForm <$> lookupEither "name" inputs <*> lookupEither "status" inputs
|
||||
instance FromForm FormUpdatePetWithForm
|
||||
instance ToForm FormUpdatePetWithForm
|
||||
|
||||
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)
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromFormUrlEncoded FormUploadFile where
|
||||
fromFormUrlEncoded inputs = FormUploadFile <$> lookupEither "additionalMetadata" inputs <*> lookupEither "file" inputs
|
||||
instance FromForm FormUploadFile
|
||||
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.
|
||||
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
|
||||
|
||||
|
||||
-- | 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.
|
||||
-- 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
|
||||
@ -181,7 +180,7 @@ data OpenAPIPetstoreBackend m = OpenAPIPetstoreBackend
|
||||
, 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 -}
|
||||
, 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. -}
|
||||
@ -195,22 +194,22 @@ data OpenAPIPetstoreBackend m = OpenAPIPetstoreBackend
|
||||
}
|
||||
|
||||
newtype OpenAPIPetstoreClient a = OpenAPIPetstoreClient
|
||||
{ runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a
|
||||
{ runClient :: ClientEnv -> ExceptT ServantError IO a
|
||||
} deriving Functor
|
||||
|
||||
instance Applicative OpenAPIPetstoreClient where
|
||||
pure x = OpenAPIPetstoreClient (\_ _ -> pure x)
|
||||
pure x = OpenAPIPetstoreClient (\_ -> pure x)
|
||||
(OpenAPIPetstoreClient f) <*> (OpenAPIPetstoreClient x) =
|
||||
OpenAPIPetstoreClient (\manager url -> f manager url <*> x manager url)
|
||||
OpenAPIPetstoreClient (\env -> f env <*> x env)
|
||||
|
||||
instance Monad OpenAPIPetstoreClient where
|
||||
(OpenAPIPetstoreClient a) >>= f =
|
||||
OpenAPIPetstoreClient (\manager url -> do
|
||||
value <- a manager url
|
||||
runClient (f value) manager url)
|
||||
OpenAPIPetstoreClient (\env -> do
|
||||
value <- a env
|
||||
runClient (f value) env)
|
||||
|
||||
instance MonadIO OpenAPIPetstoreClient where
|
||||
liftIO io = OpenAPIPetstoreClient (\_ _ -> liftIO io)
|
||||
liftIO io = OpenAPIPetstoreClient (\_ -> liftIO io)
|
||||
|
||||
createOpenAPIPetstoreClient :: OpenAPIPetstoreBackend OpenAPIPetstoreClient
|
||||
createOpenAPIPetstoreClient = OpenAPIPetstoreBackend{..}
|
||||
@ -237,22 +236,39 @@ createOpenAPIPetstoreClient = OpenAPIPetstoreBackend{..}
|
||||
(coerce -> updateUser)) = client (Proxy :: Proxy OpenAPIPetstoreAPI)
|
||||
|
||||
-- | 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
|
||||
manager <- liftIO $ newManager defaultManagerSettings
|
||||
manager <- liftIO $ newManager tlsManagerSettings
|
||||
runOpenAPIPetstoreClientWithManager manager clientConfig cl
|
||||
|
||||
-- | Run requests in the OpenAPIPetstoreClient monad using a custom manager.
|
||||
runOpenAPIPetstoreClientWithManager :: Manager -> ServerConfig -> OpenAPIPetstoreClient a -> ExceptT ServantError IO a
|
||||
runOpenAPIPetstoreClientWithManager manager clientConfig cl =
|
||||
runClient cl manager $ BaseUrl Http (configHost clientConfig) (configPort clientConfig) ""
|
||||
runOpenAPIPetstoreClientWithManager :: Manager -> Config -> OpenAPIPetstoreClient a -> ExceptT ServantError IO a
|
||||
runOpenAPIPetstoreClientWithManager manager Config{..} cl = do
|
||||
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.
|
||||
runOpenAPIPetstoreServer :: MonadIO m => ServerConfig -> OpenAPIPetstoreBackend (ExceptT ServantErr IO) -> m ()
|
||||
runOpenAPIPetstoreServer ServerConfig{..} backend =
|
||||
runOpenAPIPetstoreServer
|
||||
:: (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)
|
||||
where
|
||||
warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
|
||||
serverFromBackend OpenAPIPetstoreBackend{..} =
|
||||
(coerce addPet :<|>
|
||||
coerce deletePet :<|>
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module OpenAPIPetstore.Types (
|
||||
@ -11,11 +12,17 @@ module OpenAPIPetstore.Types (
|
||||
User (..),
|
||||
) where
|
||||
|
||||
import Data.Data (Data)
|
||||
import Data.UUID (UUID)
|
||||
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 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.Map as Map
|
||||
import GHC.Generics (Generic)
|
||||
@ -24,91 +31,127 @@ import Data.Function ((&))
|
||||
|
||||
-- | Describes the result of uploading an image resource
|
||||
data ApiResponse = ApiResponse
|
||||
{ apiResponseCode :: Int -- ^
|
||||
, apiResponseType :: Text -- ^
|
||||
, apiResponseMessage :: Text -- ^
|
||||
} deriving (Show, Eq, Generic)
|
||||
{ apiResponseCode :: Maybe Int -- ^
|
||||
, apiResponseType :: Maybe Text -- ^
|
||||
, apiResponseMessage :: Maybe Text -- ^
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON ApiResponse where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "apiResponse")
|
||||
instance ToJSON ApiResponse where
|
||||
toJSON = genericToJSON (removeFieldLabelPrefix False "apiResponse")
|
||||
instance ToSchema ApiResponse where
|
||||
declareNamedSchema = Swagger.genericDeclareNamedSchema
|
||||
$ Swagger.fromAesonOptions
|
||||
$ removeFieldLabelPrefix False "apiResponse"
|
||||
|
||||
|
||||
-- | A category for a pet
|
||||
data Category = Category
|
||||
{ categoryId :: Integer -- ^
|
||||
, categoryName :: Text -- ^
|
||||
} deriving (Show, Eq, Generic)
|
||||
{ categoryId :: Maybe Integer -- ^
|
||||
, categoryName :: Maybe Text -- ^
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON Category where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "category")
|
||||
instance ToJSON Category where
|
||||
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
|
||||
data Order = Order
|
||||
{ orderId :: Integer -- ^
|
||||
, orderPetId :: Integer -- ^
|
||||
, orderQuantity :: Int -- ^
|
||||
, orderShipDate :: Integer -- ^
|
||||
, orderStatus :: Text -- ^ Order Status
|
||||
, orderComplete :: Bool -- ^
|
||||
} deriving (Show, Eq, Generic)
|
||||
{ orderId :: Maybe Integer -- ^
|
||||
, orderPetId :: Maybe Integer -- ^
|
||||
, orderQuantity :: Maybe Int -- ^
|
||||
, orderShipDate :: Maybe UTCTime -- ^
|
||||
, orderStatus :: Maybe Text -- ^ Order Status
|
||||
, orderComplete :: Maybe Bool -- ^
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON Order where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "order")
|
||||
instance ToJSON Order where
|
||||
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
|
||||
data Pet = Pet
|
||||
{ petId :: Integer -- ^
|
||||
, petCategory :: Category -- ^
|
||||
{ petId :: Maybe Integer -- ^
|
||||
, petCategory :: Maybe Category -- ^
|
||||
, petName :: Text -- ^
|
||||
, petPhotoUrls :: [Text] -- ^
|
||||
, petTags :: [Tag] -- ^
|
||||
, petStatus :: Text -- ^ pet status in the store
|
||||
} deriving (Show, Eq, Generic)
|
||||
, petTags :: Maybe [Tag] -- ^
|
||||
, petStatus :: Maybe Text -- ^ pet status in the store
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON Pet where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "pet")
|
||||
instance ToJSON Pet where
|
||||
toJSON = genericToJSON (removeFieldLabelPrefix False "pet")
|
||||
instance ToSchema Pet where
|
||||
declareNamedSchema = Swagger.genericDeclareNamedSchema
|
||||
$ Swagger.fromAesonOptions
|
||||
$ removeFieldLabelPrefix False "pet"
|
||||
|
||||
|
||||
-- | A tag for a pet
|
||||
data Tag = Tag
|
||||
{ tagId :: Integer -- ^
|
||||
, tagName :: Text -- ^
|
||||
} deriving (Show, Eq, Generic)
|
||||
{ tagId :: Maybe Integer -- ^
|
||||
, tagName :: Maybe Text -- ^
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON Tag where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "tag")
|
||||
instance ToJSON Tag where
|
||||
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
|
||||
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)
|
||||
{ userId :: Maybe Integer -- ^
|
||||
, userUsername :: Maybe Text -- ^
|
||||
, userFirstName :: Maybe Text -- ^
|
||||
, userLastName :: Maybe Text -- ^
|
||||
, userEmail :: Maybe Text -- ^
|
||||
, userPassword :: Maybe Text -- ^
|
||||
, userPhone :: Maybe Text -- ^
|
||||
, userUserStatus :: Maybe Int -- ^ User Status
|
||||
} deriving (Show, Eq, Generic, Data)
|
||||
|
||||
instance FromJSON User where
|
||||
parseJSON = genericParseJSON (removeFieldLabelPrefix True "user")
|
||||
instance ToJSON User where
|
||||
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.
|
||||
-- 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}
|
||||
{ omitNothingFields = True
|
||||
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
|
||||
}
|
||||
where
|
||||
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
|
||||
specialChars =
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
@ -19,15 +19,22 @@ library
|
||||
, aeson
|
||||
, text
|
||||
, containers
|
||||
, exceptions
|
||||
, network-uri
|
||||
, servant
|
||||
, http-api-data
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-client-core
|
||||
, servant-server
|
||||
, servant
|
||||
, warp
|
||||
, transformers
|
||||
, mtl
|
||||
, time
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, http-types
|
||||
, swagger2
|
||||
, uuid
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
resolver: lts-8.5
|
||||
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
|
||||
resolver: lts-12.18
|
||||
extra-deps: []
|
||||
packages:
|
||||
- '.'
|
||||
nix:
|
||||
enable: false
|
||||
packages:
|
||||
- zlib
|
||||
@ -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
|
||||
Loading…
Reference in New Issue
Block a user