diff --git a/.gitignore b/.gitignore index b08434527..777ecd776 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,20 @@ dist/ /foo.json servant-client-0.4.4/ -.stack-work +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.virtualenv +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +.stack-work/ +swagger.json diff --git a/README.md b/README.md index 20a2529c6..9f165348d 100644 --- a/README.md +++ b/README.md @@ -14,73 +14,61 @@

-

+

Given the following `servant` API, `servant-swagger` generates the following json. ### [Input](example/File.hs) + ```haskell -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} module Main where -import Servant.API -import Servant.Server -import Servant.Swagger -import Data.Proxy +import Control.Lens import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Proxy +import Data.Swagger import GHC.Generics -import Control.Lens +import Servant +import Servant.Swagger -- Types -data Todo = Todo { - created :: Int +data Todo = Todo + { created :: Int , description :: String } deriving (Show, Eq, Generic) instance ToJSON Todo -instance FromJSON Todo -newtype TodoId = TodoId String deriving (FromText) +newtype TodoId = TodoId String deriving (FromText, Generic) -- API type API = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo -- Swagger Doc -swagDoc :: SwaggerAPI -swagDoc = swagger (Proxy :: Proxy API) mempty (BasePath "/") info schemes Nothing [] - where - schemes = [ Http ] - license' = APILicense "MIT" (Just "http://mit.com") - info = - Info - (APITitle "Todo API") (APIVersion "1.0") - (APIDescription "This is a an API that tests servant-swagger support for a Todo") - (Just license') - Nothing - Nothing +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 ToSwaggerParamType TodoId where toSwaggerParamType = const StringSwagParam -instance ToSwaggerDescription TodoId where toSwaggerDescription = const "TodoId param" - -instance ToSwaggerModel Todo where - toSwagModel Proxy = - emptyModel - & swagModelName .~ ModelName "Todo" - & swagProperties .~ [ ("created", IntegerSwag) - , ("description", StringSwag) - , ("extraTodos", Model $ ModelSwag (ModelName "Todo") False) - ] - & swagDescription ?~ Description "This is some real Todo right here" - & swagModelExample ?~ toJSON (Todo 100 "get milk") - & swagModelRequired .~ ["description"] +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 () @@ -90,94 +78,89 @@ main = BL8.writeFile "swagger.json" (encode swagDoc) ### Output ```json -{ +{ "swagger":"2.0", - "basePath":"/", - "schemes":[ - "http" - ], - "info":{ + "info":{ "version":"1.0", "title":"Todo API", - "license":{ + "license":{ "url":"http://mit.com", "name":"MIT" }, - "description":"This is a an API that tests servant-swagger support for a Todo" + "description":"This is an API that tests servant-swagger support for a Todo" }, - "definitions":{ - "Todo":{ - "example":{ + "definitions":{ + "Todo":{ + "example":{ "created":100, "description":"get milk" }, - "required":[ + "required":[ + "created", "description" ], "type":"object", "description":"This is some real Todo right here", - "properties":{ - "created":{ - "format":"int32", + "properties":{ + "created":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, "type":"integer" }, - "description":{ + "description":{ "type":"string" - }, - "extraTodos":{ - "$ref":"#/definitions/Todo" } } } }, - "paths":{ - "/todo/{id}":{ - "get":{ - "summary":"", - "consumes":[ - - ], - "responses":{ - "200":{ - "schema":{ + "paths":{ + "/todo/{id}":{ + "get":{ + "responses":{ + "404":{ + "description":"id not found" + }, + "200":{ + "schema":{ "$ref":"#/definitions/Todo" }, - "headers":{ - - }, - "description":"OK" + "description":"" } }, - "produces":[ + "produces":[ "application/json" ], - "parameters":[ - { + "parameters":[ + { "required":true, "in":"path", "name":"id", - "type":"string", - "description":"TodoId param" + "type":"string" } - ], - "description":"", - "tags":[ - ] } } - }, - "tags":[ - - ] + } } ``` + ## Try it out - - All generated swagger docs can be interactively viewed on Swagger Editor -## Limitations - - Quite a few, TODO: add this +All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/). + +Ready-to-use specification can be served as JSON and interactive API documentation +can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui). + +Many Swagger tools, including server and client code generation for many languages, can be found on +[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/). ## FAQ - Q: How is this project different from the `swagger` package on `hackage` ? - A: This package is based on the latest Swagger 2.0 API + +## Contributing + +We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. + +Please report bugs via the [github issue tracker](https://github.com/dmjio/servant-swagger/issues). + diff --git a/example/File.hs b/example/File.hs index 03c7777a9..7e0b67576 100644 --- a/example/File.hs +++ b/example/File.hs @@ -1,63 +1,51 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} module Main where -import Servant.API -import Servant.Server -import Servant.Swagger -import Data.Proxy +import Control.Lens import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Proxy +import Data.Swagger import GHC.Generics -import Control.Lens +import Servant +import Servant.Swagger -- Types -data Todo = Todo { - created :: Int +data Todo = Todo + { created :: Int , description :: String } deriving (Show, Eq, Generic) instance ToJSON Todo -instance FromJSON Todo -newtype TodoId = TodoId String deriving (FromText) +newtype TodoId = TodoId String deriving (FromText, Generic) -- API type API = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo -- Swagger Doc -swagDoc :: SwaggerAPI -swagDoc = swagger (Proxy :: Proxy API) mempty (BasePath "/") info schemes Nothing [] - where - schemes = [ Http ] - license' = APILicense "MIT" (Just "http://mit.com") - info = - Info - (APITitle "Todo API") (APIVersion "1.0") - (APIDescription "This is a an API that tests servant-swagger support for a Todo") - (Just license') - Nothing - Nothing +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 ToSwaggerParamType TodoId where toSwaggerParamType = const StringSwagParam -instance ToSwaggerDescription TodoId where toSwaggerDescription = const "TodoId param" - -instance ToSwaggerModel Todo where - toSwagModel Proxy = - emptyModel - & swagModelName .~ ModelName "Todo" - & swagProperties .~ [ ("created", IntegerSwag) - , ("description", StringSwag) - , ("extraTodos", Model $ ModelSwag (ModelName "Todo") False) - ] - & swagDescription ?~ Description "This is some real Todo right here" - & swagModelExample ?~ toJSON (Todo 100 "get milk") - & swagModelRequired .~ ["description"] +instance ToParamSchema TodoId + +instance ToSchema Todo where + declareNamedSchema proxy = do + (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions proxy + return (name, schema + & schemaDescription ?~ "This is some real Todo right here" + & schemaExample ?~ toJSON (Todo 100 "get milk")) -- Main, create swaggger.json main :: IO () main = BL8.writeFile "swagger.json" (encode swagDoc) + diff --git a/example/Server.hs b/example/Server.hs index 55b780b13..b65420c3c 100644 --- a/example/Server.hs +++ b/example/Server.hs @@ -1,43 +1,38 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} module Main where +import Control.Lens +import Control.Monad.Trans.Either +import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BL8 -import Servant.API -import Servant.Swagger -import Servant.Server import Data.Proxy -import Data.Aeson +import Data.Swagger import GHC.Generics import Network.Wai.Handler.Warp -import Control.Monad.Trans.Either +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 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 :: SwaggerAPI -swagDoc = swagger (Proxy :: Proxy TestAPI) mempty (BasePath "/") info schemes Nothing [] - where - schemes = [ Http ] - license' = APILicense "MIT" (Just "http://mit.com") - info = - Info - (APITitle "Todo API") (APIVersion "1.0") - (APIDescription "This is a an API that tests servant-swagger support for a Todo API") - (Just license') - Nothing - Nothing - +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] SwaggerAPI +type DocsAPI = Get '[JSON] Swagger type API = DocsAPI :<|> TodoAPI @@ -48,9 +43,9 @@ data Todo = Todo { created :: Int, description :: String } instance ToJSON Todo instance FromJSON Todo -newtype TodoId = TodoId String deriving (FromText) -newtype TodoCount = TodoCount Int deriving (FromText) -newtype Completed = Completed Bool deriving (FromText) +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 @@ -65,40 +60,22 @@ main = do undefined :<|> undefined :<|> undefined undefined :<|> undefined -swagHandler :: EitherT ServantErr IO SwaggerAPI -swagHandler = pure $ swagger api mempty (BasePath "/") info schemes Nothing [] - where - schemes = [ Http ] - license' = APILicense "MIT" (Just "http://mit.com") - info = - Info - (APITitle "Servant Swagger API") (APIVersion "2.0") - (APIDescription "This is a an API that tests swagger integration") - (Just license') - Nothing - Nothing +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 ToSwaggerModel Todo where - toSwagModel Proxy = - SwaggerModel { - _swagModelName = (ModelName "Todo") - , _swagProperties = [ ("created", IntegerSwag) - , ("description", StringSwag) - ] - , _swagDescription = Just $ Description "This is some real Todo right here" - , _swagModelExample = Just $ toJSON $ Todo 100 "get milk" - , _swagModelRequired = ["description"] - } - -instance ToSwaggerParamType TodoId where - toSwaggerParamType = const StringSwagParam - -instance ToSwaggerParamType Completed where - toSwaggerParamType = const BooleanSwagParam - -instance ToSwaggerDescription TodoId where - toSwaggerDescription = const "TodoId param" - -instance ToSwaggerDescription Completed where - toSwaggerDescription = const "Completed param" +instance ToSchema Todo where + declareNamedSchema proxy = do + (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions proxy + return (name, schema + & schemaDescription ?~ "This is some real Todo right here" + & schemaExample ?~ toJSON (Todo 100 "get milk")) + +instance ToParamSchema TodoId + +instance ToParamSchema Completed + diff --git a/example/example.cabal b/example/example.cabal index e35875e7a..23b631627 100644 --- a/example/example.cabal +++ b/example/example.cabal @@ -21,6 +21,7 @@ executable swagger-server , either , servant-server , servant-swagger + , swagger2 , lens , wai , warp @@ -33,6 +34,7 @@ executable swagger-file , aeson , bytestring == 0.10.* , servant + , swagger2 , either , servant-server , servant-swagger diff --git a/servant-swagger.cabal b/servant-swagger.cabal index 7ce3caae9..a1b83bf83 100644 --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -25,30 +25,34 @@ library exposed-modules: Servant.Swagger 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 + , http-media , lens - , text - , uuid , servant + , swagger2 + , text , unordered-containers default-language: Haskell2010 + +test-suite spec + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base == 4.* + , aeson + , aeson-qq + , hspec + , lens + , servant + , servant-swagger + , swagger2 + , text + , time + other-modules: + Servant.SwaggerSpec + default-language: Haskell2010 + diff --git a/src/Servant/Swagger.hs b/src/Servant/Swagger.hs index 237c2a1f7..f5765ea52 100644 --- a/src/Servant/Swagger.hs +++ b/src/Servant/Swagger.hs @@ -1,104 +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 +module Servant.Swagger ( + HasSwagger(..), + + addTag, + subOperations, + setResponse, + + ToResponseHeader(..), + AllAccept, + AllToResponseHeader, +) 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 diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs index 566386651..fbff12bbe 100644 --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -1,985 +1,362 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif ------------------------------------------------------------------------------- -module Servant.Swagger.Internal where ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Data.Text (Text) -import Data.Aeson -import Data.Aeson.Types ( typeMismatch ) -import qualified Data.Set as S -import Data.Hashable -import Data.List -import Data.Maybe -import Data.Data -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.ByteString.Char8 as B8 -import Data.Bool -import GHC.Generics -import Data.String -import Control.Lens hiding ((.=)) -import qualified Data.HashMap.Strict as HM -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import GHC.TypeLits -import Servant.API hiding (Header) -import qualified Servant.API.Header as H -import qualified Data.UUID as UUID - --- | Helper to generate swagger.json file -createSwaggerJson :: SwaggerAPI -> IO () -createSwaggerJson = BL8.writeFile "swagger.json" . encode - --- | This is the root document object for the API specification. -data SwaggerAPI = SwaggerAPI { - _swaggerInfo :: Info -- ^ Required, provides metadata about the API - , _swaggerPaths :: HM.HashMap PathName SwaggerOperation -- ^ Required - , _swaggerSchemes :: Maybe [Scheme] -- ^ Schemes for this API (i.e HTTP/HTTPS) - , _swaggerDefinitions :: HM.HashMap ModelName SwaggerModel -- ^ - , _swaggerTags :: Maybe [Tag] -- ^ A list of tags that provide additional metadat - , _swaggerBasePath :: Maybe BasePath -- ^ The base path upon which this API is served - , _swaggerHostName :: Maybe HostName -- ^ Host name or IP - , _swaggerSecurityDefintions :: Maybe [SecurityDefinition] - -- ^ Security scheme definitions that can be used across the specification. - , _swaggerExternalDocs :: Maybe ExternalDocs - } deriving Show - --- | Smart Constructor for `SwaggerAPI` -defSwaggerAPI :: Info -> SwaggerAPI -defSwaggerAPI info = SwaggerAPI info mempty mempty mempty mempty mempty mempty mempty mempty - --- | `ToJSON` for `SwaggerAPI` -instance ToJSON SwaggerAPI where - toJSON SwaggerAPI{..} = - object $ [ - "swagger" .= ("2.0" :: Text) - , "info" .= _swaggerInfo - , "paths" .= do Object $ HM.fromList $ map f $ HM.toList _swaggerPaths - , "definitions" .= do Object $ HM.fromList $ map g $ HM.toList _swaggerDefinitions - ] ++ - [ "host" .= _swaggerHostName | isJust _swaggerHostName ] ++ - [ "schemes" .= _swaggerSchemes | isJust _swaggerSchemes ] ++ - [ "basePath" .= _swaggerBasePath | isJust _swaggerBasePath ] ++ - [ "externalDocs" .= _swaggerExternalDocs | isJust _swaggerExternalDocs ] ++ - [ "tags" .= _swaggerTags | isJust _swaggerTags ] +{-# 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 - f (PathName pathName, sp) = (T.toLower pathName, toJSON sp) - g (ModelName modelName, model) = (modelName, toJSON model) - -data ExternalDocs = ExternalDocs { - _externalDescription :: Maybe ExternalDescription -- ^ Optional Description - , _externalURL :: ExternalURL -- ^ Required URL that links supporting documentation - } deriving (Show, Eq) - -instance ToJSON ExternalDocs where - toJSON ExternalDocs{..} = - object $ [ "url" .= _externalURL ] ++ - [ "description" .= _externalDescription - | isJust _externalDescription - ] - -instance Monoid ExternalDocs where - mempty = ExternalDocs mempty mempty - (ExternalDocs a1 b1) `mappend` (ExternalDocs a2 b2) - = ExternalDocs (a1 <> a2) (b1 <> b2) - --- | External Description for External Documentation API -newtype ExternalDescription = ExternalDescription Text - deriving (Show, Eq, Monoid, ToJSON) - --- | External Description for External Documentation API -newtype ExternalURL = ExternalURL Text - deriving (Show, Eq, Monoid, ToJSON) - --- | Type used to accumulate information of a Servant path -data SwaggerRoute = SwaggerRoute { - _routePathName :: PathName -- ^ Accumulated `PathName` - , _routeConsumes :: [ContentType] -- ^ Content Types a route consumes - , _routeModels :: HM.HashMap ModelName SwaggerModel -- ^ Models present in route - , _routeParams :: [Param] -- ^ Params present in route - , _routeVerb :: Verb -- ^ Verb of route - , _routePathSummary :: PathSummary -- ^ Summary of path - , _routeResponses :: HM.HashMap Text Response -- ^ Additional responses for a Route - , _routeTags :: [Tag] -- ^ Tags present for this Route - } deriving Show - --- | Default Route used to build up -defSwaggerRoute :: SwaggerRoute -defSwaggerRoute = SwaggerRoute mempty [] [] [] Get mempty [] [] - --- | Default --- -defSwaggerInfo :: Info -defSwaggerInfo = - Info (APITitle mempty) - (APIVersion "2.0") (APIDescription mempty) Nothing Nothing Nothing - --- | Contact name of `Contact` object -newtype ContactName = ContactName Text - deriving (Show, Eq, ToJSON, FromJSON, Ord, Monoid) - --- | Contact URL of `Contact` object -newtype ContactURL = ContactURL Text - deriving (Show, Eq, ToJSON, FromJSON, Ord, Monoid) - --- | Contact Email of `Contact` object -newtype ContactEmail = ContactEmail Text - deriving (Show, Eq, ToJSON, FromJSON, Ord, Monoid) - --- | Contact Object -data Contact = Contact { - _contactName :: ContactName - , _contactURL :: ContactURL - , _contactEmail :: ContactEmail - } deriving (Show, Eq, Ord) - -instance Monoid Contact where - mempty = Contact mempty mempty mempty - (Contact a1 b1 c1) `mappend` (Contact a2 b2 c2) = - Contact (a1 <> a2) (b1 <> b2) (c1 <> c2) - --- | Contact Object -instance ToJSON Contact where - toJSON Contact{..} = - object [ - "name" .= _contactName - , "url" .= _contactURL - , "email" .= _contactEmail - ] - --- | Description of API -newtype APIDescription = APIDescription { _unApiDesc :: Text } - deriving (Show, Eq, ToJSON, Monoid) - --- | Terms of Service of API located in `Info` -newtype TermsOfService = TermsOfService Text - deriving (Show, Eq, ToJSON, Monoid) - --- | A Swagger metadata for a Servant header -data SwaggerHeader = SwaggerHeader { - headerDescription :: Text -- ^ Header description - , headerType :: SwaggerParamType -- ^ Type of Header - , headerName :: Text -- ^ Name of Header - } deriving (Show, Eq) - --- | A container for the expected responses of an operation. -data Response = Response { - _responseDescription :: Text -- ^ Description of Response - , _responseModelName :: ModelName -- ^ `Model` this Response returns - , _responseHeaders :: HM.HashMap Text SwaggerHeader -- ^ HashMap of headers - , _responseIsArray :: Bool -- ^ Does the response return an Array? - , _responseCode :: Code -- ^ Response code this route returns - } deriving (Show, Eq) - --- | Default Response for a Path -defResponse :: Response -defResponse = Response mempty (ModelName mempty) mempty False (Code 200) - --- | Name of `Tag`, that can be applied to an operation -newtype TagName = TagName Text deriving (Show, Eq, Ord, ToJSON, FromJSON) - --- | Description of `Tag` -newtype TagDescription = TagDescription Text deriving (Show, Eq, Ord, ToJSON, FromJSON) - --- | Allows adding meta data to a single tag that is used by the Operation Object -data Tag = Tag { - _tagName :: TagName -- ^ Name of `Tag` - , _tagDescription :: TagDescription -- ^ Description of `Tag` - } deriving (Show, Eq, Ord) - --- | `ToJSON` `Tag` instance -instance ToJSON Tag where - toJSON Tag{..} = object [ "name" .= _tagName, "description" .= _tagDescription ] - --- | `FromJSON` `Tag` instance -instance FromJSON Tag where - parseJSON (Object o) = Tag <$> o .: "name" <*> o .: "description" - parseJSON x = typeMismatch "Tag" x - --- | A declaration of the security schemes available to be used in the specification -data SecurityDefinition = - OAuthDef OAuth -- ^ OAuth - | APIKeyDef APIKey -- ^ APIKey - | BasicAuthDef BasicAuth -- ^ BasicAuth - deriving Show - --- | Basic Authentication -data BasicAuth = BasicAuth deriving Show - --- ^ OAuth Flow -data OAuthFlow = Implicit | Password | Application | AccessCode deriving (Show) --- ^ OAuth URL -data OAuthURL = OAuthURL deriving (Show) -data TokenURL = TokenURL deriving (Show) -data Scopes = Scopes deriving (Show) - --- | OAuth Authentication -data OAuth = OAuth { - oauthDescription :: Maybe Description -- ^ Optional description for Swagger OAuth object - , oauthFlow :: OAuthFlow -- ^ OAuth Flow - , oauthURL :: OAuthURL -- ^ OAuth URL - , oauthTokenURL :: TokenURL -- ^ Token URL - , scopes :: Scopes -- ^ OAuth Scopes - } deriving Show - --- | API Key -newtype APIKeyName = - APIKeyName Text deriving (Show, Eq) - --- | API Location (i.e. is it located in a Query Param or a Header) -data APIKeyIn = APIKeyQueryParam - | APIKeyHeader deriving (Show, Eq) - --- | API Key Object -data APIKey = APIKey { - apiKeyDescription :: Maybe Description -- ^ Optional `Description` - , apiKeyName :: APIKeyName -- ^ Optional `Description` - , apiKeyIn :: APIKeyIn - } deriving Show - --- | API Key `ToJSON` -instance ToJSON APIKey where - toJSON APIKey{..} = - object [ "api_key" .= ([] :: [Int]) ] - --- | HostName -newtype HostName = HostName Text - deriving (Show, Eq, IsString, ToJSON, FromJSON, Monoid) - --- | BasePath -newtype BasePath = BasePath Text - deriving (Show, Eq, ToJSON, FromJSON, Monoid) - --- | Info Objet -data Info = Info { - _swaggerInfoTitle :: APITitle -- ^ API Title - , _swaggerVersion :: APIVersion -- ^ API Version - , _swaggerAPIDescription :: APIDescription -- ^ API Description - , _license :: Maybe APILicense -- ^ API Description - , _contact :: Maybe Contact - , _termsOfService :: Maybe TermsOfService - } deriving (Show, Eq) - -instance Monoid Info where - mempty = Info mempty mempty mempty mempty mempty mempty - (Info a1 b1 c1 d1 e1 f1) `mappend` (Info a2 b2 c2 d2 e2 f2) - = Info (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (f1 <> f2) - -data APILicense = APILicense { - _licenseName :: Text - , _licenseUrl :: Maybe Text - } deriving (Show, Eq) - -instance Monoid APILicense where - mempty = APILicense mempty mempty - (APILicense a1 b1) `mappend` (APILicense a2 b2) = APILicense (a1 <> a2) (b1 <> b2) - -data SwaggerOperation = SwaggerOperation { - _paths :: HM.HashMap Verb Operation - } deriving Show - -data SwagResult = SwagResult { - _resultPaths :: HM.HashMap PathName SwaggerOperation - , _resultModels :: HM.HashMap ModelName SwaggerModel - } deriving (Show) - -data Verb = Post | Get | Put | Options | Head | Delete | Patch - deriving (Show, Eq, Read, Generic) - -newtype PathSummary = PathSummary Text - deriving (Show, Eq, ToJSON, FromJSON, Monoid, IsString) - -data Operation = Operation { - _summary :: PathSummary - , _params :: [Param] - , _responses :: HM.HashMap Code Response - , _produces :: [ContentType] - , _consumes :: [ContentType] - , _tags :: [Tag] - , _operationId :: Maybe OperationId - , _description :: PathDescription - , _deprecated :: Maybe Deprecated - } deriving Show - -instance Monoid Operation where - mempty = Operation mempty mempty mempty mempty mempty mempty mempty mempty mempty - (Operation a1 b1 c1 d1 e1 f1 g1 h1 i1) `mappend` - (Operation a2 b2 c2 d2 e2 f2 g2 h2 i2) = - Operation (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (f1 <> f2) (g1 <> g2) - (h1 <> h2) (i1 <> i2) - -newtype Deprecated = Deprecated Bool deriving (Show, Eq, ToJSON) - -instance Monoid Deprecated where - mempty = Deprecated False - (Deprecated False) `mappend` (Deprecated False) = Deprecated False - _ `mappend` _ = Deprecated True - -newtype OperationId = OperationId Text deriving (Show, Eq, ToJSON, Monoid) -newtype PathDescription = PathDescription Text deriving (Show, Eq, ToJSON, Monoid) - -newtype Code = Code Int deriving (Show, Eq, Ord, ToJSON, Hashable, Num) - -data SwaggerParamType = - StringSwagParam - | NumberSwagParam - | IntegerSwagParam - | BooleanSwagParam - | ArraySwagParam - | FileSwagParam - deriving (Show, Eq) - -data SwaggerType = - IntegerSwag - | LongSwag - | FloatSwag - | DoubleSwag - | StringSwag - | ByteSwag - | BinarySwag - | BooleanSwag - | DateSwag - | DateTimeSwag - | PasswordSwag - | Model ModelSwag - deriving (Show, Eq) - -data ModelSwag = ModelSwag { - modelSwagName :: ModelName - , modelSwagIsArray :: Bool - } deriving (Show, Eq) - -data ContentType = JSON | HTML | XML | FormUrlEncoded | PlainText | OctetStream - deriving (Show, Eq) - -data In = PathUrl | Query | Header | FormData | Body deriving Show -data Scheme = Http | Https | Ws | Wss deriving Show - -data Param = Param { - _in :: In - , _name :: Text - , _type :: Maybe SwaggerParamType - , _items :: Maybe ItemObject - , _paramDescription :: Text - , _allowEmptyValue :: Bool - , _required :: Bool - , _default :: Maybe Value - , _isArray :: Bool - } deriving Show - -data ItemObject = ItemObject { - _itemsType :: SwaggerParamType - } deriving Show - -newtype APIVersion = APIVersion Text deriving (Show, Eq, ToJSON, Monoid) -newtype APITitle = APITitle Text deriving (Show, Eq, ToJSON, Monoid) -newtype PathName = PathName { unPathName :: Text } - deriving (Show, Eq, Hashable, Monoid) - -newtype ModelName = ModelName { unModelName :: Text } - deriving (Show, Eq, Hashable, Monoid) - -newtype Description = - Description { unDescription :: Text } deriving (Show, Eq, ToJSON, Monoid) - -data SwaggerModel = SwaggerModel { - _swagModelName :: ModelName - , _swagProperties :: [(Text, SwaggerType)] - , _swagDescription :: Maybe Description - , _swagModelExample :: Maybe Value - , _swagModelRequired :: [Text] - } deriving (Show, Eq) - -emptyModel :: SwaggerModel -emptyModel = SwaggerModel (ModelName mempty) mempty mempty Nothing mempty - -data SwaggerRouteDescription = SwaggerRouteDescription { - _swagRouteTags :: [Tag] -- ^ Tags - , _swagRouteSummary :: PathSummary -- ^ Description of this endpoint - , _swagRouteResponses :: HM.HashMap Code Response -- ^ Additional responses for this endpoint - , _swagRouteModels :: HM.HashMap ModelName SwaggerModel - , _swagRouteOperationId :: Maybe OperationId - , _swagRouteDescription :: PathDescription - } deriving Show - -emptyRouteDescription :: SwaggerRouteDescription -emptyRouteDescription = SwaggerRouteDescription mempty mempty mempty mempty mempty mempty - -$(makeLenses ''SwaggerModel) -$(makeLenses ''ExternalDocs) -$(makeLenses ''SwaggerRouteDescription) -$(makeLenses ''SwagResult) -$(makeLenses ''SwaggerRoute) -$(makeLenses ''SwaggerAPI) -$(makeLenses ''Info) -$(makeLenses ''Contact) -$(makeLenses ''APILicense) -$(makeLenses ''Operation) -$(makeLenses ''Tag) -$(makeLenses ''Response) - -defExternalDocs :: ExternalURL -> ExternalDocs -defExternalDocs url = mempty & externalURL .~ url - ------------------------------------------------------------------------------- --- | Swaggin' -class HasSwagger h where - toSwaggerDocs :: Proxy h -> SwaggerRoute -> SwagResult ------------------------------------------------------------------------------- -class ToSwaggerDescription a where toSwaggerDescription :: Proxy a -> Text -class ToHeader a where toHeader :: Proxy a -> SwaggerHeader -class ToResponseHeaders as where toResponseHeaders :: Proxy as -> HM.HashMap Text SwaggerHeader -instance ToResponseHeaders '[] where toResponseHeaders Proxy = [] - -instance (ToHeader x, ToResponseHeaders xs) => ToResponseHeaders (x ': xs) where - toResponseHeaders Proxy = HM.union header' (toResponseHeaders (Proxy :: Proxy xs)) + 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 - 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 + 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 - requiredList = [ "required" .= _swagModelRequired | not (null _swagModelRequired) ] - maybeDescription = maybe [] (\(Description x) -> [ "description" .= x ]) _swagDescription - maybeExample = maybe [] (\x -> [ "example" .= x ]) _swagModelExample + 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 -setPath :: BasePath -> BasePath -setPath (BasePath "") = BasePath "/" -setPath (BasePath x) = BasePath x +-- ======================================================================= +-- Below are the definitions that should be in Servant.API.ContentTypes +-- ======================================================================= +class AllAccept cs where + allContentType :: Proxy cs -> [MediaType] -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 +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 - 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 ] + 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 - 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 + (name, header) = toResponseHeader (Proxy :: Proxy h) + headers = toAllResponseHeaders (Proxy :: Proxy hs) + +instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where + toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) + +-- | Check that every element of @xs@ is an endpoint of @api@. +type family AllIsElem xs api :: Constraint where + AllIsElem '[] api = () + AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api) + +-- | Apply @(e :>)@ to every API in @xs@. +type family MapSub e xs where + MapSub e '[] = '[] + MapSub e (x ': xs) = (e :> x) ': MapSub e xs + +-- | Append two type-level lists. +type family AppendList xs ys where + AppendList '[] ys = ys + AppendList (x ': xs) ys = x ': AppendList xs ys + +-- | Build a list of endpoints from an API. +type family EndpointsList api where + EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) + EndpointsList (e :> a) = MapSub e (EndpointsList a) + EndpointsList a = '[a] + +-- | Check whether @sub@ is a sub API of @api@. +type family IsSubAPI sub api :: Constraint where + IsSubAPI sub api = AllIsElem (EndpointsList sub) api + +type family Or (a :: Constraint) (b :: Constraint) :: Constraint where + Or () b = () + Or a () = () + +type family IsIn sub api :: Constraint where + IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b) + IsIn (e :> a) (e :> b) = IsIn a b + IsIn e e = () + diff --git a/stack.yaml b/stack.yaml index ebddb4044..c83cc7a8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,7 +9,8 @@ packages: - example/ # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) -extra-deps: [] +extra-deps: +- swagger2-1.1.1 # Override default flag values for local packages and extra-deps flags: {} diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs new file mode 100644 index 000000000..de6d61b9d --- /dev/null +++ b/test/Servant/SwaggerSpec.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QuasiQuotes #-} +module Servant.SwaggerSpec where + +import Control.Lens +import Data.Aeson +import qualified Data.Aeson.Types as JSON +import Data.Aeson.QQ +import Data.Char (toLower) +import Data.Proxy +import Data.Swagger +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time +import GHC.Generics +import Servant.API +import Servant.Swagger +import Test.Hspec + +checkAPI :: HasSwagger api => Proxy api -> Value -> IO () +checkAPI proxy = checkSwagger (toSwagger proxy) + +checkSwagger :: Swagger -> Value -> IO () +checkSwagger swag js = toJSON swag `shouldBe` js + +spec :: Spec +spec = describe "HasSwagger" $ do + it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI + it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI + +main :: IO () +main = hspec spec + +-- ======================================================================= +-- Todo API +-- ======================================================================= + +data Todo = Todo + { created :: UTCTime + , title :: String + , description :: Maybe String + } deriving (Generic, FromJSON, ToSchema) + +newtype TodoId = TodoId String deriving (Generic, ToParamSchema) + +type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo + +todoAPI :: Value +todoAPI = [aesonQQ| +{ + "swagger":"2.0", + "info": + { + "title": "", + "version": "" + }, + "definitions": + { + "Todo": + { + "type": "object", + "required": [ "created", "title" ], + "properties": + { + "created": { "$ref": "#/definitions/UTCTime" }, + "title": { "type": "string" }, + "description": { "type": "string" } + } + }, + "UTCTime": + { + "type": "string", + "format": "yyyy-mm-ddThh:MM:ssZ" + } + }, + "paths": + { + "/todo/{id}": + { + "get": + { + "responses": + { + "200": + { + "schema": { "$ref":"#/definitions/Todo" }, + "description": "" + }, + "404": { "description": "id not found" } + }, + "produces": [ "application/json" ], + "parameters": + [ + { + "required": true, + "in": "path", + "name": "id", + "type": "string" + } + ] + } + } + } +} +|] + +-- ======================================================================= +-- Hackage API +-- ======================================================================= + +type HackageAPI + = HackageUserAPI + :<|> HackagePackagesAPI + +type HackageUserAPI = + "users" :> Get '[JSON] [UserSummary] + :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed + +type HackagePackagesAPI + = "packages" :> Get '[JSON] [Package] + +type Username = Text + +data UserSummary = UserSummary + { summaryUsername :: Username + , summaryUserid :: Int + } deriving (Eq, Show, Generic) + +lowerCutPrefix :: String -> String -> String +lowerCutPrefix s = map toLower . drop (length s) + +instance ToJSON UserSummary where + toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" } + +instance ToSchema UserSummary where + declareNamedSchema proxy = do + (name, schema) <- genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy + return (name, schema + & schemaExample ?~ toJSON UserSummary + { summaryUsername = "JohnDoe" + , summaryUserid = 123 }) + +type Group = Text + +data UserDetailed = UserDetailed + { username :: Username + , userid :: Int + , groups :: [Group] + } deriving (Eq, Show, Generic, ToSchema) + +newtype Package = Package { packageName :: Text } + deriving (Eq, Show, Generic, ToSchema) + +hackageSwaggerWithTags :: Swagger +hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI) + & host ?~ Host "hackage.haskell.org" Nothing + & usersOps %~ addTag "users" + & packagesOps %~ addTag "packages" + & tags .~ + [ Tag "users" (Just "Operations about user") Nothing + , Tag "packages" (Just "Query packages") Nothing + ] + where + usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) + packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI) + +hackageAPI :: Value +hackageAPI = [aesonQQ| +{ + "swagger":"2.0", + "host":"hackage.haskell.org", + "info":{ + "version":"", + "title":"" + }, + "definitions":{ + "UserDetailed":{ + "required":[ + "username", + "userid", + "groups" + ], + "type":"object", + "properties":{ + "groups":{ + "items":{ + "type":"string" + }, + "type":"array" + }, + "username":{ + "type":"string" + }, + "userid":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, + "type":"integer" + } + } + }, + "Package":{ + "required":[ + "packageName" + ], + "type":"object", + "properties":{ + "packageName":{ + "type":"string" + } + } + }, + "UserSummary":{ + "required":[ + "username", + "userid" + ], + "type":"object", + "properties":{ + "username":{ + "type":"string" + }, + "userid":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, + "type":"integer" + } + }, + "example":{ + "username": "JohnDoe", + "userid": 123 + } + } + }, + "paths":{ + "/users":{ + "get":{ + "responses":{ + "200":{ + "schema":{ + "items":{ + "$ref":"#/definitions/UserSummary" + }, + "type":"array" + }, + "description":"" + } + }, + "produces":[ + "application/json" + ], + "tags":[ + "users" + ] + } + }, + "/packages":{ + "get":{ + "responses":{ + "200":{ + "schema":{ + "items":{ + "$ref":"#/definitions/Package" + }, + "type":"array" + }, + "description":"" + } + }, + "produces":[ + "application/json" + ], + "tags":[ + "packages" + ] + } + }, + "/user/{username}":{ + "get":{ + "responses":{ + "404":{ + "description":"username not found" + }, + "200":{ + "schema":{ + "$ref":"#/definitions/UserDetailed" + }, + "description":"" + } + }, + "produces":[ + "application/json" + ], + "parameters":[ + { + "required":true, + "in":"path", + "name":"username", + "type":"string" + } + ], + "tags":[ + "users" + ] + } + } + }, + "tags":[ + { + "name":"users", + "description":"Operations about user" + }, + { + "name":"packages", + "description":"Query packages" + } + ] +} +|] + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 000000000..a824f8c30 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}