UVerb support

.travis.yml

@@ -1,14 +1,14 @@
 # This Travis job script has been generated by a script via
 #
-#   haskell-ci 'cabal.project'
+#   haskell-ci 'cabal.project' '--config' 'cabal.haskell-ci'
 #
 # To regenerate the script (for example after adjusting tested-with) run
 #
 #   haskell-ci regenerate
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.10.1
+# version: 0.10.3
 #
 version: ~> 1.0
 language: c
@@ -17,6 +17,9 @@ dist: xenial
 git:
   # whether to recursively clone submodules
   submodules: false
+branches:
+  only:
+    - master
 cache:
   directories:
     - $HOME/.cabal/packages
@@ -33,8 +36,11 @@ before_cache:
   - rm -rfv $CABALHOME/packages/head.hackage
 jobs:
   include:
-    - compiler: ghc-8.8.3
-      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}}
+    - compiler: ghc-8.10.2
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.2","cabal-install-3.2"]}}
+      os: linux
+    - compiler: ghc-8.8.4
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.4","cabal-install-3.2"]}}
       os: linux
     - compiler: ghc-8.6.5
       addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}}
@@ -96,10 +102,6 @@ install:
   - echo 'package example' >> cabal.project
   - "echo '  ghc-options: -Werror=missing-methods' >> cabal.project"
   - |
-    echo "source-repository-package"                            >> cabal.project
-    echo "  type:     git"                                      >> cabal.project
-    echo "  location: https://github.com/biocad/openapi3/"      >> cabal.project
-    echo "  tag:      bd9df532f2381c4b22fe86ef722715088f5cfa68" >> cabal.project
   - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(example|servant-openapi3)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
   - cat cabal.project || true
   - cat cabal.project.local || true
@@ -132,10 +134,6 @@ script:
   - echo 'package example' >> cabal.project
   - "echo '  ghc-options: -Werror=missing-methods' >> cabal.project"
   - |
-    echo "source-repository-package"                            >> cabal.project
-    echo "  type:     git"                                      >> cabal.project
-    echo "  location: https://github.com/biocad/openapi3/"      >> cabal.project
-    echo "  tag:      bd9df532f2381c4b22fe86ef722715088f5cfa68" >> cabal.project
   - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(example|servant-openapi3)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
   - cat cabal.project || true
   - cat cabal.project.local || true
@@ -155,6 +153,14 @@ script:
   # Building without installed constraints for packages in global-db...
   - rm -f cabal.project.local
   - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
+  # Constraint sets
+  - rm -rf cabal.project.local
+  # Constraint set servant-0.17
+  - if [ $HCNUMVER -lt 81000 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.17.*' all ; fi
+  # Constraint set servant-0.18
+  - if [ $HCNUMVER -ge 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18' all ; fi
+  # Constraint set servant-0.18.1
+  - if [ $HCNUMVER -ge 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.1' all ; fi
 
-# REGENDATA ("0.10.1",["cabal.project"])
+# REGENDATA ("0.10.3",["cabal.project","--config","cabal.haskell-ci"])
 # EOF

cabal.haskell-ci

@@ -0,0 +1,13 @@
+branches: master
+
+constraint-set servant-0.17
+  ghc: >= 8.0 && <8.10
+  constraints: servant ==0.17.*
+
+constraint-set servant-0.18
+  ghc: >= 8.8 && <8.12
+  constraints: servant ==0.18
+
+constraint-set servant-0.18.1
+  ghc: >= 8.8 && <8.12
+  constraints: servant ==0.18.1

cabal.project

@@ -2,8 +2,3 @@ packages:
     servant-openapi3.cabal,
     example/example.cabal
 tests: true
-
-source-repository-package
-    type: git
-    location: https://github.com/biocad/openapi3/
-    tag: bd9df532f2381c4b22fe86ef722715088f5cfa68

example/example.cabal

@@ -16,7 +16,8 @@ data-files:
 tested-with:
   GHC ==8.4.4
    || ==8.6.5
-   || ==8.8.3
+   || ==8.8.4
+   || ==8.10.2
 
 library
   ghc-options:      -Wall

servant-openapi3.cabal

@@ -1,5 +1,5 @@
 name:                servant-openapi3
-version:             2.0.0.1
+version:             2.0.1.0
 synopsis:            Generate a Swagger/OpenAPI/OAS 3.0 specification for your servant API.
 description:
   Swagger is a project used to describe and document RESTful APIs. The core of the 
@@ -31,7 +31,8 @@ cabal-version:       1.18
 tested-with:
   GHC ==8.4.4
    || ==8.6.5
-   || ==8.8.3
+   || ==8.8.4
+   || ==8.10.2
 
 extra-source-files:
     README.md

src/Servant/OpenApi/Internal.hs

@@ -11,11 +11,15 @@
 #if __GLASGOW_HASKELL__ >= 806
 {-# LANGUAGE UndecidableInstances #-}
 #endif
+{-# 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.Lens
 import           Data.Aeson
 import           Data.Foldable              (toList)
@@ -183,6 +187,57 @@ instance OpenApiMethod 'OPTIONS where openApiMethod _ = options
 instance OpenApiMethod 'HEAD    where openApiMethod _ = head_
 instance OpenApiMethod 'PATCH   where openApiMethod _ = patch
 
+#if MIN_VERSION_servant(0,18,1)
+instance HasOpenApi (UVerb method cs '[]) where
+  toOpenApi _ = mempty
+
+-- | @since <2.0.1.0>
+instance
+  {-# OVERLAPPABLE #-}
+  ( ToSchema a,
+    HasStatus a,
+    AllAccept cs,
+    OpenApiMethod method,
+    HasOpenApi (UVerb method cs as)
+  ) =>
+  HasOpenApi (UVerb method cs (a ': as))
+  where
+  toOpenApi _ =
+    toOpenApi (Proxy :: Proxy (Verb method (StatusOf a) cs a))
+      `combineSwagger` toOpenApi (Proxy :: Proxy (UVerb method cs as))
+    where
+      -- workaround for https://github.com/GetShopTV/swagger2/issues/218
+      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
+        , _pathItemTrace = _pathItemTrace s <> _pathItemTrace t
+        , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
+        , _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t
+        , _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t
+        , _pathItemServers = _pathItemServers s <> _pathItemServers t
+        }
+
+      combineSwagger :: OpenApi -> OpenApi -> OpenApi
+      combineSwagger s t = OpenApi
+        { _openApiInfo = _openApiInfo s <> _openApiInfo t
+        , _openApiServers = _openApiServers s <> _openApiServers t
+        , _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t)
+        , _openApiComponents = _openApiComponents s <> _openApiComponents t
+        , _openApiSecurity = _openApiSecurity s <> _openApiSecurity t
+        , _openApiTags = _openApiTags s <> _openApiTags t
+        , _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t
+        }
+
+instance ToSchema a => ToSchema (WithStatus s a) where
+  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
+#endif
+
 instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs a) where
   toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
 

test/Servant/OpenApiSpec.hs

@@ -1,10 +1,14 @@
+{-# LANGUAGE CPP                #-}
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE QuasiQuotes        #-}
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE PackageImports     #-}
+#if MIN_VERSION_servant(0,18,1)
+{-# LANGUAGE TypeFamilies       #-}
+#endif
 module Servant.OpenApiSpec where
 
 import           Control.Lens
@@ -37,6 +41,9 @@ spec = describe "HasOpenApi" $ do
   it "Comprehensive API" $ do
     let _x = toOpenApi comprehensiveAPI
     True `shouldBe` True -- type-level test
+#if MIN_VERSION_servant(0,18,1)
+  it "UVerb API" $ checkOpenApi uverbOpenApi uverbAPI
+#endif
 
 main :: IO ()
 main = hspec spec
@@ -418,3 +425,105 @@ getPostAPI = [aesonQQ|
 }
 |]
 
+-- =======================================================================
+-- UVerb API
+-- =======================================================================
+
+#if MIN_VERSION_servant(0,18,1)
+
+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]
+
+uverbOpenApi :: OpenApi
+uverbOpenApi = toOpenApi (Proxy :: Proxy UVerbAPI)
+
+uverbAPI :: Value
+uverbAPI = [aesonQQ|
+{
+  "openapi": "3.0.0",
+  "info": {
+    "version": "",
+    "title": ""
+  },
+  "components": {
+    "schemas": {
+      "ArianUser": {
+        "type": "string",
+        "enum": [
+          "ArianUser"
+        ]
+      },
+      "FisxUser": {
+        "required": [
+          "name"
+        ],
+        "type": "object",
+        "properties": {
+          "name": {
+            "type": "string"
+          }
+        }
+      }
+    }
+  },
+  "paths": {
+    "/arian": {
+      "post": {
+        "responses": {
+          "201": {
+            "content": {
+              "application/json;charset=utf-8": {
+                "schema": {
+                  "$ref": "#/components/schemas/ArianUser"
+                }
+              }
+            },
+            "description": ""
+          }
+        }
+      }
+    },
+    "/fisx": {
+      "get": {
+        "responses": {
+          "303": {
+            "content": {
+              "application/json;charset=utf-8": {
+                "schema": {
+                  "type": "string"
+                }
+              }
+            },
+            "description": ""
+          },
+          "203": {
+            "content": {
+              "application/json;charset=utf-8": {
+                "schema": {
+                  "$ref": "#/components/schemas/FisxUser"
+                }
+              }
+            },
+            "description": ""
+          }
+        }
+      }
+    }
+  }
+}
+|]
+
+#endif