fix casting issue with ModelImpl in Haskell

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);

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

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.

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)

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
+
+