From 6976a8c775ecacef9852e3060c21d8a24de777b5 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Tue, 4 Dec 2018 13:03:08 +0200 Subject: [PATCH] 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 --- .../languages/HaskellServantCodegen.java | 44 ++- .../resources/haskell-servant/API.mustache | 187 ++++++------ .../resources/haskell-servant/README.mustache | 66 ++--- .../resources/haskell-servant/Types.mustache | 30 +- .../haskell-servant-codegen.mustache | 7 + .../resources/haskell-servant/stack.mustache | 12 +- .../.openapi-generator/VERSION | 2 +- .../server/petstore/haskell-servant/README.md | 66 ++--- .../lib/OpenAPIPetstore/API.hs | 228 ++++++++------- .../lib/OpenAPIPetstore/Types.hs | 109 ++++--- .../lib/SwaggerPetstore/API.hs | 276 ------------------ .../lib/SwaggerPetstore/Types.hs | 154 ---------- .../haskell-servant/openapi-petstore.cabal | 7 + .../petstore/haskell-servant/stack.yaml | 12 +- .../haskell-servant/swagger-petstore.cabal | 33 --- 15 files changed, 461 insertions(+), 772 deletions(-) delete mode 100644 samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs delete mode 100644 samples/server/petstore/haskell-servant/lib/SwaggerPetstore/Types.hs delete mode 100644 samples/server/petstore/haskell-servant/swagger-petstore.cabal diff --git a/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java b/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java index 2cb9516469..44bbe3aebd 100644 --- a/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java +++ b/modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java @@ -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 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 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)) { diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache index 8c3e42de3a..f6271e47a7 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/API.mustache @@ -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}} :<|> diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache index 158c3da9c4..7a41289337 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/README.mustache @@ -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 ``` diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/Types.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/Types.mustache index 5eddf5fb0c..adb8f5f871 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/Types.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/Types.mustache @@ -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 = diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache index 963ba6f9d3..777cf33d6a 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache @@ -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 diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/stack.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/stack.mustache index 78ed93c541..f01b45c028 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/stack.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/stack.mustache @@ -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 \ No newline at end of file diff --git a/samples/server/petstore/haskell-servant/.openapi-generator/VERSION b/samples/server/petstore/haskell-servant/.openapi-generator/VERSION index 6d94c9c2e1..afa6365606 100644 --- a/samples/server/petstore/haskell-servant/.openapi-generator/VERSION +++ b/samples/server/petstore/haskell-servant/.openapi-generator/VERSION @@ -1 +1 @@ -3.3.0-SNAPSHOT \ No newline at end of file +4.0.0-SNAPSHOT \ No newline at end of file diff --git a/samples/server/petstore/haskell-servant/README.md b/samples/server/petstore/haskell-servant/README.md index 9d1f6d7699..a2c40300b1 100644 --- a/samples/server/petstore/haskell-servant/README.md +++ b/samples/server/petstore/haskell-servant/README.md @@ -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 ``` diff --git a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs index be52403f5c..3a78eb9ded 100644 --- a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs +++ b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/API.hs @@ -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 :<|> diff --git a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/Types.hs b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/Types.hs index 542556438d..570827d14a 100644 --- a/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/Types.hs +++ b/samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/Types.hs @@ -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 = diff --git a/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs b/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs deleted file mode 100644 index 6b9642f716..0000000000 --- a/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs +++ /dev/null @@ -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) diff --git a/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/Types.hs b/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/Types.hs deleted file mode 100644 index 7a6c6d802f..0000000000 --- a/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/Types.hs +++ /dev/null @@ -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 diff --git a/samples/server/petstore/haskell-servant/openapi-petstore.cabal b/samples/server/petstore/haskell-servant/openapi-petstore.cabal index d11cb5a364..93888ef6de 100644 --- a/samples/server/petstore/haskell-servant/openapi-petstore.cabal +++ b/samples/server/petstore/haskell-servant/openapi-petstore.cabal @@ -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 diff --git a/samples/server/petstore/haskell-servant/stack.yaml b/samples/server/petstore/haskell-servant/stack.yaml index 78ed93c541..f01b45c028 100644 --- a/samples/server/petstore/haskell-servant/stack.yaml +++ b/samples/server/petstore/haskell-servant/stack.yaml @@ -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 \ No newline at end of file diff --git a/samples/server/petstore/haskell-servant/swagger-petstore.cabal b/samples/server/petstore/haskell-servant/swagger-petstore.cabal deleted file mode 100644 index 4351d73c0d..0000000000 --- a/samples/server/petstore/haskell-servant/swagger-petstore.cabal +++ /dev/null @@ -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