servant-swagger (empty) → 0.0.0.0
raw patch · 5 files changed
+1111/−0 lines, 5 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, hashable, lens, servant, text, unordered-containers, uuid
Files
- LICENSE +0/−0
- Setup.hs +2/−0
- servant-swagger.cabal +46/−0
- src/Servant/Swagger.hs +102/−0
- src/Servant/Swagger/Internal.hs +961/−0
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-swagger.cabal view
@@ -0,0 +1,46 @@+name: servant-swagger+version: 0.0.0.0+synopsis: Swagger+description: Swagger+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+description: This is an experimental release, this API is subject to change at any moment.+++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+ hs-source-dirs: src+ build-depends: aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , hashable+ , lens+ , text+ , uuid+ , servant+ , unordered-containers+ default-language: Haskell2010
+ src/Servant/Swagger.hs view
@@ -0,0 +1,102 @@+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+ ) 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++++
+ src/Servant/Swagger/Internal.hs view
@@ -0,0 +1,961 @@+{-# 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)++-- | Contact URL of `Contact` object+newtype ContactURL = ContactURL Text+ deriving (Show, Eq, ToJSON, FromJSON, Ord)++-- | Contact Email of `Contact` object+newtype ContactEmail = ContactEmail Text+ deriving (Show, Eq, ToJSON, FromJSON, Ord)++-- | Contact Object+data Contact = Contact {+ _contactName :: ContactName+ , _contactURL :: ContactURL+ , _contactEmail :: ContactEmail+ } deriving (Show, Eq, Ord)++-- | 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)++-- | Terms of Service of API located in `Info`+newtype TermsOfService = TermsOfService Text+ deriving (Show, Eq, ToJSON)++-- | 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)++data APILicense = APILicense {+ _licenseName :: Text+ , _licenseUrl :: Maybe Text+ } deriving (Show, Eq)++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 Nothing++newtype Deprecated = Deprecated Bool deriving (Show, Eq, ToJSON)+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)+newtype APITitle = APITitle Text deriving (Show, Eq, ToJSON)+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