From 0ac472839602d90fb61bec7e9e32b23bc9c220b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Thu, 22 May 2025 13:17:39 +0200 Subject: [PATCH 1/8] Support for MultiVerb 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. --- cabal.project | 10 + example/example.cabal | 1 + example/src/Todo.hs | 30 ++- example/swagger.json | 333 ++++++++++++++++++-------------- servant-openapi3.cabal | 3 + src/Servant/OpenApi/Internal.hs | 191 ++++++++++++++++-- 6 files changed, 402 insertions(+), 166 deletions(-) diff --git a/cabal.project b/cabal.project index 22bec73..d8aa21f 100644 --- a/cabal.project +++ b/cabal.project @@ -2,3 +2,13 @@ packages: servant-openapi3.cabal, example/example.cabal tests: true + +source-repository-package + type: git + location: https://github.com/haskell-servant/servant + tag: servant-0.20.3.0 + subdir: + ./servant + ./servant-server + ./servant-client + ./servant-client-core diff --git a/example/example.cabal b/example/example.cabal index dca82a9..f0dedfc 100644 --- a/example/example.cabal +++ b/example/example.cabal @@ -41,6 +41,7 @@ library , openapi3 , text , time + , generics-sop default-language: Haskell2010 executable swagger-server diff --git a/example/src/Todo.hs b/example/src/Todo.hs index d5c2ace..cf22f1e 100644 --- a/example/src/Todo.hs +++ b/example/src/Todo.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DerivingVia #-} module Todo where import Control.Lens @@ -18,6 +19,8 @@ import Data.Typeable (Typeable) import GHC.Generics import Servant import Servant.OpenApi +import qualified Generics.SOP as GSOP +import Servant.API.MultiVerb todoAPI :: Proxy TodoAPI todoAPI = Proxy @@ -28,7 +31,7 @@ type TodoAPI :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId - + :<|> "todo" :> "choices" :> MultipleChoicesInt -- | API for serving @swagger.json@. type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi @@ -71,3 +74,28 @@ server = return todoSwagger :<|> error "not implemented" -- | Output generated @swagger.json@ file for the @'TodoAPI'@. writeSwaggerJSON :: IO () writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger) + +type MultiResponses = + '[ RespondEmpty 400 "Negative" + , Respond 200 "Even number" Bool + , Respond 200 "Odd number" Int + ] + +-- All possible return types +data MultiResult + = NegativeNumber + | Even Bool + | Odd Int + deriving stock (Generic) + deriving (AsUnion MultiResponses) + via GenericAsUnion MultiResponses MultiResult + +instance GSOP.Generic MultiResult + +type MultipleChoicesInt = + Capture "int" Int + :> MultiVerb + 'GET + '[JSON] + MultiResponses + MultiResult diff --git a/example/swagger.json b/example/swagger.json index e49524f..6db6d81 100644 --- a/example/swagger.json +++ b/example/swagger.json @@ -1,165 +1,204 @@ { - "openapi": "3.0.0", - "info": { - "version": "1.0", - "title": "Todo API", - "license": { - "url": "http://mit.com", - "name": "MIT" + "components": { + "schemas": { + "Todo": { + "description": "This is some real Todo right here", + "example": { + "created": "2015-12-31T00:00:00Z", + "summary": "get milk" }, - "description": "This is an API that tests swagger integration" + "properties": { + "created": { + "$ref": "#/components/schemas/UTCTime" + }, + "summary": { + "type": "string" + } + }, + "required": [ + "created", + "summary" + ], + "type": "object" + }, + "TodoId": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + }, + "UTCTime": { + "example": "2016-07-22T00:00:00Z", + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + } + }, + "info": { + "description": "This is an API that tests swagger integration", + "license": { + "name": "MIT", + "url": "http://mit.com" }, - "paths": { - "/todo": { - "get": { - "responses": { - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "items": { - "$ref": "#/components/schemas/Todo" - }, - "type": "array" - } - } - }, - "description": "" - } + "title": "Todo API", + "version": "1.0" + }, + "openapi": "3.0.0", + "paths": { + "/todo": { + "get": { + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "items": { + "$ref": "#/components/schemas/Todo" + }, + "type": "array" } + } }, - "post": { - "requestBody": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/Todo" - } - } - } - }, - "responses": { - "400": { - "description": "Invalid `body`" - }, - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/TodoId" - } - } - }, - "description": "" - } - } + "description": "" + } + } + }, + "post": { + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Todo" + } } + } }, - "/todo/{id}": { - "get": { - "parameters": [ - { - "required": true, - "schema": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" - }, - "in": "path", - "name": "id" - } - ], - "responses": { - "404": { - "description": "`id` not found" - }, - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/Todo" - } - } - }, - "description": "" - } + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/TodoId" } + } }, - "put": { - "parameters": [ - { - "required": true, - "schema": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" - }, - "in": "path", - "name": "id" - } - ], - "requestBody": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/Todo" - } - } - } - }, - "responses": { - "404": { - "description": "`id` not found" - }, - "400": { - "description": "Invalid `body`" - }, - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/TodoId" - } - } - }, - "description": "" - } - } - } + "description": "" + }, + "400": { + "description": "Invalid `body`" + } } + } }, - "components": { - "schemas": { - "Todo": { - "example": { - "summary": "get milk", - "created": "2015-12-31T00:00:00Z" - }, - "required": [ - "created", - "summary" - ], - "type": "object", - "description": "This is some real Todo right here", - "properties": { - "summary": { - "type": "string" - }, - "created": { - "$ref": "#/components/schemas/UTCTime" - } + "/todo/choices/{int}": { + "get": { + "parameters": [ + { + "in": "path", + "name": "int", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + } + ], + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "type": "boolean" } + }, + "application/json;charset=utf-8": { + "schema": { + "type": "boolean" + } + } }, - "UTCTime": { - "example": "2016-07-22T00:00:00Z", - "format": "yyyy-mm-ddThh:MM:ssZ", - "type": "string" + "description": "Even number\n\nOdd number" + }, + "400": { + "description": "Negative" + }, + "404": { + "description": "`int` not found" + } + } + } + }, + "/todo/{id}": { + "get": { + "parameters": [ + { + "in": "path", + "name": "id", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + } + ], + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Todo" + } + } }, - "TodoId": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" + "description": "" + }, + "404": { + "description": "`id` not found" + } + } + }, + "put": { + "parameters": [ + { + "in": "path", + "name": "id", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" } + } + ], + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Todo" + } + } + } + }, + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/TodoId" + } + } + }, + "description": "" + }, + "400": { + "description": "Invalid `body`" + }, + "404": { + "description": "`id` not found" + } } + } } + } } diff --git a/servant-openapi3.cabal b/servant-openapi3.cabal index a969943..4bbf286 100644 --- a/servant-openapi3.cabal +++ b/servant-openapi3.cabal @@ -88,10 +88,13 @@ library , insert-ordered-containers >=0.2.1.0 && <0.3 , lens >=4.17 && <5.4 , servant >=0.17 && <0.21 + , servant-server >=0.17 && <0.21 + , servant-client-core >=0.17 && <0.21 , singleton-bool >=0.1.4 && <0.2 , openapi3 >=3.2.3 && <3.3 , text >=1.2.3.0 && <3 , unordered-containers >=0.2.9.0 && <0.3 + , generics-sop >=0.5.1 , hspec , QuickCheck diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index 7551058..e2d8ad1 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} #endif {-# OPTIONS_GHC -Wno-orphans #-} module Servant.OpenApi.Internal where @@ -17,9 +21,7 @@ module Servant.OpenApi.Internal where import Prelude () import Prelude.Compat -#if MIN_VERSION_servant(0,18,1) -import Control.Applicative ((<|>)) -#endif +import Control.Applicative ((<|>)) import Control.Lens import Data.Aeson import Data.Foldable (toList) @@ -38,11 +40,12 @@ import Network.HTTP.Media (MediaType) import Servant.API import Servant.API.Description (FoldDescription, reflectDescription) import Servant.API.Modifiers (FoldRequired) -#if MIN_VERSION_servant(0,19,0) -import Servant.API.Generic (ToServantApi) -#endif - import Servant.OpenApi.Internal.TypeLevel.API +import Servant.API.MultiVerb +import Data.Kind (Type) +import Servant.API.ContentTypes (AllMime, allMime) +import qualified Servant.Server.Internal.ResponseRender as Server +import qualified Data.Maybe as List -- | Generate a OpenApi specification for a servant API. -- @@ -467,3 +470,155 @@ instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) + +type DeclareDefinition = Declare (Definitions Schema) + +instance + (AllToResponseHeader hs, IsSwaggerResponse r) => + IsSwaggerResponse (WithHeaders hs a r) + where + responseSwagger = + fmap + (headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs))) + (responseSwagger @r) + +class IsSwaggerResponseList as where + responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) + +class IsSwaggerResponse a where + responseSwagger :: DeclareDefinition Response + +simpleResponseSwagger :: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs) => DeclareDefinition Response +simpleResponseSwagger = do + ref <- declareSchemaRef (Proxy @a) + let resps :: InsOrdHashMap MediaType MediaTypeObject + resps = InsOrdHashMap.fromList $ (,MediaTypeObject (pure ref) Nothing mempty mempty) <$> cs + pure $ + mempty + & description .~ Text.pack (symbolVal (Proxy @desc)) + & content .~ resps + where + cs :: [MediaType] + cs = allMime $ Proxy @cs + +instance + (KnownSymbol desc, ToSchema a) => + IsSwaggerResponse (Respond s desc a) + where + -- Defaulting this to JSON, as openapi3 needs something to map a schema against. + responseSwagger = simpleResponseSwagger @a @'[JSON] @desc + +instance IsSwaggerResponseList '[] where + responseListSwagger = pure mempty + +instance + (KnownSymbol desc, ToSchema a, Accept ct) => + IsSwaggerResponse (RespondAs (ct :: Type) s desc a) + where + responseSwagger = simpleResponseSwagger @a @'[ct] @desc + +instance + (KnownSymbol desc) => + IsSwaggerResponse (RespondEmpty s desc) + where + responseSwagger = + pure $ + mempty + & description .~ Text.pack (symbolVal (Proxy @desc)) + +instance + ( IsSwaggerResponse a, + KnownNat (Server.ResponseStatus a), + IsSwaggerResponseList as + ) => + IsSwaggerResponseList (a ': as) + where + responseListSwagger = + InsOrdHashMap.insertWith + combineResponseSwagger + (fromIntegral (natVal (Proxy @(Server.ResponseStatus a)))) + <$> responseSwagger @a + <*> responseListSwagger @as + +combineResponseSwagger :: Response -> Response -> Response +combineResponseSwagger r1 r2 = + r1 + & description <>~ ("\n\n" <> r2 ^. description) + & content %~ flip (InsOrdHashMap.unionWith combineMediaTypeObject) (r2 ^. content) + +combineMediaTypeObject :: MediaTypeObject -> MediaTypeObject -> MediaTypeObject +combineMediaTypeObject m1 m2 = + m1 & schema .~ merge (m1 ^. schema) (m2 ^. schema) + where + merge Nothing a = a + merge a Nothing = a + merge (Just (Inline a)) (Just (Inline b)) = pure $ Inline $ combineSwaggerSchema a b + merge a@(Just (Ref _)) _ = a + merge _ a@(Just (Ref _)) = a + +combineSwaggerSchema :: Schema -> Schema -> Schema +combineSwaggerSchema s1 s2 + -- if they are both errors, merge label enums + | notNullOf (properties . ix "code") s1 + && notNullOf (properties . ix "code") s2 = + s1 + & properties . ix "label" . _Inline . enum_ . _Just + <>~ (s2 ^. properties . ix "label" . _Inline . enum_ . _Just) + | otherwise = s1 + +instance + (OpenApiMethod method, IsSwaggerResponseList as) => + HasOpenApi (MultiVerb method '() as r) + where + toOpenApi _ = + mempty + & components . schemas <>~ defs + & paths + . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & responses . responses .~ refResps + ) + ) + where + method = openApiMethod (Proxy @method) + (defs, resps) = runDeclare (responseListSwagger @as) mempty + refResps = Inline <$> resps + +instance + (OpenApiMethod method, IsSwaggerResponseList as, AllMime cs) => + HasOpenApi (MultiVerb method (cs :: [Type]) as r) + where + toOpenApi _ = + mempty + & components . schemas <>~ defs + & paths + . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & responses . responses .~ refResps + ) + ) + where + method = openApiMethod (Proxy @method) + -- This has our content types. + cs = allMime (Proxy @cs) + -- This has our schemas + (defs, resps) = runDeclare (responseListSwagger @as) mempty + -- We need to zip them together, and stick it all back into the contentMap + -- Since we have a single schema per type, and are only changing the content-types, + -- we should be able to pick a schema out of the resps' map, and then use it for + -- all of the values of cs + addMime :: Response -> Response + addMime resp = + resp + & content + %~ + -- pick out an element from the map, if any exist. + -- These will all have the same schemas, and we are reapplying the content types. + foldMap (\c -> InsOrdHashMap.fromList $ (,c) <$> cs) + . List.listToMaybe + . toList + refResps = Inline . addMime <$> resps From c22c1842b88cad1e34f96b15b365d8843cb098fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Thu, 22 May 2025 23:50:31 +0200 Subject: [PATCH 2/8] Update example/src/Todo.hs Co-authored-by: Maxim Koltsov --- example/src/Todo.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/example/src/Todo.hs b/example/src/Todo.hs index cf22f1e..8cef94f 100644 --- a/example/src/Todo.hs +++ b/example/src/Todo.hs @@ -32,6 +32,7 @@ type TodoAPI :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId :<|> "todo" :> "choices" :> MultipleChoicesInt + -- | API for serving @swagger.json@. type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi From c7bc3a01378e7bc7e5a6c0a1df1dceff0213d39c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Thu, 22 May 2025 23:54:10 +0200 Subject: [PATCH 3/8] Update src/Servant/OpenApi/Internal.hs Co-authored-by: Maxim Koltsov --- src/Servant/OpenApi/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index e2d8ad1..23a18c8 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -482,7 +482,7 @@ instance (headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs))) (responseSwagger @r) -class IsSwaggerResponseList as where +class IsSwaggerResponseList (as :: [Type]) where responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) class IsSwaggerResponse a where From 6ad0adcf27c2b00804c3fd875846c559d2604c48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Fri, 23 May 2025 00:03:11 +0200 Subject: [PATCH 4/8] use writeSwaggerJSON to update the golden test --- example/swagger.json | 378 +++++++++++++++++++++---------------------- 1 file changed, 189 insertions(+), 189 deletions(-) diff --git a/example/swagger.json b/example/swagger.json index 6db6d81..812fb78 100644 --- a/example/swagger.json +++ b/example/swagger.json @@ -1,204 +1,204 @@ { - "components": { - "schemas": { - "Todo": { - "description": "This is some real Todo right here", - "example": { - "created": "2015-12-31T00:00:00Z", - "summary": "get milk" - }, - "properties": { - "created": { - "$ref": "#/components/schemas/UTCTime" - }, - "summary": { - "type": "string" - } - }, - "required": [ - "created", - "summary" - ], - "type": "object" - }, - "TodoId": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" - }, - "UTCTime": { - "example": "2016-07-22T00:00:00Z", - "format": "yyyy-mm-ddThh:MM:ssZ", - "type": "string" - } - } - }, - "info": { - "description": "This is an API that tests swagger integration", - "license": { - "name": "MIT", - "url": "http://mit.com" - }, - "title": "Todo API", - "version": "1.0" - }, - "openapi": "3.0.0", - "paths": { - "/todo": { - "get": { - "responses": { - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "items": { - "$ref": "#/components/schemas/Todo" - }, - "type": "array" - } - } + "components": { + "schemas": { + "Todo": { + "description": "This is some real Todo right here", + "example": { + "created": "2015-12-31T00:00:00Z", + "summary": "get milk" + }, + "properties": { + "created": { + "$ref": "#/components/schemas/UTCTime" + }, + "summary": { + "type": "string" + } + }, + "required": [ + "created", + "summary" + ], + "type": "object" }, - "description": "" - } - } - }, - "post": { - "requestBody": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/Todo" - } - } - } - }, - "responses": { - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/TodoId" - } - } + "TodoId": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" }, - "description": "" - }, - "400": { - "description": "Invalid `body`" - } - } - } - }, - "/todo/choices/{int}": { - "get": { - "parameters": [ - { - "in": "path", - "name": "int", - "required": true, - "schema": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" + "UTCTime": { + "example": "2016-07-22T00:00:00Z", + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" } - } - ], - "responses": { - "200": { - "content": { - "application/json": { - "schema": { - "type": "boolean" - } - }, - "application/json;charset=utf-8": { - "schema": { - "type": "boolean" - } - } - }, - "description": "Even number\n\nOdd number" - }, - "400": { - "description": "Negative" - }, - "404": { - "description": "`int` not found" - } } - } }, - "/todo/{id}": { - "get": { - "parameters": [ - { - "in": "path", - "name": "id", - "required": true, - "schema": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" - } - } - ], - "responses": { - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/Todo" + "info": { + "description": "This is an API that tests swagger integration", + "license": { + "name": "MIT", + "url": "http://mit.com" + }, + "title": "Todo API", + "version": "1.0" + }, + "openapi": "3.0.0", + "paths": { + "/todo": { + "get": { + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "items": { + "$ref": "#/components/schemas/Todo" + }, + "type": "array" + } + } + }, + "description": "" + } } - } }, - "description": "" - }, - "404": { - "description": "`id` not found" - } - } - }, - "put": { - "parameters": [ - { - "in": "path", - "name": "id", - "required": true, - "schema": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" + "post": { + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Todo" + } + } + } + }, + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/TodoId" + } + } + }, + "description": "" + }, + "400": { + "description": "Invalid `body`" + } + } } - } - ], - "requestBody": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/Todo" - } + }, + "/todo/choices/{int}": { + "get": { + "parameters": [ + { + "in": "path", + "name": "int", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + } + ], + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "type": "boolean" + } + }, + "application/json;charset=utf-8": { + "schema": { + "type": "boolean" + } + } + }, + "description": "Even number\n\nOdd number" + }, + "400": { + "description": "Negative" + }, + "404": { + "description": "`int` not found" + } + } } - } }, - "responses": { - "200": { - "content": { - "application/json;charset=utf-8": { - "schema": { - "$ref": "#/components/schemas/TodoId" + "/todo/{id}": { + "get": { + "parameters": [ + { + "in": "path", + "name": "id", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + } + ], + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Todo" + } + } + }, + "description": "" + }, + "404": { + "description": "`id` not found" + } } - } }, - "description": "" - }, - "400": { - "description": "Invalid `body`" - }, - "404": { - "description": "`id` not found" - } + "put": { + "parameters": [ + { + "in": "path", + "name": "id", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + } + ], + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Todo" + } + } + } + }, + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/TodoId" + } + } + }, + "description": "" + }, + "400": { + "description": "Invalid `body`" + }, + "404": { + "description": "`id` not found" + } + } + } } - } } - } -} +} \ No newline at end of file From 4005975ed0490b2af4592e817bcf0760cd20603f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Fri, 23 May 2025 00:07:41 +0200 Subject: [PATCH 5/8] Review remarks --- src/Servant/OpenApi/Internal.hs | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index 23a18c8..eb6fb83 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -12,9 +12,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE UndecidableInstances #-} -#endif {-# OPTIONS_GHC -Wno-orphans #-} module Servant.OpenApi.Internal where @@ -473,6 +471,9 @@ instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where type DeclareDefinition = Declare (Definitions Schema) +class IsSwaggerResponse a where + responseSwagger :: DeclareDefinition Response + instance (AllToResponseHeader hs, IsSwaggerResponse r) => IsSwaggerResponse (WithHeaders hs a r) @@ -482,12 +483,6 @@ instance (headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs))) (responseSwagger @r) -class IsSwaggerResponseList (as :: [Type]) where - responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) - -class IsSwaggerResponse a where - responseSwagger :: DeclareDefinition Response - simpleResponseSwagger :: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs) => DeclareDefinition Response simpleResponseSwagger = do ref <- declareSchemaRef (Proxy @a) @@ -508,9 +503,6 @@ instance -- Defaulting this to JSON, as openapi3 needs something to map a schema against. responseSwagger = simpleResponseSwagger @a @'[JSON] @desc -instance IsSwaggerResponseList '[] where - responseListSwagger = pure mempty - instance (KnownSymbol desc, ToSchema a, Accept ct) => IsSwaggerResponse (RespondAs (ct :: Type) s desc a) @@ -526,6 +518,12 @@ instance mempty & description .~ Text.pack (symbolVal (Proxy @desc)) +class IsSwaggerResponseList (as :: [Type]) where + responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) + +instance IsSwaggerResponseList '[] where + responseListSwagger = pure mempty + instance ( IsSwaggerResponse a, KnownNat (Server.ResponseStatus a), From cc93a741c88bcd7f7280ddb0d109dfe64d7d2d2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Fri, 23 May 2025 00:15:24 +0200 Subject: [PATCH 6/8] Fence the MultiVerb support code behind CPP for servant --- src/Servant/OpenApi/Internal.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index eb6fb83..fa9afad 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -469,6 +469,7 @@ instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) +#if MIN_VERSION_servant(0,20,3) type DeclareDefinition = Declare (Definitions Schema) class IsSwaggerResponse a where @@ -620,3 +621,4 @@ instance . List.listToMaybe . toList refResps = Inline . addMime <$> resps +#endif From 9b2a8623ddcd3b8b6e349ee12df2e3027457fe5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Fri, 23 May 2025 00:23:15 +0200 Subject: [PATCH 7/8] re-generate haskell-ci --- .github/workflows/haskell-ci.yml | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index cbbac00..b4a8e09 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -205,6 +205,29 @@ jobs: echo "package example" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local cat cabal.project From 6ef46321ab9bf170ba9e7f030a0afc730e77e4cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Thu, 5 Jun 2025 16:43:09 +0200 Subject: [PATCH 8/8] Remove source-repository-package --- cabal.project | 10 ---------- src/Servant/OpenApi/Internal.hs | 4 +++- 2 files changed, 3 insertions(+), 11 deletions(-) diff --git a/cabal.project b/cabal.project index d8aa21f..22bec73 100644 --- a/cabal.project +++ b/cabal.project @@ -2,13 +2,3 @@ packages: servant-openapi3.cabal, example/example.cabal tests: true - -source-repository-package - type: git - location: https://github.com/haskell-servant/servant - tag: servant-0.20.3.0 - subdir: - ./servant - ./servant-server - ./servant-client - ./servant-client-core diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index fa9afad..9b70484 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -39,10 +39,12 @@ import Servant.API import Servant.API.Description (FoldDescription, reflectDescription) import Servant.API.Modifiers (FoldRequired) import Servant.OpenApi.Internal.TypeLevel.API -import Servant.API.MultiVerb import Data.Kind (Type) import Servant.API.ContentTypes (AllMime, allMime) +#if MIN_VERSION_servant(0,20,3) import qualified Servant.Server.Internal.ResponseRender as Server +import Servant.API.MultiVerb +#endif import qualified Data.Maybe as List -- | Generate a OpenApi specification for a servant API.