Merge remote-tracking branch 'origin/fisx/uverb' into maksbotan/uverb

cabal.project

@@ -7,3 +7,15 @@ source-repository-package
     type: git
     location: https://github.com/biocad/openapi3/
     tag: bd9df532f2381c4b22fe86ef722715088f5cfa68
+
+source-repository-package
+    type: git
+    location: https://github.com/maksbotan/servant
+    tag: ffab120d4234fba967b85c87352096e5264a752d
+    subdir: servant
+
+source-repository-package
+    type: git
+    location: https://github.com/maksbotan/servant
+    tag: ffab120d4234fba967b85c87352096e5264a752d
+    subdir: servant-server

servant-openapi3.cabal

@@ -80,7 +80,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.17     && <0.20
                      , singleton-bool            >=0.1.4    && <0.2
                      , openapi3                  >=3.0.0    && <4.0
                      , text                      >=1.2.3.0  && <1.3

src/Servant/OpenApi/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.OpenApi.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.Foldable              (toList)
@@ -183,6 +189,56 @@ instance OpenApiMethod 'OPTIONS where openApiMethod _ = options
 instance OpenApiMethod 'HEAD    where openApiMethod _ = head_
 instance OpenApiMethod 'PATCH   where openApiMethod _ = patch
 
+-- TODO: turn on lower version bound once servant is released.
+-- #if MIN_VERSION_servant(0,19,0)
+instance HasOpenApi (UVerb method cs '[]) where
+  toOpenApi _ = mempty
+
+-- | @since <TODO>
+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))
+      `combineOpenApi` toOpenApi (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 = s
+        { _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
+        , _pathItemServers = _pathItemServers s <> _pathItemServers t
+        , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
+        }
+
+      combineOpenApi :: OpenApi -> OpenApi -> OpenApi
+      combineOpenApi 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
+        }
+
+deriving instance ToSchema a => ToSchema (WithStatus s 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)))
 

stack.yaml

@@ -2,3 +2,5 @@ resolver: lts-16.8
 packages:
 - '.'
 - example/
+- ../servant/servant
+- ../servant/servant-server

test/Servant/OpenApiSpec.hs

@@ -2,9 +2,10 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE PackageImports     #-}
 {-# LANGUAGE QuasiQuotes        #-}
+{-# LANGUAGE TypeFamilies       #-}
 {-# LANGUAGE TypeOperators      #-}
-{-# LANGUAGE PackageImports     #-}
 module Servant.OpenApiSpec where
 
 import           Control.Lens
@@ -34,6 +35,7 @@ spec = describe "HasOpenApi" $ do
   it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI
   it "Hackage API (with tags)" $ checkOpenApi hackageOpenApiWithTags hackageAPI
   it "GetPost API (test subOperations)" $ checkOpenApi getPostOpenApi getPostAPI
+  it "UVerb API" $ checkOpenApi uverbSwagger uverbAPI
   it "Comprehensive API" $ do
     let _x = toOpenApi comprehensiveAPI
     True `shouldBe` True -- type-level test
@@ -418,3 +420,101 @@ 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 :: OpenApi
+uverbSwagger = toOpenApi (Proxy :: Proxy UVerbAPI)
+
+uverbAPI :: Value
+uverbAPI = [aesonQQ|
+{
+  "components": {
+    "schemas": {
+      "ArianUser": {
+        "type": "string",
+        "enum": [
+          "ArianUser"
+        ]
+      },
+      "FisxUser": {
+        "required": [
+          "name"
+        ],
+        "type": "object",
+        "properties": {
+          "name": {
+            "type": "string"
+          }
+        }
+      }
+    }
+  },
+  "openapi": "3.0.0",
+  "info": {
+    "version": "",
+    "title": ""
+  },
+  "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": ""
+          }
+        }
+      }
+    }
+  }
+}
+|]