From c6822eba77648f02a9efd908af1e2aad5a34fea1 Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Thu, 14 Nov 2024 17:00:59 +1000 Subject: [PATCH 1/6] Whitespace lint --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2499585..da4af3b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,7 +14,7 @@ * Support servant-0.15 - support for 'Stream' and 'StreamBody' combinators - orphan 'ToSchema (SourceT m a)' instance -* Fix BodyTypes to work with generalized ReqBody' +* Fix BodyTypes to work with generalized ReqBody' [#88](https://github.com/haskell-servant/servant-swagger/pull/88) 1.1.6 From 146d84b9248f4ee04ef2a512de957187a5fbba91 Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Thu, 14 Nov 2024 17:01:08 +1000 Subject: [PATCH 2/6] Stop NoContent appearing in BodyTypes if it appears inside Headers Recurse through `Headers hdrs` just like any other decorator that should be ignored. --- CHANGELOG.md | 6 ++++++ src/Servant/OpenApi/Internal/TypeLevel/API.hs | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index da4af3b..243d686 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +Unreleased +---------- + +* Do not count `NoContent` as a body type if it appears in `Headers + hdrs NoContent`. + 1.1.8 ------- diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs index 41feeba..5f10cf5 100644 --- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs @@ -86,7 +86,7 @@ type AddBodyType c cs a as = If (Elem c cs) (a ': as) as -- completely empty on responses to requests that only accept 'application/json', while -- setting the content-type in the response accordingly.) 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 (Headers hdrs a)) = BodyTypes' c (Verb verb b cs a) BodyTypes' c (Verb verb b cs NoContent) = '[] BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[] BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api) From 200873374aa9b9ccf7ec6817f8f8cac5b068ef22 Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Fri, 15 Nov 2024 11:35:12 +1000 Subject: [PATCH 3/6] Fix superclass conditions on HasOpenApi (UVerb method cs (a ': as)) Unconditionally requesting `ToSchema a` etc means that we erroneously demand `ToSchema NoContent`. Instead delegate to the `HasOpenApi` instance for the related `Verb`, allowing the overlapping instances for `NoContent` to be selected. --- CHANGELOG.md | 2 ++ src/Servant/OpenApi/Internal.hs | 5 +---- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 243d686..212f352 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,8 @@ Unreleased ---------- +* The `HasOpenApi` instance that recurses through `UVerb` responses no + longer demands `ToSchema NoContent`. * Do not count `NoContent` as a body type if it appears in `Headers hdrs NoContent`. diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index 7551058..ce21e8a 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -198,10 +198,7 @@ instance HasOpenApi (UVerb method cs '[]) where -- | @since <2.0.1.0> instance {-# OVERLAPPABLE #-} - ( ToSchema a, - HasStatus a, - AllAccept cs, - OpenApiMethod method, + ( HasOpenApi (Verb method (StatusOf a) cs a), HasOpenApi (UVerb method cs as) ) => HasOpenApi (UVerb method cs (a ': as)) From 97b2fd08e8ade50d9ec40812dc2c2c9ab996f57c Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Fri, 17 Jan 2025 11:38:05 +1000 Subject: [PATCH 4/6] Teach BodyTypes' to recurse through UVerb endpoints --- src/Servant/OpenApi/Internal/TypeLevel/API.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs index 5f10cf5..07c5ff7 100644 --- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs @@ -95,4 +95,17 @@ type family BodyTypes' c api :: [*] where #if MIN_VERSION_servant(0,19,0) BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api) #endif + -- Handle UVerb by recursively expanding it to BodyTypes' c (Verb ...) + -- Unwrap WithStatus explicitly to avoid trying to expand + -- `Verb .. (WithStatus n a)` later on. + BodyTypes' c (UVerb verb cs ((WithStatus n a) ': as)) = + AppendList (BodyTypes' c (Verb verb (StatusOf a) cs a)) (BodyTypes' c (UVerb verb cs as)) + -- If we don't have a WithStatus wrapper, it might be 'NoContent' or + -- some other type with a `HasStatus` instance. The catch-all will + -- expand it to '[] if we can't extract a useful body type from it, + -- so that's fine. + BodyTypes' c (UVerb verb cs (a ': as)) = + AppendList (BodyTypes' c (Verb verb (StatusOf a) cs a)) (BodyTypes' c (UVerb verb cs as)) + BodyTypes' c (UVerb verb cs '[]) = '[] + BodyTypes' c api = '[] From f8095f6bf3ae9ae194fac5b3c51cb0f738c65eb1 Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Wed, 26 Mar 2025 10:02:01 +1000 Subject: [PATCH 5/6] Avoid `WithStatus` when recursing into `Verb`s --- CHANGELOG.md | 2 + src/Servant/OpenApi/Internal.hs | 79 ++++++++++++++++++++------------- 2 files changed, 49 insertions(+), 32 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 212f352..11c6ade 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,8 @@ Unreleased * The `HasOpenApi` instance that recurses through `UVerb` responses no longer demands `ToSchema NoContent`. + - `instance ToSchema (WithStatus s a)` has been removed, as the + `WithStatus` is now unwrapped when recursing into a `Verb`. * Do not count `NoContent` as a body type if it appears in `Headers hdrs NoContent`. diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index ce21e8a..c33cb15 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -206,38 +206,53 @@ instance toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method (StatusOf a) cs a)) `combineSwagger` toOpenApi (Proxy :: Proxy (UVerb method cs as)) - where - -- workaround for https://github.com/GetShopTV/swagger2/issues/218 - combinePathItem :: PathItem -> PathItem -> PathItem - combinePathItem s t = PathItem - { _pathItemGet = _pathItemGet s <> _pathItemGet t - , _pathItemPut = _pathItemPut s <> _pathItemPut t - , _pathItemPost = _pathItemPost s <> _pathItemPost t - , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t - , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t - , _pathItemHead = _pathItemHead s <> _pathItemHead t - , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t - , _pathItemTrace = _pathItemTrace s <> _pathItemTrace t - , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t - , _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t - , _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t - , _pathItemServers = _pathItemServers s <> _pathItemServers t - } - - combineSwagger :: OpenApi -> OpenApi -> OpenApi - combineSwagger s t = OpenApi - { _openApiOpenapi = _openApiOpenapi s <> _openApiOpenapi t - , _openApiInfo = _openApiInfo s <> _openApiInfo t - , _openApiServers = _openApiServers s <> _openApiServers t - , _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t) - , _openApiComponents = _openApiComponents s <> _openApiComponents t - , _openApiSecurity = _openApiSecurity s <> _openApiSecurity t - , _openApiTags = _openApiTags s <> _openApiTags t - , _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t - } - -instance (Typeable (WithStatus s a), ToSchema a) => ToSchema (WithStatus s a) where - declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) + +-- | Although the instance this overlaps correctly sets the status code +-- for a @WithStatus n a@ entry, it also cause GHC to try and solve +-- @'HasOpenApi' (Verb method (StatusOf (WithStatus n a)) cs (WithStatus n a))@. +-- In most cases, this works fine, but it breaks down if @a ~ NoContent@ by +-- trying to satisfy @ToSchema NoContent@. +-- +-- Because 'WithStatus' inside a 'Verb' is nonsensical, we handle it +-- explicitly before recursing into the @HasOpenApi (Verb method n cs a)@ +-- instance. +instance + ( HasOpenApi (Verb method n cs a), + HasOpenApi (UVerb method cs as) + ) => HasOpenApi (UVerb method cs (WithStatus n a ': as)) + where + toOpenApi _ = + toOpenApi (Proxy :: Proxy (Verb method n cs a)) + `combineSwagger` toOpenApi (Proxy :: Proxy (UVerb method cs as)) + +-- Workaround for https://github.com/GetShopTV/swagger2/issues/218 +combineSwagger :: OpenApi -> OpenApi -> OpenApi +combineSwagger s1 s2 = OpenApi + { _openApiOpenapi = _openApiOpenapi s1 <> _openApiOpenapi s2 + , _openApiInfo = _openApiInfo s1 <> _openApiInfo s2 + , _openApiServers = _openApiServers s1 <> _openApiServers s2 + , _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s1) (_openApiPaths s2) + , _openApiComponents = _openApiComponents s1 <> _openApiComponents s2 + , _openApiSecurity = _openApiSecurity s1 <> _openApiSecurity s2 + , _openApiTags = _openApiTags s1 <> _openApiTags s2 + , _openApiExternalDocs = _openApiExternalDocs s1 <|> _openApiExternalDocs s2 + } + where + combinePathItem :: PathItem -> PathItem -> PathItem + combinePathItem p1 p2 = PathItem + { _pathItemGet = _pathItemGet p1 <> _pathItemGet p2 + , _pathItemPut = _pathItemPut p1 <> _pathItemPut p2 + , _pathItemPost = _pathItemPost p1 <> _pathItemPost p2 + , _pathItemDelete = _pathItemDelete p1 <> _pathItemDelete p2 + , _pathItemOptions = _pathItemOptions p1 <> _pathItemOptions p2 + , _pathItemHead = _pathItemHead p1 <> _pathItemHead p2 + , _pathItemPatch = _pathItemPatch p1 <> _pathItemPatch p2 + , _pathItemTrace = _pathItemTrace p1 <> _pathItemTrace p2 + , _pathItemParameters = _pathItemParameters p1 <> _pathItemParameters p2 + , _pathItemSummary = _pathItemSummary p1 <|> _pathItemSummary p2 + , _pathItemDescription = _pathItemDescription p1 <|> _pathItemDescription p2 + , _pathItemServers = _pathItemServers p1 <> _pathItemServers p2 + } #endif instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs a) where From ae62532b59590cd4952bbb16c9173da8184a6f3c Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Thu, 3 Jul 2025 15:22:17 +1000 Subject: [PATCH 6/6] Fix CPP for servant <=0.18 --- src/Servant/OpenApi/Internal/TypeLevel/API.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs index 07c5ff7..3c691ce 100644 --- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs @@ -94,7 +94,6 @@ type family BodyTypes' c api :: [*] where BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b) #if MIN_VERSION_servant(0,19,0) BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api) -#endif -- Handle UVerb by recursively expanding it to BodyTypes' c (Verb ...) -- Unwrap WithStatus explicitly to avoid trying to expand -- `Verb .. (WithStatus n a)` later on. @@ -107,5 +106,5 @@ type family BodyTypes' c api :: [*] where BodyTypes' c (UVerb verb cs (a ': as)) = AppendList (BodyTypes' c (Verb verb (StatusOf a) cs a)) (BodyTypes' c (UVerb verb cs as)) BodyTypes' c (UVerb verb cs '[]) = '[] - +#endif BodyTypes' c api = '[]