Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Swagger instances for UVerb #127

Merged
merged 10 commits into from
Nov 17, 2020
Merged
Show file tree
Hide file tree
Changes from 4 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion servant-swagger.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
51 changes: 51 additions & 0 deletions src/Servant/Swagger/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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)))

Expand Down
10 changes: 8 additions & 2 deletions src/Servant/Swagger/Internal/Orphans.hs
Original file line number Diff line number Diff line change
@@ -1,16 +1,22 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
smatting marked this conversation as resolved.
Show resolved Hide resolved
module Servant.Swagger.Internal.Orphans where

import Data.Proxy
(Proxy (..))
import Data.Swagger
import Servant.Types.SourceT
(SourceT)
import Servant.API (WithStatus(..))

-- | Pretend that 'SourceT m a' is '[a]'.
--
-- @since 1.1.7
--
instance ToSchema a => ToSchema (SourceT m a) where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

-- @since <TODO>
deriving instance ToSchema a => ToSchema (WithStatus s a)
1 change: 0 additions & 1 deletion src/Servant/Swagger/Internal/TypeLevel/API.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
4 changes: 2 additions & 2 deletions stack.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -4,5 +4,5 @@ packages:
- example/

extra-deps:
- servant-0.18
- servant-server-0.18
- servant-0.18.1
- servant-server-0.18.1
92 changes: 92 additions & 0 deletions test/Servant/SwaggerSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PackageImports #-}
module Servant.SwaggerSpec where
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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"
]
}
}
}
|]