diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,33 @@ +1.0 +--- + +* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)): + * Switch to `swagger2-2.*`; + * Add automatic `ToJSON`/`ToSchema` validation tests; + * Add great documentation; + * Export some type-level functions for servant API. + +* Minor changes: + * Rework Todo API example; + * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2)); + * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147)); + * Include changelog and example files into `extra-source-files`. + +0.1.2 +--- + +* Fixes: + * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22)); + * Set version bounds for `swagger2`. + +0.1.1 +--- + +* Fixes: + * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18)); + * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)). + +0.1 +--- +* Major changes + * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2016, David Johnson +Copyright (c) 2015-2016, Servant contributors All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,139 +5,31 @@ [![Stackage LTS](http://stackage.org/package/servant-swagger/badge/lts)](http://stackage.org/lts/package/servant-swagger) [![Stackage Nightly](http://stackage.org/package/servant-swagger/badge/nightly)](http://stackage.org/nightly/package/servant-swagger) -This project converts [servant](https://github.com/haskell-servant/servant) APIs into Swagger 2.0 conforming json. +Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs. ![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png) -
- -Given the following `servant` API, `servant-swagger` generates the following json. - -### [Input](example/File.hs) - -```haskell -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -module Main where - -import Control.Lens -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL8 -import Data.Proxy -import Data.Swagger -import GHC.Generics -import Servant -import Servant.Swagger - --- Types -data Todo = Todo - { created :: Int - , description :: String - } deriving (Show, Eq, Generic) - -instance ToJSON Todo - -newtype TodoId = TodoId String deriving (FromText, Generic) - --- API -type API = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo +### Motivation --- Swagger Doc -swagDoc :: Swagger -swagDoc = toSwagger (Proxy :: Proxy API) - & info.infoTitle .~ "Todo API" - & info.infoVersion .~ "1.0" - & info.infoDescription ?~ "This is an API that tests servant-swagger support for a Todo" - & info.infoLicense ?~ License "MIT" (Just (URL "http://mit.com")) +Swagger™ is a project used to describe and document RESTful APIs. +Unlike Servant it is language-agnostic and thus is quite popular among developers +in different languages. It also exists for a longer time and has more tools to work with. --- Documentation and annotations -instance ToParamSchema TodoId +This package provides means to generate Swagger specification for a Servant API +and also to partially test whether API conforms with its specification. -instance ToSchema Todo where - declareNamedSchema proxy = do - (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions proxy - return (name, schema - & schemaDescription ?~ "This is some real Todo right here" - & schemaExample ?~ toJSON (Todo 100 "get milk")) +Generated Swagger specification then can be used for many things such as +- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/); +- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/); +- and [many others](http://swagger.io/open-source-integrations/). --- Main, create swaggger.json -main :: IO () -main = BL8.writeFile "swagger.json" (encode swagDoc) -``` +### Usage -### Output +Please refer to [haddock documentation](http://hackage.haskell.org/package/servant-swagger). -```json -{ - "swagger":"2.0", - "info":{ - "version":"1.0", - "title":"Todo API", - "license":{ - "url":"http://mit.com", - "name":"MIT" - }, - "description":"This is an API that tests servant-swagger support for a Todo" - }, - "definitions":{ - "Todo":{ - "example":{ - "created":100, - "description":"get milk" - }, - "required":[ - "created", - "description" - ], - "type":"object", - "description":"This is some real Todo right here", - "properties":{ - "created":{ - "maximum":9223372036854775807, - "minimum":-9223372036854775808, - "type":"integer" - }, - "description":{ - "type":"string" - } - } - } - }, - "paths":{ - "/todo/{id}":{ - "get":{ - "responses":{ - "404":{ - "description":"`id` not found" - }, - "200":{ - "schema":{ - "$ref":"#/definitions/Todo" - }, - "description":"" - } - }, - "produces":[ - "application/json" - ], - "parameters":[ - { - "required":true, - "in":"path", - "name":"id", - "type":"string" - } - ] - } - } - } -} -``` +Some examples can be found in [`example/` directory](/examples). -## Try it out +### Try it out All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/). @@ -147,9 +39,9 @@ Many Swagger tools, including server and client code generation for many languages, can be found on [Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/). -## Contributing +### Contributing We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. -Please report bugs via the [github issue tracker](https://github.com/dmjio/servant-swagger/issues). +Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant-swagger/issues). diff --git a/example/File.hs b/example/File.hs deleted file mode 100644 --- a/example/File.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -module Main where - -import Control.Lens -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL8 -import Data.Proxy -import Data.Swagger -import GHC.Generics -import Servant -import Servant.Swagger - --- Types -data Todo = Todo - { created :: Int - , description :: String - } deriving (Show, Eq, Generic) - -instance ToJSON Todo - -newtype TodoId = TodoId String deriving (FromText, Generic) - --- API -type API = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo - --- Swagger Doc -swagDoc :: Swagger -swagDoc = toSwagger (Proxy :: Proxy API) - & info.infoTitle .~ "Todo API" - & info.infoVersion .~ "1.0" - & info.infoDescription ?~ "This is an API that tests servant-swagger support for a Todo" - & info.infoLicense ?~ License "MIT" (Just (URL "http://mit.com")) - --- Documentation and annotations -instance ToParamSchema TodoId - -instance ToSchema Todo where - declareNamedSchema proxy = do - (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions proxy - return (name, schema - & schemaDescription ?~ "This is some real Todo right here" - & schemaExample ?~ toJSON (Todo 100 "get milk")) - --- Main, create swaggger.json -main :: IO () -main = BL8.writeFile "swagger.json" (encode swagDoc) - diff --git a/example/LICENSE b/example/LICENSE new file mode 100644 --- /dev/null +++ b/example/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015-2016, Servant contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of servant-swagger nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/example/Server.hs b/example/Server.hs deleted file mode 100644 --- a/example/Server.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -module Main where - -import Control.Lens -import Control.Monad.Trans.Either -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL8 -import Data.Proxy -import Data.Swagger -import GHC.Generics -import Network.Wai.Handler.Warp -import Servant -import Servant.Swagger - --- Test API -type TodoAPI - = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo - :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] (Maybe Todo) - :<|> "todo" :> "count" :> Get '[JSON] Todo - :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] Todo - -type TestAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo - -swagDoc :: Swagger -swagDoc = toSwagger (Proxy :: Proxy TestAPI) - & info.infoTitle .~ "Todo API" - & info.infoVersion .~ "1.0" - & info.infoDescription ?~ "This is an API that tests servant-swagger support for a Todo" - & info.infoLicense ?~ License "MIT" (Just (URL "http://mit.com")) - -type DocsAPI = Get '[JSON] Swagger - -type API = DocsAPI :<|> TodoAPI - --- Data -data Todo = Todo { created :: Int, description :: String } - deriving (Show, Eq, Generic) - -instance ToJSON Todo -instance FromJSON Todo - -newtype TodoId = TodoId String deriving (FromText, Generic) -newtype TodoCount = TodoCount Int deriving (FromText, Generic) -newtype Completed = Completed Bool deriving (FromText, Generic) - -api :: Proxy TodoAPI -api = Proxy - --- Generate Swagger Docs -main :: IO () -main = do - putStrLn "Running on port 8000" - run 8000 $ serve (Proxy :: Proxy API) endpoints - where - endpoints = swagHandler :<|> undefined - undefined :<|> undefined :<|> undefined - undefined :<|> undefined - -swagHandler :: EitherT ServantErr IO Swagger -swagHandler = pure $ toSwagger api - & info.infoTitle .~ "Todo API" - & info.infoVersion .~ "1.0" - & info.infoDescription ?~ "This is an API that tests swagger integration" - & info.infoLicense ?~ License "MIT" (Just (URL "http://mit.com")) - --- Instances -instance ToSchema Todo where - declareNamedSchema proxy = do - (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions proxy - return (name, schema - & schemaDescription ?~ "This is some real Todo right here" - & schemaExample ?~ toJSON (Todo 100 "get milk")) - -instance ToParamSchema TodoId - -instance ToParamSchema Completed - diff --git a/example/example.cabal b/example/example.cabal --- a/example/example.cabal +++ b/example/example.cabal @@ -1,55 +1,59 @@ name: example -version: 0.1.0.0 -synopsis: Example usage -description: Example usage +version: 1.0 +synopsis: servant-swagger demonstration +description: servant-swagger demonstration license: BSD3 license-file: LICENSE -author: David Johnson -maintainer: djohnson.m@gmail.com -copyright: David Johnson (c) 2015-2016 +author: David Johnson, Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +copyright: (c) 2015-2016, Servant contributors category: Web build-type: Simple cabal-version: >=1.10 +data-files: + swagger.json -executable swagger-server - main-is: Server.hs - build-depends: - base +library + ghc-options: -Wall + hs-source-dirs: src/ + exposed-modules: + Todo + build-depends: base , aeson - , bytestring == 0.10.* + , lens , servant - , either , servant-server , servant-swagger , swagger2 - , lens - , wai - , warp + , text + , time default-language: Haskell2010 -executable swagger-file - main-is: File.hs - build-depends: - base - , aeson - , bytestring == 0.10.* - , servant - , swagger2 - , either +executable swagger-server + ghc-options: -Wall + hs-source-dirs: server/ + main-is: Main.hs + build-depends: base + , example , servant-server - , servant-swagger - , lens + , warp default-language: Haskell2010 -executable readme - main-is: README.lhs - ghc-options: -Wall -pgmL markdown-unlit - build-depends: base >=4.7 && <4.9 - , aeson - , bytestring - , lens - , markdown-unlit - , servant-server - , servant-swagger - , swagger2 - default-language: Haskell2010 +test-suite swagger-server-spec + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + TodoSpec + Paths_example + build-depends: base == 4.* + , aeson + , bytestring + , example + , hspec + , servant-swagger + , QuickCheck + , quickcheck-instances + default-language: Haskell2010 + diff --git a/example/server/Main.hs b/example/server/Main.hs new file mode 100644 --- /dev/null +++ b/example/server/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Network.Wai.Handler.Warp +import Servant +import Todo + +main :: IO () +main = do + putStrLn "Running on port 8000" + run 8000 $ serve (Proxy :: Proxy API) server + diff --git a/example/src/Todo.hs b/example/src/Todo.hs new file mode 100644 --- /dev/null +++ b/example/src/Todo.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Todo where + +import Control.Lens +import Data.Aeson +import Data.Proxy +import Data.Text (Text) +import Data.Time (UTCTime(..), fromGregorian) +import Data.Typeable +import Data.Swagger +import GHC.Generics +import Servant +import Servant.Swagger + +todoAPI :: Proxy TodoAPI +todoAPI = Proxy + +-- | The API of a Todo service. +type TodoAPI + = "todo" :> Get '[JSON] [Todo] + :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId + :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo + :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId + +-- | API for serving @swagger.json@. +type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger + +-- | Combined API of a Todo service with Swagger documentation. +type API = SwaggerAPI :<|> TodoAPI + +-- | A single Todo entry. +data Todo = Todo + { created :: UTCTime -- ^ Creation datetime. + , summary :: Text -- ^ Task summary. + } deriving (Show, Generic, Typeable) + +-- | A unique Todo entry ID. +newtype TodoId = TodoId Int + deriving (Show, Generic, Typeable, ToJSON, FromText) + +instance ToJSON Todo +instance FromJSON Todo + +instance ToSchema Todo where + declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy + & mapped.schema.description ?~ "This is some real Todo right here" + & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk") + +instance ToParamSchema TodoId +instance ToSchema TodoId + +-- | Swagger spec for Todo API. +todoSwagger :: Swagger +todoSwagger = toSwagger todoAPI + & info.title .~ "Todo API" + & info.version .~ "1.0" + & info.description ?~ "This is an API that tests swagger integration" + & info.license ?~ ("MIT" & url ?~ URL "http://mit.com") + +-- | Combined server of a Todo service with Swagger documentation. +server :: Server API +server = return todoSwagger :<|> error "not implemented" + diff --git a/example/swagger.json b/example/swagger.json new file mode 100644 --- /dev/null +++ b/example/swagger.json @@ -0,0 +1,1 @@ +{"swagger":"2.0","info":{"version":"1.0","title":"Todo API","license":{"url":"http://mit.com","name":"MIT"},"description":"This is an API that tests swagger integration"},"definitions":{"Todo":{"example":{"summary":"get milk","created":"2015-12-31T00:00:00.000000000000Z"},"required":["created","summary"],"type":"object","description":"This is some real Todo right here","properties":{"summary":{"type":"string"},"created":{"$ref":"#/definitions/UTCTime"}}},"UTCTime":{"format":"yyyy-mm-ddThh:MM:ssZ","type":"string"},"TodoId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"paths":{"/todo/{id}":{"get":{"responses":{"404":{"description":"`id` not found"},"200":{"schema":{"$ref":"#/definitions/Todo"},"description":""}},"produces":["application/json"],"parameters":[{"maximum":9223372036854775807,"minimum":-9223372036854775808,"required":true,"in":"path","name":"id","type":"integer"}]},"put":{"consumes":["application/json"],"responses":{"404":{"description":"`id` not found"},"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/TodoId"},"description":""}},"produces":["application/json"],"parameters":[{"maximum":9223372036854775807,"minimum":-9223372036854775808,"required":true,"in":"path","name":"id","type":"integer"},{"required":true,"schema":{"$ref":"#/definitions/Todo"},"in":"body","name":"body"}]}},"/todo":{"post":{"consumes":["application/json"],"responses":{"400":{"description":"Invalid `body`"},"201":{"schema":{"$ref":"#/definitions/TodoId"},"description":""}},"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/Todo"},"in":"body","name":"body"}]},"get":{"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/Todo"},"type":"array"},"description":""}},"produces":["application/json"]}}}} diff --git a/example/test/Spec.hs b/example/test/Spec.hs new file mode 100644 --- /dev/null +++ b/example/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/example/test/TodoSpec.hs b/example/test/TodoSpec.hs new file mode 100644 --- /dev/null +++ b/example/test/TodoSpec.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module TodoSpec where + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Servant.Swagger.Test +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Todo +import Paths_example + +spec :: Spec +spec = describe "Swagger" $ do + context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI + it "swagger.json is up-to-date" $ do + path <- getDataFileName "swagger.json" + swag <- eitherDecode <$> BL8.readFile path + swag `shouldBe` Right todoSwagger + +instance Arbitrary Todo where + arbitrary = Todo <$> arbitrary <*> arbitrary + +instance Arbitrary TodoId where + arbitrary = TodoId <$> arbitrary diff --git a/servant-swagger.cabal b/servant-swagger.cabal --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -1,31 +1,45 @@ name: servant-swagger -version: 0.1.2 +version: 1.0 synopsis: Generate Swagger specification for your servant API. description: Please see README.md -homepage: https://github.com/dmjio/servant-swagger -bug-reports: https://github.com/dmjio/servant-swagger/issues +homepage: https://github.com/haskell-servant/servant-swagger +bug-reports: https://github.com/haskell-servant/servant-swagger/issues license: BSD3 license-file: LICENSE -author: David Johnson -maintainer: djohnson.m@gmail.com -copyright: David Johnson (c) 2015-2016 +author: David Johnson, Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +copyright: (c) 2015-2016, Servant contributors category: Web build-type: Simple cabal-version: >=1.10 extra-source-files: README.md - , example/*.hs + , CHANGELOG.md + , example/server/*.hs + , example/src/*.hs + , example/test/*.hs , example/*.cabal + , example/swagger.json + , example/LICENSE source-repository head type: git - location: https://github.com/dmjio/servant-swagger.git + location: https://github.com/haskell-servant/servant-swagger.git library ghc-options: -Wall exposed-modules: Servant.Swagger + Servant.Swagger.Test + Servant.Swagger.TypeLevel + + -- Internal modules Servant.Swagger.Internal + Servant.Swagger.Internal.Test + Servant.Swagger.Internal.TypeLevel + Servant.Swagger.Internal.TypeLevel.API + Servant.Swagger.Internal.TypeLevel.Every + Servant.Swagger.Internal.TypeLevel.TMap hs-source-dirs: src build-depends: aeson , base >=4.7 && <5 @@ -33,11 +47,21 @@ , http-media , lens , servant - , swagger2 >= 1 && <2 + , swagger2 >= 2 && <3 , text , unordered-containers + + , hspec + , QuickCheck default-language: Haskell2010 +test-suite doctest + build-depends: base, doctest, Glob + default-language: Haskell2010 + hs-source-dirs: test + main-is: DocTest.hs + type: exitcode-stdio-1.0 + test-suite spec ghc-options: -Wall type: exitcode-stdio-1.0 @@ -47,10 +71,11 @@ , aeson , aeson-qq , hspec + , QuickCheck , lens , servant , servant-swagger - , swagger2 >= 1 && <2 + , swagger2 >= 2 && <3 , text , time other-modules: diff --git a/src/Servant/Swagger.hs b/src/Servant/Swagger.hs --- a/src/Servant/Swagger.hs +++ b/src/Servant/Swagger.hs @@ -1,14 +1,178 @@ +-- | +-- Module: Servant.Swagger +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- This module provides means to generate and manipulate +-- Swagger specification for servant APIs. +-- +-- Swagger™ is a project used to describe and document RESTful APIs. +-- +-- The Swagger specification defines a set of files required to describe such an API. +-- These files can then be used by the Swagger-UI project to display the API +-- and Swagger-Codegen to generate clients in various languages. +-- Additional utilities can also take advantage of the resulting files, such as testing tools. +-- +-- For more information see . module Servant.Swagger ( + -- * How to use this library + -- $howto + + -- ** Generate @'Swagger'@ + -- $generate + + -- ** Annotate + -- $annotate + + -- ** Test + -- $test + + -- ** Serve + -- $serve + + -- * @'HasSwagger'@ class HasSwagger(..), - addTag, + -- * Manipulation subOperations, - setResponse, - ToResponseHeader(..), - AllAccept, - AllToResponseHeader, + -- * Testing + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, ) where import Servant.Swagger.Internal +import Servant.Swagger.Test +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Aeson +-- >>> import Data.Swagger +-- >>> import Data.Typeable +-- >>> import GHC.Generics +-- >>> import Servant.API +-- >>> import Test.Hspec +-- >>> import Test.QuickCheck +-- >>> :set -XDataKinds +-- >>> :set -XDeriveGeneric +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeOperators +-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) +-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) +-- >>> instance ToJSON User +-- >>> instance ToSchema User +-- >>> instance ToSchema UserId +-- >>> instance ToParamSchema UserId +-- >>> type GetUsers = Get '[JSON] [User] +-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User +-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId +-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser + +-- $howto +-- +-- This section explains how to use this library to generate Swagger specification, +-- modify it and run automatic tests for a servant API. +-- +-- For the purposes of this section we will use this servant API: +-- +-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) +-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) +-- >>> instance ToJSON User +-- >>> instance ToSchema User +-- >>> instance ToSchema UserId +-- >>> instance ToParamSchema UserId +-- >>> type GetUsers = Get '[JSON] [User] +-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User +-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId +-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser +-- +-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users. +-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID. + +-- $generate +-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@: +-- +-- >>> encode $ toSwagger (Proxy :: Proxy UserAPI) +-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"201\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}" +-- +-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas. +-- +-- For some parameters it will also add 400 and/or 404 responses with a description mentioning parameter name. +-- +-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes. + +-- $annotate +-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API. +-- +-- We can add this information using field lenses from @"Data.Swagger"@: +-- +-- >>> :{ +-- encode $ toSwagger (Proxy :: Proxy UserAPI) +-- & info.title .~ "User API" +-- & info.version .~ "1.0" +-- & info.description ?~ "This is an API for the Users service" +-- & info.license ?~ "MIT" +-- & host ?~ "example.com" +-- :} +-- "{\"swagger\":\"2.0\",\"host\":\"example.com\",\"info\":{\"version\":\"1.0\",\"title\":\"User API\",\"license\":{\"name\":\"MIT\"},\"description\":\"This is an API for the Users service\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"201\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}" +-- +-- It is also useful to annotate or modify certain endpoints. +-- @'subOperations'@ provides a convenient way to zoom into a part of an API. +-- +-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@. +-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck. +-- +-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@. +-- One example is applying tags to certain endpoints: +-- +-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI) +-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI) +-- >>> :{ +-- encode $ toSwagger (Proxy :: Proxy UserAPI) +-- & applyTagsFor getOps ["get" & description ?~ "GET operations"] +-- & applyTagsFor postOps ["post" & description ?~ "POST operations"] +-- :} +-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}],\"tags\":[\"get\"]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"201\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}],\"tags\":[\"post\"]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"tags\":[\"get\"]}}},\"tags\":[{\"name\":\"get\",\"description\":\"GET operations\"},{\"name\":\"post\",\"description\":\"POST operations\"}]}" +-- +-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API. + +-- $test +-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types +-- used in a servant API. But to encode/decode actual data servant uses different classes. +-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances. +-- +-- To be sure your Haskell server/client handles data properly you need to check +-- that @'ToJSON'@ instance always generates values that satisfy schema produced +-- by @'ToSchema'@ instance. +-- +-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically, +-- without having to write down every type: +-- +-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary +-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary +-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI) +-- +-- [User] +-- User +-- UserId +-- +-- Finished in ... seconds +-- 3 examples, 0 failures +-- +-- Although servant is great, chances are that your API clients don't use Haskell. +-- In many cases @swagger.json@ serves as a specification, not a Haskell type. +-- +-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file +-- under a version control system (such as Git, Subversion, Mercurial, etc.). +-- +-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes +-- to the Haskell API. +-- +-- See for an example of a complete test suite for a swagger specification. + +-- $serve +-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification. +-- +-- See for an example of a server. diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -5,19 +5,13 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} module Servant.Swagger.Internal where -import Control.Arrow (first) import Control.Lens import Data.Aeson -import Data.Data.Lens (template) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List (dropWhileEnd) -import Data.Maybe (mapMaybe) import Data.Monoid import Data.Proxy import qualified Data.Swagger as Swagger @@ -25,55 +19,58 @@ import Data.Swagger.Declare import Data.Text (Text) import qualified Data.Text as Text -import Data.Traversable (sequenceA) import GHC.TypeLits -import GHC.Exts import Network.HTTP.Media (MediaType) import Servant.API +import Servant.Swagger.Internal.TypeLevel.API + +-- | Generate a Swagger specification for a servant API. +-- +-- To generate Swagger specification, your data types need +-- @'ToParamSchema'@ and/or @'ToSchema'@ instances. +-- +-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@. +-- @'ToSchema'@ is used for @'ReqBody'@ and response data types. +-- +-- You can easily derive those instances via @Generic@. +-- For more information, refer to . +-- +-- Example: +-- +-- @ +-- newtype Username = Username String deriving (Generic, ToText) +-- +-- instance ToParamSchema Username +-- +-- data User = User +-- { username :: Username +-- , fullname :: String +-- } deriving (Generic) +-- +-- instance ToJSON User +-- instance ToSchema User +-- +-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User +-- +-- mySwagger :: Swagger +-- mySwagger = toSwagger (Proxy :: Proxy MyAPI) +-- @ class HasSwagger api where + -- | Generate a Swagger specification for a servant API. toSwagger :: Proxy api -> Swagger instance HasSwagger Raw where - toSwagger _ = mempty & paths.pathsMap.at "/" ?~ mempty + toSwagger _ = mempty & paths . at "/" ?~ mempty -- | All operations of sub API. -subOperations :: forall sub api. (IsSubAPI sub api, HasSwagger sub) => - Proxy sub -> Proxy api -> Traversal' Swagger Operation -subOperations sub _ = paths.pathsMap.itraversed.withIndex.subops - where - -- | Traverse operations that correspond to paths and methods of the sub API. - subops :: Traversal' (FilePath, PathItem) Operation - subops f (path, item) = case HashMap.lookup path subpaths of - Just subitem -> (,) path <$> methodsOf subitem f item - Nothing -> pure (path, item) - - -- | Paths of the sub API. - subpaths :: HashMap FilePath PathItem - subpaths = toSwagger sub ^. paths.pathsMap - - -- | Traverse operations that exist in a given @'PathItem'@ - -- This is used to traverse only the operations that exist in sub API. - methodsOf :: PathItem -> Traversal' PathItem Operation - methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just - where - ops = pathItem ^.. template :: [Maybe Operation] - ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops - --- | Tag an operation. -addTag :: TagName -> Operation -> Operation -addTag tag = operationTags %~ (tag:) - --- | Set a response for an operation. -setResponse :: HttpStatusCode -> Response -> Operation -> Operation -setResponse code res = operationResponses.responsesResponses.at code ?~ Inline res - -() :: FilePath -> FilePath -> FilePath -x y = case trim y of - "" -> "/" <> trim x - y' -> "/" <> trim x <> "/" <> y' - where - trim = dropWhile (== '/') . dropWhileEnd (== '/') +-- This is similar to @'operationsOf'@ but ensures that operations +-- indeed belong to the API at compile time. +subOperations :: (IsSubAPI sub api, HasSwagger sub) => + Proxy sub -- ^ Part of a servant API. + -> Proxy api -- ^ The whole servant API. + -> Traversal' Swagger Operation +subOperations sub _ = operationsOf (toSwagger sub) mkEndpoint :: forall a cs hs proxy _verb. (ToSchema a, AllAccept cs, AllToResponseHeader hs) => FilePath @@ -102,61 +99,39 @@ -> proxy (verb cs (Headers hs a)) -> Swagger mkEndpointWithSchemaRef mref path verb code _ = mempty - & paths.pathsMap.at path ?~ + & paths.at path ?~ (mempty & verb ?~ (mempty - & operationProduces ?~ MimeList (allContentType (Proxy :: Proxy cs)) - & operationResponses .~ (mempty - & responsesResponses . at code ?~ Inline (mempty - & responseSchema .~ mref - & responseHeaders .~ toAllResponseHeaders (Proxy :: Proxy hs))))) - --- | Prepend path to all API endpoints. -prependPath :: FilePath -> Swagger -> Swagger -prependPath path spec = spec & paths.pathsMap %~ f - where - f = HashMap.fromList . map (first (path )) . HashMap.toList + & produces ?~ MimeList (allContentType (Proxy :: Proxy cs)) + & at code ?~ Inline (mempty + & schema .~ mref + & headers .~ toAllResponseHeaders (Proxy :: Proxy hs)))) -- | Add parameter to every operation in the spec. addParam :: Param -> Swagger -> Swagger -addParam param spec = spec & template.operationParameters %~ (Inline param :) +addParam param = allOperations.parameters %~ (Inline param :) -- | Add accepted content types to every operation in the spec. addConsumes :: [MediaType] -> Swagger -> Swagger -addConsumes cs spec = spec & template.operationConsumes %~ (<> Just (MimeList cs)) - --- | Add/modify response for every operation in the spec. -addResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Response -> Swagger -> Swagger -addResponseWith f code new spec = spec - & paths.template.responsesResponses . at code %~ Just . Inline . combine - where - combine (Just (Ref (Reference name))) = case spec ^. responses.at name of - Just old -> f old new - Nothing -> new -- FIXME: what is the right choice here? - combine (Just (Inline old)) = f old new - combine Nothing = new - --- | Add/overwrite response for every operation in the spec. -addResponse :: HttpStatusCode -> Response -> Swagger -> Swagger -addResponse = addResponseWith (\_old new -> new) +addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs)) -- | Format given text as inline code in Markdown. markdownCode :: Text -> Text markdownCode s = "`" <> s <> "`" addDefaultResponse404 :: ParamName -> Swagger -> Swagger -addDefaultResponse404 pname = addResponseWith (\old _new -> alter404 old) 404 response404 +addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (pure response404) where - name = markdownCode pname - description404 = name <> " not found" - alter404 = description %~ ((name <> " or ") <>) + sname = markdownCode pname + description404 = sname <> " not found" + alter404 = description %~ ((sname <> " or ") <>) response404 = mempty & description .~ description404 addDefaultResponse400 :: ParamName -> Swagger -> Swagger -addDefaultResponse400 pname = addResponseWith (\old _new -> alter400 old) 400 response400 +addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (pure response400) where - name = markdownCode pname - description400 = "Invalid " <> name - alter400 = description %~ (<> (" or " <> name)) + sname = markdownCode pname + description400 = "Invalid " <> sname + alter400 = description %~ (<> (" or " <> sname)) response400 = mempty & description .~ description400 -- ----------------------------------------------------------------------- @@ -167,10 +142,10 @@ toSwagger _ = toSwagger (Proxy :: Proxy (Delete cs (Headers '[] a))) instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Delete cs (Headers hs a)) where - toSwagger = mkEndpoint "/" pathItemDelete 200 + toSwagger = mkEndpoint "/" delete 200 instance AllAccept cs => HasSwagger (Delete cs ()) where - toSwagger = noContentEndpoint "/" pathItemDelete + toSwagger = noContentEndpoint "/" delete -- ----------------------------------------------------------------------- -- GET @@ -180,10 +155,10 @@ toSwagger _ = toSwagger (Proxy :: Proxy (Get cs (Headers '[] a))) instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Get cs (Headers hs a)) where - toSwagger = mkEndpoint "/" pathItemGet 200 + toSwagger = mkEndpoint "/" get 200 instance AllAccept cs => HasSwagger (Get cs ()) where - toSwagger = noContentEndpoint "/" pathItemGet + toSwagger = noContentEndpoint "/" get -- ----------------------------------------------------------------------- -- PATCH @@ -193,10 +168,10 @@ toSwagger _ = toSwagger (Proxy :: Proxy (Patch cs (Headers '[] a))) instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Patch cs (Headers hs a)) where - toSwagger = mkEndpoint "/" pathItemPatch 200 + toSwagger = mkEndpoint "/" patch 200 instance AllAccept cs => HasSwagger (Patch cs ()) where - toSwagger = noContentEndpoint "/" pathItemPatch + toSwagger = noContentEndpoint "/" patch -- ----------------------------------------------------------------------- -- PUT @@ -206,10 +181,10 @@ toSwagger _ = toSwagger (Proxy :: Proxy (Put cs (Headers '[] a))) instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Put cs (Headers hs a)) where - toSwagger = mkEndpoint "/" pathItemPut 200 + toSwagger = mkEndpoint "/" put 200 instance AllAccept cs => HasSwagger (Put cs ()) where - toSwagger = noContentEndpoint "/" pathItemPut + toSwagger = noContentEndpoint "/" put -- ----------------------------------------------------------------------- -- POST @@ -219,11 +194,10 @@ toSwagger _ = toSwagger (Proxy :: Proxy (Post cs (Headers '[] a))) instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Post cs (Headers hs a)) where - toSwagger = mkEndpoint "/" pathItemPost 201 + toSwagger = mkEndpoint "/" post 201 instance AllAccept cs => HasSwagger (Post cs ()) where - toSwagger = noContentEndpoint "/" pathItemPost - + toSwagger = noContentEndpoint "/" post instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b) @@ -237,82 +211,83 @@ toSwagger _ = toSwagger (Proxy :: Proxy sub) & addParam param & prependPath capture - & addDefaultResponse404 (Text.pack name) + & addDefaultResponse404 tname where - name = symbolVal (Proxy :: Proxy sym) - capture = "{" <> name <> "}" + pname = symbolVal (Proxy :: Proxy sym) + tname = Text.pack pname + capture = "{" <> pname <> "}" param = mempty - & paramName .~ Text.pack name - & paramRequired ?~ True - & paramSchema .~ ParamOther (mempty - & paramOtherSchemaIn .~ ParamPath - & parameterSchema .~ toParamSchema (Proxy :: Proxy a)) + & name .~ tname + & required ?~ True + & schema .~ ParamOther (mempty + & in_ .~ ParamPath + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParam sym a :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) & addParam param - & addDefaultResponse400 (Text.pack name) + & addDefaultResponse400 tname where - name = symbolVal (Proxy :: Proxy sym) + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) param = mempty - & paramName .~ Text.pack name - & paramSchema .~ ParamOther (mempty - & paramOtherSchemaIn .~ ParamQuery - & parameterSchema .~ toParamSchema (Proxy :: Proxy a)) + & name .~ tname + & schema .~ ParamOther (mempty + & in_ .~ ParamQuery + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) & addParam param - & addDefaultResponse400 (Text.pack name) + & addDefaultResponse400 tname where - name = symbolVal (Proxy :: Proxy sym) + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) param = mempty - & paramName .~ Text.pack name - & paramSchema .~ ParamOther (mempty - & paramOtherSchemaIn .~ ParamQuery - & parameterSchema .~ (mempty - & schemaType .~ SwaggerArray - & schemaItems ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a)))) + & name .~ tname + & schema .~ ParamOther (mempty + & in_ .~ ParamQuery + & paramSchema .~ (mempty + & type_ .~ SwaggerArray + & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a)))) instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) & addParam param - & addDefaultResponse400 (Text.pack name) + & addDefaultResponse400 tname where - name = symbolVal (Proxy :: Proxy sym) + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) param = mempty - & paramName .~ Text.pack name - & paramSchema .~ ParamOther (mempty - & paramOtherSchemaIn .~ ParamQuery - & paramOtherSchemaAllowEmptyValue ?~ True - & parameterSchema .~ (toParamSchema (Proxy :: Proxy Bool) - & schemaDefault ?~ toJSON False)) + & name .~ tname + & schema .~ ParamOther (mempty + & in_ .~ ParamQuery + & allowEmptyValue ?~ True + & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool) + & default_ ?~ toJSON False)) instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (Header sym a :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) & addParam param - & addDefaultResponse400 (Text.pack name) + & addDefaultResponse400 tname where - name = symbolVal (Proxy :: Proxy sym) + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) param = mempty - & paramName .~ Text.pack name - & paramSchema .~ ParamOther (mempty - & paramOtherSchemaIn .~ ParamHeader - & parameterSchema .~ toParamSchema (Proxy :: Proxy a)) + & name .~ tname + & schema .~ ParamOther (mempty + & in_ .~ ParamHeader + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) instance (ToSchema a, AllAccept cs, HasSwagger sub) => HasSwagger (ReqBody cs a :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) & addParam param & addConsumes (allContentType (Proxy :: Proxy cs)) - & addDefaultResponse400 name + & addDefaultResponse400 tname & definitions %~ (<> defs) where - name = "body" + tname = "body" (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty param = mempty - & paramName .~ "body" - & paramRequired ?~ True - & paramSchema .~ ParamBody ref + & name .~ tname + & required ?~ True + & schema .~ ParamBody ref -- ======================================================================= -- Below are the definitions that should be in Servant.API.ContentTypes @@ -331,10 +306,10 @@ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header) instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where - toResponseHeader _ = (hname, Swagger.Header Nothing schema) + toResponseHeader _ = (hname, Swagger.Header Nothing hschema) where hname = Text.pack (symbolVal (Proxy :: Proxy sym)) - schema = toParamSchema (Proxy :: Proxy a) + hschema = toParamSchema (Proxy :: Proxy a) class AllToResponseHeader hs where toAllResponseHeaders :: Proxy hs -> HashMap HeaderName Swagger.Header @@ -343,45 +318,10 @@ toAllResponseHeaders _ = mempty instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where - toAllResponseHeaders _ = HashMap.insert name header headers + toAllResponseHeaders _ = HashMap.insert hname header hdrs where - (name, header) = toResponseHeader (Proxy :: Proxy h) - headers = toAllResponseHeaders (Proxy :: Proxy hs) + (hname, header) = toResponseHeader (Proxy :: Proxy h) + hdrs = toAllResponseHeaders (Proxy :: Proxy hs) instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) - --- | Check that every element of @xs@ is an endpoint of @api@. -type family AllIsElem xs api :: Constraint where - AllIsElem '[] api = () - AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api) - --- | Apply @(e :>)@ to every API in @xs@. -type family MapSub e xs where - MapSub e '[] = '[] - MapSub e (x ': xs) = (e :> x) ': MapSub e xs - --- | Append two type-level lists. -type family AppendList xs ys where - AppendList '[] ys = ys - AppendList (x ': xs) ys = x ': AppendList xs ys - --- | Build a list of endpoints from an API. -type family EndpointsList api where - EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) - EndpointsList (e :> a) = MapSub e (EndpointsList a) - EndpointsList a = '[a] - --- | Check whether @sub@ is a sub API of @api@. -type family IsSubAPI sub api :: Constraint where - IsSubAPI sub api = AllIsElem (EndpointsList sub) api - -type family Or (a :: Constraint) (b :: Constraint) :: Constraint where - Or () b = () - Or a () = () - -type family IsIn sub api :: Constraint where - IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b) - IsIn (e :> a) (e :> b) = IsIn a b - IsIn e e = () - diff --git a/src/Servant/Swagger/Internal/Test.hs b/src/Servant/Swagger/Internal/Test.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/Internal/Test.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Swagger.Internal.Test where + +import Data.Aeson (ToJSON) +import Data.Swagger +import Data.Swagger.Internal (Pattern) +import Data.Text (Text) +import Data.Typeable +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Arbitrary) + +import Servant.API +import Servant.Swagger.Internal.TypeLevel + +-- $setup +-- >>> import GHC.Generics +-- >>> import Test.QuickCheck +-- >>> :set -XDeriveGeneric +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> :set -XDataKinds +-- >>> :set -XTypeOperators + +-- | Verify that every type used with @'JSON'@ content type in a servant API +-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@. +-- +-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation. +-- See @'validateEveryToJSONWithPatternChecker'@. +-- +-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API. +-- Each type only gets one test, even if it occurs multiple times in the API. +-- +-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable) +-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary) +-- >>> instance ToJSON User +-- >>> instance ToSchema User +-- >>> instance ToSchema UserId +-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary +-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId) +-- +-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI) +-- +-- ToJSON matches ToSchema +-- User +-- UserId +-- +-- Finished in ... seconds +-- 2 examples, 0 failures +-- +-- For the test to compile all body types should have the following instances: +-- +-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation; +-- * @'Typeable'@ is used to name the test for each type; +-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@. +-- * @'Arbitrary'@ is used to arbitrarily generate values. +-- +-- If any of the instances is missing, you'll get a descriptive type error: +-- +-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic) +-- >>> instance ToJSON Contact +-- >>> instance ToSchema Contact +-- >>> type ContactAPI = Get '[JSON] Contact +-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI) +-- ... +-- No instance for (Arbitrary Contact) +-- arising from a use of ‘validateEveryToJSON’ +-- ... +validateEveryToJSON :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) => + proxy api -- ^ Servant API. + -> Spec +validateEveryToJSON _ = props + (Proxy :: Proxy [ToJSON, ToSchema]) + (null . validateToJSON) + (Proxy :: Proxy (BodyTypes JSON api)) + +-- | Verify that every type used with @'JSON'@ content type in a servant API +-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@. +-- +-- For validation without patterns see @'validateEveryToJSON'@. +validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) => + (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker. + -> proxy api -- ^ Servant API. + -> Spec +validateEveryToJSONWithPatternChecker checker _ = props + (Proxy :: Proxy [ToJSON, ToSchema]) + (null . validateToJSONWithPatternChecker checker) + (Proxy :: Proxy (BodyTypes JSON api)) + +-- * QuickCheck-related stuff + +-- | Construct property tests for each type in a list. +-- The name for each property is the name of the corresponding type. +-- +-- >>> :{ +-- hspec $ +-- context "read . show == id" $ +-- props +-- (Proxy :: Proxy [Eq, Show, Read]) +-- (\x -> read (show x) == x) +-- (Proxy :: Proxy [Bool, Int, String]) +-- :} +-- +-- read . show == id +-- Bool +-- Int +-- [Char] +-- +-- Finished in ... seconds +-- 3 examples, 0 failures +props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs => + p cs -- ^ A list of constraints. + -> (forall x. EveryTF cs x => x -> Bool) -- ^ Property predicate. + -> p'' xs -- ^ A list of types. + -> Spec +props _ f px = sequence_ specs + where + specs :: [Spec] + specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px + + aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec + aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Bool) + diff --git a/src/Servant/Swagger/Internal/TypeLevel.hs b/src/Servant/Swagger/Internal/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/Internal/TypeLevel.hs @@ -0,0 +1,9 @@ +module Servant.Swagger.Internal.TypeLevel ( + module Servant.Swagger.Internal.TypeLevel.API, + module Servant.Swagger.Internal.TypeLevel.Every, + module Servant.Swagger.Internal.TypeLevel.TMap, +) where + +import Servant.Swagger.Internal.TypeLevel.API +import Servant.Swagger.Internal.TypeLevel.Every +import Servant.Swagger.Internal.TypeLevel.TMap diff --git a/src/Servant/Swagger/Internal/TypeLevel/API.hs b/src/Servant/Swagger/Internal/TypeLevel/API.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/Internal/TypeLevel/API.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Swagger.Internal.TypeLevel.API where + +import Data.Type.Bool (If) +import Servant.API +import GHC.Exts (Constraint) + +-- | Build a list of endpoints from an API. +type family EndpointsList api where + EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) + EndpointsList (e :> a) = MapSub e (EndpointsList a) + EndpointsList a = '[a] + +-- | Check whether @sub@ is a sub API of @api@. +type family IsSubAPI sub api :: Constraint where + IsSubAPI sub api = AllIsElem (EndpointsList sub) api + +-- | Check that every element of @xs@ is an endpoint of @api@. +type family AllIsElem xs api :: Constraint where + AllIsElem '[] api = () + AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api) + +-- | Apply @(e :>)@ to every API in @xs@. +type family MapSub e xs where + MapSub e '[] = '[] + MapSub e (x ': xs) = (e :> x) ': MapSub e xs + +-- | Append two type-level lists. +type family AppendList xs ys where + AppendList '[] ys = ys + AppendList (x ': xs) ys = x ': AppendList xs ys + +type family Or (a :: Constraint) (b :: Constraint) :: Constraint where + Or () b = () + Or a () = () + +type family IsIn sub api :: Constraint where + IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b) + IsIn (e :> a) (e :> b) = IsIn a b + IsIn e e = () + +-- | Check whether a type is a member of a list of types. +-- This is a type-level analogue of @'elem'@. +type family Elem x xs where + Elem x '[] = 'False + Elem x (x ': xs) = 'True + Elem x (y ': xs) = Elem x xs + +-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@ +-- only if @c@ is in @cs@ and @a@ is not in @as@. +-- This allows to build a list of unique body types. +type AddBodyType c cs a as = If (Elem c cs) (Insert a as) as + +-- | Insert type @x@ into a type list @xs@ only if it is not already there. +type Insert x xs = If (Elem x xs) xs (x ': xs) + +-- | Merge two lists, ignoring any type in @xs@ which occurs also in @ys@. +type family Merge xs ys where + Merge '[] ys = ys + Merge (x ': xs) ys = Insert x (Merge xs ys) + +-- | Extract a list of unique "body" types for a specific content-type from a servant API. +type family BodyTypes c api :: [*] where + BodyTypes c (Delete cs (Headers hdrs a)) = AddBodyType c cs a '[] + BodyTypes c (Get cs (Headers hdrs a)) = AddBodyType c cs a '[] + BodyTypes c (Patch cs (Headers hdrs a)) = AddBodyType c cs a '[] + BodyTypes c (Post cs (Headers hdrs a)) = AddBodyType c cs a '[] + BodyTypes c (Put cs (Headers hdrs a)) = AddBodyType c cs a '[] + BodyTypes c (Delete cs a) = AddBodyType c cs a '[] + BodyTypes c (Get cs a) = AddBodyType c cs a '[] + BodyTypes c (Patch cs a) = AddBodyType c cs a '[] + BodyTypes c (Post cs a) = AddBodyType c cs a '[] + BodyTypes c (Put cs a) = AddBodyType c cs a '[] + BodyTypes c (ReqBody cs a :> api) = AddBodyType c cs a (BodyTypes c api) + BodyTypes c (e :> api) = BodyTypes c api + BodyTypes c (a :<|> b) = Merge (BodyTypes c a) (BodyTypes c b) + diff --git a/src/Servant/Swagger/Internal/TypeLevel/Every.hs b/src/Servant/Swagger/Internal/TypeLevel/Every.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/Internal/TypeLevel/Every.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Swagger.Internal.TypeLevel.Every where + +import Data.Proxy +import GHC.Exts (Constraint) + +import Servant.Swagger.Internal.TypeLevel.TMap + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XFlexibleContexts +-- >>> :set -XGADTs +-- >>> :set -XRankNTypes +-- >>> :set -XScopedTypeVariables +-- >>> import GHC.TypeLits +-- >>> import Data.List + +-- | Apply multiple constraint constructors to a type. +-- +-- @ +-- EveryTF '[Show, Read] a ~ (Show a, Read a) +-- @ +-- +-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@. +-- +-- For partial application of multiple constraint constructors see @'Every'@. +type family EveryTF cs x :: Constraint where + EveryTF '[] x = () + EveryTF (c ': cs) x = (c x, EveryTF cs x) + +-- | Apply multiple constraint constructors to a type as a class. +-- +-- This is different from @'EveryTF'@ in that it allows partial application. +class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where + +instance Every '[] x where +instance (c x, Every cs x) => Every (c ': cs) x where + +-- | Like @'tmap'@, but uses @'Every'@ for multiple constraints. +-- +-- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a) +-- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) +-- ["0","0.0"] +tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) => + p cs -> (forall x p'. EveryTF cs x => p' x -> a) -> p'' xs -> [a] +tmapEvery _ = tmap (Proxy :: Proxy (Every cs)) + diff --git a/src/Servant/Swagger/Internal/TypeLevel/TMap.hs b/src/Servant/Swagger/Internal/TypeLevel/TMap.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/Internal/TypeLevel/TMap.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Swagger.Internal.TypeLevel.TMap where + +import Data.Proxy +import GHC.Exts (Constraint) + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XFlexibleContexts +-- >>> :set -XGADTs +-- >>> :set -XRankNTypes +-- >>> :set -XScopedTypeVariables +-- >>> import GHC.TypeLits +-- >>> import Data.List + +-- | Map a list of constrained types to a list of values. +-- +-- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"]) +-- ["hello","world"] +class TMap (q :: k -> Constraint) (xs :: [k]) where + tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a] + +instance TMap q '[] where + tmap _ _ _ = [] + +instance (q x, TMap q xs) => TMap q (x ': xs) where + tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs) + diff --git a/src/Servant/Swagger/Test.hs b/src/Servant/Swagger/Test.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/Test.hs @@ -0,0 +1,13 @@ +-- | +-- Module: Servant.Swagger.Test +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Automatic tests for servant API against Swagger spec. +module Servant.Swagger.Test ( + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, +) where + +import Servant.Swagger.Internal.Test diff --git a/src/Servant/Swagger/TypeLevel.hs b/src/Servant/Swagger/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Swagger/TypeLevel.hs @@ -0,0 +1,15 @@ +-- | +-- Module: Servant.Swagger.TypeLevel +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Useful type families for servant APIs. +module Servant.Swagger.TypeLevel ( + IsSubAPI, + EndpointsList, + BodyTypes, +) where + +import Servant.Swagger.Internal.TypeLevel + diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doctest + diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs --- a/test/Servant/SwaggerSpec.hs +++ b/test/Servant/SwaggerSpec.hs @@ -14,12 +14,11 @@ import Data.Proxy import Data.Swagger import Data.Text (Text) -import qualified Data.Text as Text import Data.Time import GHC.Generics import Servant.API import Servant.Swagger -import Test.Hspec +import Test.Hspec hiding (example) checkAPI :: HasSwagger api => Proxy api -> Value -> IO () checkAPI proxy = checkSwagger (toSwagger proxy) @@ -41,9 +40,9 @@ -- ======================================================================= data Todo = Todo - { created :: UTCTime - , title :: String - , description :: Maybe String + { created :: UTCTime + , title :: String + , summary :: Maybe String } deriving (Generic, FromJSON, ToSchema) newtype TodoId = TodoId String deriving (Generic, ToParamSchema) @@ -69,7 +68,7 @@ { "created": { "$ref": "#/definitions/UTCTime" }, "title": { "type": "string" }, - "description": { "type": "string" } + "summary": { "type": "string" } } }, "UTCTime": @@ -138,12 +137,10 @@ toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" } instance ToSchema UserSummary where - declareNamedSchema proxy = do - (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy - return (name, schema - & schemaExample ?~ toJSON UserSummary + declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy + & mapped.schema.example ?~ toJSON UserSummary { summaryUsername = "JohnDoe" - , summaryUserid = 123 }) + , summaryUserid = 123 } type Group = Text @@ -159,13 +156,10 @@ hackageSwaggerWithTags :: Swagger hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI) & host ?~ Host "hackage.haskell.org" Nothing - & usersOps %~ addTag "users" - & packagesOps %~ addTag "packages" - & tags .~ - [ Tag "users" (Just "Operations about user") Nothing - , Tag "packages" (Just "Query packages") Nothing - ] + & applyTagsFor usersOps ["users" & description ?~ "Operations about user"] + & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"] where + usersOps, packagesOps :: Traversal' Swagger Operation usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI) @@ -311,12 +305,12 @@ }, "tags":[ { - "name":"users", - "description":"Operations about user" - }, - { "name":"packages", "description":"Query packages" + }, + { + "name":"users", + "description":"Operations about user" } ] } @@ -331,10 +325,9 @@ getPostSwagger :: Swagger getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI) - & getOps %~ addTag "get" - & tags .~ - [ Tag "get" (Just "GET operations") Nothing ] + & applyTagsFor getOps ["get" & description ?~ "GET operations"] where + getOps :: Traversal' Swagger Operation getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI) getPostAPI :: Value