Skip to content

Support for MultiVerb #59

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 8 commits into
base: master
Choose a base branch
from
Open

Support for MultiVerb #59

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
0ac4728
Support for MultiVerb
tchoutri May 22, 2025
c22c184
Update example/src/Todo.hs
tchoutri May 22, 2025
c7bc3a0
Update src/Servant/OpenApi/Internal.hs
tchoutri May 22, 2025
6ad0adc
use writeSwaggerJSON to update the golden test
tchoutri May 22, 2025
4005975
Review remarks
tchoutri May 22, 2025
cc93a74
Fence the MultiVerb support code behind CPP for servant
tchoutri May 22, 2025
9b2a862
re-generate haskell-ci
tchoutri May 22, 2025
6ef4632
Remove source-repository-package
tchoutri Jun 5, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
23 changes: 23 additions & 0 deletions .github/workflows/haskell-ci.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -205,6 +205,29 @@ jobs:
echo "package example" >> cabal.project
echo " ghc-options: -Werror=missing-methods" >> cabal.project
cat >> cabal.project <<EOF
source-repository-package
type: git
location: https://github.com/haskell-servant/servant
tag: servant-0.20.3.0
subdir: ./servant

source-repository-package
type: git
location: https://github.com/haskell-servant/servant
tag: servant-0.20.3.0
subdir: ./servant-server

source-repository-package
type: git
location: https://github.com/haskell-servant/servant
tag: servant-0.20.3.0
subdir: ./servant-client

source-repository-package
type: git
location: https://github.com/haskell-servant/servant
tag: servant-0.20.3.0
subdir: ./servant-client-core
EOF
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(example|servant-openapi3)$/; }' >> cabal.project.local
cat cabal.project
Expand Down
1 change: 1 addition & 0 deletions example/example.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -41,6 +41,7 @@ library
, openapi3
, text
, time
, generics-sop
default-language: Haskell2010

executable swagger-server
Expand Down
31 changes: 30 additions & 1 deletion example/src/Todo.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DerivingVia #-}
module Todo where

import Control.Lens
Expand All @@ -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
Expand All @@ -28,7 +31,8 @@ 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

Expand Down Expand Up @@ -71,3 +75,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 =
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

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

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

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.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Oh, I see.

I've never had a need for this

'[ 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
153 changes: 96 additions & 57 deletions example/swagger.json
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,14 +1,48 @@
{
"openapi": "3.0.0",
"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": {
"version": "1.0",
"title": "Todo API",
"description": "This is an API that tests swagger integration",
"license": {
"url": "http://mit.com",
"name": "MIT"
"name": "MIT",
"url": "http://mit.com"
},
"description": "This is an API that tests swagger integration"
"title": "Todo API",
"version": "1.0"
},
"openapi": "3.0.0",
"paths": {
"/todo": {
"get": {
Expand Down Expand Up @@ -39,9 +73,6 @@
}
},
"responses": {
"400": {
"description": "Invalid `body`"
},
"200": {
"content": {
"application/json;charset=utf-8": {
Expand All @@ -51,28 +82,67 @@
}
},
"description": ""
},
"400": {
"description": "Invalid `body`"
}
}
}
},
"/todo/{id}": {
"/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"
}
}
}
},
"/todo/{id}": {
"get": {
"parameters": [
{
"in": "path",
"name": "id"
"name": "id",
"required": true,
"schema": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "integer"
}
}
],
"responses": {
"404": {
"description": "`id` not found"
},
"200": {
"content": {
"application/json;charset=utf-8": {
Expand All @@ -82,20 +152,23 @@
}
},
"description": ""
},
"404": {
"description": "`id` not found"
}
}
},
"put": {
"parameters": [
{
"in": "path",
"name": "id",
"required": true,
"schema": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "integer"
},
"in": "path",
"name": "id"
}
}
],
"requestBody": {
Expand All @@ -108,12 +181,6 @@
}
},
"responses": {
"404": {
"description": "`id` not found"
},
"400": {
"description": "Invalid `body`"
},
"200": {
"content": {
"application/json;charset=utf-8": {
Expand All @@ -123,43 +190,15 @@
}
},
"description": ""
}
}
}
}
},
"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"
"400": {
"description": "Invalid `body`"
},
"404": {
"description": "`id` not found"
}
}
},
"UTCTime": {
"example": "2016-07-22T00:00:00Z",
"format": "yyyy-mm-ddThh:MM:ssZ",
"type": "string"
},
"TodoId": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "integer"
}
}
}
}
}
3 changes: 3 additions & 0 deletions servant-openapi3.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Comment on lines +91 to +92
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

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

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

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

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Shame...

, 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
Expand Down
Loading