forked from loafle/openapi-generator-original
add haskell-http-client-generator (#6429)
This commit is contained in:
Jon Schoning
wing328
@@ -0,0 +1,17 @@
|
||||
{-|
|
||||
Module : SwaggerPetstore
|
||||
-}
|
||||
|
||||
module SwaggerPetstore
|
||||
( module SwaggerPetstore.Client
|
||||
, module SwaggerPetstore.API
|
||||
, module SwaggerPetstore.Model
|
||||
, module SwaggerPetstore.MimeTypes
|
||||
, module SwaggerPetstore.Lens
|
||||
) where
|
||||
|
||||
import SwaggerPetstore.API
|
||||
import SwaggerPetstore.Client
|
||||
import SwaggerPetstore.Model
|
||||
import SwaggerPetstore.MimeTypes
|
||||
import SwaggerPetstore.Lens
|
||||
@@ -0,0 +1,830 @@
|
||||
{-|
|
||||
Module : SwaggerPetstore.API
|
||||
-}
|
||||
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module SwaggerPetstore.API where
|
||||
|
||||
|
||||
import SwaggerPetstore.Model as M
|
||||
import SwaggerPetstore.MimeTypes
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Aeson (Value)
|
||||
|
||||
import qualified Data.Time as TI
|
||||
import Data.Time (UTCTime)
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy.Char8 as BCL
|
||||
|
||||
import qualified Network.HTTP.Client.MultipartFormData as NH
|
||||
import qualified Network.HTTP.Media as ME
|
||||
import qualified Network.HTTP.Types as NH
|
||||
|
||||
import qualified Web.HttpApiData as WH
|
||||
import qualified Web.FormUrlEncoded as WH
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Data as P (Typeable)
|
||||
import qualified Data.Foldable as P
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as P
|
||||
import qualified Data.Proxy as P (Proxy(..))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Encoding as TL
|
||||
import qualified GHC.Base as P (Alternative)
|
||||
import qualified Control.Arrow as P (left)
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Function ((&))
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import GHC.Base ((<|>))
|
||||
|
||||
import Prelude ((==),(/=),($), (.),(<$>),(<*>),(>>=),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor)
|
||||
import qualified Prelude as P
|
||||
|
||||
-- * Operations
|
||||
|
||||
|
||||
-- ** Pet
|
||||
|
||||
-- *** addPet
|
||||
|
||||
-- | @POST \/pet@
|
||||
--
|
||||
-- Add a new pet to the store
|
||||
--
|
||||
--
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
addPet
|
||||
:: (Consumes AddPet contentType, MimeRender contentType Pet)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> Pet -- ^ "body" - Pet object that needs to be added to the store
|
||||
-> SwaggerPetstoreRequest AddPet contentType res
|
||||
addPet _ body =
|
||||
_mkRequest "POST" ["/pet"]
|
||||
`setBodyParam` body
|
||||
|
||||
data AddPet
|
||||
|
||||
-- | /Body Param/ "body" - Pet object that needs to be added to the store
|
||||
instance HasBodyParam AddPet Pet
|
||||
|
||||
-- | @application/json@
|
||||
instance Consumes AddPet MimeJSON
|
||||
-- | @application/xml@
|
||||
instance Consumes AddPet MimeXML
|
||||
|
||||
-- | @application/xml@
|
||||
instance Produces AddPet MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces AddPet MimeJSON
|
||||
|
||||
|
||||
-- *** deletePet
|
||||
|
||||
-- | @DELETE \/pet\/{petId}@
|
||||
--
|
||||
-- Deletes a pet
|
||||
--
|
||||
--
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
deletePet
|
||||
:: Integer -- ^ "petId" - Pet id to delete
|
||||
-> SwaggerPetstoreRequest DeletePet MimeNoContent res
|
||||
deletePet petId =
|
||||
_mkRequest "DELETE" ["/pet/",toPath petId]
|
||||
|
||||
|
||||
data DeletePet
|
||||
instance HasOptionalParam DeletePet ApiUnderscorekey where
|
||||
applyOptionalParam req (ApiUnderscorekey xs) =
|
||||
req `setHeader` toHeader ("api_key", xs)
|
||||
-- | @application/xml@
|
||||
instance Produces DeletePet MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces DeletePet MimeJSON
|
||||
|
||||
|
||||
-- *** findPetsByStatus
|
||||
|
||||
-- | @GET \/pet\/findByStatus@
|
||||
--
|
||||
-- Finds Pets by status
|
||||
--
|
||||
-- Multiple status values can be provided with comma separated strings
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
findPetsByStatus
|
||||
:: [Text] -- ^ "status" - Status values that need to be considered for filter
|
||||
-> SwaggerPetstoreRequest FindPetsByStatus MimeNoContent [Pet]
|
||||
findPetsByStatus status =
|
||||
_mkRequest "GET" ["/pet/findByStatus"]
|
||||
`_setQuery` toQueryColl CommaSeparated ("status", Just status)
|
||||
|
||||
data FindPetsByStatus
|
||||
-- | @application/xml@
|
||||
instance Produces FindPetsByStatus MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces FindPetsByStatus MimeJSON
|
||||
|
||||
|
||||
-- *** findPetsByTags
|
||||
|
||||
-- | @GET \/pet\/findByTags@
|
||||
--
|
||||
-- Finds Pets by tags
|
||||
--
|
||||
-- Multiple tags can be provided with comma separated strings. Use tag1, tag2, tag3 for testing.
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
findPetsByTags
|
||||
:: [Text] -- ^ "tags" - Tags to filter by
|
||||
-> SwaggerPetstoreRequest FindPetsByTags MimeNoContent [Pet]
|
||||
findPetsByTags tags =
|
||||
_mkRequest "GET" ["/pet/findByTags"]
|
||||
`_setQuery` toQueryColl CommaSeparated ("tags", Just tags)
|
||||
|
||||
{-# DEPRECATED findPetsByTags "" #-}
|
||||
|
||||
data FindPetsByTags
|
||||
-- | @application/xml@
|
||||
instance Produces FindPetsByTags MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces FindPetsByTags MimeJSON
|
||||
|
||||
|
||||
-- *** getPetById
|
||||
|
||||
-- | @GET \/pet\/{petId}@
|
||||
--
|
||||
-- Find pet by ID
|
||||
--
|
||||
-- Returns a single pet
|
||||
--
|
||||
-- AuthMethod: api_key
|
||||
--
|
||||
getPetById
|
||||
:: Integer -- ^ "petId" - ID of pet to return
|
||||
-> SwaggerPetstoreRequest GetPetById MimeNoContent Pet
|
||||
getPetById petId =
|
||||
_mkRequest "GET" ["/pet/",toPath petId]
|
||||
|
||||
|
||||
data GetPetById
|
||||
-- | @application/xml@
|
||||
instance Produces GetPetById MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces GetPetById MimeJSON
|
||||
|
||||
|
||||
-- *** updatePet
|
||||
|
||||
-- | @PUT \/pet@
|
||||
--
|
||||
-- Update an existing pet
|
||||
--
|
||||
--
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
updatePet
|
||||
:: (Consumes UpdatePet contentType, MimeRender contentType Pet)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> Pet -- ^ "body" - Pet object that needs to be added to the store
|
||||
-> SwaggerPetstoreRequest UpdatePet contentType res
|
||||
updatePet _ body =
|
||||
_mkRequest "PUT" ["/pet"]
|
||||
`setBodyParam` body
|
||||
|
||||
data UpdatePet
|
||||
|
||||
-- | /Body Param/ "body" - Pet object that needs to be added to the store
|
||||
instance HasBodyParam UpdatePet Pet
|
||||
|
||||
-- | @application/json@
|
||||
instance Consumes UpdatePet MimeJSON
|
||||
-- | @application/xml@
|
||||
instance Consumes UpdatePet MimeXML
|
||||
|
||||
-- | @application/xml@
|
||||
instance Produces UpdatePet MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces UpdatePet MimeJSON
|
||||
|
||||
|
||||
-- *** updatePetWithForm
|
||||
|
||||
-- | @POST \/pet\/{petId}@
|
||||
--
|
||||
-- Updates a pet in the store with form data
|
||||
--
|
||||
--
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
updatePetWithForm
|
||||
:: (Consumes UpdatePetWithForm contentType)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> Integer -- ^ "petId" - ID of pet that needs to be updated
|
||||
-> SwaggerPetstoreRequest UpdatePetWithForm contentType res
|
||||
updatePetWithForm _ petId =
|
||||
_mkRequest "POST" ["/pet/",toPath petId]
|
||||
|
||||
|
||||
data UpdatePetWithForm
|
||||
|
||||
-- | /Optional Param/ "name" - Updated name of the pet
|
||||
instance HasOptionalParam UpdatePetWithForm Name where
|
||||
applyOptionalParam req (Name xs) =
|
||||
req `_addForm` toForm ("name", xs)
|
||||
|
||||
-- | /Optional Param/ "status" - Updated status of the pet
|
||||
instance HasOptionalParam UpdatePetWithForm Status where
|
||||
applyOptionalParam req (Status xs) =
|
||||
req `_addForm` toForm ("status", xs)
|
||||
|
||||
-- | @application/x-www-form-urlencoded@
|
||||
instance Consumes UpdatePetWithForm MimeFormUrlEncoded
|
||||
|
||||
-- | @application/xml@
|
||||
instance Produces UpdatePetWithForm MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces UpdatePetWithForm MimeJSON
|
||||
|
||||
|
||||
-- *** uploadFile
|
||||
|
||||
-- | @POST \/pet\/{petId}\/uploadImage@
|
||||
--
|
||||
-- uploads an image
|
||||
--
|
||||
--
|
||||
--
|
||||
-- AuthMethod: petstore_auth
|
||||
--
|
||||
uploadFile
|
||||
:: (Consumes UploadFile contentType)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> Integer -- ^ "petId" - ID of pet to update
|
||||
-> SwaggerPetstoreRequest UploadFile contentType ApiResponse
|
||||
uploadFile _ petId =
|
||||
_mkRequest "POST" ["/pet/",toPath petId,"/uploadImage"]
|
||||
|
||||
|
||||
data UploadFile
|
||||
|
||||
-- | /Optional Param/ "additionalMetadata" - Additional data to pass to server
|
||||
instance HasOptionalParam UploadFile AdditionalMetadata where
|
||||
applyOptionalParam req (AdditionalMetadata xs) =
|
||||
req `_addMultiFormPart` NH.partLBS "additionalMetadata" (mimeRender' MimeMultipartFormData xs)
|
||||
|
||||
-- | /Optional Param/ "file" - file to upload
|
||||
instance HasOptionalParam UploadFile File where
|
||||
applyOptionalParam req (File xs) =
|
||||
req `_addMultiFormPart` NH.partFileSource "file" xs
|
||||
|
||||
-- | @multipart/form-data@
|
||||
instance Consumes UploadFile MimeMultipartFormData
|
||||
|
||||
-- | @application/json@
|
||||
instance Produces UploadFile MimeJSON
|
||||
|
||||
|
||||
-- ** Store
|
||||
|
||||
-- *** deleteOrder
|
||||
|
||||
-- | @DELETE \/store\/order\/{orderId}@
|
||||
--
|
||||
-- Delete purchase order by ID
|
||||
--
|
||||
-- For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
deleteOrder
|
||||
:: Text -- ^ "orderId" - ID of the order that needs to be deleted
|
||||
-> SwaggerPetstoreRequest DeleteOrder MimeNoContent res
|
||||
deleteOrder orderId =
|
||||
_mkRequest "DELETE" ["/store/order/",toPath orderId]
|
||||
|
||||
|
||||
data DeleteOrder
|
||||
-- | @application/xml@
|
||||
instance Produces DeleteOrder MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces DeleteOrder MimeJSON
|
||||
|
||||
|
||||
-- *** getInventory
|
||||
|
||||
-- | @GET \/store\/inventory@
|
||||
--
|
||||
-- Returns pet inventories by status
|
||||
--
|
||||
-- Returns a map of status codes to quantities
|
||||
--
|
||||
-- AuthMethod: api_key
|
||||
--
|
||||
getInventory
|
||||
:: SwaggerPetstoreRequest GetInventory MimeNoContent (Map.Map String Int)
|
||||
getInventory =
|
||||
_mkRequest "GET" ["/store/inventory"]
|
||||
|
||||
data GetInventory
|
||||
-- | @application/json@
|
||||
instance Produces GetInventory MimeJSON
|
||||
|
||||
|
||||
-- *** getOrderById
|
||||
|
||||
-- | @GET \/store\/order\/{orderId}@
|
||||
--
|
||||
-- Find purchase order by ID
|
||||
--
|
||||
-- For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions
|
||||
--
|
||||
getOrderById
|
||||
:: Integer -- ^ "orderId" - ID of pet that needs to be fetched
|
||||
-> SwaggerPetstoreRequest GetOrderById MimeNoContent Order
|
||||
getOrderById orderId =
|
||||
_mkRequest "GET" ["/store/order/",toPath orderId]
|
||||
|
||||
|
||||
data GetOrderById
|
||||
-- | @application/xml@
|
||||
instance Produces GetOrderById MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces GetOrderById MimeJSON
|
||||
|
||||
|
||||
-- *** placeOrder
|
||||
|
||||
-- | @POST \/store\/order@
|
||||
--
|
||||
-- Place an order for a pet
|
||||
--
|
||||
--
|
||||
--
|
||||
placeOrder
|
||||
:: (Consumes PlaceOrder contentType, MimeRender contentType Order)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> Order -- ^ "body" - order placed for purchasing the pet
|
||||
-> SwaggerPetstoreRequest PlaceOrder contentType Order
|
||||
placeOrder _ body =
|
||||
_mkRequest "POST" ["/store/order"]
|
||||
`setBodyParam` body
|
||||
|
||||
data PlaceOrder
|
||||
|
||||
-- | /Body Param/ "body" - order placed for purchasing the pet
|
||||
instance HasBodyParam PlaceOrder Order
|
||||
-- | @application/xml@
|
||||
instance Produces PlaceOrder MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces PlaceOrder MimeJSON
|
||||
|
||||
|
||||
-- ** User
|
||||
|
||||
-- *** createUser
|
||||
|
||||
-- | @POST \/user@
|
||||
--
|
||||
-- Create user
|
||||
--
|
||||
-- This can only be done by the logged in user.
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
createUser
|
||||
:: (Consumes CreateUser contentType, MimeRender contentType User)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> User -- ^ "body" - Created user object
|
||||
-> SwaggerPetstoreRequest CreateUser contentType res
|
||||
createUser _ body =
|
||||
_mkRequest "POST" ["/user"]
|
||||
`setBodyParam` body
|
||||
|
||||
data CreateUser
|
||||
|
||||
-- | /Body Param/ "body" - Created user object
|
||||
instance HasBodyParam CreateUser User
|
||||
-- | @application/xml@
|
||||
instance Produces CreateUser MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces CreateUser MimeJSON
|
||||
|
||||
|
||||
-- *** createUsersWithArrayInput
|
||||
|
||||
-- | @POST \/user\/createWithArray@
|
||||
--
|
||||
-- Creates list of users with given input array
|
||||
--
|
||||
--
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
createUsersWithArrayInput
|
||||
:: (Consumes CreateUsersWithArrayInput contentType, MimeRender contentType [User])
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> [User] -- ^ "body" - List of user object
|
||||
-> SwaggerPetstoreRequest CreateUsersWithArrayInput contentType res
|
||||
createUsersWithArrayInput _ body =
|
||||
_mkRequest "POST" ["/user/createWithArray"]
|
||||
`setBodyParam` body
|
||||
|
||||
data CreateUsersWithArrayInput
|
||||
|
||||
-- | /Body Param/ "body" - List of user object
|
||||
instance HasBodyParam CreateUsersWithArrayInput [User]
|
||||
-- | @application/xml@
|
||||
instance Produces CreateUsersWithArrayInput MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces CreateUsersWithArrayInput MimeJSON
|
||||
|
||||
|
||||
-- *** createUsersWithListInput
|
||||
|
||||
-- | @POST \/user\/createWithList@
|
||||
--
|
||||
-- Creates list of users with given input array
|
||||
--
|
||||
--
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
createUsersWithListInput
|
||||
:: (Consumes CreateUsersWithListInput contentType, MimeRender contentType [User])
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> [User] -- ^ "body" - List of user object
|
||||
-> SwaggerPetstoreRequest CreateUsersWithListInput contentType res
|
||||
createUsersWithListInput _ body =
|
||||
_mkRequest "POST" ["/user/createWithList"]
|
||||
`setBodyParam` body
|
||||
|
||||
data CreateUsersWithListInput
|
||||
|
||||
-- | /Body Param/ "body" - List of user object
|
||||
instance HasBodyParam CreateUsersWithListInput [User]
|
||||
-- | @application/xml@
|
||||
instance Produces CreateUsersWithListInput MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces CreateUsersWithListInput MimeJSON
|
||||
|
||||
|
||||
-- *** deleteUser
|
||||
|
||||
-- | @DELETE \/user\/{username}@
|
||||
--
|
||||
-- Delete user
|
||||
--
|
||||
-- This can only be done by the logged in user.
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
deleteUser
|
||||
:: Text -- ^ "username" - The name that needs to be deleted
|
||||
-> SwaggerPetstoreRequest DeleteUser MimeNoContent res
|
||||
deleteUser username =
|
||||
_mkRequest "DELETE" ["/user/",toPath username]
|
||||
|
||||
|
||||
data DeleteUser
|
||||
-- | @application/xml@
|
||||
instance Produces DeleteUser MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces DeleteUser MimeJSON
|
||||
|
||||
|
||||
-- *** getUserByName
|
||||
|
||||
-- | @GET \/user\/{username}@
|
||||
--
|
||||
-- Get user by user name
|
||||
--
|
||||
--
|
||||
--
|
||||
getUserByName
|
||||
:: Text -- ^ "username" - The name that needs to be fetched. Use user1 for testing.
|
||||
-> SwaggerPetstoreRequest GetUserByName MimeNoContent User
|
||||
getUserByName username =
|
||||
_mkRequest "GET" ["/user/",toPath username]
|
||||
|
||||
|
||||
data GetUserByName
|
||||
-- | @application/xml@
|
||||
instance Produces GetUserByName MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces GetUserByName MimeJSON
|
||||
|
||||
|
||||
-- *** loginUser
|
||||
|
||||
-- | @GET \/user\/login@
|
||||
--
|
||||
-- Logs user into the system
|
||||
--
|
||||
--
|
||||
--
|
||||
loginUser
|
||||
:: Text -- ^ "username" - The user name for login
|
||||
-> Text -- ^ "password" - The password for login in clear text
|
||||
-> SwaggerPetstoreRequest LoginUser MimeNoContent Text
|
||||
loginUser username password =
|
||||
_mkRequest "GET" ["/user/login"]
|
||||
`_setQuery` toQuery ("username", Just username)
|
||||
`_setQuery` toQuery ("password", Just password)
|
||||
|
||||
data LoginUser
|
||||
-- | @application/xml@
|
||||
instance Produces LoginUser MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces LoginUser MimeJSON
|
||||
|
||||
|
||||
-- *** logoutUser
|
||||
|
||||
-- | @GET \/user\/logout@
|
||||
--
|
||||
-- Logs out current logged in user session
|
||||
--
|
||||
--
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
logoutUser
|
||||
:: SwaggerPetstoreRequest LogoutUser MimeNoContent res
|
||||
logoutUser =
|
||||
_mkRequest "GET" ["/user/logout"]
|
||||
|
||||
data LogoutUser
|
||||
-- | @application/xml@
|
||||
instance Produces LogoutUser MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces LogoutUser MimeJSON
|
||||
|
||||
|
||||
-- *** updateUser
|
||||
|
||||
-- | @PUT \/user\/{username}@
|
||||
--
|
||||
-- Updated user
|
||||
--
|
||||
-- This can only be done by the logged in user.
|
||||
--
|
||||
-- Note: Has 'Produces' instances, but no response schema
|
||||
--
|
||||
updateUser
|
||||
:: (Consumes UpdateUser contentType, MimeRender contentType User)
|
||||
=> contentType -- ^ request content-type ('MimeType')
|
||||
-> Text -- ^ "username" - name that need to be deleted
|
||||
-> User -- ^ "body" - Updated user object
|
||||
-> SwaggerPetstoreRequest UpdateUser contentType res
|
||||
updateUser _ username body =
|
||||
_mkRequest "PUT" ["/user/",toPath username]
|
||||
|
||||
`setBodyParam` body
|
||||
|
||||
data UpdateUser
|
||||
|
||||
-- | /Body Param/ "body" - Updated user object
|
||||
instance HasBodyParam UpdateUser User
|
||||
-- | @application/xml@
|
||||
instance Produces UpdateUser MimeXML
|
||||
-- | @application/json@
|
||||
instance Produces UpdateUser MimeJSON
|
||||
|
||||
|
||||
|
||||
-- * HasBodyParam
|
||||
|
||||
-- | Designates the body parameter of a request
|
||||
class HasBodyParam req param where
|
||||
setBodyParam :: forall contentType res. (Consumes req contentType, MimeRender contentType param) => SwaggerPetstoreRequest req contentType res -> param -> SwaggerPetstoreRequest req contentType res
|
||||
setBodyParam req xs =
|
||||
req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader
|
||||
|
||||
-- * HasOptionalParam
|
||||
|
||||
-- | Designates the optional parameters of a request
|
||||
class HasOptionalParam req param where
|
||||
{-# MINIMAL applyOptionalParam | (-&-) #-}
|
||||
|
||||
-- | Apply an optional parameter to a request
|
||||
applyOptionalParam :: SwaggerPetstoreRequest req contentType res -> param -> SwaggerPetstoreRequest req contentType res
|
||||
applyOptionalParam = (-&-)
|
||||
{-# INLINE applyOptionalParam #-}
|
||||
|
||||
-- | infix operator \/ alias for 'addOptionalParam'
|
||||
(-&-) :: SwaggerPetstoreRequest req contentType res -> param -> SwaggerPetstoreRequest req contentType res
|
||||
(-&-) = applyOptionalParam
|
||||
{-# INLINE (-&-) #-}
|
||||
|
||||
infixl 2 -&-
|
||||
|
||||
-- * Optional Request Parameter Types
|
||||
|
||||
|
||||
newtype ApiUnderscorekey = ApiUnderscorekey { unApiUnderscorekey :: Text } deriving (P.Eq, P.Show)
|
||||
|
||||
newtype Name = Name { unName :: Text } deriving (P.Eq, P.Show)
|
||||
|
||||
newtype Status = Status { unStatus :: Text } deriving (P.Eq, P.Show)
|
||||
|
||||
newtype AdditionalMetadata = AdditionalMetadata { unAdditionalMetadata :: Text } deriving (P.Eq, P.Show)
|
||||
|
||||
newtype File = File { unFile :: FilePath } deriving (P.Eq, P.Show)
|
||||
|
||||
|
||||
-- * SwaggerPetstoreRequest
|
||||
|
||||
-- | Represents a request. The "req" type variable is the request type. The "res" type variable is the response type.
|
||||
data SwaggerPetstoreRequest req contentType res = SwaggerPetstoreRequest
|
||||
{ rMethod :: NH.Method -- ^ Method of SwaggerPetstoreRequest
|
||||
, urlPath :: [BCL.ByteString] -- ^ Endpoint of SwaggerPetstoreRequest
|
||||
, params :: Params -- ^ params of SwaggerPetstoreRequest
|
||||
}
|
||||
deriving (P.Show)
|
||||
|
||||
-- | Request Params
|
||||
data Params = Params
|
||||
{ paramsQuery :: NH.Query
|
||||
, paramsHeaders :: NH.RequestHeaders
|
||||
, paramsBody :: ParamBody
|
||||
}
|
||||
deriving (P.Show)
|
||||
|
||||
-- | Request Body
|
||||
data ParamBody
|
||||
= ParamBodyNone
|
||||
| ParamBodyB B.ByteString
|
||||
| ParamBodyBL BL.ByteString
|
||||
| ParamBodyFormUrlEncoded WH.Form
|
||||
| ParamBodyMultipartFormData [NH.Part]
|
||||
deriving (P.Show)
|
||||
|
||||
-- ** SwaggerPetstoreRequest Utils
|
||||
|
||||
_mkRequest :: NH.Method -- ^ Method
|
||||
-> [BCL.ByteString] -- ^ Endpoint
|
||||
-> SwaggerPetstoreRequest req contentType res -- ^ req: Request Type, res: Response Type
|
||||
_mkRequest m u = SwaggerPetstoreRequest m u _mkParams
|
||||
|
||||
_mkParams :: Params
|
||||
_mkParams = Params [] [] ParamBodyNone
|
||||
|
||||
setHeader :: SwaggerPetstoreRequest req contentType res -> [NH.Header] -> SwaggerPetstoreRequest req contentType res
|
||||
setHeader req header =
|
||||
let _params = params (req `removeHeader` P.fmap P.fst header)
|
||||
in req { params = _params { paramsHeaders = header P.++ paramsHeaders _params } }
|
||||
|
||||
removeHeader :: SwaggerPetstoreRequest req contentType res -> [NH.HeaderName] -> SwaggerPetstoreRequest req contentType res
|
||||
removeHeader req header =
|
||||
let _params = params req
|
||||
in req { params = _params { paramsHeaders = [h | h <- paramsHeaders _params, cifst h `P.notElem` P.fmap CI.mk header] } }
|
||||
where cifst = CI.mk . P.fst
|
||||
|
||||
|
||||
_setContentTypeHeader :: forall req contentType res. MimeType contentType => SwaggerPetstoreRequest req contentType res -> SwaggerPetstoreRequest req contentType res
|
||||
_setContentTypeHeader req =
|
||||
case mimeType (P.Proxy :: P.Proxy contentType) of
|
||||
Just m -> req `setHeader` [("content-type", BC.pack $ P.show m)]
|
||||
Nothing -> req `removeHeader` ["content-type"]
|
||||
|
||||
_setAcceptHeader :: forall req contentType res accept. MimeType accept => SwaggerPetstoreRequest req contentType res -> accept -> SwaggerPetstoreRequest req contentType res
|
||||
_setAcceptHeader req accept =
|
||||
case mimeType' accept of
|
||||
Just m -> req `setHeader` [("accept", BC.pack $ P.show m)]
|
||||
Nothing -> req `removeHeader` ["accept"]
|
||||
|
||||
_setQuery :: SwaggerPetstoreRequest req contentType res -> [NH.QueryItem] -> SwaggerPetstoreRequest req contentType res
|
||||
_setQuery req query =
|
||||
let _params = params req
|
||||
in req { params = _params { paramsQuery = query P.++ [q | q <- paramsQuery _params, cifst q `P.notElem` P.fmap cifst query] } }
|
||||
where cifst = CI.mk . P.fst
|
||||
|
||||
_addForm :: SwaggerPetstoreRequest req contentType res -> WH.Form -> SwaggerPetstoreRequest req contentType res
|
||||
_addForm req newform =
|
||||
let _params = params req
|
||||
form = case paramsBody _params of
|
||||
ParamBodyFormUrlEncoded _form -> _form
|
||||
_ -> mempty
|
||||
in req { params = _params { paramsBody = ParamBodyFormUrlEncoded (newform <> form) } }
|
||||
|
||||
_addMultiFormPart :: SwaggerPetstoreRequest req contentType res -> NH.Part -> SwaggerPetstoreRequest req contentType res
|
||||
_addMultiFormPart req newpart =
|
||||
let _params = params req
|
||||
parts = case paramsBody _params of
|
||||
ParamBodyMultipartFormData _parts -> _parts
|
||||
_ -> []
|
||||
in req { params = _params { paramsBody = ParamBodyMultipartFormData (newpart : parts) } }
|
||||
|
||||
_setBodyBS :: SwaggerPetstoreRequest req contentType res -> B.ByteString -> SwaggerPetstoreRequest req contentType res
|
||||
_setBodyBS req body =
|
||||
let _params = params req
|
||||
in req { params = _params { paramsBody = ParamBodyB body } }
|
||||
|
||||
_setBodyLBS :: SwaggerPetstoreRequest req contentType res -> BL.ByteString -> SwaggerPetstoreRequest req contentType res
|
||||
_setBodyLBS req body =
|
||||
let _params = params req
|
||||
in req { params = _params { paramsBody = ParamBodyBL body } }
|
||||
|
||||
|
||||
-- ** Params Utils
|
||||
|
||||
toPath
|
||||
:: WH.ToHttpApiData a
|
||||
=> a -> BCL.ByteString
|
||||
toPath = BB.toLazyByteString . WH.toEncodedUrlPiece
|
||||
|
||||
toHeader :: WH.ToHttpApiData a => (NH.HeaderName, a) -> [NH.Header]
|
||||
toHeader x = [fmap WH.toHeader x]
|
||||
|
||||
toForm :: WH.ToHttpApiData v => (BC.ByteString, v) -> WH.Form
|
||||
toForm (k,v) = WH.toForm [(BC.unpack k,v)]
|
||||
|
||||
toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem]
|
||||
toQuery x = [(fmap . fmap) toQueryParam x]
|
||||
where toQueryParam = T.encodeUtf8 . WH.toQueryParam
|
||||
|
||||
-- *** Swagger `CollectionFormat` Utils
|
||||
|
||||
-- | Determines the format of the array if type array is used.
|
||||
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`. This is valid only for parameters in "query" ('NH.Query') or "formData" ('WH.Form')
|
||||
|
||||
toHeaderColl :: WH.ToHttpApiData a => CollectionFormat -> (NH.HeaderName, [a]) -> [NH.Header]
|
||||
toHeaderColl c xs = _toColl c toHeader xs
|
||||
|
||||
toFormColl :: WH.ToHttpApiData v => CollectionFormat -> (BC.ByteString, [v]) -> WH.Form
|
||||
toFormColl c xs = WH.toForm $ fmap unpack $ _toColl c toHeader $ pack xs
|
||||
where
|
||||
pack (k,v) = (CI.mk k, v)
|
||||
unpack (k,v) = (BC.unpack (CI.original k), BC.unpack v)
|
||||
|
||||
toQueryColl :: WH.ToHttpApiData a => CollectionFormat -> (BC.ByteString, Maybe [a]) -> NH.Query
|
||||
toQueryColl c xs = _toCollA c toQuery xs
|
||||
|
||||
_toColl :: P.Traversable f => CollectionFormat -> (f a -> [(b, BC.ByteString)]) -> f [a] -> [(b, BC.ByteString)]
|
||||
_toColl c encode xs = fmap (fmap P.fromJust) (_toCollA' c fencode BC.singleton (fmap Just xs))
|
||||
where fencode = fmap (fmap Just) . encode . fmap P.fromJust
|
||||
{-# INLINE fencode #-}
|
||||
|
||||
_toCollA :: (P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t BC.ByteString)]) -> f (t [a]) -> [(b, t BC.ByteString)]
|
||||
_toCollA c encode xs = _toCollA' c encode BC.singleton xs
|
||||
|
||||
_toCollA' :: (P.Monoid c, P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t c)]) -> (Char -> c) -> f (t [a]) -> [(b, t c)]
|
||||
_toCollA' c encode one xs = case c of
|
||||
CommaSeparated -> go (one ',')
|
||||
SpaceSeparated -> go (one ' ')
|
||||
TabSeparated -> go (one '\t')
|
||||
PipeSeparated -> go (one '|')
|
||||
MultiParamArray -> expandList
|
||||
where
|
||||
go sep =
|
||||
[P.foldl1 (\(sk, sv) (_, v) -> (sk, (combine sep <$> sv <*> v) <|> sv <|> v)) expandList]
|
||||
combine sep x y = x <> sep <> y
|
||||
expandList = (P.concatMap encode . (P.traverse . P.traverse) P.toList) xs
|
||||
{-# INLINE go #-}
|
||||
{-# INLINE expandList #-}
|
||||
{-# INLINE combine #-}
|
||||
|
||||
@@ -0,0 +1,317 @@
|
||||
{-|
|
||||
Module : SwaggerPetstore.Client
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module SwaggerPetstore.Client where
|
||||
|
||||
import SwaggerPetstore.Model
|
||||
import SwaggerPetstore.API
|
||||
import SwaggerPetstore.MimeTypes
|
||||
|
||||
import qualified Control.Monad.IO.Class as P
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Types as A
|
||||
import qualified Data.Proxy as P (Proxy(..))
|
||||
import Data.Function ((&))
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import GHC.Exts (IsString(..))
|
||||
import Web.FormUrlEncoded as WH
|
||||
import Web.HttpApiData as WH
|
||||
import Control.Monad.Catch (MonadThrow)
|
||||
|
||||
import qualified Control.Monad.Logger as LG
|
||||
|
||||
import qualified Data.Time as TI
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Text.Printf as T
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy.Char8 as BCL
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Network.HTTP.Client as NH
|
||||
import qualified Network.HTTP.Client.TLS as NH
|
||||
import qualified Network.HTTP.Client.MultipartFormData as NH
|
||||
import qualified Network.HTTP.Types.Method as NH
|
||||
import qualified Network.HTTP.Types as NH
|
||||
import qualified Network.HTTP.Types.URI as NH
|
||||
|
||||
import qualified Control.Exception.Safe as E
|
||||
-- * Config
|
||||
|
||||
-- |
|
||||
data SwaggerPetstoreConfig = SwaggerPetstoreConfig
|
||||
{ configHost :: BCL.ByteString -- ^ host supplied in the Request
|
||||
, configUserAgent :: Text -- ^ user-agent supplied in the Request
|
||||
, configExecLoggingT :: ExecLoggingT -- ^ Run a block using a MonadLogger instance
|
||||
, configLoggingFilter :: LG.LogSource -> LG.LogLevel -> Bool -- ^ Only log messages passing the given predicate function.
|
||||
}
|
||||
|
||||
-- | display the config
|
||||
instance Show SwaggerPetstoreConfig where
|
||||
show c =
|
||||
T.printf
|
||||
"{ configHost = %v, configUserAgent = %v, ..}"
|
||||
(show (configHost c))
|
||||
(show (configUserAgent c))
|
||||
|
||||
-- | constructs a default SwaggerPetstoreConfig
|
||||
--
|
||||
-- configHost:
|
||||
--
|
||||
-- @http://petstore.swagger.io/v2@
|
||||
--
|
||||
-- configUserAgent:
|
||||
--
|
||||
-- @"swagger-haskell-http-client/1.0.0"@
|
||||
--
|
||||
-- configExecLoggingT: 'runNullLoggingT'
|
||||
--
|
||||
-- configLoggingFilter: 'infoLevelFilter'
|
||||
newConfig :: SwaggerPetstoreConfig
|
||||
newConfig =
|
||||
SwaggerPetstoreConfig
|
||||
{ configHost = "http://petstore.swagger.io/v2"
|
||||
, configUserAgent = "swagger-haskell-http-client/1.0.0"
|
||||
, configExecLoggingT = runNullLoggingT
|
||||
, configLoggingFilter = infoLevelFilter
|
||||
}
|
||||
|
||||
-- | updates the config to use a MonadLogger instance which prints to stdout.
|
||||
withStdoutLogging :: SwaggerPetstoreConfig -> SwaggerPetstoreConfig
|
||||
withStdoutLogging p = p { configExecLoggingT = LG.runStdoutLoggingT}
|
||||
|
||||
-- | updates the config to use a MonadLogger instance which prints to stderr.
|
||||
withStderrLogging :: SwaggerPetstoreConfig -> SwaggerPetstoreConfig
|
||||
withStderrLogging p = p { configExecLoggingT = LG.runStderrLoggingT}
|
||||
|
||||
-- | updates the config to disable logging
|
||||
withNoLogging :: SwaggerPetstoreConfig -> SwaggerPetstoreConfig
|
||||
withNoLogging p = p { configExecLoggingT = runNullLoggingT}
|
||||
|
||||
-- * Dispatch
|
||||
|
||||
-- ** Lbs
|
||||
|
||||
-- | send a request returning the raw http response
|
||||
dispatchLbs
|
||||
:: (Produces req accept, MimeType contentType)
|
||||
=> NH.Manager -- ^ http-client Connection manager
|
||||
-> SwaggerPetstoreConfig -- ^ config
|
||||
-> SwaggerPetstoreRequest req contentType res -- ^ request
|
||||
-> accept -- ^ "accept" 'MimeType'
|
||||
-> IO (NH.Response BCL.ByteString) -- ^ response
|
||||
dispatchLbs manager config request accept = do
|
||||
initReq <- _toInitRequest config request accept
|
||||
dispatchInitUnsafe manager config initReq
|
||||
|
||||
-- ** Mime
|
||||
|
||||
-- | pair of decoded http body and http response
|
||||
data MimeResult res =
|
||||
MimeResult { mimeResult :: Either MimeError res -- ^ decoded http body
|
||||
, mimeResultResponse :: NH.Response BCL.ByteString -- ^ http response
|
||||
}
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
|
||||
-- | pair of unrender/parser error and http response
|
||||
data MimeError =
|
||||
MimeError {
|
||||
mimeError :: String -- ^ unrender/parser error
|
||||
, mimeErrorResponse :: NH.Response BCL.ByteString -- ^ http response
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | send a request returning the 'MimeResult'
|
||||
dispatchMime
|
||||
:: (Produces req accept, MimeUnrender accept res, MimeType contentType)
|
||||
=> NH.Manager -- ^ http-client Connection manager
|
||||
-> SwaggerPetstoreConfig -- ^ config
|
||||
-> SwaggerPetstoreRequest req contentType res -- ^ request
|
||||
-> accept -- ^ "accept" 'MimeType'
|
||||
-> IO (MimeResult res) -- ^ response
|
||||
dispatchMime manager config request accept = do
|
||||
httpResponse <- dispatchLbs manager config request accept
|
||||
parsedResult <-
|
||||
runExceptionLoggingT "Client" config $
|
||||
do case mimeUnrender' accept (NH.responseBody httpResponse) of
|
||||
Left s -> do
|
||||
logNST LG.LevelError "Client" (T.pack s)
|
||||
pure (Left (MimeError s httpResponse))
|
||||
Right r -> pure (Right r)
|
||||
return (MimeResult parsedResult httpResponse)
|
||||
|
||||
-- | like 'dispatchMime', but only returns the decoded http body
|
||||
dispatchMime'
|
||||
:: (Produces req accept, MimeUnrender accept res, MimeType contentType)
|
||||
=> NH.Manager -- ^ http-client Connection manager
|
||||
-> SwaggerPetstoreConfig -- ^ config
|
||||
-> SwaggerPetstoreRequest req contentType res -- ^ request
|
||||
-> accept -- ^ "accept" 'MimeType'
|
||||
-> IO (Either MimeError res) -- ^ response
|
||||
dispatchMime' manager config request accept = do
|
||||
MimeResult parsedResult _ <- dispatchMime manager config request accept
|
||||
return parsedResult
|
||||
|
||||
-- ** Unsafe
|
||||
|
||||
-- | like 'dispatchReqLbs', but does not validate the operation is a 'Producer' of the "accept" 'MimeType'. (Useful if the server's response is undocumented)
|
||||
dispatchLbsUnsafe
|
||||
:: (MimeType accept, MimeType contentType)
|
||||
=> NH.Manager -- ^ http-client Connection manager
|
||||
-> SwaggerPetstoreConfig -- ^ config
|
||||
-> SwaggerPetstoreRequest req contentType res -- ^ request
|
||||
-> accept -- ^ "accept" 'MimeType'
|
||||
-> IO (NH.Response BCL.ByteString) -- ^ response
|
||||
dispatchLbsUnsafe manager config request accept = do
|
||||
initReq <- _toInitRequest config request accept
|
||||
dispatchInitUnsafe manager config initReq
|
||||
|
||||
-- | dispatch an InitRequest
|
||||
dispatchInitUnsafe
|
||||
:: NH.Manager -- ^ http-client Connection manager
|
||||
-> SwaggerPetstoreConfig -- ^ config
|
||||
-> InitRequest req contentType res accept -- ^ init request
|
||||
-> IO (NH.Response BCL.ByteString) -- ^ response
|
||||
dispatchInitUnsafe manager config (InitRequest req) = do
|
||||
runExceptionLoggingT logSrc config $
|
||||
do logNST LG.LevelInfo logSrc requestLogMsg
|
||||
logNST LG.LevelDebug logSrc requestDbgLogMsg
|
||||
res <- P.liftIO $ NH.httpLbs req manager
|
||||
logNST LG.LevelInfo logSrc (responseLogMsg res)
|
||||
logNST LG.LevelDebug logSrc ((T.pack . show) res)
|
||||
return res
|
||||
where
|
||||
logSrc = "Client"
|
||||
endpoint =
|
||||
T.pack $
|
||||
BC.unpack $
|
||||
NH.method req <> " " <> NH.host req <> NH.path req <> NH.queryString req
|
||||
requestLogMsg = "REQ:" <> endpoint
|
||||
requestDbgLogMsg =
|
||||
"Headers=" <> (T.pack . show) (NH.requestHeaders req) <> " Body=" <>
|
||||
(case NH.requestBody req of
|
||||
NH.RequestBodyLBS xs -> T.decodeUtf8 (BL.toStrict xs)
|
||||
_ -> "<RequestBody>")
|
||||
responseStatusCode = (T.pack . show) . NH.statusCode . NH.responseStatus
|
||||
responseLogMsg res =
|
||||
"RES:statusCode=" <> responseStatusCode res <> " (" <> endpoint <> ")"
|
||||
|
||||
-- * InitRequest
|
||||
|
||||
-- | wraps an http-client 'Request' with request/response type parameters
|
||||
newtype InitRequest req contentType res accept = InitRequest
|
||||
{ unInitRequest :: NH.Request
|
||||
} deriving (Show)
|
||||
|
||||
-- | Build an http-client 'Request' record from the supplied config and request
|
||||
_toInitRequest
|
||||
:: (MimeType accept, MimeType contentType)
|
||||
=> SwaggerPetstoreConfig -- ^ config
|
||||
-> SwaggerPetstoreRequest req contentType res -- ^ request
|
||||
-> accept -- ^ "accept" 'MimeType'
|
||||
-> IO (InitRequest req contentType res accept) -- ^ initialized request
|
||||
_toInitRequest config req0 accept = do
|
||||
parsedReq <- NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (urlPath req0))
|
||||
let req1 = _setAcceptHeader req0 accept & _setContentTypeHeader
|
||||
reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders (params req1)
|
||||
reqQuery = NH.renderQuery True (paramsQuery (params req1))
|
||||
pReq = parsedReq { NH.method = (rMethod req1)
|
||||
, NH.requestHeaders = reqHeaders
|
||||
, NH.queryString = reqQuery
|
||||
}
|
||||
outReq <- case paramsBody (params req1) of
|
||||
ParamBodyNone -> pure (pReq { NH.requestBody = mempty })
|
||||
ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs })
|
||||
ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl })
|
||||
ParamBodyFormUrlEncoded form -> pure (pReq { NH.requestBody = NH.RequestBodyLBS (WH.urlEncodeForm form) })
|
||||
ParamBodyMultipartFormData parts -> NH.formDataBody parts pReq
|
||||
|
||||
pure (InitRequest outReq)
|
||||
|
||||
-- | modify the underlying Request
|
||||
modifyInitRequest :: InitRequest req contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept
|
||||
modifyInitRequest (InitRequest req) f = InitRequest (f req)
|
||||
|
||||
-- | modify the underlying Request (monadic)
|
||||
modifyInitRequestM :: Monad m => InitRequest req contentType res accept -> (NH.Request -> m NH.Request) -> m (InitRequest req contentType res accept)
|
||||
modifyInitRequestM (InitRequest req) f = fmap InitRequest (f req)
|
||||
|
||||
-- * Logging
|
||||
|
||||
-- | A block using a MonadLogger instance
|
||||
type ExecLoggingT = forall m. P.MonadIO m =>
|
||||
forall a. LG.LoggingT m a -> m a
|
||||
|
||||
-- ** Null Logger
|
||||
|
||||
-- | a logger which disables logging
|
||||
nullLogger :: LG.Loc -> LG.LogSource -> LG.LogLevel -> LG.LogStr -> IO ()
|
||||
nullLogger _ _ _ _ = return ()
|
||||
|
||||
-- | run the monad transformer that disables logging
|
||||
runNullLoggingT :: LG.LoggingT m a -> m a
|
||||
runNullLoggingT = (`LG.runLoggingT` nullLogger)
|
||||
|
||||
-- ** Logging Filters
|
||||
|
||||
-- | a log filter that uses 'LevelError' as the minimum logging level
|
||||
errorLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
|
||||
errorLevelFilter = minLevelFilter LG.LevelError
|
||||
|
||||
-- | a log filter that uses 'LevelInfo' as the minimum logging level
|
||||
infoLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
|
||||
infoLevelFilter = minLevelFilter LG.LevelInfo
|
||||
|
||||
-- | a log filter that uses 'LevelDebug' as the minimum logging level
|
||||
debugLevelFilter :: LG.LogSource -> LG.LogLevel -> Bool
|
||||
debugLevelFilter = minLevelFilter LG.LevelDebug
|
||||
|
||||
minLevelFilter :: LG.LogLevel -> LG.LogSource -> LG.LogLevel -> Bool
|
||||
minLevelFilter l _ l' = l' >= l
|
||||
|
||||
-- ** Logging
|
||||
|
||||
-- | Log a message using the current time
|
||||
logNST :: (P.MonadIO m, LG.MonadLogger m) => LG.LogLevel -> Text -> Text -> m ()
|
||||
logNST level src msg = do
|
||||
now <- P.liftIO (formatTimeLog <$> TI.getCurrentTime)
|
||||
LG.logOtherNS sourceLog level (now <> " " <> msg)
|
||||
where
|
||||
sourceLog = "SwaggerPetstore/" <> src
|
||||
formatTimeLog =
|
||||
T.pack . TI.formatTime TI.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Z"
|
||||
|
||||
-- | re-throws exceptions after logging them
|
||||
logExceptions
|
||||
:: (LG.MonadLogger m, E.MonadCatch m, P.MonadIO m)
|
||||
=> Text -> m a -> m a
|
||||
logExceptions src =
|
||||
E.handle
|
||||
(\(e :: E.SomeException) -> do
|
||||
logNST LG.LevelError src ((T.pack . show) e)
|
||||
E.throw e)
|
||||
|
||||
-- | Run a block using the configured MonadLogger instance
|
||||
runLoggingT :: SwaggerPetstoreConfig -> ExecLoggingT
|
||||
runLoggingT config =
|
||||
configExecLoggingT config . LG.filterLogger (configLoggingFilter config)
|
||||
|
||||
-- | Run a block using the configured MonadLogger instance (logs exceptions)
|
||||
runExceptionLoggingT
|
||||
:: (E.MonadCatch m, P.MonadIO m)
|
||||
=> T.Text -> SwaggerPetstoreConfig -> LG.LoggingT m a -> m a
|
||||
runExceptionLoggingT logSrc config = runLoggingT config . logExceptions logSrc
|
||||
@@ -0,0 +1,202 @@
|
||||
{-|
|
||||
Module : SwaggerPetstore.Lens
|
||||
-}
|
||||
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module SwaggerPetstore.Lens where
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Aeson (Value)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import qualified Data.Data as P (Data, Typeable)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Time as TI
|
||||
import Data.Time (UTCTime)
|
||||
|
||||
import Prelude (($), (.),(<$>),(<*>),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor)
|
||||
import qualified Prelude as P
|
||||
|
||||
import SwaggerPetstore.Model
|
||||
|
||||
-- * Type Aliases
|
||||
|
||||
type Traversal_' s a = Traversal_ s s a a
|
||||
type Traversal_ s t a b = forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
|
||||
type Lens_' s a = Lens_ s s a a
|
||||
type Lens_ s t a b = forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t
|
||||
|
||||
|
||||
-- * ApiResponse
|
||||
|
||||
-- | 'apiResponseCode' Traversal
|
||||
apiResponseCodeT :: Traversal_' ApiResponse Int
|
||||
apiResponseCodeT f s = _mtraversal apiResponseCode (\b -> s { apiResponseCode = Just b}) f s
|
||||
{-# INLINE apiResponseCodeT #-}
|
||||
|
||||
-- | 'apiResponseType' Traversal
|
||||
apiResponseTypeT :: Traversal_' ApiResponse Text
|
||||
apiResponseTypeT f s = _mtraversal apiResponseType (\b -> s { apiResponseType = Just b}) f s
|
||||
{-# INLINE apiResponseTypeT #-}
|
||||
|
||||
-- | 'apiResponseMessage' Traversal
|
||||
apiResponseMessageT :: Traversal_' ApiResponse Text
|
||||
apiResponseMessageT f s = _mtraversal apiResponseMessage (\b -> s { apiResponseMessage = Just b}) f s
|
||||
{-# INLINE apiResponseMessageT #-}
|
||||
|
||||
|
||||
|
||||
-- * Category
|
||||
|
||||
-- | 'categoryId' Traversal
|
||||
categoryIdT :: Traversal_' Category Integer
|
||||
categoryIdT f s = _mtraversal categoryId (\b -> s { categoryId = Just b}) f s
|
||||
{-# INLINE categoryIdT #-}
|
||||
|
||||
-- | 'categoryName' Traversal
|
||||
categoryNameT :: Traversal_' Category Text
|
||||
categoryNameT f s = _mtraversal categoryName (\b -> s { categoryName = Just b}) f s
|
||||
{-# INLINE categoryNameT #-}
|
||||
|
||||
|
||||
|
||||
-- * Order
|
||||
|
||||
-- | 'orderId' Traversal
|
||||
orderIdT :: Traversal_' Order Integer
|
||||
orderIdT f s = _mtraversal orderId (\b -> s { orderId = Just b}) f s
|
||||
{-# INLINE orderIdT #-}
|
||||
|
||||
-- | 'orderPetId' Traversal
|
||||
orderPetIdT :: Traversal_' Order Integer
|
||||
orderPetIdT f s = _mtraversal orderPetId (\b -> s { orderPetId = Just b}) f s
|
||||
{-# INLINE orderPetIdT #-}
|
||||
|
||||
-- | 'orderQuantity' Traversal
|
||||
orderQuantityT :: Traversal_' Order Int
|
||||
orderQuantityT f s = _mtraversal orderQuantity (\b -> s { orderQuantity = Just b}) f s
|
||||
{-# INLINE orderQuantityT #-}
|
||||
|
||||
-- | 'orderShipDate' Traversal
|
||||
orderShipDateT :: Traversal_' Order UTCTime
|
||||
orderShipDateT f s = _mtraversal orderShipDate (\b -> s { orderShipDate = Just b}) f s
|
||||
{-# INLINE orderShipDateT #-}
|
||||
|
||||
-- | 'orderStatus' Traversal
|
||||
orderStatusT :: Traversal_' Order Text
|
||||
orderStatusT f s = _mtraversal orderStatus (\b -> s { orderStatus = Just b}) f s
|
||||
{-# INLINE orderStatusT #-}
|
||||
|
||||
-- | 'orderComplete' Traversal
|
||||
orderCompleteT :: Traversal_' Order Bool
|
||||
orderCompleteT f s = _mtraversal orderComplete (\b -> s { orderComplete = Just b}) f s
|
||||
{-# INLINE orderCompleteT #-}
|
||||
|
||||
|
||||
|
||||
-- * Pet
|
||||
|
||||
-- | 'petId' Traversal
|
||||
petIdT :: Traversal_' Pet Integer
|
||||
petIdT f s = _mtraversal petId (\b -> s { petId = Just b}) f s
|
||||
{-# INLINE petIdT #-}
|
||||
|
||||
-- | 'petCategory' Traversal
|
||||
petCategoryT :: Traversal_' Pet Category
|
||||
petCategoryT f s = _mtraversal petCategory (\b -> s { petCategory = Just b}) f s
|
||||
{-# INLINE petCategoryT #-}
|
||||
|
||||
-- | 'petName' Lens
|
||||
petNameL :: Lens_' Pet Text
|
||||
petNameL f Pet{..} = (\petName -> Pet { petName, ..} ) <$> f petName
|
||||
{-# INLINE petNameL #-}
|
||||
|
||||
-- | 'petPhotoUrls' Lens
|
||||
petPhotoUrlsL :: Lens_' Pet [Text]
|
||||
petPhotoUrlsL f Pet{..} = (\petPhotoUrls -> Pet { petPhotoUrls, ..} ) <$> f petPhotoUrls
|
||||
{-# INLINE petPhotoUrlsL #-}
|
||||
|
||||
-- | 'petTags' Traversal
|
||||
petTagsT :: Traversal_' Pet [Tag]
|
||||
petTagsT f s = _mtraversal petTags (\b -> s { petTags = Just b}) f s
|
||||
{-# INLINE petTagsT #-}
|
||||
|
||||
-- | 'petStatus' Traversal
|
||||
petStatusT :: Traversal_' Pet Text
|
||||
petStatusT f s = _mtraversal petStatus (\b -> s { petStatus = Just b}) f s
|
||||
{-# INLINE petStatusT #-}
|
||||
|
||||
|
||||
|
||||
-- * Tag
|
||||
|
||||
-- | 'tagId' Traversal
|
||||
tagIdT :: Traversal_' Tag Integer
|
||||
tagIdT f s = _mtraversal tagId (\b -> s { tagId = Just b}) f s
|
||||
{-# INLINE tagIdT #-}
|
||||
|
||||
-- | 'tagName' Traversal
|
||||
tagNameT :: Traversal_' Tag Text
|
||||
tagNameT f s = _mtraversal tagName (\b -> s { tagName = Just b}) f s
|
||||
{-# INLINE tagNameT #-}
|
||||
|
||||
|
||||
|
||||
-- * User
|
||||
|
||||
-- | 'userId' Traversal
|
||||
userIdT :: Traversal_' User Integer
|
||||
userIdT f s = _mtraversal userId (\b -> s { userId = Just b}) f s
|
||||
{-# INLINE userIdT #-}
|
||||
|
||||
-- | 'userUsername' Traversal
|
||||
userUsernameT :: Traversal_' User Text
|
||||
userUsernameT f s = _mtraversal userUsername (\b -> s { userUsername = Just b}) f s
|
||||
{-# INLINE userUsernameT #-}
|
||||
|
||||
-- | 'userFirstName' Traversal
|
||||
userFirstNameT :: Traversal_' User Text
|
||||
userFirstNameT f s = _mtraversal userFirstName (\b -> s { userFirstName = Just b}) f s
|
||||
{-# INLINE userFirstNameT #-}
|
||||
|
||||
-- | 'userLastName' Traversal
|
||||
userLastNameT :: Traversal_' User Text
|
||||
userLastNameT f s = _mtraversal userLastName (\b -> s { userLastName = Just b}) f s
|
||||
{-# INLINE userLastNameT #-}
|
||||
|
||||
-- | 'userEmail' Traversal
|
||||
userEmailT :: Traversal_' User Text
|
||||
userEmailT f s = _mtraversal userEmail (\b -> s { userEmail = Just b}) f s
|
||||
{-# INLINE userEmailT #-}
|
||||
|
||||
-- | 'userPassword' Traversal
|
||||
userPasswordT :: Traversal_' User Text
|
||||
userPasswordT f s = _mtraversal userPassword (\b -> s { userPassword = Just b}) f s
|
||||
{-# INLINE userPasswordT #-}
|
||||
|
||||
-- | 'userPhone' Traversal
|
||||
userPhoneT :: Traversal_' User Text
|
||||
userPhoneT f s = _mtraversal userPhone (\b -> s { userPhone = Just b}) f s
|
||||
{-# INLINE userPhoneT #-}
|
||||
|
||||
-- | 'userUserStatus' Traversal
|
||||
userUserStatusT :: Traversal_' User Int
|
||||
userUserStatusT f s = _mtraversal userUserStatus (\b -> s { userUserStatus = Just b}) f s
|
||||
{-# INLINE userUserStatusT #-}
|
||||
|
||||
|
||||
|
||||
|
||||
-- * Helpers
|
||||
|
||||
_mtraversal :: Applicative f => (b -> Maybe t) -> (a -> b) -> (t -> f a) -> b -> f b
|
||||
_mtraversal x fsb f s = maybe (pure s) (\a -> fsb <$> f a) (x s)
|
||||
{-# INLINE _mtraversal #-}
|
||||
@@ -0,0 +1,190 @@
|
||||
|
||||
{-|
|
||||
Module : SwaggerPetstore.MimeTypes
|
||||
-}
|
||||
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module SwaggerPetstore.MimeTypes where
|
||||
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy.Char8 as BCL
|
||||
|
||||
import qualified Network.HTTP.Media as ME
|
||||
|
||||
import qualified Web.FormUrlEncoded as WH
|
||||
|
||||
import qualified Data.Data as P (Typeable)
|
||||
import qualified Data.Proxy as P (Proxy(..))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Control.Arrow as P (left)
|
||||
|
||||
import Prelude (($), (.),(<$>),(<*>),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty)
|
||||
import qualified Prelude as P
|
||||
|
||||
-- * Content Negotiation
|
||||
|
||||
-- | A type for responses without content-body.
|
||||
data NoContent = NoContent
|
||||
deriving (P.Show, P.Eq)
|
||||
|
||||
-- ** Mime Types
|
||||
|
||||
data MimeJSON = MimeJSON deriving (P.Typeable)
|
||||
data MimeXML = MimeXML deriving (P.Typeable)
|
||||
data MimePlainText = MimePlainText deriving (P.Typeable)
|
||||
data MimeFormUrlEncoded = MimeFormUrlEncoded deriving (P.Typeable)
|
||||
data MimeMultipartFormData = MimeMultipartFormData deriving (P.Typeable)
|
||||
data MimeOctetStream = MimeOctetStream deriving (P.Typeable)
|
||||
data MimeNoContent = MimeNoContent deriving (P.Typeable)
|
||||
|
||||
|
||||
-- ** MimeType Class
|
||||
|
||||
class P.Typeable mtype => MimeType mtype where
|
||||
{-# MINIMAL mimeType | mimeTypes #-}
|
||||
|
||||
mimeTypes :: P.Proxy mtype -> [ME.MediaType]
|
||||
mimeTypes p =
|
||||
case mimeType p of
|
||||
Just x -> [x]
|
||||
Nothing -> []
|
||||
|
||||
mimeType :: P.Proxy mtype -> Maybe ME.MediaType
|
||||
mimeType p =
|
||||
case mimeTypes p of
|
||||
[] -> Nothing
|
||||
(x:_) -> Just x
|
||||
|
||||
mimeType' :: mtype -> Maybe ME.MediaType
|
||||
mimeType' _ = mimeType (P.Proxy :: P.Proxy mtype)
|
||||
mimeTypes' :: mtype -> [ME.MediaType]
|
||||
mimeTypes' _ = mimeTypes (P.Proxy :: P.Proxy mtype)
|
||||
|
||||
-- ** MimeType Instances
|
||||
|
||||
-- | @application/json@
|
||||
instance MimeType MimeJSON where
|
||||
mimeTypes _ =
|
||||
[ "application" ME.// "json" ME./: ("charset", "utf-8")
|
||||
, "application" ME.// "json"
|
||||
]
|
||||
|
||||
-- | @application/xml@
|
||||
instance MimeType MimeXML where
|
||||
mimeType _ = Just $ "application" ME.// "xml"
|
||||
|
||||
-- | @application/x-www-form-urlencoded@
|
||||
instance MimeType MimeFormUrlEncoded where
|
||||
mimeType _ = Just $ "application" ME.// "x-www-form-urlencoded"
|
||||
|
||||
-- | @multipart/form-data@
|
||||
instance MimeType MimeMultipartFormData where
|
||||
mimeType _ = Just $ "multipart" ME.// "form-data"
|
||||
|
||||
-- | @text/plain;charset=utf-8@
|
||||
instance MimeType MimePlainText where
|
||||
mimeType _ = Just $ "text" ME.// "plain" ME./: ("charset", "utf-8")
|
||||
instance MimeType MimeOctetStream where
|
||||
mimeType _ = Just $ "application" ME.// "octet-stream"
|
||||
instance MimeType MimeNoContent where
|
||||
mimeType _ = Nothing
|
||||
|
||||
|
||||
-- ** MimeRender Class
|
||||
|
||||
class MimeType mtype => MimeRender mtype x where
|
||||
mimeRender :: P.Proxy mtype -> x -> BL.ByteString
|
||||
mimeRender' :: mtype -> x -> BL.ByteString
|
||||
mimeRender' _ x = mimeRender (P.Proxy :: P.Proxy mtype) x
|
||||
|
||||
|
||||
-- ** MimeRender Instances
|
||||
|
||||
-- | `A.encode`
|
||||
instance A.ToJSON a => MimeRender MimeJSON a where mimeRender _ = A.encode
|
||||
-- | @WH.urlEncodeAsForm@
|
||||
instance WH.ToForm a => MimeRender MimeFormUrlEncoded a where mimeRender _ = WH.urlEncodeAsForm
|
||||
|
||||
-- | @P.id@
|
||||
instance MimeRender MimePlainText BL.ByteString where mimeRender _ = P.id
|
||||
-- | @BL.fromStrict . T.encodeUtf8@
|
||||
instance MimeRender MimePlainText T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8
|
||||
-- | @BCL.pack@
|
||||
instance MimeRender MimePlainText String where mimeRender _ = BCL.pack
|
||||
|
||||
-- | @P.id@
|
||||
instance MimeRender MimeOctetStream BL.ByteString where mimeRender _ = P.id
|
||||
-- | @BL.fromStrict . T.encodeUtf8@
|
||||
instance MimeRender MimeOctetStream T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8
|
||||
-- | @BCL.pack@
|
||||
instance MimeRender MimeOctetStream String where mimeRender _ = BCL.pack
|
||||
|
||||
-- | @P.id@
|
||||
instance MimeRender MimeMultipartFormData BL.ByteString where mimeRender _ = P.id
|
||||
-- | @BL.fromStrict . T.encodeUtf8@
|
||||
instance MimeRender MimeMultipartFormData T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8
|
||||
-- | @BCL.pack@
|
||||
instance MimeRender MimeMultipartFormData String where mimeRender _ = BCL.pack
|
||||
|
||||
-- | @P.Right . P.const NoContent@
|
||||
instance MimeRender MimeNoContent NoContent where mimeRender _ = P.const BCL.empty
|
||||
|
||||
-- instance MimeRender MimeOctetStream Double where mimeRender _ = BB.toLazyByteString . BB.doubleDec
|
||||
-- instance MimeRender MimeOctetStream Float where mimeRender _ = BB.toLazyByteString . BB.floatDec
|
||||
-- instance MimeRender MimeOctetStream Int where mimeRender _ = BB.toLazyByteString . BB.intDec
|
||||
-- instance MimeRender MimeOctetStream Integer where mimeRender _ = BB.toLazyByteString . BB.integerDec
|
||||
|
||||
|
||||
-- ** MimeUnrender Class
|
||||
|
||||
class MimeType mtype => MimeUnrender mtype o where
|
||||
mimeUnrender :: P.Proxy mtype -> BL.ByteString -> P.Either String o
|
||||
mimeUnrender' :: mtype -> BL.ByteString -> P.Either String o
|
||||
mimeUnrender' _ x = mimeUnrender (P.Proxy :: P.Proxy mtype) x
|
||||
|
||||
-- ** MimeUnrender Instances
|
||||
|
||||
-- | @A.eitherDecode@
|
||||
instance A.FromJSON a => MimeUnrender MimeJSON a where mimeUnrender _ = A.eitherDecode
|
||||
-- | @P.left T.unpack . WH.urlDecodeAsForm@
|
||||
instance WH.FromForm a => MimeUnrender MimeFormUrlEncoded a where mimeUnrender _ = P.left T.unpack . WH.urlDecodeAsForm
|
||||
-- | @P.Right . P.id@
|
||||
|
||||
instance MimeUnrender MimePlainText BL.ByteString where mimeUnrender _ = P.Right . P.id
|
||||
-- | @P.left P.show . TL.decodeUtf8'@
|
||||
instance MimeUnrender MimePlainText T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict
|
||||
-- | @P.Right . BCL.unpack@
|
||||
instance MimeUnrender MimePlainText String where mimeUnrender _ = P.Right . BCL.unpack
|
||||
|
||||
-- | @P.Right . P.id@
|
||||
instance MimeUnrender MimeOctetStream BL.ByteString where mimeUnrender _ = P.Right . P.id
|
||||
-- | @P.left P.show . T.decodeUtf8' . BL.toStrict@
|
||||
instance MimeUnrender MimeOctetStream T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict
|
||||
-- | @P.Right . BCL.unpack@
|
||||
instance MimeUnrender MimeOctetStream String where mimeUnrender _ = P.Right . BCL.unpack
|
||||
|
||||
-- | @P.Right . P.const NoContent@
|
||||
instance MimeUnrender MimeNoContent NoContent where mimeUnrender _ = P.Right . P.const NoContent
|
||||
|
||||
|
||||
-- ** Request Consumes
|
||||
|
||||
class MimeType mtype => Consumes req mtype where
|
||||
|
||||
-- ** Request Produces
|
||||
|
||||
class MimeType mtype => Produces req mtype where
|
||||
@@ -0,0 +1,378 @@
|
||||
{-|
|
||||
Module : SwaggerPetstore.Model
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-}
|
||||
|
||||
module SwaggerPetstore.Model where
|
||||
|
||||
import Data.Aeson ((.:),(.:!),(.:?),(.=))
|
||||
import Data.Text (Text)
|
||||
|
||||
import Data.Aeson (Value)
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Data as P (Data, Typeable)
|
||||
import qualified Data.HashMap.Lazy as HM
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as P
|
||||
import qualified Data.Foldable as P
|
||||
import qualified Web.FormUrlEncoded as WH
|
||||
import qualified Web.HttpApiData as WH
|
||||
|
||||
import qualified Data.Time as TI
|
||||
import qualified Data.Time.ISO8601 as TI
|
||||
import Data.Time (UTCTime)
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative (Alternative)
|
||||
import Prelude (($), (.),(<$>),(<*>),(>>=),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor)
|
||||
import qualified Prelude as P
|
||||
|
||||
|
||||
|
||||
-- * Models
|
||||
|
||||
|
||||
-- ** ApiResponse
|
||||
-- |
|
||||
-- An uploaded response
|
||||
--
|
||||
-- Describes the result of uploading an image resource
|
||||
data ApiResponse = ApiResponse
|
||||
{ apiResponseCode :: Maybe Int -- ^ "code"
|
||||
, apiResponseType :: Maybe Text -- ^ "type"
|
||||
, apiResponseMessage :: Maybe Text -- ^ "message"
|
||||
} deriving (P.Show,P.Eq,P.Typeable)
|
||||
|
||||
instance A.FromJSON ApiResponse where
|
||||
parseJSON = A.withObject "ApiResponse" $ \o ->
|
||||
ApiResponse
|
||||
<$> (o .:? "code")
|
||||
<*> (o .:? "type")
|
||||
<*> (o .:? "message")
|
||||
|
||||
instance A.ToJSON ApiResponse where
|
||||
toJSON ApiResponse {..} =
|
||||
_omitNulls
|
||||
[ "code" .= apiResponseCode
|
||||
, "type" .= apiResponseType
|
||||
, "message" .= apiResponseMessage
|
||||
]
|
||||
|
||||
|
||||
-- | Construct a value of type 'ApiResponse' (by applying it's required fields, if any)
|
||||
mkApiResponse
|
||||
:: ApiResponse
|
||||
mkApiResponse =
|
||||
ApiResponse
|
||||
{ apiResponseCode = Nothing
|
||||
, apiResponseType = Nothing
|
||||
, apiResponseMessage = Nothing
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- ** Category
|
||||
-- |
|
||||
-- Pet catehgry
|
||||
--
|
||||
-- A category for a pet
|
||||
data Category = Category
|
||||
{ categoryId :: Maybe Integer -- ^ "id"
|
||||
, categoryName :: Maybe Text -- ^ "name"
|
||||
} deriving (P.Show,P.Eq,P.Typeable)
|
||||
|
||||
instance A.FromJSON Category where
|
||||
parseJSON = A.withObject "Category" $ \o ->
|
||||
Category
|
||||
<$> (o .:? "id")
|
||||
<*> (o .:? "name")
|
||||
|
||||
instance A.ToJSON Category where
|
||||
toJSON Category {..} =
|
||||
_omitNulls
|
||||
[ "id" .= categoryId
|
||||
, "name" .= categoryName
|
||||
]
|
||||
|
||||
|
||||
-- | Construct a value of type 'Category' (by applying it's required fields, if any)
|
||||
mkCategory
|
||||
:: Category
|
||||
mkCategory =
|
||||
Category
|
||||
{ categoryId = Nothing
|
||||
, categoryName = Nothing
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- ** Order
|
||||
-- |
|
||||
-- Pet Order
|
||||
--
|
||||
-- An order for a pets from the pet store
|
||||
data Order = Order
|
||||
{ orderId :: Maybe Integer -- ^ "id"
|
||||
, orderPetId :: Maybe Integer -- ^ "petId"
|
||||
, orderQuantity :: Maybe Int -- ^ "quantity"
|
||||
, orderShipDate :: Maybe UTCTime -- ^ "shipDate"
|
||||
, orderStatus :: Maybe Text -- ^ "status" - Order Status
|
||||
, orderComplete :: Maybe Bool -- ^ "complete"
|
||||
} deriving (P.Show,P.Eq,P.Typeable)
|
||||
|
||||
instance A.FromJSON Order where
|
||||
parseJSON = A.withObject "Order" $ \o ->
|
||||
Order
|
||||
<$> (o .:? "id")
|
||||
<*> (o .:? "petId")
|
||||
<*> (o .:? "quantity")
|
||||
<*> (o .:? "shipDate" >>= P.mapM _readDateTime)
|
||||
<*> (o .:? "status")
|
||||
<*> (o .:? "complete")
|
||||
|
||||
instance A.ToJSON Order where
|
||||
toJSON Order {..} =
|
||||
_omitNulls
|
||||
[ "id" .= orderId
|
||||
, "petId" .= orderPetId
|
||||
, "quantity" .= orderQuantity
|
||||
, "shipDate" .= P.fmap _showDateTime orderShipDate
|
||||
, "status" .= orderStatus
|
||||
, "complete" .= orderComplete
|
||||
]
|
||||
|
||||
|
||||
-- | Construct a value of type 'Order' (by applying it's required fields, if any)
|
||||
mkOrder
|
||||
:: Order
|
||||
mkOrder =
|
||||
Order
|
||||
{ orderId = Nothing
|
||||
, orderPetId = Nothing
|
||||
, orderQuantity = Nothing
|
||||
, orderShipDate = Nothing
|
||||
, orderStatus = Nothing
|
||||
, orderComplete = Nothing
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- ** Pet
|
||||
-- |
|
||||
-- a Pet
|
||||
--
|
||||
-- A pet for sale in the pet store
|
||||
data Pet = Pet
|
||||
{ petId :: Maybe Integer -- ^ "id"
|
||||
, petCategory :: Maybe Category -- ^ "category"
|
||||
, petName :: Text -- ^ /Required/ "name"
|
||||
, petPhotoUrls :: [Text] -- ^ /Required/ "photoUrls"
|
||||
, petTags :: Maybe [Tag] -- ^ "tags"
|
||||
, petStatus :: Maybe Text -- ^ "status" - pet status in the store
|
||||
} deriving (P.Show,P.Eq,P.Typeable)
|
||||
|
||||
instance A.FromJSON Pet where
|
||||
parseJSON = A.withObject "Pet" $ \o ->
|
||||
Pet
|
||||
<$> (o .:? "id")
|
||||
<*> (o .:? "category")
|
||||
<*> (o .: "name")
|
||||
<*> (o .: "photoUrls")
|
||||
<*> (o .:? "tags")
|
||||
<*> (o .:? "status")
|
||||
|
||||
instance A.ToJSON Pet where
|
||||
toJSON Pet {..} =
|
||||
_omitNulls
|
||||
[ "id" .= petId
|
||||
, "category" .= petCategory
|
||||
, "name" .= petName
|
||||
, "photoUrls" .= petPhotoUrls
|
||||
, "tags" .= petTags
|
||||
, "status" .= petStatus
|
||||
]
|
||||
|
||||
|
||||
-- | Construct a value of type 'Pet' (by applying it's required fields, if any)
|
||||
mkPet
|
||||
:: Text -- ^ 'petName'
|
||||
-> [Text] -- ^ 'petPhotoUrls'
|
||||
-> Pet
|
||||
mkPet petName petPhotoUrls =
|
||||
Pet
|
||||
{ petId = Nothing
|
||||
, petCategory = Nothing
|
||||
, petName
|
||||
, petPhotoUrls
|
||||
, petTags = Nothing
|
||||
, petStatus = Nothing
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- ** Tag
|
||||
-- |
|
||||
-- Pet Tag
|
||||
--
|
||||
-- A tag for a pet
|
||||
data Tag = Tag
|
||||
{ tagId :: Maybe Integer -- ^ "id"
|
||||
, tagName :: Maybe Text -- ^ "name"
|
||||
} deriving (P.Show,P.Eq,P.Typeable)
|
||||
|
||||
instance A.FromJSON Tag where
|
||||
parseJSON = A.withObject "Tag" $ \o ->
|
||||
Tag
|
||||
<$> (o .:? "id")
|
||||
<*> (o .:? "name")
|
||||
|
||||
instance A.ToJSON Tag where
|
||||
toJSON Tag {..} =
|
||||
_omitNulls
|
||||
[ "id" .= tagId
|
||||
, "name" .= tagName
|
||||
]
|
||||
|
||||
|
||||
-- | Construct a value of type 'Tag' (by applying it's required fields, if any)
|
||||
mkTag
|
||||
:: Tag
|
||||
mkTag =
|
||||
Tag
|
||||
{ tagId = Nothing
|
||||
, tagName = Nothing
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- ** User
|
||||
-- |
|
||||
-- a User
|
||||
--
|
||||
-- A User who is purchasing from the pet store
|
||||
data User = User
|
||||
{ userId :: Maybe Integer -- ^ "id"
|
||||
, userUsername :: Maybe Text -- ^ "username"
|
||||
, userFirstName :: Maybe Text -- ^ "firstName"
|
||||
, userLastName :: Maybe Text -- ^ "lastName"
|
||||
, userEmail :: Maybe Text -- ^ "email"
|
||||
, userPassword :: Maybe Text -- ^ "password"
|
||||
, userPhone :: Maybe Text -- ^ "phone"
|
||||
, userUserStatus :: Maybe Int -- ^ "userStatus" - User Status
|
||||
} deriving (P.Show,P.Eq,P.Typeable)
|
||||
|
||||
instance A.FromJSON User where
|
||||
parseJSON = A.withObject "User" $ \o ->
|
||||
User
|
||||
<$> (o .:? "id")
|
||||
<*> (o .:? "username")
|
||||
<*> (o .:? "firstName")
|
||||
<*> (o .:? "lastName")
|
||||
<*> (o .:? "email")
|
||||
<*> (o .:? "password")
|
||||
<*> (o .:? "phone")
|
||||
<*> (o .:? "userStatus")
|
||||
|
||||
instance A.ToJSON User where
|
||||
toJSON User {..} =
|
||||
_omitNulls
|
||||
[ "id" .= userId
|
||||
, "username" .= userUsername
|
||||
, "firstName" .= userFirstName
|
||||
, "lastName" .= userLastName
|
||||
, "email" .= userEmail
|
||||
, "password" .= userPassword
|
||||
, "phone" .= userPhone
|
||||
, "userStatus" .= userUserStatus
|
||||
]
|
||||
|
||||
|
||||
-- | Construct a value of type 'User' (by applying it's required fields, if any)
|
||||
mkUser
|
||||
:: User
|
||||
mkUser =
|
||||
User
|
||||
{ userId = Nothing
|
||||
, userUsername = Nothing
|
||||
, userFirstName = Nothing
|
||||
, userLastName = Nothing
|
||||
, userEmail = Nothing
|
||||
, userPassword = Nothing
|
||||
, userPhone = Nothing
|
||||
, userUserStatus = Nothing
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- * Utils
|
||||
|
||||
-- | Removes Null fields. (OpenAPI-Specification 2.0 does not allow Null in JSON)
|
||||
|
||||
_omitNulls :: [(Text, A.Value)] -> A.Value
|
||||
_omitNulls = A.object . P.filter notNull
|
||||
where
|
||||
notNull (_, A.Null) = False
|
||||
notNull _ = True
|
||||
|
||||
_toFormItem :: (WH.ToHttpApiData a, Functor f) => t -> f a -> f (t, [Text])
|
||||
_toFormItem name x = (name,) . (:[]) . WH.toQueryParam <$> x
|
||||
|
||||
_emptyToNothing :: Maybe String -> Maybe String
|
||||
_emptyToNothing (Just "") = Nothing
|
||||
_emptyToNothing x = x
|
||||
{-# INLINE _emptyToNothing #-}
|
||||
|
||||
_memptyToNothing :: (P.Monoid a, P.Eq a) => Maybe a -> Maybe a
|
||||
_memptyToNothing (Just x) | x P.== P.mempty = Nothing
|
||||
_memptyToNothing x = x
|
||||
{-# INLINE _memptyToNothing #-}
|
||||
|
||||
-- * DateTime Formatting
|
||||
|
||||
-- | @_parseISO8601@
|
||||
_readDateTime :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t
|
||||
_readDateTime =
|
||||
_parseISO8601
|
||||
{-# INLINE _readDateTime #-}
|
||||
|
||||
-- | @TI.formatISO8601Millis@
|
||||
_showDateTime :: (t ~ UTCTime, TI.FormatTime t) => t -> String
|
||||
_showDateTime =
|
||||
TI.formatISO8601Millis
|
||||
{-# INLINE _showDateTime #-}
|
||||
|
||||
_parseISO8601 :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t
|
||||
_parseISO8601 t =
|
||||
P.asum $
|
||||
P.flip (TI.parseTimeM True TI.defaultTimeLocale) t <$>
|
||||
["%FT%T%QZ", "%FT%T%Q%z", "%FT%T%Q%Z"]
|
||||
{-# INLINE _parseISO8601 #-}
|
||||
|
||||
-- * Date Formatting
|
||||
|
||||
-- | @TI.parseTimeM True TI.defaultTimeLocale ""@
|
||||
_readDate :: (TI.ParseTime t, Monad m) => String -> m t
|
||||
_readDate =
|
||||
TI.parseTimeM True TI.defaultTimeLocale ""
|
||||
{-# INLINE _readDate #-}
|
||||
|
||||
-- | @TI.formatTime TI.defaultTimeLocale ""@
|
||||
_showDate :: TI.FormatTime t => t -> String
|
||||
_showDate =
|
||||
TI.formatTime TI.defaultTimeLocale ""
|
||||
{-# INLINE _showDate #-}
|
||||
Reference in New Issue
Block a user