diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -62,11 +62,11 @@ | allowToJsonNulls | allow emitting JSON Null during model encoding to JSON | false | false | | dateFormat | format string used to parse/render a date | %Y-%m-%d | %Y-%m-%d | | dateTimeFormat | format string used to parse/render a datetime. (Defaults to [formatISO8601Millis][1] when not provided) | | | -| generateEnums | Generate specific datatypes for swagger enums | true | true | +| generateEnums | Generate specific datatypes for swagger enums | true | true | | 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 | -| inlineConsumesContentTypes | Inline (hardcode) the content-type on operations that do not have multiple content-types (Consumes) | false | false | +| inlineMimeTypes | Inline (hardcode) the content-type and accept parameters on operations, when there is only 1 option | false | false | | modelDeriving | Additional classes to include in the deriving() clause of Models | | | | strictFields | Add strictness annotations to all model fields | true | true | | useMonadLogger | Use the monad-logger package to provide logging (if instead false, use the katip logging package) | false | false | @@ -180,11 +180,17 @@ let config = config0 `addAuthMethod` AuthOAuthFoo "secret-key" -let addFooRequest = addFoo MimeJSON foomodel requiredparam1 requiredparam2 +let addFooRequest = + addFoo + (ContentType MimeJSON) + (Accept MimeXML) + (ParamBar paramBar) + (ParamQux paramQux) + modelBaz `applyOptionalParam` FooId 1 `applyOptionalParam` FooName "name" `setHeader` [("qux_header","xxyy")] -addFooResult <- dispatchMime mgr config addFooRequest MimeXML +addFooResult <- dispatchMime mgr config addFooRequest ``` See the example app and the haddocks for details. diff --git a/lib/SwaggerPetstore/API.hs b/lib/SwaggerPetstore/API.hs --- a/lib/SwaggerPetstore/API.hs +++ b/lib/SwaggerPetstore/API.hs @@ -80,10 +80,11 @@ -- testSpecialTags :: (Consumes TestSpecialTags contentType, MimeRender contentType Client) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Client -- ^ "body" - client model - -> SwaggerPetstoreRequest TestSpecialTags contentType Client -testSpecialTags _ body = + -> SwaggerPetstoreRequest TestSpecialTags contentType Client accept +testSpecialTags _ _ body = _mkRequest "PATCH" ["/another-fake/dummy"] `setBodyParam` body @@ -109,9 +110,10 @@ -- fakeOuterBooleanSerialize :: (Consumes FakeOuterBooleanSerialize contentType) - => contentType -- ^ request content-type ('MimeType') - -> SwaggerPetstoreRequest FakeOuterBooleanSerialize contentType OuterBoolean -fakeOuterBooleanSerialize _ = + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest FakeOuterBooleanSerialize contentType OuterBoolean accept +fakeOuterBooleanSerialize _ _ = _mkRequest "POST" ["/fake/outer/boolean"] data FakeOuterBooleanSerialize @@ -127,9 +129,10 @@ -- fakeOuterCompositeSerialize :: (Consumes FakeOuterCompositeSerialize contentType) - => contentType -- ^ request content-type ('MimeType') - -> SwaggerPetstoreRequest FakeOuterCompositeSerialize contentType OuterComposite -fakeOuterCompositeSerialize _ = + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest FakeOuterCompositeSerialize contentType OuterComposite accept +fakeOuterCompositeSerialize _ _ = _mkRequest "POST" ["/fake/outer/composite"] data FakeOuterCompositeSerialize @@ -145,9 +148,10 @@ -- fakeOuterNumberSerialize :: (Consumes FakeOuterNumberSerialize contentType) - => contentType -- ^ request content-type ('MimeType') - -> SwaggerPetstoreRequest FakeOuterNumberSerialize contentType OuterNumber -fakeOuterNumberSerialize _ = + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest FakeOuterNumberSerialize contentType OuterNumber accept +fakeOuterNumberSerialize _ _ = _mkRequest "POST" ["/fake/outer/number"] data FakeOuterNumberSerialize @@ -163,9 +167,10 @@ -- fakeOuterStringSerialize :: (Consumes FakeOuterStringSerialize contentType) - => contentType -- ^ request content-type ('MimeType') - -> SwaggerPetstoreRequest FakeOuterStringSerialize contentType OuterString -fakeOuterStringSerialize _ = + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest FakeOuterStringSerialize contentType OuterString accept +fakeOuterStringSerialize _ _ = _mkRequest "POST" ["/fake/outer/string"] data FakeOuterStringSerialize @@ -183,10 +188,11 @@ -- testClientModel :: (Consumes TestClientModel contentType, MimeRender contentType Client) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Client -- ^ "body" - client model - -> SwaggerPetstoreRequest TestClientModel contentType Client -testClientModel _ body = + -> SwaggerPetstoreRequest TestClientModel contentType Client accept +testClientModel _ _ body = _mkRequest "PATCH" ["/fake"] `setBodyParam` body @@ -216,13 +222,14 @@ -- testEndpointParameters :: (Consumes TestEndpointParameters contentType) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Number -- ^ "number" - None -> ParamDouble -- ^ "double" - None -> PatternWithoutDelimiter -- ^ "patternWithoutDelimiter" - None -> Byte -- ^ "byte" - None - -> SwaggerPetstoreRequest TestEndpointParameters contentType res -testEndpointParameters _ (Number number) (ParamDouble double) (PatternWithoutDelimiter patternWithoutDelimiter) (Byte byte) = + -> SwaggerPetstoreRequest TestEndpointParameters contentType res accept +testEndpointParameters _ _ (Number number) (ParamDouble double) (PatternWithoutDelimiter patternWithoutDelimiter) (Byte byte) = _mkRequest "POST" ["/fake"] `_hasAuthType` (P.Proxy :: P.Proxy AuthBasicHttpBasicTest) `addForm` toForm ("number", number) @@ -305,9 +312,10 @@ -- testEnumParameters :: (Consumes TestEnumParameters contentType) - => contentType -- ^ request content-type ('MimeType') - -> SwaggerPetstoreRequest TestEnumParameters contentType res -testEnumParameters _ = + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest TestEnumParameters contentType res accept +testEnumParameters _ _ = _mkRequest "GET" ["/fake"] data TestEnumParameters @@ -369,9 +377,9 @@ -- testInlineAdditionalProperties :: (Consumes TestInlineAdditionalProperties contentType, MimeRender contentType A.Value) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') -> A.Value -- ^ "param" - request body - -> SwaggerPetstoreRequest TestInlineAdditionalProperties contentType NoContent + -> SwaggerPetstoreRequest TestInlineAdditionalProperties contentType NoContent MimeNoContent testInlineAdditionalProperties _ param = _mkRequest "POST" ["/fake/inline-additionalProperties"] `setBodyParam` param @@ -395,10 +403,10 @@ -- testJsonFormData :: (Consumes TestJsonFormData contentType) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') -> Param -- ^ "param" - field1 -> Param2 -- ^ "param2" - field2 - -> SwaggerPetstoreRequest TestJsonFormData contentType NoContent + -> SwaggerPetstoreRequest TestJsonFormData contentType NoContent MimeNoContent testJsonFormData _ (Param param) (Param2 param2) = _mkRequest "GET" ["/fake/jsonFormData"] `addForm` toForm ("param", param) @@ -422,10 +430,11 @@ -- testClassname :: (Consumes TestClassname contentType, MimeRender contentType Client) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Client -- ^ "body" - client model - -> SwaggerPetstoreRequest TestClassname contentType Client -testClassname _ body = + -> SwaggerPetstoreRequest TestClassname contentType Client accept +testClassname _ _ body = _mkRequest "PATCH" ["/fake_classname_test"] `_hasAuthType` (P.Proxy :: P.Proxy AuthApiKeyApiKeyQuery) `setBodyParam` body @@ -458,10 +467,11 @@ -- addPet :: (Consumes AddPet contentType, MimeRender contentType Pet) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Pet -- ^ "body" - Pet object that needs to be added to the store - -> SwaggerPetstoreRequest AddPet contentType res -addPet _ body = + -> SwaggerPetstoreRequest AddPet contentType res accept +addPet _ _ body = _mkRequest "POST" ["/pet"] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) `setBodyParam` body @@ -495,9 +505,10 @@ -- Note: Has 'Produces' instances, but no response schema -- deletePet - :: PetId -- ^ "petId" - Pet id to delete - -> SwaggerPetstoreRequest DeletePet MimeNoContent res -deletePet (PetId petId) = + :: Accept accept -- ^ request accept ('MimeType') + -> PetId -- ^ "petId" - Pet id to delete + -> SwaggerPetstoreRequest DeletePet MimeNoContent res accept +deletePet _ (PetId petId) = _mkRequest "DELETE" ["/pet/",toPath petId] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) @@ -522,9 +533,10 @@ -- AuthMethod: 'AuthOAuthPetstoreAuth' -- findPetsByStatus - :: Status -- ^ "status" - Status values that need to be considered for filter - -> SwaggerPetstoreRequest FindPetsByStatus MimeNoContent [Pet] -findPetsByStatus (Status status) = + :: Accept accept -- ^ request accept ('MimeType') + -> Status -- ^ "status" - Status values that need to be considered for filter + -> SwaggerPetstoreRequest FindPetsByStatus MimeNoContent [Pet] accept +findPetsByStatus _ (Status status) = _mkRequest "GET" ["/pet/findByStatus"] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) `setQuery` toQueryColl CommaSeparated ("status", Just status) @@ -547,9 +559,10 @@ -- AuthMethod: 'AuthOAuthPetstoreAuth' -- findPetsByTags - :: Tags -- ^ "tags" - Tags to filter by - -> SwaggerPetstoreRequest FindPetsByTags MimeNoContent [Pet] -findPetsByTags (Tags tags) = + :: Accept accept -- ^ request accept ('MimeType') + -> Tags -- ^ "tags" - Tags to filter by + -> SwaggerPetstoreRequest FindPetsByTags MimeNoContent [Pet] accept +findPetsByTags _ (Tags tags) = _mkRequest "GET" ["/pet/findByTags"] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) `setQuery` toQueryColl CommaSeparated ("tags", Just tags) @@ -574,9 +587,10 @@ -- AuthMethod: 'AuthApiKeyApiKey' -- getPetById - :: PetId -- ^ "petId" - ID of pet to return - -> SwaggerPetstoreRequest GetPetById MimeNoContent Pet -getPetById (PetId petId) = + :: Accept accept -- ^ request accept ('MimeType') + -> PetId -- ^ "petId" - ID of pet to return + -> SwaggerPetstoreRequest GetPetById MimeNoContent Pet accept +getPetById _ (PetId petId) = _mkRequest "GET" ["/pet/",toPath petId] `_hasAuthType` (P.Proxy :: P.Proxy AuthApiKeyApiKey) @@ -601,10 +615,11 @@ -- updatePet :: (Consumes UpdatePet contentType, MimeRender contentType Pet) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Pet -- ^ "body" - Pet object that needs to be added to the store - -> SwaggerPetstoreRequest UpdatePet contentType res -updatePet _ body = + -> SwaggerPetstoreRequest UpdatePet contentType res accept +updatePet _ _ body = _mkRequest "PUT" ["/pet"] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) `setBodyParam` body @@ -639,10 +654,11 @@ -- updatePetWithForm :: (Consumes UpdatePetWithForm contentType) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> PetId -- ^ "petId" - ID of pet that needs to be updated - -> SwaggerPetstoreRequest UpdatePetWithForm contentType res -updatePetWithForm _ (PetId petId) = + -> SwaggerPetstoreRequest UpdatePetWithForm contentType res accept +updatePetWithForm _ _ (PetId petId) = _mkRequest "POST" ["/pet/",toPath petId] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) @@ -679,10 +695,11 @@ -- uploadFile :: (Consumes UploadFile contentType) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> PetId -- ^ "petId" - ID of pet to update - -> SwaggerPetstoreRequest UploadFile contentType ApiResponse -uploadFile _ (PetId petId) = + -> SwaggerPetstoreRequest UploadFile contentType ApiResponse accept +uploadFile _ _ (PetId petId) = _mkRequest "POST" ["/pet/",toPath petId,"/uploadImage"] `_hasAuthType` (P.Proxy :: P.Proxy AuthOAuthPetstoreAuth) @@ -718,9 +735,10 @@ -- Note: Has 'Produces' instances, but no response schema -- deleteOrder - :: OrderIdText -- ^ "orderId" - ID of the order that needs to be deleted - -> SwaggerPetstoreRequest DeleteOrder MimeNoContent res -deleteOrder (OrderIdText orderId) = + :: Accept accept -- ^ request accept ('MimeType') + -> OrderIdText -- ^ "orderId" - ID of the order that needs to be deleted + -> SwaggerPetstoreRequest DeleteOrder MimeNoContent res accept +deleteOrder _ (OrderIdText orderId) = _mkRequest "DELETE" ["/store/order/",toPath orderId] data DeleteOrder @@ -741,8 +759,9 @@ -- AuthMethod: 'AuthApiKeyApiKey' -- getInventory - :: SwaggerPetstoreRequest GetInventory MimeNoContent ((Map.Map String Int)) -getInventory = + :: Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest GetInventory MimeNoContent ((Map.Map String Int)) accept +getInventory _ = _mkRequest "GET" ["/store/inventory"] `_hasAuthType` (P.Proxy :: P.Proxy AuthApiKeyApiKey) @@ -760,9 +779,10 @@ -- For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions -- getOrderById - :: OrderId -- ^ "orderId" - ID of pet that needs to be fetched - -> SwaggerPetstoreRequest GetOrderById MimeNoContent Order -getOrderById (OrderId orderId) = + :: Accept accept -- ^ request accept ('MimeType') + -> OrderId -- ^ "orderId" - ID of pet that needs to be fetched + -> SwaggerPetstoreRequest GetOrderById MimeNoContent Order accept +getOrderById _ (OrderId orderId) = _mkRequest "GET" ["/store/order/",toPath orderId] data GetOrderById @@ -782,10 +802,11 @@ -- placeOrder :: (Consumes PlaceOrder contentType, MimeRender contentType Order) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Order -- ^ "body" - order placed for purchasing the pet - -> SwaggerPetstoreRequest PlaceOrder contentType Order -placeOrder _ body = + -> SwaggerPetstoreRequest PlaceOrder contentType Order accept +placeOrder _ _ body = _mkRequest "POST" ["/store/order"] `setBodyParam` body @@ -813,10 +834,11 @@ -- createUser :: (Consumes CreateUser contentType, MimeRender contentType User) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> User -- ^ "body" - Created user object - -> SwaggerPetstoreRequest CreateUser contentType res -createUser _ body = + -> SwaggerPetstoreRequest CreateUser contentType res accept +createUser _ _ body = _mkRequest "POST" ["/user"] `setBodyParam` body @@ -842,10 +864,11 @@ -- createUsersWithArrayInput :: (Consumes CreateUsersWithArrayInput contentType, MimeRender contentType Body) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Body -- ^ "body" - List of user object - -> SwaggerPetstoreRequest CreateUsersWithArrayInput contentType res -createUsersWithArrayInput _ body = + -> SwaggerPetstoreRequest CreateUsersWithArrayInput contentType res accept +createUsersWithArrayInput _ _ body = _mkRequest "POST" ["/user/createWithArray"] `setBodyParam` body @@ -871,10 +894,11 @@ -- createUsersWithListInput :: (Consumes CreateUsersWithListInput contentType, MimeRender contentType Body) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Body -- ^ "body" - List of user object - -> SwaggerPetstoreRequest CreateUsersWithListInput contentType res -createUsersWithListInput _ body = + -> SwaggerPetstoreRequest CreateUsersWithListInput contentType res accept +createUsersWithListInput _ _ body = _mkRequest "POST" ["/user/createWithList"] `setBodyParam` body @@ -899,9 +923,10 @@ -- Note: Has 'Produces' instances, but no response schema -- deleteUser - :: Username -- ^ "username" - The name that needs to be deleted - -> SwaggerPetstoreRequest DeleteUser MimeNoContent res -deleteUser (Username username) = + :: Accept accept -- ^ request accept ('MimeType') + -> Username -- ^ "username" - The name that needs to be deleted + -> SwaggerPetstoreRequest DeleteUser MimeNoContent res accept +deleteUser _ (Username username) = _mkRequest "DELETE" ["/user/",toPath username] data DeleteUser @@ -920,9 +945,10 @@ -- -- getUserByName - :: Username -- ^ "username" - The name that needs to be fetched. Use user1 for testing. - -> SwaggerPetstoreRequest GetUserByName MimeNoContent User -getUserByName (Username username) = + :: Accept accept -- ^ request accept ('MimeType') + -> Username -- ^ "username" - The name that needs to be fetched. Use user1 for testing. + -> SwaggerPetstoreRequest GetUserByName MimeNoContent User accept +getUserByName _ (Username username) = _mkRequest "GET" ["/user/",toPath username] data GetUserByName @@ -941,10 +967,11 @@ -- -- loginUser - :: Username -- ^ "username" - The user name for login + :: Accept accept -- ^ request accept ('MimeType') + -> Username -- ^ "username" - The user name for login -> Password -- ^ "password" - The password for login in clear text - -> SwaggerPetstoreRequest LoginUser MimeNoContent Text -loginUser (Username username) (Password password) = + -> SwaggerPetstoreRequest LoginUser MimeNoContent Text accept +loginUser _ (Username username) (Password password) = _mkRequest "GET" ["/user/login"] `setQuery` toQuery ("username", Just username) `setQuery` toQuery ("password", Just password) @@ -967,8 +994,9 @@ -- Note: Has 'Produces' instances, but no response schema -- logoutUser - :: SwaggerPetstoreRequest LogoutUser MimeNoContent res -logoutUser = + :: Accept accept -- ^ request accept ('MimeType') + -> SwaggerPetstoreRequest LogoutUser MimeNoContent res accept +logoutUser _ = _mkRequest "GET" ["/user/logout"] data LogoutUser @@ -990,11 +1018,12 @@ -- updateUser :: (Consumes UpdateUser contentType, MimeRender contentType User) - => contentType -- ^ request content-type ('MimeType') + => ContentType contentType -- ^ request content-type ('MimeType') + -> Accept accept -- ^ request accept ('MimeType') -> Username -- ^ "username" - name that need to be deleted -> User -- ^ "body" - Updated user object - -> SwaggerPetstoreRequest UpdateUser contentType res -updateUser _ (Username username) body = + -> SwaggerPetstoreRequest UpdateUser contentType res accept +updateUser _ _ (Username username) body = _mkRequest "PUT" ["/user/",toPath username] `setBodyParam` body diff --git a/lib/SwaggerPetstore/Client.hs b/lib/SwaggerPetstore/Client.hs --- a/lib/SwaggerPetstore/Client.hs +++ b/lib/SwaggerPetstore/Client.hs @@ -59,11 +59,10 @@ :: (Produces req accept, MimeType contentType) => NH.Manager -- ^ http-client Connection manager -> SwaggerPetstoreConfig -- ^ config - -> SwaggerPetstoreRequest req contentType res -- ^ request - -> accept -- ^ "accept" 'MimeType' + -> SwaggerPetstoreRequest req contentType res accept -- ^ request -> IO (NH.Response BCL.ByteString) -- ^ response -dispatchLbs manager config request accept = do - initReq <- _toInitRequest config request accept +dispatchLbs manager config request = do + initReq <- _toInitRequest config request dispatchInitUnsafe manager config initReq -- ** Mime @@ -84,21 +83,26 @@ -- | send a request returning the 'MimeResult' dispatchMime - :: (Produces req accept, MimeUnrender accept res, MimeType contentType) + :: forall req contentType res accept. (Produces req accept, MimeUnrender accept res, MimeType contentType) => NH.Manager -- ^ http-client Connection manager -> SwaggerPetstoreConfig -- ^ config - -> SwaggerPetstoreRequest req contentType res -- ^ request - -> accept -- ^ "accept" 'MimeType' + -> SwaggerPetstoreRequest req contentType res accept -- ^ request -> IO (MimeResult res) -- ^ response -dispatchMime manager config request accept = do - httpResponse <- dispatchLbs manager config request accept +dispatchMime manager config request = do + httpResponse <- dispatchLbs manager config request + let statusCode = NH.statusCode . NH.responseStatus $ httpResponse parsedResult <- runConfigLogWithExceptions "Client" config $ - do case mimeUnrender' accept (NH.responseBody httpResponse) of - Left s -> do + do if (statusCode >= 400 && statusCode < 600) + then do + let s = "error statusCode: " ++ show statusCode _log "Client" levelError (T.pack s) pure (Left (MimeError s httpResponse)) - Right r -> pure (Right r) + else case mimeUnrender (P.Proxy :: P.Proxy accept) (NH.responseBody httpResponse) of + Left s -> do + _log "Client" levelError (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 @@ -106,11 +110,10 @@ :: (Produces req accept, MimeUnrender accept res, MimeType contentType) => NH.Manager -- ^ http-client Connection manager -> SwaggerPetstoreConfig -- ^ config - -> SwaggerPetstoreRequest req contentType res -- ^ request - -> accept -- ^ "accept" 'MimeType' + -> SwaggerPetstoreRequest req contentType res accept -- ^ request -> IO (Either MimeError res) -- ^ response -dispatchMime' manager config request accept = do - MimeResult parsedResult _ <- dispatchMime manager config request accept +dispatchMime' manager config request = do + MimeResult parsedResult _ <- dispatchMime manager config request return parsedResult -- ** Unsafe @@ -120,11 +123,10 @@ :: (MimeType accept, MimeType contentType) => NH.Manager -- ^ http-client Connection manager -> SwaggerPetstoreConfig -- ^ config - -> SwaggerPetstoreRequest req contentType res -- ^ request - -> accept -- ^ "accept" 'MimeType' + -> SwaggerPetstoreRequest req contentType res accept -- ^ request -> IO (NH.Response BCL.ByteString) -- ^ response -dispatchLbsUnsafe manager config request accept = do - initReq <- _toInitRequest config request accept +dispatchLbsUnsafe manager config request = do + initReq <- _toInitRequest config request dispatchInitUnsafe manager config initReq -- | dispatch an InitRequest @@ -168,17 +170,16 @@ _toInitRequest :: (MimeType accept, MimeType contentType) => SwaggerPetstoreConfig -- ^ config - -> SwaggerPetstoreRequest req contentType res -- ^ request - -> accept -- ^ "accept" 'MimeType' + -> SwaggerPetstoreRequest req contentType res accept -- ^ request -> IO (InitRequest req contentType res accept) -- ^ initialized request -_toInitRequest config req0 accept = +_toInitRequest config req0 = runConfigLogWithExceptions "Client" config $ do parsedReq <- P.liftIO $ NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (rUrlPath req0)) req1 <- P.liftIO $ _applyAuthMethods req0 config P.when (configValidateAuthMethods config && (not . null . rAuthTypes) req1) - (E.throwString $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1) - let req2 = req1 & _setContentTypeHeader & flip _setAcceptHeader accept + (E.throw $ AuthMethodException $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1) + let req2 = req1 & _setContentTypeHeader & _setAcceptHeader reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders (rParams req2) reqQuery = NH.renderQuery True (paramsQuery (rParams req2)) pReq = parsedReq { NH.method = (rMethod req2) @@ -195,7 +196,7 @@ 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 contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept modifyInitRequest (InitRequest req) f = InitRequest (f req) -- | modify the underlying Request (monadic) diff --git a/lib/SwaggerPetstore/Core.hs b/lib/SwaggerPetstore/Core.hs --- a/lib/SwaggerPetstore/Core.hs +++ b/lib/SwaggerPetstore/Core.hs @@ -33,6 +33,7 @@ import qualified Control.Arrow as P (left) import qualified Control.DeepSeq as NF +import qualified Control.Exception.Safe as E import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Base64.Lazy as BL64 @@ -132,8 +133,15 @@ -- * 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 +-- | Represents a request. +-- +-- Type Variables: +-- +-- * req - request operation +-- * contentType - 'MimeType' associated with request body +-- * res - response model +-- * accept - 'MimeType' associated with response body +data SwaggerPetstoreRequest req contentType res accept = SwaggerPetstoreRequest { rMethod :: NH.Method -- ^ Method of SwaggerPetstoreRequest , rUrlPath :: [BCL.ByteString] -- ^ Endpoint of SwaggerPetstoreRequest , rParams :: Params -- ^ params of SwaggerPetstoreRequest @@ -142,22 +150,22 @@ deriving (P.Show) -- | 'rMethod' Lens -rMethodL :: Lens_' (SwaggerPetstoreRequest req contentType res) NH.Method +rMethodL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) NH.Method rMethodL f SwaggerPetstoreRequest{..} = (\rMethod -> SwaggerPetstoreRequest { rMethod, ..} ) <$> f rMethod {-# INLINE rMethodL #-} -- | 'rUrlPath' Lens -rUrlPathL :: Lens_' (SwaggerPetstoreRequest req contentType res) [BCL.ByteString] +rUrlPathL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) [BCL.ByteString] rUrlPathL f SwaggerPetstoreRequest{..} = (\rUrlPath -> SwaggerPetstoreRequest { rUrlPath, ..} ) <$> f rUrlPath {-# INLINE rUrlPathL #-} -- | 'rParams' Lens -rParamsL :: Lens_' (SwaggerPetstoreRequest req contentType res) Params +rParamsL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) Params rParamsL f SwaggerPetstoreRequest{..} = (\rParams -> SwaggerPetstoreRequest { rParams, ..} ) <$> f rParams {-# INLINE rParamsL #-} -- | 'rParams' Lens -rAuthTypesL :: Lens_' (SwaggerPetstoreRequest req contentType res) [P.TypeRep] +rAuthTypesL :: Lens_' (SwaggerPetstoreRequest req contentType res accept) [P.TypeRep] rAuthTypesL f SwaggerPetstoreRequest{..} = (\rAuthTypes -> SwaggerPetstoreRequest { rAuthTypes, ..} ) <$> f rAuthTypes {-# INLINE rAuthTypesL #-} @@ -165,7 +173,7 @@ -- | 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 :: forall contentType res accept. (Consumes req contentType, MimeRender contentType param) => SwaggerPetstoreRequest req contentType res accept -> param -> SwaggerPetstoreRequest req contentType res accept setBodyParam req xs = req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader @@ -176,12 +184,12 @@ {-# MINIMAL applyOptionalParam | (-&-) #-} -- | Apply an optional parameter to a request - applyOptionalParam :: SwaggerPetstoreRequest req contentType res -> param -> SwaggerPetstoreRequest req contentType res + applyOptionalParam :: SwaggerPetstoreRequest req contentType res accept -> param -> SwaggerPetstoreRequest req contentType res accept applyOptionalParam = (-&-) {-# INLINE applyOptionalParam #-} -- | infix operator \/ alias for 'addOptionalParam' - (-&-) :: SwaggerPetstoreRequest req contentType res -> param -> SwaggerPetstoreRequest req contentType res + (-&-) :: SwaggerPetstoreRequest req contentType res accept -> param -> SwaggerPetstoreRequest req contentType res accept (-&-) = applyOptionalParam {-# INLINE (-&-) #-} @@ -223,18 +231,18 @@ _mkRequest :: NH.Method -- ^ Method -> [BCL.ByteString] -- ^ Endpoint - -> SwaggerPetstoreRequest req contentType res -- ^ req: Request Type, res: Response Type + -> SwaggerPetstoreRequest req contentType res accept -- ^ 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 :: SwaggerPetstoreRequest req contentType res accept -> [NH.Header] -> SwaggerPetstoreRequest req contentType res accept setHeader req header = req `removeHeader` P.fmap P.fst header & L.over (rParamsL . paramsHeadersL) (header P.++) -removeHeader :: SwaggerPetstoreRequest req contentType res -> [NH.HeaderName] -> SwaggerPetstoreRequest req contentType res +removeHeader :: SwaggerPetstoreRequest req contentType res accept -> [NH.HeaderName] -> SwaggerPetstoreRequest req contentType res accept removeHeader req header = req & L.over @@ -244,19 +252,19 @@ cifst = CI.mk . P.fst -_setContentTypeHeader :: forall req contentType res. MimeType contentType => SwaggerPetstoreRequest req contentType res -> SwaggerPetstoreRequest req contentType res +_setContentTypeHeader :: forall req contentType res accept. MimeType contentType => SwaggerPetstoreRequest req contentType res accept -> SwaggerPetstoreRequest req contentType res accept _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 +_setAcceptHeader :: forall req contentType res accept. MimeType accept => SwaggerPetstoreRequest req contentType res accept -> SwaggerPetstoreRequest req contentType res accept +_setAcceptHeader req = + case mimeType (P.Proxy :: P.Proxy 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 :: SwaggerPetstoreRequest req contentType res accept -> [NH.QueryItem] -> SwaggerPetstoreRequest req contentType res accept setQuery req query = req & L.over @@ -265,29 +273,29 @@ where cifst = CI.mk . P.fst -addForm :: SwaggerPetstoreRequest req contentType res -> WH.Form -> SwaggerPetstoreRequest req contentType res +addForm :: SwaggerPetstoreRequest req contentType res accept -> WH.Form -> SwaggerPetstoreRequest req contentType res accept addForm req newform = let form = case paramsBody (rParams req) of ParamBodyFormUrlEncoded _form -> _form _ -> mempty in req & L.set (rParamsL . paramsBodyL) (ParamBodyFormUrlEncoded (newform <> form)) -_addMultiFormPart :: SwaggerPetstoreRequest req contentType res -> NH.Part -> SwaggerPetstoreRequest req contentType res +_addMultiFormPart :: SwaggerPetstoreRequest req contentType res accept -> NH.Part -> SwaggerPetstoreRequest req contentType res accept _addMultiFormPart req newpart = let parts = case paramsBody (rParams req) of ParamBodyMultipartFormData _parts -> _parts _ -> [] in req & L.set (rParamsL . paramsBodyL) (ParamBodyMultipartFormData (newpart : parts)) -_setBodyBS :: SwaggerPetstoreRequest req contentType res -> B.ByteString -> SwaggerPetstoreRequest req contentType res +_setBodyBS :: SwaggerPetstoreRequest req contentType res accept -> B.ByteString -> SwaggerPetstoreRequest req contentType res accept _setBodyBS req body = req & L.set (rParamsL . paramsBodyL) (ParamBodyB body) -_setBodyLBS :: SwaggerPetstoreRequest req contentType res -> BL.ByteString -> SwaggerPetstoreRequest req contentType res +_setBodyLBS :: SwaggerPetstoreRequest req contentType res accept -> BL.ByteString -> SwaggerPetstoreRequest req contentType res accept _setBodyLBS req body = req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body) -_hasAuthType :: AuthMethod authMethod => SwaggerPetstoreRequest req contentType res -> P.Proxy authMethod -> SwaggerPetstoreRequest req contentType res +_hasAuthType :: AuthMethod authMethod => SwaggerPetstoreRequest req contentType res accept -> P.Proxy authMethod -> SwaggerPetstoreRequest req contentType res accept _hasAuthType req proxy = req & L.over rAuthTypesL (P.typeRep proxy :) @@ -362,19 +370,24 @@ applyAuthMethod :: SwaggerPetstoreConfig -> a - -> SwaggerPetstoreRequest req contentType res - -> IO (SwaggerPetstoreRequest req contentType res) + -> SwaggerPetstoreRequest req contentType res accept + -> IO (SwaggerPetstoreRequest req contentType res accept) -- | An existential wrapper for any AuthMethod data AnyAuthMethod = forall a. AuthMethod a => AnyAuthMethod a deriving (P.Typeable) instance AuthMethod AnyAuthMethod where applyAuthMethod config (AnyAuthMethod a) req = applyAuthMethod config a req +-- | indicates exceptions related to AuthMethods +data AuthMethodException = AuthMethodException String deriving (P.Show, P.Typeable) + +instance E.Exception AuthMethodException + -- | apply all matching AuthMethods in config to request _applyAuthMethods - :: SwaggerPetstoreRequest req contentType res + :: SwaggerPetstoreRequest req contentType res accept -> SwaggerPetstoreConfig - -> IO (SwaggerPetstoreRequest req contentType res) + -> IO (SwaggerPetstoreRequest req contentType res accept) _applyAuthMethods req config@(SwaggerPetstoreConfig {configAuthMethods = as}) = foldlM go req as where diff --git a/lib/SwaggerPetstore/MimeTypes.hs b/lib/SwaggerPetstore/MimeTypes.hs --- a/lib/SwaggerPetstore/MimeTypes.hs +++ b/lib/SwaggerPetstore/MimeTypes.hs @@ -14,6 +14,7 @@ -} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -42,6 +43,13 @@ import Prelude (($), (.),(<$>),(<*>),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty) import qualified Prelude as P +-- * ContentType MimeType + +data ContentType a = MimeType a => ContentType { unContentType :: a } + +-- * Accept MimeType + +data Accept a = MimeType a => Accept { unAccept :: a } -- * Consumes Class diff --git a/swagger-petstore.cabal b/swagger-petstore.cabal --- a/swagger-petstore.cabal +++ b/swagger-petstore.cabal @@ -1,5 +1,5 @@ name: swagger-petstore -version: 0.0.1.5 +version: 0.0.1.6 synopsis: Auto-generated swagger-petstore API Client description: . Client library for calling the swagger-petstore API based on http-client.