servant-swagger 0.0.0.1 → 0.1

raw patch · 10 files changed

+1100/−1115 lines, 10 filesdep +aeson-qqdep +hspecdep +http-mediadep −containersdep −hashabledep −uuiddep ~basedep ~servantnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-qq, hspec, http-media, servant-swagger, swagger2, time

Dependencies removed: containers, hashable, uuid

Dependency ranges changed: base, servant

API changes (from Hackage documentation)

Files

• LICENSE +28/−0
• README.md +166/−0
• example/File.hs +51/−0
• example/Server.hs +81/−0
• example/example.cabal +42/−0
• servant-swagger.cabal +36/−26
• src/Servant/Swagger.hs +10/−104
• src/Servant/Swagger/Internal.hs +362/−985
• test/Servant/SwaggerSpec.hs +323/−0
• test/Spec.hs +1/−0

@@ -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.+

@@ -0,0 +1,166 @@+<h1 align="center">+    <a href="https://github.com/dmjio/servant-swagger">+        servant-swagger+    </a>+    <br/>+    <a href="http://hackage.haskell.org/package/servant-swagger">+      <img alt="Hackage" src="https://img.shields.io/hackage/v/servant-swagger.svg" />+    </a>+</h1>++<p align="center">+  This project converts <a href="https://github.com/haskell-servant/servant">servant</a> APIs into Swagger 2.0 conforming JSON.+</p>++<p align="center">+  <img src="http://s16.postimg.org/rndz1wbyt/servant.png" />+</p>++<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++-- 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).+

@@ -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)+

@@ -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+

@@ -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

@@ -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+

@@ -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 

@@ -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 --- <http://swagger.io/specification/#contactObject contact>-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 = ()+

@@ -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"+      }+   ]+}+|]+

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}