From 321594f74bff7b39a45952e46cfed2c959bce708 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Aug 2020 16:46:22 +0200 Subject: [PATCH 1/5] Tailing whitespace. --- src/Servant/Swagger/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs index f273ac661..85d56bc87 100644 --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -352,7 +352,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) From 533992c3f958bff82957f2cad6fc906b2a1b2c92 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Aug 2020 16:52:49 +0200 Subject: [PATCH 2/5] Swagger instances for UVerb. --- servant-swagger.cabal | 2 +- src/Servant/Swagger/Internal.hs | 61 +++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 1 deletion(-) 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 85d56bc87..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))) From fd311f260163b957ff9ed7558db7cad009d58bd4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Aug 2020 16:53:31 +0200 Subject: [PATCH 3/5] bump stack.yaml --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index bf333ff96..329c66235 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-13.25 +resolver: lts-16.7 packages: - '.' - example/ From 507086039ad186ddaa2a080d6c1c6fc0eb44163a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Aug 2020 16:53:50 +0200 Subject: [PATCH 4/5] ... --- cabal.project | 6 +++++- src/Servant/Swagger/Internal.hs | 2 ++ stack.yaml | 2 ++ 3 files changed, 9 insertions(+), 1 deletion(-) 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/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs index 94402370f..85cbd307e 100644 --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -15,6 +15,8 @@ #endif module Servant.Swagger.Internal where +-- TODO: write tests! + import Prelude () import Prelude.Compat diff --git a/stack.yaml b/stack.yaml index 329c66235..d531acf77 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,5 @@ resolver: lts-16.7 packages: - '.' - example/ +- ../servant/servant +- ../servant/servant-server From b9d6ee39f21b80e1b508f9df0bb84b39b76c0195 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Aug 2020 09:25:16 +0200 Subject: [PATCH 5/5] test. --- src/Servant/Swagger/Internal.hs | 2 - test/Servant/SwaggerSpec.hs | 92 +++++++++++++++++++++++++++++++++ 2 files changed, 92 insertions(+), 2 deletions(-) diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs index 85cbd307e..94402370f 100644 --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -15,8 +15,6 @@ #endif module Servant.Swagger.Internal where --- TODO: write tests! - import Prelude () import Prelude.Compat 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" + ] + } + } +} +|]