Swagger instances for UVerb (#127)

Author: smatting

.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

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

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 <TODO>
+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)))
 

src/Servant/Swagger/Internal/Orphans.hs

@@ -1,16 +1,27 @@
-{-# 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
                  (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]'.
 --
 -- @since 1.1.7
 --
 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

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
 

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

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"
+          ]
+        }
+      }
+    }
+}
+|]