packages feed

servant-swagger 0.1.2 → 1.0

raw patch · 24 files changed

+912/−509 lines, 24 filesdep +Globdep +QuickCheckdep +doctestdep ~basedep ~swagger2

Dependencies added: Glob, QuickCheck, doctest

Dependency ranges changed: base, swagger2

Files

+ CHANGELOG.md view
@@ -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.
LICENSE view
@@ -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
README.md view
@@ -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) -<hr>--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).
− example/File.hs 
@@ -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)-
+ example/LICENSE view
@@ -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.+
− example/Server.hs 
@@ -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-
example/example.cabal view
@@ -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+
+ example/server/Main.hs view
@@ -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+
+ example/src/Todo.hs view
@@ -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"+
+ example/swagger.json view
@@ -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"]}}}}
+ example/test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ example/test/TodoSpec.hs view
@@ -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
servant-swagger.cabal view
@@ -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:
src/Servant/Swagger.hs view
@@ -1,14 +1,178 @@+-- |+-- Module:      Servant.Swagger+-- License:     BSD3+-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>+-- 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 <http://swagger.io/ Swagger™ documentation>. 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)+-- <BLANKLINE>+-- [User]+-- User+-- UserId+-- <BLANKLINE>+-- 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 <example/test/TodoSpec.hs TodoSpec.hs> 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 <example/src/Todo.hs Todo.hs> for an example of a server.
src/Servant/Swagger/Internal.hs view
@@ -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 <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.+--+-- 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 = ()-
+ src/Servant/Swagger/Internal/Test.hs view
@@ -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)+-- <BLANKLINE>+-- ToJSON matches ToSchema+--   User+--   UserId+-- <BLANKLINE>+-- 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])+-- :}+-- <BLANKLINE>+-- read . show == id+--   Bool+--   Int+--   [Char]+-- <BLANKLINE>+-- 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)+
+ src/Servant/Swagger/Internal/TypeLevel.hs view
@@ -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
+ src/Servant/Swagger/Internal/TypeLevel/API.hs view
@@ -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)+
+ src/Servant/Swagger/Internal/TypeLevel/Every.hs view
@@ -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))+
+ src/Servant/Swagger/Internal/TypeLevel/TMap.hs view
@@ -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)+
+ src/Servant/Swagger/Test.hs view
@@ -0,0 +1,13 @@+-- |+-- Module:      Servant.Swagger.Test+-- License:     BSD3+-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability:   experimental+--+-- Automatic tests for servant API against Swagger spec.+module Servant.Swagger.Test (+  validateEveryToJSON,+  validateEveryToJSONWithPatternChecker,+) where++import Servant.Swagger.Internal.Test
+ src/Servant/Swagger/TypeLevel.hs view
@@ -0,0 +1,15 @@+-- |+-- Module:      Servant.Swagger.TypeLevel+-- License:     BSD3+-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability:   experimental+--+-- Useful type families for servant APIs.+module Servant.Swagger.TypeLevel (+  IsSubAPI,+  EndpointsList,+  BodyTypes,+) where++import Servant.Swagger.Internal.TypeLevel+
+ test/DocTest.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doctest+
test/Servant/SwaggerSpec.hs view
@@ -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