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 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..8cef94f 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,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 @@ -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 = + '[ 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..812fb78 100644 --- a/example/swagger.json +++ b/example/swagger.json @@ -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": { @@ -39,9 +73,6 @@ } }, "responses": { - "400": { - "description": "Invalid `body`" - }, "200": { "content": { "application/json;charset=utf-8": { @@ -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": { @@ -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": { @@ -108,12 +181,6 @@ } }, "responses": { - "404": { - "description": "`id` not found" - }, - "400": { - "description": "Invalid `body`" - }, "200": { "content": { "application/json;charset=utf-8": { @@ -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" } } } -} +} \ No newline at end of file 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..9b70484 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE UndecidableInstances #-} -#endif +{-# 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 #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} 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 +38,14 @@ 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 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. -- @@ -467,3 +470,157 @@ 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 + responseSwagger :: DeclareDefinition Response + +instance + (AllToResponseHeader hs, IsSwaggerResponse r) => + IsSwaggerResponse (WithHeaders hs a r) + where + responseSwagger = + fmap + (headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs))) + (responseSwagger @r) + +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 + (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)) + +class IsSwaggerResponseList (as :: [Type]) where + responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) + +instance IsSwaggerResponseList '[] where + responseListSwagger = pure mempty + +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 +#endif