diff --git a/cabal.project b/cabal.project index 0527dc9..4453317 100644 --- a/cabal.project +++ b/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 diff --git a/servant-openapi3.cabal b/servant-openapi3.cabal index f9896cd..69fa373 100644 --- a/servant-openapi3.cabal +++ b/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 diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs index fee1c2f..f8a458d 100644 --- a/src/Servant/OpenApi/Internal.hs +++ b/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 +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))) diff --git a/stack.yaml b/stack.yaml index c2860f7..4c67a83 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,5 @@ resolver: lts-16.8 packages: - '.' - example/ +- ../servant/servant +- ../servant/servant-server diff --git a/test/Servant/OpenApiSpec.hs b/test/Servant/OpenApiSpec.hs index 0333000..35ec014 100644 --- a/test/Servant/OpenApiSpec.hs +++ b/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": "" + } + } + } + } + } +} +|]