diff --git a/modules/swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellServantCodegen.java b/modules/swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellServantCodegen.java index 59d9658ab75..f485d7c33bf 100644 --- a/modules/swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellServantCodegen.java +++ b/modules/swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellServantCodegen.java @@ -471,6 +471,11 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf // Create newtypes for things with non-object types String dataOrNewtype = "data"; + // check if it's a ModelImpl before casting + if (!(mod instanceof ModelImpl)) { + return model; + } + String modelType = ((ModelImpl) mod).getType(); if(modelType != "object" && typeMapping.containsKey(modelType)) { String newtype = typeMapping.get(modelType); diff --git a/samples/server/petstore/haskell-servant/.swagger-codegen-ignore b/samples/server/petstore/haskell-servant/.swagger-codegen-ignore new file mode 100644 index 00000000000..c5fa491b4c5 --- /dev/null +++ b/samples/server/petstore/haskell-servant/.swagger-codegen-ignore @@ -0,0 +1,23 @@ +# Swagger Codegen Ignore +# Generated by swagger-codegen https://github.com/swagger-api/swagger-codegen + +# Use this file to prevent files from being overwritten by the generator. +# The patterns follow closely to .gitignore or .dockerignore. + +# As an example, the C# client generator defines ApiClient.cs. +# You can make changes and tell Swagger Codgen to ignore just this file by uncommenting the following line: +#ApiClient.cs + +# You can match any string of characters against a directory, file or extension with a single asterisk (*): +#foo/*/qux +# The above matches foo/bar/qux and foo/baz/qux, but not foo/bar/baz/qux + +# You can recursively match patterns against a directory, file or extension with a double asterisk (**): +#foo/**/qux +# This matches foo/bar/qux, foo/baz/qux, and foo/bar/baz/qux + +# You can also negate patterns with an exclamation (!). +# For example, you can ignore all files in a docs folder with the file extension .md: +#docs/*.md +# Then explicitly reverse the ignore rule for a single file: +#!docs/README.md diff --git a/samples/server/petstore/haskell-servant/LICENSE b/samples/server/petstore/haskell-servant/LICENSE index b0033f5f837..8dada3edaf5 100644 --- a/samples/server/petstore/haskell-servant/LICENSE +++ b/samples/server/petstore/haskell-servant/LICENSE @@ -1,4 +1,3 @@ - Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ @@ -179,7 +178,7 @@ APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" + boilerplate notice, with the fields enclosed by brackets "{}" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a @@ -187,7 +186,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright 2015 Masahiro Yamauchi + Copyright {yyyy} {name of copyright owner} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs b/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs new file mode 100644 index 00000000000..75f53f95395 --- /dev/null +++ b/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/API.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, FlexibleInstances, OverloadedStrings, ViewPatterns #-} +{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, DeriveTraversable, FlexibleContexts, DeriveGeneric #-} +{-# 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 Data.Aeson (Value) +import Data.Coerce (coerce) +import Servant.API +import Servant (serve, ServantErr) +import Web.HttpApiData +import qualified Network.Wai.Handler.Warp as Warp +import qualified Data.Text as T +import Data.Text (Text) +import Servant.Common.BaseUrl(BaseUrl(..)) +import Servant.Client (ServantError, client, Scheme(Http)) +import Data.Proxy (Proxy(..)) +import Control.Monad.IO.Class +import Data.Function ((&)) +import GHC.Exts (IsString(..)) +import qualified Data.Map as Map +import GHC.Generics (Generic) +import Data.Monoid ((<>)) +import Servant.API.Verbs (Verb, StdMethod(..)) +import Control.Monad.Except (ExceptT) +import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) +import Network.HTTP.Types.Method (methodOptions) + +instance ReflectMethod 'OPTIONS where + reflectMethod _ = methodOptions + + + +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 Text b +lookupEither key assocs = + case lookup key assocs of + Nothing -> Left $ "Could not find parameter " <> key <> " in form data" + Just value -> parseQueryParam value + +-- | 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 new file mode 100644 index 00000000000..cb88243d957 --- /dev/null +++ b/samples/server/petstore/haskell-servant/lib/SwaggerPetstore/Types.hs @@ -0,0 +1,119 @@ +{-# 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 ((&)) + + +-- | +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") + +-- | +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") + +-- | +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") + +-- | +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") + +-- | +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") + +-- | +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 = [("#", "'Hash"), ("!", "'Exclamation"), ("&", "'Ampersand"), ("@", "'At"), ("$", "'Dollar"), ("%", "'Percent"), ("*", "'Star"), ("+", "'Plus"), ("-", "'Dash"), (":", "'Colon"), ("^", "'Caret"), ("|", "'Pipe"), (">", "'GreaterThan"), ("=", "'Equal"), ("<", "'LessThan")] + mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack + replacer = if forParsing then flip T.replace else T.replace + +