forked from loafle/openapi-generator-original
fix casting issue with ModelImpl in Haskell
This commit is contained in:
wing328
parent
c23b473636
commit
3cd37bf5e9
@ -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);
|
||||
|
||||
@ -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
|
||||
@ -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.
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user