diff --git a/cabal.project b/cabal.project index 2d61bba2b..eacb9181f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,6 @@ -packages: . +packages: + ./ + ../servant/servant/ + ../servant/servant-server/ + allow-newer: aeson-pretty-0.8.7:base-compat diff --git a/servant-swagger.cabal b/servant-swagger.cabal index f96a4ead7..7afef2d80 100644 --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -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.18 + , servant >=0.17 && <0.20 , 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 f273ac661..94402370f 100644 --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- TODO: can we get rid of this? {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -- TODO: can we get away with terminating support for ghcs that don't have this? {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE UndecidableInstances #-} @@ -16,6 +18,10 @@ module Servant.Swagger.Internal where import Prelude () import Prelude.Compat +-- TODO: turn on lower version bound once servant is released. +-- #if MIN_VERSION_servant(0,19,0) +import Control.Applicative ((<|>)) +-- #endif import Control.Lens import Data.Aeson import Data.HashMap.Strict.InsOrd (InsOrdHashMap) @@ -183,6 +189,61 @@ instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options instance SwaggerMethod 'HEAD where swaggerMethod _ = head_ instance SwaggerMethod 'PATCH where swaggerMethod _ = patch +-- TODO: turn on lower version bound once servant is released. +-- #if MIN_VERSION_servant(0,19,0) +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 + } + +deriving instance ToSchema a => ToSchema (WithStatus s a) +-- #endif + 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))) @@ -352,7 +413,7 @@ instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription & schema .~ ParamBody ref -- | This instance is an approximation. --- +-- -- @since 1.1.7 instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) diff --git a/stack.yaml b/stack.yaml index bf333ff96..d531acf77 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,6 @@ -resolver: lts-13.25 +resolver: lts-16.7 packages: - '.' - example/ +- ../servant/servant +- ../servant/servant-server diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs index 1d03908fe..0460aa36a 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,93 @@ getPostAPI = [aesonQQ| } |] +-- ======================================================================= +-- UVerb API +-- ======================================================================= + +data FisxUser = FisxUser {name :: String} + deriving (Eq, Show, Generic) + +instance ToSchema FisxUser + +instance HasStatus FisxUser where + type StatusOf FisxUser = 203 + +data ArianUser = ArianUser + deriving (Eq, Show, Generic) + +instance ToSchema ArianUser + +type UVerbAPI = "fisx" :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String] + :<|> "arian" :> UVerb 'POST '[JSON] '[WithStatus 201 ArianUser] + +uverbSwagger :: Swagger +uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI) + +uverbAPI :: Value +uverbAPI = [aesonQQ| +{ + "swagger": "2.0", + "info": { + "version": "", + "title": "" + }, + "paths": { + "/fisx": { + "get": { + "produces": [ + "application/json;charset=utf-8" + ], + "responses": { + "303": { + "schema": { + "type": "string" + }, + "description": "" + }, + "203": { + "schema": { + "$ref": "#/definitions/FisxUser" + }, + "description": "" + } + } + } + }, + "/arian": { + "post": { + "produces": [ + "application/json;charset=utf-8" + ], + "responses": { + "201": { + "schema": { + "$ref": "#/definitions/ArianUser" + }, + "description": "" + } + } + } + } + }, + "definitions": { + "FisxUser": { + "required": [ + "name" + ], + "properties": { + "name": { + "type": "string" + } + }, + "type": "object" + }, + "ArianUser": { + "type": "string", + "enum": [ + "ArianUser" + ] + } + } +} +|]