diff --git a/.travis.yml b/.travis.yml index e45f72b72..ce5e36159 100644 --- a/.travis.yml +++ b/.travis.yml @@ -149,8 +149,8 @@ script: - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='swagger2 ==2.4.*' all # Constraint set swagger2-2.5 - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='swagger2 ==2.5.*' all - # Constraint set servant-0.17 - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant == 0.17.*' all + # Constraint set servant-0.18.1 + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant == 0.18.1' all # REGENDATA ("0.9.20200121",["--config=cabal.haskell-ci","cabal.project"]) # EOF diff --git a/servant-swagger.cabal b/servant-swagger.cabal index 64e7b3490..96212880b 100644 --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -1,5 +1,5 @@ name: servant-swagger -version: 1.1.10 +version: 1.1.11 synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API. description: Swagger is a project used to describe and document RESTful APIs. The core of the @@ -82,7 +82,7 @@ library , http-media >=0.7.1.3 && <0.9 , insert-ordered-containers >=0.2.1.0 && <0.3 , lens >=4.17 && <4.20 - , servant >=0.17 && <0.19 + , servant >=0.18.1 && <0.19 , singleton-bool >=0.1.4 && <0.2 , swagger2 >=2.3.0.1 && <2.7 , text >=1.2.3.0 && <1.3 diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs index 7f160319a..666636a9b 100644 --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -16,6 +16,7 @@ module Servant.Swagger.Internal where import Prelude () import Prelude.Compat +import Control.Applicative ((<|>)) import Control.Lens import Data.Aeson import Data.HashMap.Strict.InsOrd (InsOrdHashMap) @@ -184,6 +185,56 @@ instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options instance SwaggerMethod 'HEAD where swaggerMethod _ = head_ instance SwaggerMethod 'PATCH where swaggerMethod _ = patch +instance HasSwagger (UVerb method cs '[]) where + toSwagger _ = mempty + +-- | @since +instance + {-# OVERLAPPABLE #-} + ( ToSchema a, + HasStatus a, + AllAccept cs, + SwaggerMethod method, + HasSwagger (UVerb method cs as) + ) => + HasSwagger (UVerb method cs (a ': as)) + where + toSwagger _ = + toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a)) + `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as)) + where + -- workaround for https://github.com/GetShopTV/swagger2/issues/218 + -- We'd like to juse use (<>) but the instances are wrong + 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 + , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t + } + + combineSwagger :: Swagger -> Swagger -> Swagger + combineSwagger s t = Swagger + { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t + , _swaggerHost = _swaggerHost s <|> _swaggerHost t + , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t + , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t + , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t + , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t + , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t) + , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t + , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t + , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t + , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t + , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t + , _swaggerTags = _swaggerTags s <> _swaggerTags t + , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t + } + instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a))) diff --git a/src/Servant/Swagger/Internal/Orphans.hs b/src/Servant/Swagger/Internal/Orphans.hs index ea97cb496..acd2f4232 100644 --- a/src/Servant/Swagger/Internal/Orphans.hs +++ b/src/Servant/Swagger/Internal/Orphans.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} module Servant.Swagger.Internal.Orphans where import Data.Proxy @@ -7,6 +10,9 @@ import Data.Proxy import Data.Swagger import Servant.Types.SourceT (SourceT) +#if __GLASGOW_HASKELL__ >= 881 +import Servant.API (WithStatus(..)) +#endif -- | Pretend that 'SourceT m a' is '[a]'. -- @@ -14,3 +20,8 @@ import Servant.Types.SourceT -- instance ToSchema a => ToSchema (SourceT m a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) + +#if __GLASGOW_HASKELL__ >= 881 +-- @since 1.1.11 +deriving instance ToSchema a => ToSchema (WithStatus s a) +#endif diff --git a/src/Servant/Swagger/Internal/TypeLevel/API.hs b/src/Servant/Swagger/Internal/TypeLevel/API.hs index 3c79ed8ce..818e378ba 100644 --- a/src/Servant/Swagger/Internal/TypeLevel/API.hs +++ b/src/Servant/Swagger/Internal/TypeLevel/API.hs @@ -7,7 +7,6 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Swagger.Internal.TypeLevel.API where -import Data.Type.Bool (If) import GHC.Exts (Constraint) import Servant.API diff --git a/stack.yaml b/stack.yaml index 6fc693944..4011b92ac 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,5 +4,5 @@ packages: - example/ extra-deps: -- servant-0.18 -- servant-server-0.18 +- servant-0.18.1 +- servant-server-0.18.1 diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs index 1d03908fe..2c1359c60 100644 --- a/test/Servant/SwaggerSpec.hs +++ b/test/Servant/SwaggerSpec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PackageImports #-} module Servant.SwaggerSpec where @@ -40,6 +41,7 @@ spec = describe "HasSwagger" $ do it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI + it "UVerb API" $ checkSwagger uverbSwagger uverbAPI it "Comprehensive API" $ do let _x = toSwagger comprehensiveAPI True `shouldBe` True -- type-level test @@ -406,3 +408,82 @@ getPostAPI = [aesonQQ| } |] +-- ======================================================================= +-- UVerb API +-- ======================================================================= + +data Lunch = Lunch {name :: String} + deriving (Eq, Show, Generic) + +instance ToSchema Lunch + +instance HasStatus Lunch where + type StatusOf Lunch = 200 + +data NoLunch = NoLunch + deriving (Eq, Show, Generic) + +instance ToSchema NoLunch + +instance HasStatus NoLunch where + type StatusOf NoLunch = 404 + +type UVerbAPI2 = + "lunch" :> UVerb 'GET '[JSON] '[Lunch, NoLunch] + +uverbSwagger :: Swagger +uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI2) + +uverbAPI :: Value +uverbAPI = + [aesonQQ| + { + "swagger": "2.0", + "info": { + "version": "", + "title": "" + }, + "definitions": { + "Lunch": { + "required": [ + "name" + ], + "type": "object", + "properties": { + "name": { + "type": "string" + } + } + }, + "NoLunch": { + "type": "string", + "enum": [ + "NoLunch" + ] + } + }, + "paths": { + "/lunch": { + "get": { + "responses": { + "404": { + "schema": { + "$ref": "#/definitions/NoLunch" + }, + "description": "" + }, + "200": { + "schema": { + "$ref": "#/definitions/Lunch" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ] + } + } + } +} +|]