diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015 Jon Schoning + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,163 @@ +## Swagger Auto-Generated [http-client](https://www.stackage.org/lts-9.0/package/http-client-0.5.7.0) Bindings to `SwaggerPetstore` + +The library in `lib` provides auto-generated-from-Swagger [http-client](https://www.stackage.org/lts-9.0/package/http-client-0.5.7.0) bindings to the SwaggerPetstore API. + +Targeted swagger version: 2.0 + +OpenAPI-Specification: https://github.com/OAI/OpenAPI-Specification/blob/master/versions/2.0.md + +## Installation + +Installation follows the standard approach to installing Stack-based projects. + +1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). +2. To build the package, and generate the documentation (recommended): +``` +stack haddock +``` +which will generate docs for this lib in the `docs` folder. + +To generate the docs in the normal location (to enable hyperlinks to external libs), remove +``` +build: + haddock-arguments: + haddock-args: + - "--odir=./docs" +``` +from the stack.yaml file and run `stack haddock` again. + +3. To run unit tests: +``` +stack test +``` + +## Swagger-Codegen + +The code generator that produced this library, and which explains how +to obtain and use the swagger-codegen cli tool lives at + +https://github.com/swagger-api/swagger-codegen + +The _language_ argument (`--lang`) passed to the cli tool used should be + +``` +haskell-http-client +``` + +### Unsupported Swagger Features + +* Auth Methods (https://swagger.io/docs/specification/2-0/authentication/) + + - use `setHeader` to add any required headers to requests + +* Default Parameter Values + +* Enum Parameters + +This is beta software; other cases may not be supported. + +### Codegen "config option" parameters + +These options allow some customization of the code generation process. + +**haskell-http-client specific options:** + +| OPTION | DESCRIPTION | DEFAULT | ACTUAL | +| ------------------------------- | ----------------------------------------------------------------------------------------------------------------------------- | -------- | ----------------------------------- | +| allowFromJsonNulls | allow JSON Null during model decoding from JSON | true | true | +| allowToJsonNulls | allow emitting JSON Null during model encoding to JSON | false | false | +| dateFormat | format string used to parse/render a date | %Y-%m-%d | | +| dateTimeFormat | format string used to parse/render a datetime. (Defaults to [formatISO8601Millis][1] when not provided) | | | +| generateFormUrlEncodedInstances | Generate FromForm/ToForm instances for models used by x-www-form-urlencoded operations (model fields must be primitive types) | true | true | +| generateLenses | Generate Lens optics for Models | true | true | +| generateModelConstructors | Generate smart constructors (only supply required fields) for models | true | true | +| modelDeriving | Additional classes to include in the deriving() clause of Models | | | + +[1]: https://www.stackage.org/haddock/lts-9.0/iso8601-time-0.1.4/Data-Time-ISO8601.html#v:formatISO8601Millis + +View the full list of Codegen "config option" parameters with the command: + +``` +java -jar modules/swagger-codegen-cli/target/swagger-codegen-cli.jar config-help -l haskell-http-client +``` + +### Example SwaggerPetstore Haddock documentation + +An example of the generated haddock documentation targeting the server http://petstore.swagger.io/ (SwaggerPetstore) can be found [here][2] + +[2]: https://jonschoning.github.io/swaggerpetstore-haskell-http-client/ + +### Example SwaggerPetstore App + +An example application using the auto-generated haskell-http-client bindings for the server http://petstore.swagger.io/ can be found [here][3] + +[3]: https://github.com/jonschoning/swagger-codegen/tree/haskell-http-client/samples/client/petstore/haskell-http-client/example-app + +### Usage Notes + +This library is intended to be imported qualified. + +| MODULE | NOTES | +| ------------------- | --------------------------------------------------- | +| SwaggerPetstore.Client | use the "dispatch" functions to send requests | +| SwaggerPetstore.API | construct requetss | +| SwaggerPetstore.Model | describes models | +| SwaggerPetstore.MimeTypes | encoding/decoding MIME types (content-types/accept) | +| SwaggerPetstore.Lens | lenses & traversals for model fields | + +This library adds type safety around what swagger specifies as +Produces and Consumes for each Operation (e.g. the list of MIME types an +Operation can Produce (using 'accept' headers) and Consume (using 'content-type' headers). + +For example, if there is an Operation named _addFoo_, there will be a +data type generated named _AddFoo_ (note the capitalization) which +describes additional constraints and actions on the _addFoo_ +operation, which can be viewed in GHCi or via the Haddocks. + +* requried parameters are included as function arguments to _addFoo_ +* optional non-body parameters are included by using `applyOptionalParam` +* optional body parameters are set by using `setBodyParam` + +Example for pretend _addFoo_ operation: + +```haskell +data AddFoo +instance Consumes AddFoo MimeJSON +instance Produces AddFoo MimeJSON +instance Produces AddFoo MimeXML +instance HasBodyParam AddFoo FooModel +instance HasOptionalParam AddFoo FooName +instance HasOptionalParam AddFoo FooId +``` + +this would indicate that: + +* the _addFoo_ operation can consume JSON +* the _addFoo_ operation produces JSON or XML, depending on the argument passed to the dispatch function +* the _addFoo_ operation can set it's body param of _FooModel_ via `setBodyParam` +* the _addFoo_ operation can set 2 different optional parameters via `applyOptionalParam` + +putting this together: + +```haskell +let addFooRequest = addFoo MimeJSON foomodel requiredparam1 requiredparam2 + `applyOptionalParam` FooId 1 + `applyOptionalParam` FooName "name" + `setHeader` [("api_key","xxyy")] +addFooResult <- dispatchMime mgr config addFooRequest MimeXML +``` + +If the swagger spec doesn't declare it can accept or produce a certain +MIME type for a given Operation, you should either add a Produces or +Consumes instance for the desired MIME types (assuming the server +supports it), use `dispatchLbsUnsafe` or modify the swagger spec and +run the generator again. + +New MIME type instances can be added via MimeType/MimeRender/MimeUnrender + +Only JSON instances are generated by default, and in some case +x-www-form-urlencoded instances (FromFrom, ToForm) will also be +generated if the model fields are primitive types, and there are +Operations using x-www-form-urlencoded which use those models. + +See the example app and the haddocks for details. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/SwaggerPetstore.hs b/lib/SwaggerPetstore.hs new file mode 100644 --- /dev/null +++ b/lib/SwaggerPetstore.hs @@ -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 diff --git a/lib/SwaggerPetstore/API.hs b/lib/SwaggerPetstore/API.hs new file mode 100644 --- /dev/null +++ b/lib/SwaggerPetstore/API.hs @@ -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 #-} + diff --git a/lib/SwaggerPetstore/Client.hs b/lib/SwaggerPetstore/Client.hs new file mode 100644 --- /dev/null +++ b/lib/SwaggerPetstore/Client.hs @@ -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) + _ -> "") + 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 diff --git a/lib/SwaggerPetstore/Lens.hs b/lib/SwaggerPetstore/Lens.hs new file mode 100644 --- /dev/null +++ b/lib/SwaggerPetstore/Lens.hs @@ -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 #-} diff --git a/lib/SwaggerPetstore/MimeTypes.hs b/lib/SwaggerPetstore/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/lib/SwaggerPetstore/MimeTypes.hs @@ -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 diff --git a/lib/SwaggerPetstore/Model.hs b/lib/SwaggerPetstore/Model.hs new file mode 100644 --- /dev/null +++ b/lib/SwaggerPetstore/Model.hs @@ -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 #-} diff --git a/swagger-petstore.cabal b/swagger-petstore.cabal new file mode 100644 --- /dev/null +++ b/swagger-petstore.cabal @@ -0,0 +1,96 @@ +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack + +name: swagger-petstore +version: 0.0.1.0 +synopsis: Auto-generated swagger-petstore API Client +description: . + Client library for calling the swagger-petstore API based on http-client. + host: petstore.swagger.io + . + base path: http://petstore.swagger.io/v2 + . + apiVersion: 0.0.1 + . + swagger version: 2.0 + . + OpenAPI-Specification: https://github.com/OAI/OpenAPI-Specification/blob/master/versions/2.0.md +category: Web +homepage: https://github.com/swagger-api/swagger-codegen#readme +author: Jon Schoning +maintainer: jonschoning@gmail.com +copyright: Copyright (c) 2015 Jon Schoning +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + swagger.json + +library + hs-source-dirs: + lib + ghc-options: -Wall + build-depends: + base >=4.7 && <5.0 + , transformers >=0.4.0.0 + , mtl >=2.2.1 + , unordered-containers + , aeson >=1.0 && <2.0 + , bytestring >=0.10.0 && <0.11 + , containers >=0.5.0.0 && <0.6 + , http-types >=0.8 && <0.10 + , http-client >=0.5 && <0.6 + , http-client-tls + , http-api-data >= 0.3.4 && <0.4 + , http-media >= 0.4 && < 0.8 + , text >=0.11 && <1.3 + , time >=1.5 && <1.9 + , iso8601-time >=0.1.3 && <0.2.0 + , vector >=0.10.9 && <0.13 + , network >=2.6.2 && <2.7 + , random >=1.1 + , exceptions >= 0.4 + , monad-logger >=0.3 && <0.4 + , safe-exceptions <0.2 + , case-insensitive + exposed-modules: + SwaggerPetstore + SwaggerPetstore.API + SwaggerPetstore.Client + SwaggerPetstore.Model + SwaggerPetstore.MimeTypes + SwaggerPetstore.Lens + other-modules: + Paths_swagger_petstore + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: + tests + ghc-options: -fno-warn-orphans + build-depends: + base >=4.7 && <5.0 + , transformers >=0.4.0.0 + , mtl >=2.2.1 + , unordered-containers + , swagger-petstore + , bytestring >=0.10.0 && <0.11 + , containers + , hspec >=1.8 + , text + , time + , iso8601-time + , aeson + , semigroups + , QuickCheck + other-modules: + ApproxEq + Instances + PropMime + default-language: Haskell2010 diff --git a/swagger.json b/swagger.json new file mode 100644 --- /dev/null +++ b/swagger.json @@ -0,0 +1,831 @@ +{ + "swagger" : "2.0", + "info" : { + "description" : "This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.", + "version" : "1.0.0", + "title" : "Swagger Petstore", + "termsOfService" : "http://swagger.io/terms/", + "contact" : { + "email" : "apiteam@swagger.io" + }, + "license" : { + "name" : "Apache 2.0", + "url" : "http://www.apache.org/licenses/LICENSE-2.0.html" + } + }, + "host" : "petstore.swagger.io", + "basePath" : "/v2", + "tags" : [ { + "name" : "pet", + "description" : "Everything about your Pets", + "externalDocs" : { + "description" : "Find out more", + "url" : "http://swagger.io" + } + }, { + "name" : "store", + "description" : "Access to Petstore orders" + }, { + "name" : "user", + "description" : "Operations about user", + "externalDocs" : { + "description" : "Find out more about our store", + "url" : "http://swagger.io" + } + } ], + "schemes" : [ "http" ], + "paths" : { + "/pet" : { + "post" : { + "tags" : [ "pet" ], + "summary" : "Add a new pet to the store", + "description" : "", + "operationId" : "addPet", + "consumes" : [ "application/json", "application/xml" ], + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "in" : "body", + "name" : "body", + "description" : "Pet object that needs to be added to the store", + "required" : true, + "schema" : { + "$ref" : "#/definitions/Pet" + } + } ], + "responses" : { + "405" : { + "description" : "Invalid input" + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ] + }, + "put" : { + "tags" : [ "pet" ], + "summary" : "Update an existing pet", + "description" : "", + "operationId" : "updatePet", + "consumes" : [ "application/json", "application/xml" ], + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "in" : "body", + "name" : "body", + "description" : "Pet object that needs to be added to the store", + "required" : true, + "schema" : { + "$ref" : "#/definitions/Pet" + } + } ], + "responses" : { + "400" : { + "description" : "Invalid ID supplied" + }, + "404" : { + "description" : "Pet not found" + }, + "405" : { + "description" : "Validation exception" + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ] + } + }, + "/pet/findByStatus" : { + "get" : { + "tags" : [ "pet" ], + "summary" : "Finds Pets by status", + "description" : "Multiple status values can be provided with comma separated strings", + "operationId" : "findPetsByStatus", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "status", + "in" : "query", + "description" : "Status values that need to be considered for filter", + "required" : true, + "type" : "array", + "items" : { + "type" : "string", + "enum" : [ "available", "pending", "sold" ], + "default" : "available" + }, + "collectionFormat" : "csv" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "type" : "array", + "items" : { + "$ref" : "#/definitions/Pet" + } + } + }, + "400" : { + "description" : "Invalid status value" + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ] + } + }, + "/pet/findByTags" : { + "get" : { + "tags" : [ "pet" ], + "summary" : "Finds Pets by tags", + "description" : "Multiple tags can be provided with comma separated strings. Use tag1, tag2, tag3 for testing.", + "operationId" : "findPetsByTags", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "tags", + "in" : "query", + "description" : "Tags to filter by", + "required" : true, + "type" : "array", + "items" : { + "type" : "string" + }, + "collectionFormat" : "csv" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "type" : "array", + "items" : { + "$ref" : "#/definitions/Pet" + } + } + }, + "400" : { + "description" : "Invalid tag value" + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ], + "deprecated" : true + } + }, + "/pet/{petId}" : { + "get" : { + "tags" : [ "pet" ], + "summary" : "Find pet by ID", + "description" : "Returns a single pet", + "operationId" : "getPetById", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "petId", + "in" : "path", + "description" : "ID of pet to return", + "required" : true, + "type" : "integer", + "format" : "int64" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "$ref" : "#/definitions/Pet" + } + }, + "400" : { + "description" : "Invalid ID supplied" + }, + "404" : { + "description" : "Pet not found" + } + }, + "security" : [ { + "api_key" : [ ] + } ] + }, + "post" : { + "tags" : [ "pet" ], + "summary" : "Updates a pet in the store with form data", + "description" : "", + "operationId" : "updatePetWithForm", + "consumes" : [ "application/x-www-form-urlencoded" ], + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "petId", + "in" : "path", + "description" : "ID of pet that needs to be updated", + "required" : true, + "type" : "integer", + "format" : "int64" + }, { + "name" : "name", + "in" : "formData", + "description" : "Updated name of the pet", + "required" : false, + "type" : "string" + }, { + "name" : "status", + "in" : "formData", + "description" : "Updated status of the pet", + "required" : false, + "type" : "string" + } ], + "responses" : { + "405" : { + "description" : "Invalid input" + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ] + }, + "delete" : { + "tags" : [ "pet" ], + "summary" : "Deletes a pet", + "description" : "", + "operationId" : "deletePet", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "api_key", + "in" : "header", + "required" : false, + "type" : "string" + }, { + "name" : "petId", + "in" : "path", + "description" : "Pet id to delete", + "required" : true, + "type" : "integer", + "format" : "int64" + } ], + "responses" : { + "400" : { + "description" : "Invalid pet value" + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ] + } + }, + "/pet/{petId}/uploadImage" : { + "post" : { + "tags" : [ "pet" ], + "summary" : "uploads an image", + "description" : "", + "operationId" : "uploadFile", + "consumes" : [ "multipart/form-data" ], + "produces" : [ "application/json" ], + "parameters" : [ { + "name" : "petId", + "in" : "path", + "description" : "ID of pet to update", + "required" : true, + "type" : "integer", + "format" : "int64" + }, { + "name" : "additionalMetadata", + "in" : "formData", + "description" : "Additional data to pass to server", + "required" : false, + "type" : "string" + }, { + "name" : "file", + "in" : "formData", + "description" : "file to upload", + "required" : false, + "type" : "file" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "$ref" : "#/definitions/ApiResponse" + } + } + }, + "security" : [ { + "petstore_auth" : [ "write:pets", "read:pets" ] + } ] + } + }, + "/store/inventory" : { + "get" : { + "tags" : [ "store" ], + "summary" : "Returns pet inventories by status", + "description" : "Returns a map of status codes to quantities", + "operationId" : "getInventory", + "produces" : [ "application/json" ], + "parameters" : [ ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "type" : "object", + "additionalProperties" : { + "type" : "integer", + "format" : "int32" + } + } + } + }, + "security" : [ { + "api_key" : [ ] + } ] + } + }, + "/store/order" : { + "post" : { + "tags" : [ "store" ], + "summary" : "Place an order for a pet", + "description" : "", + "operationId" : "placeOrder", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "in" : "body", + "name" : "body", + "description" : "order placed for purchasing the pet", + "required" : true, + "schema" : { + "$ref" : "#/definitions/Order" + } + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "$ref" : "#/definitions/Order" + } + }, + "400" : { + "description" : "Invalid Order" + } + } + } + }, + "/store/order/{orderId}" : { + "get" : { + "tags" : [ "store" ], + "summary" : "Find purchase order by ID", + "description" : "For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions", + "operationId" : "getOrderById", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "orderId", + "in" : "path", + "description" : "ID of pet that needs to be fetched", + "required" : true, + "type" : "integer", + "maximum" : 5, + "minimum" : 1, + "format" : "int64" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "$ref" : "#/definitions/Order" + } + }, + "400" : { + "description" : "Invalid ID supplied" + }, + "404" : { + "description" : "Order not found" + } + } + }, + "delete" : { + "tags" : [ "store" ], + "summary" : "Delete purchase order by ID", + "description" : "For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors", + "operationId" : "deleteOrder", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "orderId", + "in" : "path", + "description" : "ID of the order that needs to be deleted", + "required" : true, + "type" : "string" + } ], + "responses" : { + "400" : { + "description" : "Invalid ID supplied" + }, + "404" : { + "description" : "Order not found" + } + } + } + }, + "/user" : { + "post" : { + "tags" : [ "user" ], + "summary" : "Create user", + "description" : "This can only be done by the logged in user.", + "operationId" : "createUser", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "in" : "body", + "name" : "body", + "description" : "Created user object", + "required" : true, + "schema" : { + "$ref" : "#/definitions/User" + } + } ], + "responses" : { + "default" : { + "description" : "successful operation" + } + } + } + }, + "/user/createWithArray" : { + "post" : { + "tags" : [ "user" ], + "summary" : "Creates list of users with given input array", + "description" : "", + "operationId" : "createUsersWithArrayInput", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "in" : "body", + "name" : "body", + "description" : "List of user object", + "required" : true, + "schema" : { + "type" : "array", + "items" : { + "$ref" : "#/definitions/User" + } + } + } ], + "responses" : { + "default" : { + "description" : "successful operation" + } + } + } + }, + "/user/createWithList" : { + "post" : { + "tags" : [ "user" ], + "summary" : "Creates list of users with given input array", + "description" : "", + "operationId" : "createUsersWithListInput", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "in" : "body", + "name" : "body", + "description" : "List of user object", + "required" : true, + "schema" : { + "type" : "array", + "items" : { + "$ref" : "#/definitions/User" + } + } + } ], + "responses" : { + "default" : { + "description" : "successful operation" + } + } + } + }, + "/user/login" : { + "get" : { + "tags" : [ "user" ], + "summary" : "Logs user into the system", + "description" : "", + "operationId" : "loginUser", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "username", + "in" : "query", + "description" : "The user name for login", + "required" : true, + "type" : "string" + }, { + "name" : "password", + "in" : "query", + "description" : "The password for login in clear text", + "required" : true, + "type" : "string" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "type" : "string" + }, + "headers" : { + "X-Rate-Limit" : { + "type" : "integer", + "format" : "int32", + "description" : "calls per hour allowed by the user" + }, + "X-Expires-After" : { + "type" : "string", + "format" : "date-time", + "description" : "date in UTC when toekn expires" + } + } + }, + "400" : { + "description" : "Invalid username/password supplied" + } + } + } + }, + "/user/logout" : { + "get" : { + "tags" : [ "user" ], + "summary" : "Logs out current logged in user session", + "description" : "", + "operationId" : "logoutUser", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ ], + "responses" : { + "default" : { + "description" : "successful operation" + } + } + } + }, + "/user/{username}" : { + "get" : { + "tags" : [ "user" ], + "summary" : "Get user by user name", + "description" : "", + "operationId" : "getUserByName", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "username", + "in" : "path", + "description" : "The name that needs to be fetched. Use user1 for testing. ", + "required" : true, + "type" : "string" + } ], + "responses" : { + "200" : { + "description" : "successful operation", + "schema" : { + "$ref" : "#/definitions/User" + } + }, + "400" : { + "description" : "Invalid username supplied" + }, + "404" : { + "description" : "User not found" + } + } + }, + "put" : { + "tags" : [ "user" ], + "summary" : "Updated user", + "description" : "This can only be done by the logged in user.", + "operationId" : "updateUser", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "username", + "in" : "path", + "description" : "name that need to be deleted", + "required" : true, + "type" : "string" + }, { + "in" : "body", + "name" : "body", + "description" : "Updated user object", + "required" : true, + "schema" : { + "$ref" : "#/definitions/User" + } + } ], + "responses" : { + "400" : { + "description" : "Invalid user supplied" + }, + "404" : { + "description" : "User not found" + } + } + }, + "delete" : { + "tags" : [ "user" ], + "summary" : "Delete user", + "description" : "This can only be done by the logged in user.", + "operationId" : "deleteUser", + "produces" : [ "application/xml", "application/json" ], + "parameters" : [ { + "name" : "username", + "in" : "path", + "description" : "The name that needs to be deleted", + "required" : true, + "type" : "string" + } ], + "responses" : { + "400" : { + "description" : "Invalid username supplied" + }, + "404" : { + "description" : "User not found" + } + } + } + } + }, + "securityDefinitions" : { + "petstore_auth" : { + "type" : "oauth2", + "authorizationUrl" : "http://petstore.swagger.io/api/oauth/dialog", + "flow" : "implicit", + "scopes" : { + "write:pets" : "modify pets in your account", + "read:pets" : "read your pets" + } + }, + "api_key" : { + "type" : "apiKey", + "name" : "api_key", + "in" : "header" + } + }, + "definitions" : { + "Order" : { + "type" : "object", + "properties" : { + "id" : { + "type" : "integer", + "format" : "int64" + }, + "petId" : { + "type" : "integer", + "format" : "int64" + }, + "quantity" : { + "type" : "integer", + "format" : "int32" + }, + "shipDate" : { + "type" : "string", + "format" : "date-time" + }, + "status" : { + "type" : "string", + "description" : "Order Status", + "enum" : [ "placed", "approved", "delivered" ] + }, + "complete" : { + "type" : "boolean", + "default" : false + } + }, + "title" : "Pet Order", + "description" : "An order for a pets from the pet store", + "xml" : { + "name" : "Order" + } + }, + "Category" : { + "type" : "object", + "properties" : { + "id" : { + "type" : "integer", + "format" : "int64" + }, + "name" : { + "type" : "string" + } + }, + "title" : "Pet catehgry", + "description" : "A category for a pet", + "xml" : { + "name" : "Category" + } + }, + "User" : { + "type" : "object", + "properties" : { + "id" : { + "type" : "integer", + "format" : "int64" + }, + "username" : { + "type" : "string" + }, + "firstName" : { + "type" : "string" + }, + "lastName" : { + "type" : "string" + }, + "email" : { + "type" : "string" + }, + "password" : { + "type" : "string" + }, + "phone" : { + "type" : "string" + }, + "userStatus" : { + "type" : "integer", + "format" : "int32", + "description" : "User Status" + } + }, + "title" : "a User", + "description" : "A User who is purchasing from the pet store", + "xml" : { + "name" : "User" + } + }, + "Tag" : { + "type" : "object", + "properties" : { + "id" : { + "type" : "integer", + "format" : "int64" + }, + "name" : { + "type" : "string" + } + }, + "title" : "Pet Tag", + "description" : "A tag for a pet", + "xml" : { + "name" : "Tag" + } + }, + "Pet" : { + "type" : "object", + "required" : [ "name", "photoUrls" ], + "properties" : { + "id" : { + "type" : "integer", + "format" : "int64" + }, + "category" : { + "$ref" : "#/definitions/Category" + }, + "name" : { + "type" : "string", + "example" : "doggie" + }, + "photoUrls" : { + "type" : "array", + "xml" : { + "name" : "photoUrl", + "wrapped" : true + }, + "items" : { + "type" : "string" + } + }, + "tags" : { + "type" : "array", + "xml" : { + "name" : "tag", + "wrapped" : true + }, + "items" : { + "$ref" : "#/definitions/Tag" + } + }, + "status" : { + "type" : "string", + "description" : "pet status in the store", + "enum" : [ "available", "pending", "sold" ] + } + }, + "title" : "a Pet", + "description" : "A pet for sale in the pet store", + "xml" : { + "name" : "Pet" + } + }, + "ApiResponse" : { + "type" : "object", + "properties" : { + "code" : { + "type" : "integer", + "format" : "int32" + }, + "type" : { + "type" : "string" + }, + "message" : { + "type" : "string" + } + }, + "title" : "An uploaded response", + "description" : "Describes the result of uploading an image resource" + } + }, + "externalDocs" : { + "description" : "Find out more about Swagger", + "url" : "http://swagger.io" + } +} diff --git a/tests/ApproxEq.hs b/tests/ApproxEq.hs new file mode 100644 --- /dev/null +++ b/tests/ApproxEq.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ApproxEq where + +import Data.Text (Text) +import Data.Time.Clock +import Test.QuickCheck +import GHC.Generics as G + +(==~) + :: (ApproxEq a, Show a) + => a -> a -> Property +a ==~ b = counterexample (show a ++ " !=~ " ++ show b) (a =~ b) + +class GApproxEq f where + gApproxEq :: f a -> f a -> Bool + +instance GApproxEq U1 where + gApproxEq U1 U1 = True + +instance (GApproxEq a, GApproxEq b) => + GApproxEq (a :+: b) where + gApproxEq (L1 a) (L1 b) = gApproxEq a b + gApproxEq (R1 a) (R1 b) = gApproxEq a b + gApproxEq _ _ = False + +instance (GApproxEq a, GApproxEq b) => + GApproxEq (a :*: b) where + gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2 + +instance (ApproxEq a) => + GApproxEq (K1 i a) where + gApproxEq (K1 a) (K1 b) = a =~ b + +instance (GApproxEq f) => + GApproxEq (M1 i t f) where + gApproxEq (M1 a) (M1 b) = gApproxEq a b + +class ApproxEq a where + (=~) :: a -> a -> Bool + default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool + a =~ b = gApproxEq (G.from a) (G.from b) + +instance ApproxEq Text where + (=~) = (==) + +instance ApproxEq Char where + (=~) = (==) + +instance ApproxEq Bool where + (=~) = (==) + +instance ApproxEq Int where + (=~) = (==) + +instance ApproxEq Double where + (=~) = (==) + +instance ApproxEq a => + ApproxEq (Maybe a) + +instance ApproxEq UTCTime where + (=~) = (==) + +instance ApproxEq a => + ApproxEq [a] where + as =~ bs = and (zipWith (=~) as bs) + +instance (ApproxEq l, ApproxEq r) => + ApproxEq (Either l r) where + Left a =~ Left b = a =~ b + Right a =~ Right b = a =~ b + _ =~ _ = False + +instance (ApproxEq l, ApproxEq r) => + ApproxEq (l, r) where + (=~) (l1, r1) (l2, r2) = l1 =~ l2 && r1 =~ r2 diff --git a/tests/Instances.hs b/tests/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Instances.hs @@ -0,0 +1,100 @@ +module Instances where + +import Data.Text (Text, pack) +import Data.Char (isSpace) +import Data.List (sort) +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import Test.QuickCheck +import qualified Data.HashMap.Strict as HM +import qualified Data.Set as Set + +import ApproxEq +import SwaggerPetstore.Model + +instance Arbitrary Text where + arbitrary = pack <$> arbitrary + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay . (2000 +) <$> arbitrary + shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay + +instance Arbitrary UTCTime where + arbitrary = + UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose (0, 86401)) + +-- | Checks if a given list has no duplicates in _O(n log n)_. +hasNoDups + :: (Ord a) + => [a] -> Bool +hasNoDups = go Set.empty + where + go _ [] = True + go s (x:xs) + | s' <- Set.insert x s + , Set.size s' > Set.size s = go s' xs + | otherwise = False + +instance ApproxEq Day where + (=~) = (==) + +-- * Models + +instance Arbitrary ApiResponse where + arbitrary = + ApiResponse + <$> arbitrary -- apiResponseCode :: Maybe Int + <*> arbitrary -- apiResponseType :: Maybe Text + <*> arbitrary -- apiResponseMessage :: Maybe Text + + +instance Arbitrary Category where + arbitrary = + Category + <$> arbitrary -- categoryId :: Maybe Integer + <*> arbitrary -- categoryName :: Maybe Text + + +instance Arbitrary Order where + arbitrary = + Order + <$> arbitrary -- orderId :: Maybe Integer + <*> arbitrary -- orderPetId :: Maybe Integer + <*> arbitrary -- orderQuantity :: Maybe Int + <*> arbitrary -- orderShipDate :: Maybe UTCTime + <*> arbitrary -- orderStatus :: Maybe Text + <*> arbitrary -- orderComplete :: Maybe Bool + + +instance Arbitrary Pet where + arbitrary = + Pet + <$> arbitrary -- petId :: Maybe Integer + <*> arbitrary -- petCategory :: Maybe Category + <*> arbitrary -- petName :: Text + <*> arbitrary -- petPhotoUrls :: [Text] + <*> arbitrary -- petTags :: Maybe [Tag] + <*> arbitrary -- petStatus :: Maybe Text + + +instance Arbitrary Tag where + arbitrary = + Tag + <$> arbitrary -- tagId :: Maybe Integer + <*> arbitrary -- tagName :: Maybe Text + + +instance Arbitrary User where + arbitrary = + User + <$> arbitrary -- userId :: Maybe Integer + <*> arbitrary -- userUsername :: Maybe Text + <*> arbitrary -- userFirstName :: Maybe Text + <*> arbitrary -- userLastName :: Maybe Text + <*> arbitrary -- userEmail :: Maybe Text + <*> arbitrary -- userPassword :: Maybe Text + <*> arbitrary -- userPhone :: Maybe Text + <*> arbitrary -- userUserStatus :: Maybe Int + + + diff --git a/tests/PropMime.hs b/tests/PropMime.hs new file mode 100644 --- /dev/null +++ b/tests/PropMime.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} + +module PropMime where + +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.Monoid ((<>)) +import Data.Typeable (Proxy(..), typeOf, Typeable) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Property +import Test.Hspec.QuickCheck (prop) + +import SwaggerPetstore.MimeTypes + +import ApproxEq + +-- * Type Aliases + +type ArbitraryMime mime a = ArbitraryRoundtrip (MimeUnrender mime) (MimeRender mime) a + +type ArbitraryRoundtrip from to a = (from a, to a, Arbitrary' a) + +type Arbitrary' a = (Arbitrary a, Show a, Typeable a) + +-- * Mime + +propMime + :: forall a b mime. + (ArbitraryMime mime a, Testable b) + => String -> (a -> a -> b) -> mime -> Proxy a -> Spec +propMime eqDescr eq m _ = + prop + (show (typeOf (undefined :: a)) <> " " <> show (typeOf (undefined :: mime)) <> " roundtrip " <> eqDescr) $ + \(x :: a) -> + let rendered = mimeRender' m x + actual = mimeUnrender' m rendered + expected = Right x + failMsg = + "ACTUAL: " <> show actual <> "\nRENDERED: " <> BL8.unpack rendered + in counterexample failMsg $ + either reject property (eq <$> actual <*> expected) + where + reject = property . const rejected + +propMimeEq :: (ArbitraryMime mime a, Eq a) => mime -> Proxy a -> Spec +propMimeEq = propMime "(EQ)" (==) diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module Main where + +import Data.Typeable (Proxy(..)) +import Test.Hspec +import Test.Hspec.QuickCheck + +import PropMime +import Instances () + +import SwaggerPetstore.Model +import SwaggerPetstore.MimeTypes + +main :: IO () +main = + hspec $ modifyMaxSize (const 10) $ + do describe "JSON instances" $ + do propMimeEq MimeJSON (Proxy :: Proxy ApiResponse) + propMimeEq MimeJSON (Proxy :: Proxy Category) + propMimeEq MimeJSON (Proxy :: Proxy Order) + propMimeEq MimeJSON (Proxy :: Proxy Pet) + propMimeEq MimeJSON (Proxy :: Proxy Tag) + propMimeEq MimeJSON (Proxy :: Proxy User) +