Support for MultiVerb by tchoutri · Pull Request #59 · biocad/servant-openapi3

tchoutri · 2025-05-22T11:17:59Z

This commit brings support for MultiVerb, introduced in servant-0.20.3.0.
The cabal.project file is used to depend on the pre-release.

This commit brings support for MultiVerb, introduced in servant-0.20.3.0. The cabal.project file is used to depend on the pre-release.

tchoutri · 2025-05-22T11:18:06Z

cc @maksbotan

example/src/Todo.hs

maksbotan · 2025-05-22T21:29:55Z

example/src/Todo.hs

 writeSwaggerJSON :: IO ()
 writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)
+
+type MultiResponses =


By the way, I liked UVerb better :/

We have this helper type:

newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a } deriving newtype (Functor, Applicative, Monad, MonadTrans) deriving newtype instance MonadReader r m => MonadReader r (UVerbT xs m) instance MonadError e m => MonadError e (UVerbT xs m) where throwError = lift . throwError catchError (UVerbT act) h = UVerbT $ ExceptT $ runExceptT act `catchError` (runExceptT . unUVerbT . h) runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs) runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond) throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a throwUVerb = UVerbT . ExceptT . fmap Left . respond

I can understand, but MultiVerb lifts a lot of limitations of UVerb, like haskell-servant/servant#1369. Maybe we can get further using the former.

Oh, I see.

I've never had a need for this

example/swagger.json

maksbotan · 2025-05-22T21:33:01Z

servant-openapi3.cabal

+                     , servant-server            >=0.17     && <0.21
+                     , servant-client-core       >=0.17     && <0.21


wow, can we save this package from depending on server?

Alas no, we're depending on https://github.com/haskell-servant/servant/blob/e07e92abd62641fc0f199a33e5131de273140cb0/servant-server/src/Servant/Server/Internal/ResponseRender.hs#L68

src/Servant/OpenApi/Internal.hs

maksbotan · 2025-05-22T21:45:37Z

src/Servant/OpenApi/Internal.hs

+class IsSwaggerResponse a where
+  responseSwagger :: DeclareDefinition Response
+
+simpleResponseSwagger :: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs) => DeclareDefinition Response


Is there really no existing instance or function for this?

I took this code from the Wire codebase. I'm not sure there's anything that already exist that could replace it.

Well, ok. As long as it does not break anything :)

src/Servant/OpenApi/Internal.hs

Co-authored-by: Maxim Koltsov <kolmax94@gmail.com>

maksbotan · 2025-05-22T22:08:41Z

example/src/Todo.hs

 writeSwaggerJSON :: IO ()
 writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)
+
+type MultiResponses =


Oh, I see.

I've never had a need for this

maksbotan · 2025-05-22T22:09:20Z

servant-openapi3.cabal

+                     , servant-server            >=0.17     && <0.21
+                     , servant-client-core       >=0.17     && <0.21


maksbotan · 2025-05-22T22:09:58Z

src/Servant/OpenApi/Internal.hs

+class IsSwaggerResponse a where
+  responseSwagger :: DeclareDefinition Response
+
+simpleResponseSwagger :: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs) => DeclareDefinition Response


Well, ok. As long as it does not break anything :)

maksbotan · 2025-05-22T22:10:20Z

cabal.project

    example/example.cabal
 tests: true
+
+source-repository-package


I suppose this PR should be merged after official Hackage release of Servant 0.20.3?

Yes, or at least servant-openapi3 should be released after the official Hackage release. :)

maksbotan · 2025-05-22T22:11:03Z

src/Servant/OpenApi/Internal.hs

+      (defs, resps) = runDeclare (responseListSwagger @as) mempty
+      refResps = Inline <$> resps
+
+instance


By the way, did you test with servant <0.20.3? I suppose this instances should be CPP'd?

CI is taking care of that. ;) Yes I will put them behind CPP.

Yeah, even 9.12 job is failing.

I think you should re-run haskell-ci to get new cabal.project changes

@maksbotan done! I was unfamiliar with haskell-ci's need to re-create a cabal.project file. :)

Yeah, this tool is often not obvious how to use

maksbotan · 2025-05-22T22:34:27Z

Great. Old GHCs in CI are expected to fail as servant 0.20.3 is not available for them.

I'll proceed with this once servant is released.

What is blocking that, by the way?

tchoutri · 2025-05-22T22:35:27Z

Great. Old GHCs in CI are expected to fail as servant 0.20.3 is not available for them.

I'll proceed with this once servant is released.

What is blocking that, by the way?

I wanted to make sure you were happy with my patch, and I advertised the pre-release on Discourse to give people a bit of time to try it out and report any problem. :)

Is it ok if I publish the release next Monday? Usually people are more active during the week-end.

maksbotan · 2025-05-22T22:36:39Z

I can try building our project with your candidates, if you give me some time

tchoutri · 2025-05-22T22:37:12Z

@maksbotan Your time is mine, let me know when you've finished and if the release needs tweaking. 👍

maksbotan · 2025-05-23T09:19:12Z

@tchoutri well, servant and servant-core Hackage candidates worked for me, our project compiled and tests passed.

I can't check servant-client as we don't use it :)

tchoutri · 2025-06-05T14:44:00Z

@maksbotan The 0.20.3.0 has been published, let's get this PR to the finish line. :)

tchoutri · 2025-06-09T19:31:00Z

ping @maksbotan :)

fpringle · 2025-07-11T11:58:40Z

Hi, are there any updates on this?

tchoutri · 2025-10-05T10:04:04Z

@maksbotan Hi, I have use-cases of MultiVerb that need this PR to be merged. Anything I can do to help?

LaurentRDC · 2026-01-09T14:39:15Z

@tchoutri I believe you also need to apply this patch to get validateEveryToJSON to work properly with MultiVerb:

diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs
index 41feeba..d91156e 100644
--- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs
+++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs
@@ -13,7 +13,9 @@ import           Servant.API
 #if MIN_VERSION_servant(0,19,0)
 import           Servant.API.Generic (ToServantApi)
 #endif
-
+#if MIN_VERSION_servant(0,20,3)
+import Servant.API.MultiVerb (MultiVerb, ResponseTypes)
+#endif
 -- | Build a list of endpoints from an API.
 type family EndpointsList api where
   EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b)
@@ -89,6 +91,9 @@ type family BodyTypes' c api :: [*] where
   BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[]
   BodyTypes' c (Verb verb b cs NoContent) = '[]
   BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[]
+#if MIN_VERSION_servant(0,20,3)
+  BodyTypes' c (MultiVerb verb cs as _) = AddBodyType c cs () (ResponseTypes as)
+#endif
   BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api)
   BodyTypes' c (e :> api) = BodyTypes' c api
   BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b)

Edit: confirmed that this works

LaurentRDC · 2026-03-12T14:55:14Z

One more patch we had to add to support WithHeaders in conjunction with MultiVerb. The use of ResponseTypes above isn't right:

---
 src/Servant/OpenApi/Internal/TypeLevel/API.hs | 34 +++++++++++++++++--
 1 file changed, 32 insertions(+), 2 deletions(-)

diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs
index d91156e..6b8e74f 100644
--- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs
+++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs
@@ -14,7 +14,8 @@ import           Servant.API
 import           Servant.API.Generic (ToServantApi)
 #endif
 #if MIN_VERSION_servant(0,20,3)
-import Servant.API.MultiVerb (MultiVerb, ResponseTypes)
+import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, RespondStreaming, WithHeaders, GenericAsConstructor)
+import Data.ByteString (ByteString)
 #endif
 -- | Build a list of endpoints from an API.
 type family EndpointsList api where
@@ -92,7 +93,7 @@ type family BodyTypes' c api :: [*] where
   BodyTypes' c (Verb verb b cs NoContent) = '[]
   BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[]
 #if MIN_VERSION_servant(0,20,3)
-  BodyTypes' c (MultiVerb verb cs as _) = AddBodyType c cs () (ResponseTypes as)
+  BodyTypes' c (MultiVerb verb cs as _) = AddBodyType c cs () (MultiVerbResponseBodies as)
 #endif
   BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api)
   BodyTypes' c (e :> api) = BodyTypes' c api
@@ -101,3 +102,32 @@ type family BodyTypes' c api :: [*] where
   BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api)
 #endif
   BodyTypes' c api = '[]
+
+
+#if MIN_VERSION_servant(0,20,3)
+-- | The 'ResponseTypes' class allows to extract all types
+-- involved in a response, whether or not this type is
+-- in the body of the response, or, for example, in a header.
+--
+-- This is problematic because, if the response contains a header (e.g. `Header "Set-Cookie" SetCookie`),
+-- then the header type also needs instances for `To/FromJSON` and `Arbitrary`
+-- for testing purposes, even though this isn't needed in practice.
+--
+-- We want to extract only the body, for which there is no
+-- built-in functionality at this time.
+--
+-- See Servant.API.MultiVerb.ResponseTypes for an example of how
+-- this mechanism can be implemented
+type family MultiVerbResponseBody a
+
+type instance MultiVerbResponseBody (Respond s description a) = a
+type instance MultiVerbResponseBody (RespondAs contentType s description a) = a
+type instance MultiVerbResponseBody (RespondStreaming s description framing contentType) = SourceIO ByteString
+-- The following instance is the main difference between 'MultiVerbResponseBody' and 'ResponseType'
+type instance MultiVerbResponseBody (WithHeaders headers returnType response) = MultiVerbResponseBody response
+type instance MultiVerbResponseBody (GenericAsConstructor r) = MultiVerbResponseBody r
+
+type family MultiVerbResponseBodies (as :: [*]) where
+  MultiVerbResponseBodies '[] = '[]
+  MultiVerbResponseBodies (a ': as) = MultiVerbResponseBody a ': MultiVerbResponseBodies as
+#endif

BTW, my employer maintains a fork which includes the changes from this pull request, plus the patches I'm talking about, and a few other things, here: https://github.com/bitnomial/servant-openapi3

Support for MultiVerb

0ac4728

This commit brings support for MultiVerb, introduced in servant-0.20.3.0. The cabal.project file is used to depend on the pre-release.

tchoutri mentioned this pull request May 22, 2025

Releasing Servant 0.20.3.0 haskell-servant/servant#1807

Closed

maksbotan reviewed May 22, 2025

View reviewed changes

tchoutri and others added 4 commits May 22, 2025 23:50

Update example/src/Todo.hs

c22c184

Co-authored-by: Maxim Koltsov <kolmax94@gmail.com>

Update src/Servant/OpenApi/Internal.hs

c7bc3a0

Co-authored-by: Maxim Koltsov <kolmax94@gmail.com>

use writeSwaggerJSON to update the golden test

6ad0adc

Review remarks

4005975

tchoutri requested a review from maksbotan May 22, 2025 22:09

maksbotan reviewed May 22, 2025

View reviewed changes

tchoutri added 2 commits May 23, 2025 00:15

Fence the MultiVerb support code behind CPP for servant

cc93a74

re-generate haskell-ci

9b2a862

Remove source-repository-package

6ef4632

tchoutri force-pushed the support-multiverb branch from 002443e to 6ef4632 Compare June 5, 2025 14:46

tchoutri requested a review from maksbotan July 11, 2025 13:58

Add CPP guards

f651f9b

		, servant-server >=0.17 && <0.21
		, servant-client-core >=0.17 && <0.21

Conversation

tchoutri commented May 22, 2025 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Uh oh!

tchoutri commented May 22, 2025

Uh oh!

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Uh oh!

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

maksbotan commented May 22, 2025

Uh oh!

tchoutri commented May 22, 2025 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Uh oh!

maksbotan commented May 22, 2025

Uh oh!

tchoutri commented May 22, 2025

Uh oh!

maksbotan commented May 23, 2025

Uh oh!

tchoutri commented Jun 5, 2025

Uh oh!

tchoutri commented Jun 9, 2025

Uh oh!

fpringle commented Jul 11, 2025 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Uh oh!

tchoutri commented Oct 5, 2025

Uh oh!

LaurentRDC commented Jan 9, 2026 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Uh oh!

LaurentRDC commented Mar 12, 2026 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Uh oh!

Reviewers

Assignees

Labels

Projects

Milestone

tchoutri commented May 22, 2025 •

edited

Loading

tchoutri commented May 22, 2025 •

edited

Loading

fpringle commented Jul 11, 2025 •

edited

Loading

LaurentRDC commented Jan 9, 2026 •

edited

Loading

LaurentRDC commented Mar 12, 2026 •

edited

Loading