diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -0,0 +1,28 @@
+Copyright (c) 2015-2016, David Johnson
+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/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,166 @@
+
+
+
+ This project converts servant APIs into Swagger 2.0 conforming JSON.
+
+
+
+ 
+
+
+
+
+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
+
+-- 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)
+```
+
+### Output
+
+```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"
+ }
+ ]
+ }
+ }
+ }
+}
+```
+
+## Try it out
+
+All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).
+
+Ready-to-use specification can be served as JSON and interactive API documentation
+can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).
+
+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/).
+
+## FAQ
+- Q: How is this project different from the `swagger` package on `hackage` ?
+ - A: This package is based on the latest Swagger 2.0 API
+
+## 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).
+
diff --git a/example/File.hs b/example/File.hs
new file mode 100644
--- /dev/null
+++ b/example/File.hs
@@ -0,0 +1,51 @@
+{-# 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/Server.hs b/example/Server.hs
new file mode 100644
--- /dev/null
+++ b/example/Server.hs
@@ -0,0 +1,81 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/example/example.cabal
@@ -0,0 +1,42 @@
+name: example
+version: 0.1.0.0
+synopsis: Example usage
+description: Example usage
+license: BSD3
+license-file: LICENSE
+author: David Johnson
+maintainer: djohnson.m@gmail.com
+copyright: David Johnson (c) 2015-2016
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable swagger-server
+ main-is: Server.hs
+ build-depends:
+ base
+ , aeson
+ , bytestring == 0.10.*
+ , servant
+ , either
+ , servant-server
+ , servant-swagger
+ , swagger2
+ , lens
+ , wai
+ , warp
+ default-language: Haskell2010
+
+executable swagger-file
+ main-is: File.hs
+ build-depends:
+ base
+ , aeson
+ , bytestring == 0.10.*
+ , servant
+ , swagger2
+ , either
+ , servant-server
+ , servant-swagger
+ , lens
+ default-language: Haskell2010
diff --git a/servant-swagger.cabal b/servant-swagger.cabal
--- a/servant-swagger.cabal
+++ b/servant-swagger.cabal
@@ -1,7 +1,9 @@
name: servant-swagger
-version: 0.0.0.1
-synopsis: Swagger
-description: Swagger
+version: 0.1
+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
license: BSD3
license-file: LICENSE
author: David Johnson
@@ -10,40 +12,48 @@
category: Web
build-type: Simple
cabal-version: >=1.10
-description: This is an experimental release, this API is subject to change at any moment.
+extra-source-files:
+ README.md
+ , example/*.hs
+ , example/*.cabal
source-repository head
type: git
- location: git://github.com/dmjio/servant-swagger.git
+ location: https://github.com/dmjio/servant-swagger.git
library
ghc-options: -Wall
- exposed-modules: Servant.Swagger
- other-modules: Servant.Swagger.Internal
- default-extensions:
- FlexibleContexts
- , DeriveGeneric
- , DeriveDataTypeable
- , GeneralizedNewtypeDeriving
- , RecordWildCards
- , FlexibleInstances
- , OverloadedLists
- , PolyKinds
- , OverloadedStrings
- , TypeFamilies
- , KindSignatures
- , TypeOperators
- , CPP
- , DataKinds
+ exposed-modules:
+ Servant.Swagger
+ Servant.Swagger.Internal
hs-source-dirs: src
build-depends: aeson
, base >=4.7 && <5
, bytestring
- , containers
- , hashable
+ , http-media
, lens
- , text
- , uuid
, servant
+ , swagger2
+ , text
, unordered-containers
default-language: Haskell2010
+
+test-suite spec
+ ghc-options: -Wall
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Spec.hs
+ build-depends: base == 4.*
+ , aeson
+ , aeson-qq
+ , hspec
+ , lens
+ , servant
+ , servant-swagger
+ , swagger2
+ , text
+ , time
+ other-modules:
+ Servant.SwaggerSpec
+ default-language: Haskell2010
+
diff --git a/src/Servant/Swagger.hs b/src/Servant/Swagger.hs
--- a/src/Servant/Swagger.hs
+++ b/src/Servant/Swagger.hs
@@ -1,108 +1,14 @@
-module Servant.Swagger
- (
- -- * Classes
- HasSwagger (..)
- , ToSwaggerDescription (..)
- , ToHeader (..)
- , ToSwaggerParamType (..)
- , SwaggerParamType (..)
- , ToSwaggerModel (..)
- , ToHeaderDescription (..)
- , ToModelExample (..)
- -- * Types
- , APIDescription (..)
- , Contact (..)
- , ContactName (..)
- , ContactURL (..)
- , ContactEmail (..)
- , TermsOfService (..)
- , SwaggerAPI (..)
- , SwaggerOperation (..)
- , SwaggerRouteInfo (..)
- , Operation (..)
- , Code (..)
- , Verb (..)
- , PathSummary (..)
- , SwaggerType (..)
- , SwaggerModel (..)
- , Info (..)
- , ModelName (..)
- , ContentType (..)
- , APIVersion (..)
- , APITitle (..)
- , APILicense (..)
- , Scheme (..)
- , Description (..)
- , BasePath (..)
- , Response (..)
- , ModelSwag (..)
- , SwaggerHeader (..)
- , responseDescription
- , responseModelName
- , responseHeaders
- , responseIsArray
- , responseCode
- , defResponse
- , Tag (..)
- , TagName (..)
- , TagDescription (..)
- , tagName
- , tagDescription
- -- * Swaggadelic
- , swagger
- , emptyModel
- , swaggerPathInfo
- , emptyRouteDescription
- -- * Lenses
- , swagModelName
- , swagModelExample
- , swagProperties
- , swagModelRequired
- , swagDescription
- , swagRouteTags
- , swagRouteSummary
- , swagRouteResponses
- , swagRouteModels
- , PathDescription (..)
- , swagRouteDescription
- , OperationId (..)
- , swagRouteOperationId
- , defSwaggerInfo
- , createSwaggerJson
- , swaggerInfoTitle
- , swaggerVersion
- , swaggerAPIDescription
- , license
- , contact
- , termsOfService
- ) where
-
-import Servant.Swagger.Internal
-import Data.Proxy
-import Data.Monoid
-import Control.Lens
-
-swagger
- :: HasSwagger swagger
- => Proxy swagger
- -> SwaggerRouteInfo swagger
- -> BasePath
- -> Info
- -> [Scheme]
- -> Maybe HostName
- -> [SecurityDefinition]
- -> SwaggerAPI
-swagger proxy (SwaggerRouteInfo routeInfo) basePath info schemes hostName secDefs = do
- let result@SwagResult{..} = routeInfo <> toSwaggerDocs proxy defSwaggerRoute
- defSwaggerAPI info
- & swaggerPaths .~ _resultPaths
- & swaggerSchemes ?~ schemes
- & swaggerDefinitions .~ _resultModels
- & swaggerTags ?~ getAllTags result
- & swaggerBasePath ?~ basePath
- & swaggerHostName .~ hostName
- & swaggerSecurityDefintions ?~ secDefs
+module Servant.Swagger (
+ HasSwagger(..),
+ addTag,
+ subOperations,
+ setResponse,
+ ToResponseHeader(..),
+ AllAccept,
+ AllToResponseHeader,
+) where
+import Servant.Swagger.Internal
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
@@ -1,985 +1,362 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ConstraintKinds #-}
-#if !MIN_VERSION_base(4,8,0)
-{-# LANGUAGE OverlappingInstances #-}
-#endif
-------------------------------------------------------------------------------
-module Servant.Swagger.Internal where
-------------------------------------------------------------------------------
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Data.Text (Text)
-import Data.Aeson
-import Data.Aeson.Types ( typeMismatch )
-import qualified Data.Set as S
-import Data.Hashable
-import Data.List
-import Data.Maybe
-import Data.Data
-import qualified Data.ByteString.Lazy.Char8 as BL8
-import qualified Data.ByteString.Char8 as B8
-import Data.Bool
-import GHC.Generics
-import Data.String
-import Control.Lens hiding ((.=))
-import qualified Data.HashMap.Strict as HM
-import Data.Monoid
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as L
-import GHC.TypeLits
-import Servant.API hiding (Header)
-import qualified Servant.API.Header as H
-import qualified Data.UUID as UUID
-
--- | Helper to generate swagger.json file
-createSwaggerJson :: SwaggerAPI -> IO ()
-createSwaggerJson = BL8.writeFile "swagger.json" . encode
-
--- | This is the root document object for the API specification.
-data SwaggerAPI = SwaggerAPI {
- _swaggerInfo :: Info -- ^ Required, provides metadata about the API
- , _swaggerPaths :: HM.HashMap PathName SwaggerOperation -- ^ Required
- , _swaggerSchemes :: Maybe [Scheme] -- ^ Schemes for this API (i.e HTTP/HTTPS)
- , _swaggerDefinitions :: HM.HashMap ModelName SwaggerModel -- ^
- , _swaggerTags :: Maybe [Tag] -- ^ A list of tags that provide additional metadat
- , _swaggerBasePath :: Maybe BasePath -- ^ The base path upon which this API is served
- , _swaggerHostName :: Maybe HostName -- ^ Host name or IP
- , _swaggerSecurityDefintions :: Maybe [SecurityDefinition]
- -- ^ Security scheme definitions that can be used across the specification.
- , _swaggerExternalDocs :: Maybe ExternalDocs
- } deriving Show
-
--- | Smart Constructor for `SwaggerAPI`
-defSwaggerAPI :: Info -> SwaggerAPI
-defSwaggerAPI info = SwaggerAPI info mempty mempty mempty mempty mempty mempty mempty mempty
-
--- | `ToJSON` for `SwaggerAPI`
-instance ToJSON SwaggerAPI where
- toJSON SwaggerAPI{..} =
- object $ [
- "swagger" .= ("2.0" :: Text)
- , "info" .= _swaggerInfo
- , "paths" .= do Object $ HM.fromList $ map f $ HM.toList _swaggerPaths
- , "definitions" .= do Object $ HM.fromList $ map g $ HM.toList _swaggerDefinitions
- ] ++
- [ "host" .= _swaggerHostName | isJust _swaggerHostName ] ++
- [ "schemes" .= _swaggerSchemes | isJust _swaggerSchemes ] ++
- [ "basePath" .= _swaggerBasePath | isJust _swaggerBasePath ] ++
- [ "externalDocs" .= _swaggerExternalDocs | isJust _swaggerExternalDocs ] ++
- [ "tags" .= _swaggerTags | isJust _swaggerTags ]
- where
- f (PathName pathName, sp) = (T.toLower pathName, toJSON sp)
- g (ModelName modelName, model) = (modelName, toJSON model)
-
-data ExternalDocs = ExternalDocs {
- _externalDescription :: Maybe ExternalDescription -- ^ Optional Description
- , _externalURL :: ExternalURL -- ^ Required URL that links supporting documentation
- } deriving (Show, Eq)
-
-instance ToJSON ExternalDocs where
- toJSON ExternalDocs{..} =
- object $ [ "url" .= _externalURL ] ++
- [ "description" .= _externalDescription
- | isJust _externalDescription
- ]
-
-instance Monoid ExternalDocs where
- mempty = ExternalDocs mempty mempty
- (ExternalDocs a1 b1) `mappend` (ExternalDocs a2 b2)
- = ExternalDocs (a1 <> a2) (b1 <> b2)
-
--- | External Description for External Documentation API
-newtype ExternalDescription = ExternalDescription Text
- deriving (Show, Eq, Monoid, ToJSON)
-
--- | External Description for External Documentation API
-newtype ExternalURL = ExternalURL Text
- deriving (Show, Eq, Monoid, ToJSON)
-
--- | Type used to accumulate information of a Servant path
-data SwaggerRoute = SwaggerRoute {
- _routePathName :: PathName -- ^ Accumulated `PathName`
- , _routeConsumes :: [ContentType] -- ^ Content Types a route consumes
- , _routeModels :: HM.HashMap ModelName SwaggerModel -- ^ Models present in route
- , _routeParams :: [Param] -- ^ Params present in route
- , _routeVerb :: Verb -- ^ Verb of route
- , _routePathSummary :: PathSummary -- ^ Summary of path
- , _routeResponses :: HM.HashMap Text Response -- ^ Additional responses for a Route
- , _routeTags :: [Tag] -- ^ Tags present for this Route
- } deriving Show
-
--- | Default Route used to build up
-defSwaggerRoute :: SwaggerRoute
-defSwaggerRoute = SwaggerRoute mempty [] [] [] Get mempty [] []
-
--- | Default
---
-defSwaggerInfo :: Info
-defSwaggerInfo =
- Info (APITitle mempty)
- (APIVersion "2.0") (APIDescription mempty) Nothing Nothing Nothing
-
--- | Contact name of `Contact` object
-newtype ContactName = ContactName Text
- deriving (Show, Eq, ToJSON, FromJSON, Ord, Monoid)
-
--- | Contact URL of `Contact` object
-newtype ContactURL = ContactURL Text
- deriving (Show, Eq, ToJSON, FromJSON, Ord, Monoid)
-
--- | Contact Email of `Contact` object
-newtype ContactEmail = ContactEmail Text
- deriving (Show, Eq, ToJSON, FromJSON, Ord, Monoid)
-
--- | Contact Object
-data Contact = Contact {
- _contactName :: ContactName
- , _contactURL :: ContactURL
- , _contactEmail :: ContactEmail
- } deriving (Show, Eq, Ord)
-
-instance Monoid Contact where
- mempty = Contact mempty mempty mempty
- (Contact a1 b1 c1) `mappend` (Contact a2 b2 c2) =
- Contact (a1 <> a2) (b1 <> b2) (c1 <> c2)
-
--- | Contact Object
-instance ToJSON Contact where
- toJSON Contact{..} =
- object [
- "name" .= _contactName
- , "url" .= _contactURL
- , "email" .= _contactEmail
- ]
-
--- | Description of API
-newtype APIDescription = APIDescription { _unApiDesc :: Text }
- deriving (Show, Eq, ToJSON, Monoid)
-
--- | Terms of Service of API located in `Info`
-newtype TermsOfService = TermsOfService Text
- deriving (Show, Eq, ToJSON, Monoid)
-
--- | A Swagger metadata for a Servant header
-data SwaggerHeader = SwaggerHeader {
- headerDescription :: Text -- ^ Header description
- , headerType :: SwaggerParamType -- ^ Type of Header
- , headerName :: Text -- ^ Name of Header
- } deriving (Show, Eq)
-
--- | A container for the expected responses of an operation.
-data Response = Response {
- _responseDescription :: Text -- ^ Description of Response
- , _responseModelName :: ModelName -- ^ `Model` this Response returns
- , _responseHeaders :: HM.HashMap Text SwaggerHeader -- ^ HashMap of headers
- , _responseIsArray :: Bool -- ^ Does the response return an Array?
- , _responseCode :: Code -- ^ Response code this route returns
- } deriving (Show, Eq)
-
--- | Default Response for a Path
-defResponse :: Response
-defResponse = Response mempty (ModelName mempty) mempty False (Code 200)
-
--- | Name of `Tag`, that can be applied to an operation
-newtype TagName = TagName Text deriving (Show, Eq, Ord, ToJSON, FromJSON)
-
--- | Description of `Tag`
-newtype TagDescription = TagDescription Text deriving (Show, Eq, Ord, ToJSON, FromJSON)
-
--- | Allows adding meta data to a single tag that is used by the Operation Object
-data Tag = Tag {
- _tagName :: TagName -- ^ Name of `Tag`
- , _tagDescription :: TagDescription -- ^ Description of `Tag`
- } deriving (Show, Eq, Ord)
-
--- | `ToJSON` `Tag` instance
-instance ToJSON Tag where
- toJSON Tag{..} = object [ "name" .= _tagName, "description" .= _tagDescription ]
-
--- | `FromJSON` `Tag` instance
-instance FromJSON Tag where
- parseJSON (Object o) = Tag <$> o .: "name" <*> o .: "description"
- parseJSON x = typeMismatch "Tag" x
-
--- | A declaration of the security schemes available to be used in the specification
-data SecurityDefinition =
- OAuthDef OAuth -- ^ OAuth
- | APIKeyDef APIKey -- ^ APIKey
- | BasicAuthDef BasicAuth -- ^ BasicAuth
- deriving Show
-
--- | Basic Authentication
-data BasicAuth = BasicAuth deriving Show
-
--- ^ OAuth Flow
-data OAuthFlow = Implicit | Password | Application | AccessCode deriving (Show)
--- ^ OAuth URL
-data OAuthURL = OAuthURL deriving (Show)
-data TokenURL = TokenURL deriving (Show)
-data Scopes = Scopes deriving (Show)
-
--- | OAuth Authentication
-data OAuth = OAuth {
- oauthDescription :: Maybe Description -- ^ Optional description for Swagger OAuth object
- , oauthFlow :: OAuthFlow -- ^ OAuth Flow
- , oauthURL :: OAuthURL -- ^ OAuth URL
- , oauthTokenURL :: TokenURL -- ^ Token URL
- , scopes :: Scopes -- ^ OAuth Scopes
- } deriving Show
-
--- | API Key
-newtype APIKeyName =
- APIKeyName Text deriving (Show, Eq)
-
--- | API Location (i.e. is it located in a Query Param or a Header)
-data APIKeyIn = APIKeyQueryParam
- | APIKeyHeader deriving (Show, Eq)
-
--- | API Key Object
-data APIKey = APIKey {
- apiKeyDescription :: Maybe Description -- ^ Optional `Description`
- , apiKeyName :: APIKeyName -- ^ Optional `Description`
- , apiKeyIn :: APIKeyIn
- } deriving Show
-
--- | API Key `ToJSON`
-instance ToJSON APIKey where
- toJSON APIKey{..} =
- object [ "api_key" .= ([] :: [Int]) ]
-
--- | HostName
-newtype HostName = HostName Text
- deriving (Show, Eq, IsString, ToJSON, FromJSON, Monoid)
-
--- | BasePath
-newtype BasePath = BasePath Text
- deriving (Show, Eq, ToJSON, FromJSON, Monoid)
-
--- | Info Objet
-data Info = Info {
- _swaggerInfoTitle :: APITitle -- ^ API Title
- , _swaggerVersion :: APIVersion -- ^ API Version
- , _swaggerAPIDescription :: APIDescription -- ^ API Description
- , _license :: Maybe APILicense -- ^ API Description
- , _contact :: Maybe Contact
- , _termsOfService :: Maybe TermsOfService
- } deriving (Show, Eq)
-
-instance Monoid Info where
- mempty = Info mempty mempty mempty mempty mempty mempty
- (Info a1 b1 c1 d1 e1 f1) `mappend` (Info a2 b2 c2 d2 e2 f2)
- = Info (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (f1 <> f2)
-
-data APILicense = APILicense {
- _licenseName :: Text
- , _licenseUrl :: Maybe Text
- } deriving (Show, Eq)
-
-instance Monoid APILicense where
- mempty = APILicense mempty mempty
- (APILicense a1 b1) `mappend` (APILicense a2 b2) = APILicense (a1 <> a2) (b1 <> b2)
-
-data SwaggerOperation = SwaggerOperation {
- _paths :: HM.HashMap Verb Operation
- } deriving Show
-
-data SwagResult = SwagResult {
- _resultPaths :: HM.HashMap PathName SwaggerOperation
- , _resultModels :: HM.HashMap ModelName SwaggerModel
- } deriving (Show)
-
-data Verb = Post | Get | Put | Options | Head | Delete | Patch
- deriving (Show, Eq, Read, Generic)
-
-newtype PathSummary = PathSummary Text
- deriving (Show, Eq, ToJSON, FromJSON, Monoid, IsString)
-
-data Operation = Operation {
- _summary :: PathSummary
- , _params :: [Param]
- , _responses :: HM.HashMap Code Response
- , _produces :: [ContentType]
- , _consumes :: [ContentType]
- , _tags :: [Tag]
- , _operationId :: Maybe OperationId
- , _description :: PathDescription
- , _deprecated :: Maybe Deprecated
- } deriving Show
-
-instance Monoid Operation where
- mempty = Operation mempty mempty mempty mempty mempty mempty mempty mempty mempty
- (Operation a1 b1 c1 d1 e1 f1 g1 h1 i1) `mappend`
- (Operation a2 b2 c2 d2 e2 f2 g2 h2 i2) =
- Operation (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (f1 <> f2) (g1 <> g2)
- (h1 <> h2) (i1 <> i2)
-
-newtype Deprecated = Deprecated Bool deriving (Show, Eq, ToJSON)
-
-instance Monoid Deprecated where
- mempty = Deprecated False
- (Deprecated False) `mappend` (Deprecated False) = Deprecated False
- _ `mappend` _ = Deprecated True
-
-newtype OperationId = OperationId Text deriving (Show, Eq, ToJSON, Monoid)
-newtype PathDescription = PathDescription Text deriving (Show, Eq, ToJSON, Monoid)
-
-newtype Code = Code Int deriving (Show, Eq, Ord, ToJSON, Hashable, Num)
-
-data SwaggerParamType =
- StringSwagParam
- | NumberSwagParam
- | IntegerSwagParam
- | BooleanSwagParam
- | ArraySwagParam
- | FileSwagParam
- deriving (Show, Eq)
-
-data SwaggerType =
- IntegerSwag
- | LongSwag
- | FloatSwag
- | DoubleSwag
- | StringSwag
- | ByteSwag
- | BinarySwag
- | BooleanSwag
- | DateSwag
- | DateTimeSwag
- | PasswordSwag
- | Model ModelSwag
- deriving (Show, Eq)
-
-data ModelSwag = ModelSwag {
- modelSwagName :: ModelName
- , modelSwagIsArray :: Bool
- } deriving (Show, Eq)
-
-data ContentType = JSON | HTML | XML | FormUrlEncoded | PlainText | OctetStream
- deriving (Show, Eq)
-
-data In = PathUrl | Query | Header | FormData | Body deriving Show
-data Scheme = Http | Https | Ws | Wss deriving Show
-
-data Param = Param {
- _in :: In
- , _name :: Text
- , _type :: Maybe SwaggerParamType
- , _items :: Maybe ItemObject
- , _paramDescription :: Text
- , _allowEmptyValue :: Bool
- , _required :: Bool
- , _default :: Maybe Value
- , _isArray :: Bool
- } deriving Show
-
-data ItemObject = ItemObject {
- _itemsType :: SwaggerParamType
- } deriving Show
-
-newtype APIVersion = APIVersion Text deriving (Show, Eq, ToJSON, Monoid)
-newtype APITitle = APITitle Text deriving (Show, Eq, ToJSON, Monoid)
-newtype PathName = PathName { unPathName :: Text }
- deriving (Show, Eq, Hashable, Monoid)
-
-newtype ModelName = ModelName { unModelName :: Text }
- deriving (Show, Eq, Hashable, Monoid)
-
-newtype Description =
- Description { unDescription :: Text } deriving (Show, Eq, ToJSON, Monoid)
-
-data SwaggerModel = SwaggerModel {
- _swagModelName :: ModelName
- , _swagProperties :: [(Text, SwaggerType)]
- , _swagDescription :: Maybe Description
- , _swagModelExample :: Maybe Value
- , _swagModelRequired :: [Text]
- } deriving (Show, Eq)
-
-emptyModel :: SwaggerModel
-emptyModel = SwaggerModel (ModelName mempty) mempty mempty Nothing mempty
-
-data SwaggerRouteDescription = SwaggerRouteDescription {
- _swagRouteTags :: [Tag] -- ^ Tags
- , _swagRouteSummary :: PathSummary -- ^ Description of this endpoint
- , _swagRouteResponses :: HM.HashMap Code Response -- ^ Additional responses for this endpoint
- , _swagRouteModels :: HM.HashMap ModelName SwaggerModel
- , _swagRouteOperationId :: Maybe OperationId
- , _swagRouteDescription :: PathDescription
- } deriving Show
-
-emptyRouteDescription :: SwaggerRouteDescription
-emptyRouteDescription = SwaggerRouteDescription mempty mempty mempty mempty mempty mempty
-
-$(makeLenses ''SwaggerModel)
-$(makeLenses ''ExternalDocs)
-$(makeLenses ''SwaggerRouteDescription)
-$(makeLenses ''SwagResult)
-$(makeLenses ''SwaggerRoute)
-$(makeLenses ''SwaggerAPI)
-$(makeLenses ''Info)
-$(makeLenses ''Contact)
-$(makeLenses ''APILicense)
-$(makeLenses ''Operation)
-$(makeLenses ''Tag)
-$(makeLenses ''Response)
-
-defExternalDocs :: ExternalURL -> ExternalDocs
-defExternalDocs url = mempty & externalURL .~ url
-
-------------------------------------------------------------------------------
--- | Swaggin'
-class HasSwagger h where
- toSwaggerDocs :: Proxy h -> SwaggerRoute -> SwagResult
-------------------------------------------------------------------------------
-class ToSwaggerDescription a where toSwaggerDescription :: Proxy a -> Text
-class ToHeader a where toHeader :: Proxy a -> SwaggerHeader
-class ToResponseHeaders as where toResponseHeaders :: Proxy as -> HM.HashMap Text SwaggerHeader
-instance ToResponseHeaders '[] where toResponseHeaders Proxy = []
-
-instance (ToHeader x, ToResponseHeaders xs) => ToResponseHeaders (x ': xs) where
- toResponseHeaders Proxy = HM.union header' (toResponseHeaders (Proxy :: Proxy xs))
- where
- header' = transHeader (toHeader (Proxy :: Proxy x))
-
-transHeader :: SwaggerHeader -> HM.HashMap Text SwaggerHeader
-transHeader r@SwaggerHeader{..} = HM.fromList [(headerName, r)]
-
-------------------------------------------------------------------------------
-instance (HasSwagger rest, KnownSymbol sym) => HasSwagger (sym :> rest) where
- toSwaggerDocs Proxy swagRoute =
- toSwaggerDocs (Proxy :: Proxy rest) $ swagRoute & routePathName %~ flip (<>) path
- where path = PathName $ "/" <> T.pack (symbolVal (Proxy :: Proxy sym))
-
-instance (HasSwagger left, HasSwagger right) => HasSwagger (left :<|> right) where
- toSwaggerDocs Proxy swagRoute =
- let swagLeft = toSwaggerDocs (Proxy :: Proxy left) swagRoute
- swagRight = toSwaggerDocs (Proxy :: Proxy right) swagRoute
- paths = HM.unionWith f (swagLeft ^. resultPaths) (swagRight ^. resultPaths)
- models = HM.union (swagLeft ^. resultModels) (swagRight ^. resultModels)
- in SwagResult paths models
- where f (SwaggerOperation l) (SwaggerOperation r) = SwaggerOperation (HM.union l r)
-
-class ToSwaggerParamType a where toSwaggerParamType :: Proxy a -> SwaggerParamType
-instance ToSwaggerParamType Int where toSwaggerParamType = const IntegerSwagParam
-instance ToSwaggerParamType Integer where toSwaggerParamType = const IntegerSwagParam
-instance ToSwaggerParamType UUID.UUID where toSwaggerParamType = const StringSwagParam
-instance ToSwaggerParamType String where toSwaggerParamType = const StringSwagParam
-instance ToSwaggerParamType Text where toSwaggerParamType = const StringSwagParam
-instance ToSwaggerParamType L.Text where toSwaggerParamType = const StringSwagParam
-instance ToSwaggerParamType BL8.ByteString where toSwaggerParamType = const StringSwagParam
-instance ToSwaggerParamType B8.ByteString where toSwaggerParamType = const StringSwagParam
-instance ToSwaggerParamType Double where toSwaggerParamType = const NumberSwagParam
-instance ToSwaggerParamType Float where toSwaggerParamType = const NumberSwagParam
-instance ToSwaggerParamType Bool where toSwaggerParamType Proxy = BooleanSwagParam
-
-instance
- ToSwaggerParamType a => ToSwaggerParamType [a] where
- toSwaggerParamType _ = ArraySwagParam
-
-class ToHeaderDescription a where
- toHeaderDescription :: Proxy a -> Text
-
-instance ( ToSwaggerParamType headerType
- , KnownSymbol headerName
- , ToHeaderDescription headerName
- ) => ToHeader (H.Header headerName headerType) where
- toHeader Proxy = SwaggerHeader desc ht hn
- where
- desc = T.pack . symbolVal $ (Proxy :: Proxy headerName)
- hn = T.pack . symbolVal $ (Proxy :: Proxy headerName)
- ht = toSwaggerParamType (Proxy :: Proxy headerType)
-
-class SwaggerAccept a where toSwaggerAccept :: Proxy a -> ContentType
-instance SwaggerAccept JSON where toSwaggerAccept Proxy = JSON
-instance SwaggerAccept HTML where toSwaggerAccept Proxy = HTML
-instance SwaggerAccept XML where toSwaggerAccept Proxy = XML
-instance SwaggerAccept FormUrlEncoded where toSwaggerAccept Proxy = FormUrlEncoded
-instance SwaggerAccept PlainText where toSwaggerAccept Proxy = PlainText
-instance SwaggerAccept OctetStream where toSwaggerAccept Proxy = OctetStream
-------------------------------------------------------------------------------
-class SwaggerAcceptTypes (xs :: [*]) where toSwaggerAcceptTypes :: Proxy xs -> [ContentType]
-instance SwaggerAcceptTypes '[] where toSwaggerAcceptTypes Proxy = []
-instance (SwaggerAccept x, SwaggerAcceptTypes xs) => SwaggerAcceptTypes (x ': xs) where
- toSwaggerAcceptTypes Proxy =
- toSwaggerAccept (Proxy :: Proxy x) : toSwaggerAcceptTypes (Proxy :: Proxy xs)
-------------------------------------------------------------------------------
-class ToVerb a where toVerb :: Proxy a -> Verb
-instance ToVerb Get where toVerb Proxy = Get
-instance ToVerb Put where toVerb Proxy = Put
-instance ToVerb Patch where toVerb Proxy = Patch
-instance ToVerb Post where toVerb Proxy = Post
-instance ToVerb Delete where toVerb Proxy = Delete
-instance ToVerb Options where toVerb Proxy = Options
-
-class ToSwaggerModel a where
- toSwagModel :: Proxy a -> SwaggerModel
- toSwagModelName :: Proxy a -> ModelName
- toSwagModelName = _swagModelName . toSwagModel
- default toSwagModel :: (Generic a, GToSwaggerModel (Rep a)) => Proxy a -> SwaggerModel
- toSwagModel = undefined
-
-class GToSwaggerModel a where
- gToSwaggerModel :: Proxy a -> f a -> SwaggerModel
-
-instance ToSwaggerModel () where
- toSwagModel Proxy = emptyModel
-
-instance ToSwaggerModel SwaggerAPI where
- toSwagModel Proxy = emptyModel
-
-instance
-#if MIN_VERSION_base(4,8,0)
- {-# OVERLAPPABLe #-}
-#endif
- (ToSwaggerModel returnType, ToVerb verb, SwaggerAcceptTypes xs)
- => HasSwagger (verb xs returnType) where
- toSwaggerDocs Proxy swagRoute =
- let swagPath = SwaggerOperation [(toVerb (Proxy :: Proxy verb), path)]
- path = mempty & summary .~ swagRoute ^. routePathSummary
- & params .~ swagRoute ^. routeParams
- & responses .~ [(_responseCode response, response)]
- & produces .~ toSwaggerAcceptTypes (Proxy :: Proxy xs)
- & consumes .~ swagRoute ^. routeConsumes
- in SwagResult [(pathName, swagPath)] newModels
- where
- response = Response "OK" (swagModel ^. swagModelName) [] False 200
- pathName | swagRoute ^. routePathName == PathName "" = PathName "/"
- | otherwise = swagRoute ^. routePathName
- swagModel@SwaggerModel{..} = toSwagModel (Proxy :: Proxy returnType)
- newModels = bool (swagRoute ^. routeModels)
- (HM.insert _swagModelName swagModel (swagRoute ^. routeModels))
- (swagModel /= emptyModel)
-
-instance
-#if MIN_VERSION_base(4,8,0)
- {-# OVERLAPPABLe #-}
-#endif
- (ToSwaggerModel returnType, ToVerb verb, SwaggerAcceptTypes xs)
- => HasSwagger (verb xs [returnType]) where
- toSwaggerDocs Proxy swagRoute =
- let swagPath = SwaggerOperation [(toVerb (Proxy :: Proxy verb), path)]
- path = mempty & summary .~ swagRoute ^. routePathSummary
- & params .~ swagRoute ^. routeParams
- & responses .~ [(_responseCode response, response)]
- & produces .~ toSwaggerAcceptTypes (Proxy :: Proxy xs)
- & consumes .~ swagRoute ^. routeConsumes
- in SwagResult [(pathName, swagPath)] newModels
- where
- response = Response "OK" (swagModel ^. swagModelName) [] False 200
- pathName | swagRoute ^. routePathName == PathName "" = PathName "/"
- | otherwise = swagRoute ^. routePathName
- swagModel@SwaggerModel{..} = toSwagModel (Proxy :: Proxy returnType)
- newModels = bool (swagRoute ^. routeModels)
- (HM.insert _swagModelName swagModel (swagRoute ^. routeModels))
- (swagModel /= emptyModel)
-
-instance
-#if MIN_VERSION_base(4,8,0)
- {-# OVERLAPPING #-}
-#endif
- (ToSwaggerModel returnType, ToVerb verb, SwaggerAcceptTypes xs, ToResponseHeaders ls)
- => HasSwagger (verb xs (Headers ls [returnType])) where
- toSwaggerDocs Proxy swagRoute =
- let swagPath = SwaggerOperation [(toVerb (Proxy :: Proxy verb), path)]
- path = mempty & summary .~ swagRoute ^. routePathSummary
- & params .~ swagRoute ^. routeParams
- & responses .~ [(_responseCode response, response)]
- & produces .~ toSwaggerAcceptTypes (Proxy :: Proxy xs)
- & consumes .~ swagRoute ^. routeConsumes
- in SwagResult [(swagRoute ^. routePathName, swagPath)] newModels
- where
- response = Response "OK" (swagModel ^. swagModelName)
- (toResponseHeaders (Proxy :: Proxy ls)) True 200
- swagModel@SwaggerModel{..} = toSwagModel (Proxy :: Proxy returnType)
- newModels = bool (swagRoute ^. routeModels)
- (HM.insert _swagModelName swagModel (swagRoute ^. routeModels))
- (swagModel /= emptyModel)
-
-instance
-#if MIN_VERSION_base(4,8,0)
- {-# OVERLAPPING #-}
-#endif
- (ToSwaggerModel returnType, ToVerb verb, SwaggerAcceptTypes xs, ToResponseHeaders ls)
- => HasSwagger (verb xs (Headers ls returnType)) where
- toSwaggerDocs Proxy swagRoute =
- let swagPath = SwaggerOperation [(toVerb (Proxy :: Proxy verb), path)]
- path = mempty & summary .~ swagRoute ^. routePathSummary
- & params .~ swagRoute ^. routeParams
- & responses .~ [(_responseCode response, response)]
- & produces .~ toSwaggerAcceptTypes (Proxy :: Proxy xs)
- & consumes .~ swagRoute ^. routeConsumes
- in SwagResult [(swagRoute ^. routePathName, swagPath)] newModels
- where
- response = Response "OK" (swagModel ^. swagModelName) rspHeaders False 200
- swagModel@SwaggerModel{..} = toSwagModel (Proxy :: Proxy returnType)
- rspHeaders = (toResponseHeaders (Proxy :: Proxy ls))
- newModels = bool (swagRoute ^. routeModels)
- (HM.insert _swagModelName swagModel (swagRoute ^. routeModels))
- (swagModel /= emptyModel)
-
-instance (ToSwaggerDescription typ, ToSwaggerParamType typ, KnownSymbol sym, HasSwagger rest) =>
- HasSwagger (Capture sym typ :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- pName = T.pack $ symbolVal (Proxy :: Proxy sym)
- newPath = PathName $ mconcat ["/{",pName,"}"]
- newParam = Param PathUrl pName
- (Just $ toSwaggerParamType (Proxy :: Proxy typ)) Nothing
- (toSwaggerDescription (Proxy :: Proxy typ)) True True Nothing False
- newSwaggerRoute = swagRoute & routePathName %~ flip (<>) newPath
- & routeParams %~ (:) newParam
-
-instance (ToSwaggerDescription typ, ToSwaggerParamType typ, KnownSymbol sym, HasSwagger rest) =>
- HasSwagger (QueryParam sym typ :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- pName = T.pack $ symbolVal (Proxy :: Proxy sym)
- newParam = Param Query pName
- (Just $ toSwaggerParamType (Proxy :: Proxy typ)) Nothing
- (toSwaggerDescription (Proxy :: Proxy typ)) True False Nothing False
- newSwaggerRoute = swagRoute & routeParams %~ (:) newParam
-
-instance (ToSwaggerDescription typ, ToSwaggerParamType typ, KnownSymbol sym, HasSwagger rest) =>
- HasSwagger (QueryParams sym typ :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- ptyp = toSwaggerParamType (Proxy :: Proxy typ)
- pName = T.pack $ symbolVal (Proxy :: Proxy sym)
- newParam = Param Query pName
- (Just ArraySwagParam) (Just $ ItemObject ptyp)
- (toSwaggerDescription (Proxy :: Proxy typ)) True False Nothing True
- newSwaggerRoute = swagRoute & routeParams %~ (:) newParam
-
-------------------------------------------------------------------------------
--- | Query Flag
-instance (ToSwaggerDescription sym, KnownSymbol sym, HasSwagger rest) =>
- HasSwagger (QueryFlag sym :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- pName = T.pack $ symbolVal (Proxy :: Proxy sym)
- newParam = Param Query pName
- (Just StringSwagParam) Nothing
- (toSwaggerDescription (Proxy :: Proxy sym)) True False Nothing False
- newSwaggerRoute = swagRoute & routeParams %~ (:) newParam
-
-------------------------------------------------------------------------------
--- | Raw holds no verb / body information
-instance HasSwagger Raw where
- toSwaggerDocs Proxy swagRoute =
- SwagResult [(swagRoute ^. routePathName, mempty)] []
-
-------------------------------------------------------------------------------
--- | Swagger doesn't support Raw, bypass
-instance HasSwagger rest => HasSwagger (MatrixParam typ :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) swagRoute
-
-------------------------------------------------------------------------------
--- | Swagger doesn't support matrix flags, bypass
-instance (ToSwaggerDescription typ, ToSwaggerParamType typ, HasSwagger rest) =>
- HasSwagger (MatrixFlag typ :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) swagRoute
-
-------------------------------------------------------------------------------
--- | Swagger Header
-instance (KnownSymbol sym, ToSwaggerDescription typ, ToSwaggerParamType typ, HasSwagger rest) =>
- HasSwagger (H.Header sym typ :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- newSwaggerRoute = swagRoute & routeParams %~ (:) newParams
- pName = T.pack $ symbolVal (Proxy :: Proxy sym)
- pDesc = toSwaggerDescription (Proxy :: Proxy typ)
- typ = toSwaggerParamType (Proxy :: Proxy typ)
- newParams = Param Header pName (Just typ)
- Nothing pDesc False True Nothing False
-
-------------------------------------------------------------------------------
--- | ReqBody Object
-instance
-#if MIN_VERSION_base(4,8,0)
- {-# OVERLAPPABLe #-}
-#endif
- (SwaggerAcceptTypes ctypes, ToSwaggerModel model, HasSwagger rest) =>
- HasSwagger (ReqBody ctypes model :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- swagModel@SwaggerModel {..} = toSwagModel (Proxy :: Proxy model)
- newSwaggerRoute =
- swagRoute & routeModels %~ model
- & routeParams %~ (++) newParam
- & routeConsumes %~ (++) (toSwaggerAcceptTypes (Proxy :: Proxy ctypes))
- model | swagModel == emptyModel = (<> mempty)
- | otherwise = HM.insert _swagModelName (toSwagModel (Proxy :: Proxy model))
- newParam =
- case _swagModelName of
- (ModelName "") -> []
- name -> [ Param Body (unModelName name) Nothing Nothing
- (fromMaybe mempty (unDescription <$> _swagDescription)) True False Nothing False]
-
-------------------------------------------------------------------------------
--- | ReqBody Array
-instance
-#if MIN_VERSION_base(4,8,0)
- {-# OVERLAPPING #-}
-#endif
- (SwaggerAcceptTypes ctypes, ToSwaggerModel model, HasSwagger rest) =>
- HasSwagger (ReqBody ctypes [model] :> rest) where
- toSwaggerDocs Proxy swagRoute = toSwaggerDocs (Proxy :: Proxy rest) newSwaggerRoute
- where
- swagModel@SwaggerModel {..} = toSwagModel (Proxy :: Proxy model)
- newSwaggerRoute =
- swagRoute & routeModels %~ model
- & routeParams %~ (++) newParam
- & routeConsumes %~ (++) (toSwaggerAcceptTypes (Proxy :: Proxy ctypes))
- model | swagModel == emptyModel = (<> mempty)
- | otherwise = HM.insert _swagModelName (toSwagModel (Proxy :: Proxy model))
- newParam =
- case _swagModelName of
- (ModelName "") -> []
- name -> [ Param Body (unModelName name) Nothing Nothing
- (fromMaybe mempty (unDescription <$> _swagDescription)) True False Nothing True]
-
-class ToModelExample model where toExample :: Proxy model -> Maybe Value
-
-instance ToJSON SwaggerHeader where
- toJSON SwaggerHeader{..} =
- object [
- "type" .= headerType
- , "description" .= headerDescription
- ]
-
-instance Monoid SwaggerOperation where
- mempty = SwaggerOperation HM.empty
- SwaggerOperation a `mappend` SwaggerOperation b =
- SwaggerOperation ( a <> b )
-
-instance ToJSON APILicense where
- toJSON APILicense{..} =
- object [ "name" .= _licenseName
- , "url" .= _licenseUrl
- ]
-
-instance Hashable Verb where hash = hash . show
-
-instance ToJSON SwaggerParamType where
- toJSON StringSwagParam = String "string"
- toJSON NumberSwagParam = String "number"
- toJSON IntegerSwagParam = String "integer"
- toJSON BooleanSwagParam = String "boolean"
- toJSON ArraySwagParam = String "array"
- toJSON FileSwagParam = String "file"
-
-instance ToJSON SwaggerType where
- toJSON x =
- let f typ format = object $ [ "type" .= (typ :: Text) ] ++
- if isJust format
- then [ "format" .= ((fromJust format) :: Text) ]
- else []
- in case x of
- IntegerSwag -> f "integer" (Just "int32")
- LongSwag -> f "integer" (Just "int64")
- FloatSwag -> f "number" (Just "float")
- DoubleSwag -> f "number" (Just "double")
- StringSwag -> f "string" Nothing
- ByteSwag -> f "string" (Just "byte")
- BinarySwag -> f "string" (Just "binary")
- BooleanSwag -> f "boolean" Nothing
- DateSwag -> f "string" (Just "date")
- DateTimeSwag -> f "string" (Just "date-time")
- PasswordSwag -> f "string" (Just "password")
- Model ModelSwag{..} ->
- case modelSwagIsArray of
- True ->
- object [ "type" .= ("array" :: Text)
- , "items" .= object [
- "$ref" .= ("#/definitions/" <> unModelName modelSwagName)
- ]
- ]
- False ->
- object [
- "$ref".= ("#/definitions/"<> unModelName modelSwagName)
- ]
-
-instance ToJSON ContentType where
- toJSON JSON = String "application/json"
- toJSON XML = String "application/xml"
- toJSON FormUrlEncoded = String "application/x-www-form-urlencoded"
- toJSON HTML = String "text/html"
- toJSON PlainText = String "text/plain; charset=utf-8"
- toJSON OctetStream = String "application/octet-stream"
-
-instance ToJSON Scheme where
- toJSON Http = String "http"
- toJSON Https = String "https"
- toJSON Ws = String "ws"
- toJSON Wss = String "wss"
-
-instance ToJSON In where
- toJSON PathUrl = "path"
- toJSON Query = "query"
- toJSON Body = "body"
- toJSON Header = "header"
- toJSON FormData = "formData"
-
-instance ToJSON PathName where
- toJSON (PathName x) = String (T.toLower x)
-
-instance ToJSON SwaggerModel where
- toJSON SwaggerModel{..} =
- object $ [
- "type" .= ("object" :: Text)
- , "properties" .= HM.fromList _swagProperties
- ] ++ maybeExample ++ maybeDescription ++ requiredList
- where
- requiredList = [ "required" .= _swagModelRequired | not (null _swagModelRequired) ]
- maybeDescription = maybe [] (\(Description x) -> [ "description" .= x ]) _swagDescription
- maybeExample = maybe [] (\x -> [ "example" .= x ]) _swagModelExample
-
-setPath :: BasePath -> BasePath
-setPath (BasePath "") = BasePath "/"
-setPath (BasePath x) = BasePath x
-
-
-instance ToJSON SwaggerOperation where
- toJSON (SwaggerOperation paths) =
- Object . HM.fromList . map f . HM.toList $ paths
- where
- f (verb, sp) = (T.toLower $ toTxt verb, toJSON sp)
-
-instance ToJSON Operation where
- toJSON Operation {..} =
- object $ [ "parameters" .= _params
- , "responses" .= do Object . HM.fromList . map f . HM.toList $ _responses
- , "produces" .= _produces
- , "consumes" .= _consumes
- , "summary" .= _summary
- , "tags" .= map _tagName _tags
- , "description" .= _description
- ] ++ [ "deprecated" .= _deprecated | isJust _deprecated ]
- ++ [ "operationId" .= _operationId | isJust _operationId ]
- where f (Code x, resp) = (toTxt x, toJSON resp)
-
-instance ToJSON Response where
- toJSON Response {..} = object $ [
- "description" .= _responseDescription
- , "headers" .= _responseHeaders
- ] ++ maybeModelName
- where
- maybeModelName =
- case _responseModelName of
- (ModelName "") -> []
- (ModelName name) ->
- case _responseIsArray of
- True -> [ "schema" .= object [
- "type" .= ("array" :: Text)
- , "items" .= object [
- "$ref" .= ("#/definitions/" <> name)
- ]]]
- False -> ["schema".=object["$ref".=("#/definitions/"<> name)]]
-
-instance ToJSON Param where
- toJSON Param{..} =
- object $ [
- "in" .= _in
- , "name" .= _name
- , "description" .= _paramDescription
- , "required" .= _required
- ] ++ maybeSchema ++ [ "type" .= _type | isJust _type ]
- where
- maybeSchema =
- case _in of
- Body -> [ "schema" .=
- case _isArray of
- False ->
- object [ "$ref" .= ("#/definitions/" <> _name) ]
- True ->
- object [
- "type" .= ("array" :: Text)
- , "items" .= object [
- "$ref" .= ("#/definitions/" <> _name )
- ]
- ]
- ]
- _ -> []
-
-instance ToSwaggerModel a => ToSwaggerModel (Maybe a) where
- toSwagModel _ = toSwagModel (Proxy :: Proxy a)
-
-instance ToJSON Info where
- toJSON Info{..} =
- object $ [
- "title" .= _swaggerInfoTitle
- , "version" .= _swaggerVersion
- , "description" .= _swaggerAPIDescription
- ] ++ [ "license" .= _license | isJust _license ]
- ++ [ "contact" .= _contact | isJust _contact ]
- ++ [ "termsOfService" .= _termsOfService | isJust _termsOfService ]
-
-toTxt :: Show a => a -> Text
-toTxt = T.pack . show
-
-newtype SwaggerRouteInfo a = SwaggerRouteInfo SwagResult -- deriving Monoid
-
-instance Monoid (SwaggerRouteInfo a) where
- mempty = SwaggerRouteInfo mempty
- SwaggerRouteInfo s1 `mappend` SwaggerRouteInfo s2
- = SwaggerRouteInfo (s1 `mappend` s2)
-
-instance Monoid SwagResult where
- mempty = SwagResult mempty mempty
- SwagResult x1 y1 `mappend` SwagResult x2 y2
- = SwagResult (HM.unionWith mergePaths x1 x2) (HM.union y1 y2)
- where
- mergePaths (SwaggerOperation l) (SwaggerOperation r) = SwaggerOperation (HM.unionWith g l r)
- g p1 p2 =
- p1 & summary %~ (<>) (p2 ^. summary)
- & responses %~ HM.union (p2 ^. responses)
- & tags %~ (++) (p2 ^. tags)
- & operationId .~ p1 ^. operationId <> p2 ^. operationId
- & description .~ p1 ^. description <> p2 ^. description
-
-swaggerPathInfo
- :: ( IsElem endpoint layout, HasLink endpoint, HasSwagger endpoint, HasSwagger layout )
- => Proxy endpoint
- -> Proxy layout
- -> SwaggerRouteDescription
- -> SwaggerRouteInfo layout
-swaggerPathInfo pEndpoint pLayout SwaggerRouteDescription{..} = swagResult
- where
- f [(pName, SwaggerOperation swagPath)] =
- [(pName, SwaggerOperation $ HM.fromList . g . HM.toList $ swagPath)]
- f _ = error "Route non-existant, impossible"
- g [(verb, path)] = [(verb, newPath path)]
- g _ = error "Route non-existant, impossible"
- newPath p = p & summary .~ _swagRouteSummary
- & operationId .~ _swagRouteOperationId
- & description .~ _swagRouteDescription
- & responses %~ HM.union _swagRouteResponses
- & tags %~ (++) _swagRouteTags
- swagResult =
- let finalDocs = toSwaggerDocs pLayout defSwaggerRoute
- SwagResult paths models = toSwaggerDocs pEndpoint defSwaggerRoute
- newModels = _swagRouteModels `HM.union` models
- newPaths = HM.fromList . f . HM.toList $ paths
- pathDocs = SwagResult newPaths newModels
- in SwaggerRouteInfo (finalDocs <> pathDocs)
-
-getAllTags :: SwagResult -> [Tag]
-getAllTags (SwagResult paths _) =
- S.toList . S.fromList . _tags =<< HM.elems =<< _paths <$> HM.elems paths
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# 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.Monoid
+import Data.Proxy
+import qualified Data.Swagger as Swagger
+import Data.Swagger hiding (Header)
+import Data.Swagger.Declare
+import Data.Text (Text)
+import qualified Data.Text as Text
+import GHC.TypeLits
+import GHC.Exts
+import Network.HTTP.Media (MediaType)
+import Servant.API
+
+class HasSwagger api where
+ toSwagger :: Proxy api -> Swagger
+
+instance HasSwagger Raw where
+ toSwagger _ = mempty & paths.pathsMap.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.indices (`elem` ps).template
+ where
+ ps = toSwagger sub ^. paths.pathsMap.to HashMap.keys
+
+-- | 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 (== '/')
+
+mkEndpoint :: forall a cs hs proxy _verb. (ToSchema a, AllAccept cs, AllToResponseHeader hs)
+ => FilePath
+ -> Lens' PathItem (Maybe Operation)
+ -> HttpStatusCode
+ -> proxy (_verb cs (Headers hs a))
+ -> Swagger
+mkEndpoint path verb code proxy
+ = mkEndpointWithSchemaRef (Just ref) path verb code proxy
+ & definitions .~ defs
+ where
+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
+
+noContentEndpoint :: forall cs proxy verb. (AllAccept cs)
+ => FilePath
+ -> Lens' PathItem (Maybe Operation)
+ -> proxy (verb cs ())
+ -> Swagger
+noContentEndpoint path verb _ = mkEndpointWithSchemaRef Nothing path verb 204 (Proxy :: Proxy (verb cs (Headers '[] ())))
+
+mkEndpointWithSchemaRef :: forall cs hs proxy verb a. (AllAccept cs, AllToResponseHeader hs)
+ => Maybe (Referenced Schema)
+ -> FilePath
+ -> Lens' PathItem (Maybe Operation)
+ -> HttpStatusCode
+ -> proxy (verb cs (Headers hs a))
+ -> Swagger
+mkEndpointWithSchemaRef mref path verb code _ = mempty
+ & paths.pathsMap.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
+
+-- | Add parameter to every operation in the spec.
+addParam :: Param -> Swagger -> Swagger
+addParam param spec = spec & template.operationParameters %~ (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)
+
+addDefaultResponse404 :: ParamName -> Swagger -> Swagger
+addDefaultResponse404 name = addResponseWith (\old _new -> alter404 old) 404 response404
+ where
+ description404 = name <> " not found"
+ alter404 = description %~ ((name <> " or ") <>)
+ response404 = mempty & description .~ description404
+
+addDefaultResponse400 :: ParamName -> Swagger -> Swagger
+addDefaultResponse400 name = addResponseWith (\old _new -> alter400 old) 400 response400
+ where
+ description400 = "Invalid " <> name
+ alter400 = description %~ (<> (" or " <> name))
+ response400 = mempty & description .~ description400
+
+-- -----------------------------------------------------------------------
+-- DELETE
+-- -----------------------------------------------------------------------
+
+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs) => HasSwagger (Delete cs a) where
+ 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
+
+instance AllAccept cs => HasSwagger (Delete cs ()) where
+ toSwagger = noContentEndpoint "/" pathItemDelete
+
+-- -----------------------------------------------------------------------
+-- GET
+-- -----------------------------------------------------------------------
+
+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs) => HasSwagger (Get cs a) where
+ 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
+
+instance AllAccept cs => HasSwagger (Get cs ()) where
+ toSwagger = noContentEndpoint "/" pathItemGet
+
+-- -----------------------------------------------------------------------
+-- PATCH
+-- -----------------------------------------------------------------------
+
+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs) => HasSwagger (Patch cs a) where
+ 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
+
+instance AllAccept cs => HasSwagger (Patch cs ()) where
+ toSwagger = noContentEndpoint "/" pathItemPatch
+
+-- -----------------------------------------------------------------------
+-- PUT
+-- -----------------------------------------------------------------------
+
+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs) => HasSwagger (Put cs a) where
+ 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
+
+instance AllAccept cs => HasSwagger (Put cs ()) where
+ toSwagger = noContentEndpoint "/" pathItemPut
+
+-- -----------------------------------------------------------------------
+-- POST
+-- -----------------------------------------------------------------------
+
+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs) => HasSwagger (Post cs a) where
+ 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
+
+instance AllAccept cs => HasSwagger (Post cs ()) where
+ toSwagger = noContentEndpoint "/" pathItemPost
+
+
+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
+
+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
+ where
+ piece = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (Capture sym a :> sub) where
+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
+ & addParam param
+ & prependPath capture
+ & addDefaultResponse404 (Text.pack name)
+ where
+ name = symbolVal (Proxy :: Proxy sym)
+ capture = "{" <> name <> "}"
+ param = mempty
+ & paramName .~ Text.pack name
+ & paramRequired ?~ True
+ & paramSchema .~ ParamOther (mempty
+ & paramOtherSchemaIn .~ ParamPath
+ & parameterSchema .~ 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)
+ where
+ name = symbolVal (Proxy :: Proxy sym)
+ param = mempty
+ & paramName .~ Text.pack name
+ & paramSchema .~ ParamOther (mempty
+ & paramOtherSchemaIn .~ ParamQuery
+ & parameterSchema .~ 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)
+ where
+ name = 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))))
+
+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
+ & addParam param
+ & addDefaultResponse400 (Text.pack name)
+ where
+ name = 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))
+
+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (Header sym a :> sub) where
+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
+ & addParam param
+ & addDefaultResponse400 (Text.pack name)
+ where
+ name = symbolVal (Proxy :: Proxy sym)
+ param = mempty
+ & paramName .~ Text.pack name
+ & paramSchema .~ ParamOther (mempty
+ & paramOtherSchemaIn .~ ParamHeader
+ & parameterSchema .~ toParamSchema (Proxy :: Proxy Bool))
+
+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
+ & definitions %~ (<> defs)
+ where
+ name = "body"
+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
+ param = mempty
+ & paramName .~ "body"
+ & paramSchema .~ ParamBody ref
+
+-- =======================================================================
+-- Below are the definitions that should be in Servant.API.ContentTypes
+-- =======================================================================
+
+class AllAccept cs where
+ allContentType :: Proxy cs -> [MediaType]
+
+instance AllAccept '[] where
+ allContentType _ = []
+
+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
+
+class ToResponseHeader h where
+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
+
+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
+ toResponseHeader _ = (hname, Swagger.Header Nothing schema)
+ where
+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))
+ schema = toParamSchema (Proxy :: Proxy a)
+
+class AllToResponseHeader hs where
+ toAllResponseHeaders :: Proxy hs -> HashMap HeaderName Swagger.Header
+
+instance AllToResponseHeader '[] where
+ toAllResponseHeaders _ = mempty
+
+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
+ toAllResponseHeaders _ = HashMap.insert name header headers
+ where
+ (name, header) = toResponseHeader (Proxy :: Proxy h)
+ headers = 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/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Servant/SwaggerSpec.hs
@@ -0,0 +1,323 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Servant.SwaggerSpec where
+
+import Control.Lens
+import Data.Aeson
+import qualified Data.Aeson.Types as JSON
+import Data.Aeson.QQ
+import Data.Char (toLower)
+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
+
+checkAPI :: HasSwagger api => Proxy api -> Value -> IO ()
+checkAPI proxy = checkSwagger (toSwagger proxy)
+
+checkSwagger :: Swagger -> Value -> IO ()
+checkSwagger swag js = toJSON swag `shouldBe` js
+
+spec :: Spec
+spec = describe "HasSwagger" $ do
+ it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI
+ it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI
+
+main :: IO ()
+main = hspec spec
+
+-- =======================================================================
+-- Todo API
+-- =======================================================================
+
+data Todo = Todo
+ { created :: UTCTime
+ , title :: String
+ , description :: Maybe String
+ } deriving (Generic, FromJSON, ToSchema)
+
+newtype TodoId = TodoId String deriving (Generic, ToParamSchema)
+
+type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo
+
+todoAPI :: Value
+todoAPI = [aesonQQ|
+{
+ "swagger":"2.0",
+ "info":
+ {
+ "title": "",
+ "version": ""
+ },
+ "definitions":
+ {
+ "Todo":
+ {
+ "type": "object",
+ "required": [ "created", "title" ],
+ "properties":
+ {
+ "created": { "$ref": "#/definitions/UTCTime" },
+ "title": { "type": "string" },
+ "description": { "type": "string" }
+ }
+ },
+ "UTCTime":
+ {
+ "type": "string",
+ "format": "yyyy-mm-ddThh:MM:ssZ"
+ }
+ },
+ "paths":
+ {
+ "/todo/{id}":
+ {
+ "get":
+ {
+ "responses":
+ {
+ "200":
+ {
+ "schema": { "$ref":"#/definitions/Todo" },
+ "description": ""
+ },
+ "404": { "description": "id not found" }
+ },
+ "produces": [ "application/json" ],
+ "parameters":
+ [
+ {
+ "required": true,
+ "in": "path",
+ "name": "id",
+ "type": "string"
+ }
+ ]
+ }
+ }
+ }
+}
+|]
+
+-- =======================================================================
+-- Hackage API
+-- =======================================================================
+
+type HackageAPI
+ = HackageUserAPI
+ :<|> HackagePackagesAPI
+
+type HackageUserAPI =
+ "users" :> Get '[JSON] [UserSummary]
+ :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed
+
+type HackagePackagesAPI
+ = "packages" :> Get '[JSON] [Package]
+
+type Username = Text
+
+data UserSummary = UserSummary
+ { summaryUsername :: Username
+ , summaryUserid :: Int
+ } deriving (Eq, Show, Generic)
+
+lowerCutPrefix :: String -> String -> String
+lowerCutPrefix s = map toLower . drop (length s)
+
+instance ToJSON UserSummary where
+ 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
+ { summaryUsername = "JohnDoe"
+ , summaryUserid = 123 })
+
+type Group = Text
+
+data UserDetailed = UserDetailed
+ { username :: Username
+ , userid :: Int
+ , groups :: [Group]
+ } deriving (Eq, Show, Generic, ToSchema)
+
+newtype Package = Package { packageName :: Text }
+ deriving (Eq, Show, Generic, ToSchema)
+
+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
+ ]
+ where
+ usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI)
+ packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI)
+
+hackageAPI :: Value
+hackageAPI = [aesonQQ|
+{
+ "swagger":"2.0",
+ "host":"hackage.haskell.org",
+ "info":{
+ "version":"",
+ "title":""
+ },
+ "definitions":{
+ "UserDetailed":{
+ "required":[
+ "username",
+ "userid",
+ "groups"
+ ],
+ "type":"object",
+ "properties":{
+ "groups":{
+ "items":{
+ "type":"string"
+ },
+ "type":"array"
+ },
+ "username":{
+ "type":"string"
+ },
+ "userid":{
+ "maximum":9223372036854775807,
+ "minimum":-9223372036854775808,
+ "type":"integer"
+ }
+ }
+ },
+ "Package":{
+ "required":[
+ "packageName"
+ ],
+ "type":"object",
+ "properties":{
+ "packageName":{
+ "type":"string"
+ }
+ }
+ },
+ "UserSummary":{
+ "required":[
+ "username",
+ "userid"
+ ],
+ "type":"object",
+ "properties":{
+ "username":{
+ "type":"string"
+ },
+ "userid":{
+ "maximum":9223372036854775807,
+ "minimum":-9223372036854775808,
+ "type":"integer"
+ }
+ },
+ "example":{
+ "username": "JohnDoe",
+ "userid": 123
+ }
+ }
+ },
+ "paths":{
+ "/users":{
+ "get":{
+ "responses":{
+ "200":{
+ "schema":{
+ "items":{
+ "$ref":"#/definitions/UserSummary"
+ },
+ "type":"array"
+ },
+ "description":""
+ }
+ },
+ "produces":[
+ "application/json"
+ ],
+ "tags":[
+ "users"
+ ]
+ }
+ },
+ "/packages":{
+ "get":{
+ "responses":{
+ "200":{
+ "schema":{
+ "items":{
+ "$ref":"#/definitions/Package"
+ },
+ "type":"array"
+ },
+ "description":""
+ }
+ },
+ "produces":[
+ "application/json"
+ ],
+ "tags":[
+ "packages"
+ ]
+ }
+ },
+ "/user/{username}":{
+ "get":{
+ "responses":{
+ "404":{
+ "description":"username not found"
+ },
+ "200":{
+ "schema":{
+ "$ref":"#/definitions/UserDetailed"
+ },
+ "description":""
+ }
+ },
+ "produces":[
+ "application/json"
+ ],
+ "parameters":[
+ {
+ "required":true,
+ "in":"path",
+ "name":"username",
+ "type":"string"
+ }
+ ],
+ "tags":[
+ "users"
+ ]
+ }
+ }
+ },
+ "tags":[
+ {
+ "name":"users",
+ "description":"Operations about user"
+ },
+ {
+ "name":"packages",
+ "description":"Query packages"
+ }
+ ]
+}
+|]
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
+