@@ -1,488 +0,0 @@
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE TypeFamilies #-}
13−#if __GLASGOW_HASKELL__ >= 806
14−{-# LANGUAGE UndecidableInstances #-}
16−module Servant.Swagger.Internal where
21−import Control.Applicative ((<|>))
24−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
25−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
26−import Data.Foldable (toList)
29−import Data.Singletons.Bool
30−import Data.Swagger hiding (Header)
31−import qualified Data.Swagger as Swagger
32−import Data.Swagger.Declare
33−import Data.Text (Text)
34−import qualified Data.Text as Text
35−import GHC.Generics (D1, Meta(..), Rep)
37−import Network.HTTP.Media (MediaType)
39−import Servant.API.Description (FoldDescription,
41−import Servant.API.Generic (ToServantApi, AsApi)
42−import Servant.API.Modifiers (FoldRequired)
44−import Servant.Swagger.Internal.TypeLevel.API
46−-- | Generate a Swagger specification for a servant API.
48−-- To generate Swagger specification, your data types need
49−-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
51−-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.
52−-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
54−-- You can easily derive those instances via @Generic@.
55−-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
60−-- newtype Username = Username String deriving (Generic, ToText)
62−-- instance ToParamSchema Username
65−-- { username :: Username
66−-- , fullname :: String
67−-- } deriving (Generic)
69−-- instance ToJSON User
70−-- instance ToSchema User
72−-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
74−-- mySwagger :: Swagger
75−-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)
77−class HasSwagger api where
78− -- | Generate a Swagger specification for a servant API.
79− toSwagger :: Proxy api -> Swagger
81−instance HasSwagger Raw where
82− toSwagger _ = mempty & paths . at "/" ?~ mempty
84−instance HasSwagger EmptyAPI where
87−-- | All operations of sub API.
88−-- This is similar to @'operationsOf'@ but ensures that operations
89−-- indeed belong to the API at compile time.
90−subOperations :: (IsSubAPI sub api, HasSwagger sub) =>
91− Proxy sub -- ^ Part of a servant API.
92− -> Proxy api -- ^ The whole servant API.
93− -> Traversal' Swagger Operation
94−subOperations sub _ = operationsOf (toSwagger sub)
96−-- | Make a singleton Swagger spec (with only one endpoint).
97−-- For endpoints with no content see 'mkEndpointNoContent'.
98−mkEndpoint :: forall a cs hs proxy method status.
99− (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
100− => FilePath -- ^ Endpoint path.
101− -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.
103−mkEndpoint path proxy
104− = mkEndpointWithSchemaRef (Just ref) path proxy
105− & definitions .~ defs
107− (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
109−-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.
110−mkEndpointNoContent :: forall nocontent cs hs proxy method status.
111− (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
112− => FilePath -- ^ Endpoint path.
113− -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.
115−mkEndpointNoContent path proxy
116− = mkEndpointWithSchemaRef Nothing path proxy
118−-- | Like @'mkEndpoint'@ but with explicit schema reference.
119−-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.
120−mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
121− (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
122− => Maybe (Referenced Schema)
124− -> proxy (Verb method status cs (Headers hs a))
126−mkEndpointWithSchemaRef mref path _ = mempty
128− (mempty & method ?~ (mempty
129− & produces ?~ MimeList responseContentTypes
130− & at code ?~ Inline (mempty
132− & headers .~ responseHeaders)))
134− method = swaggerMethod (Proxy :: Proxy method)
135− code = fromIntegral (natVal (Proxy :: Proxy status))
136− responseContentTypes = allContentType (Proxy :: Proxy cs)
137− responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
139−mkEndpointNoContentVerb :: forall proxy method.
140− (SwaggerMethod method)
141− => FilePath -- ^ Endpoint path.
142− -> proxy (NoContentVerb method) -- ^ Method
144−mkEndpointNoContentVerb path _ = mempty
146− (mempty & method ?~ (mempty
147− & at code ?~ Inline mempty))
149− method = swaggerMethod (Proxy :: Proxy method)
150− code = 204 -- hardcoded in servant-server
152−-- | Add parameter to every operation in the spec.
153−addParam :: Param -> Swagger -> Swagger
154−addParam param = allOperations.parameters %~ (Inline param :)
156−-- | Add a tag to every operation in the spec.
157−addTag :: Text -> Swagger -> Swagger
158−addTag tag = allOperations.tags %~ ([tag] <>)
160−-- | Add accepted content types to every operation in the spec.
161−addConsumes :: [MediaType] -> Swagger -> Swagger
162−addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
164−-- | Format given text as inline code in Markdown.
165−markdownCode :: Text -> Text
166−markdownCode s = "`" <> s <> "`"
168−addDefaultResponse400 :: ParamName -> Swagger -> Swagger
169−addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
171− sname = markdownCode pname
172− description400 = "Invalid " <> sname
173− alter400 = description %~ (<> (" or " <> sname))
174− response400 = mempty & description .~ description400
176−-- | Methods, available for Swagger.
177−class SwaggerMethod method where
178− swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)
180−instance SwaggerMethod 'GET where swaggerMethod _ = get
181−instance SwaggerMethod 'PUT where swaggerMethod _ = put
182−instance SwaggerMethod 'POST where swaggerMethod _ = post
183−instance SwaggerMethod 'DELETE where swaggerMethod _ = delete
184−instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
185−instance SwaggerMethod 'HEAD where swaggerMethod _ = head_
186−instance SwaggerMethod 'PATCH where swaggerMethod _ = patch
188−instance HasSwagger (UVerb method cs '[]) where
189− toSwagger _ = mempty
193− {-# OVERLAPPABLE #-}
197− SwaggerMethod method,
198− HasSwagger (UVerb method cs as)
200− HasSwagger (UVerb method cs (a ': as))
203− toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
204− `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
206−-- ATTENTION: do not remove this instance!
207−-- A similar instance above will always use the more general
208−-- polymorphic -- HasSwagger instance and will result in a type error
209−-- since 'NoContent' does not have a 'ToSchema' instance.
213− SwaggerMethod method,
214− HasSwagger (UVerb method cs as)
216− HasSwagger (UVerb method cs (WithStatus status NoContent ': as))
219− toSwagger (Proxy :: Proxy (Verb method status cs NoContent))
220− `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
223−-- workaround for https://github.com/GetShopTV/swagger2/issues/218
224−-- We'd like to juse use (<>) but the instances are wrong
225−combinePathItem :: PathItem -> PathItem -> PathItem
226−combinePathItem s t = PathItem
227− { _pathItemGet = _pathItemGet s <> _pathItemGet t
228− , _pathItemPut = _pathItemPut s <> _pathItemPut t
229− , _pathItemPost = _pathItemPost s <> _pathItemPost t
230− , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
231− , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
232− , _pathItemHead = _pathItemHead s <> _pathItemHead t
233− , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
234− , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
237−combineSwagger :: Swagger -> Swagger -> Swagger
238−combineSwagger s t = Swagger
239− { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
240− , _swaggerHost = _swaggerHost s <|> _swaggerHost t
241− , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
242− , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
243− , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
244− , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
245− , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
246− , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
247− , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
248− , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
249− , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
250− , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
251− , _swaggerTags = _swaggerTags s <> _swaggerTags t
252− , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
255−instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
256− toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
259−instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where
260− toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))
262−instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
263− => HasSwagger (Verb method status cs (Headers hs a)) where
264− toSwagger = mkEndpoint "/"
266−-- ATTENTION: do not remove this instance!
267−-- A similar instance above will always use the more general
268−-- polymorphic -- HasSwagger instance and will result in a type error
269−-- since 'NoContent' does not have a 'ToSchema' instance.
270−instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
271− toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
273−instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
274− => HasSwagger (Verb method status cs (Headers hs NoContent)) where
275− toSwagger = mkEndpointNoContent "/"
277−instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where
278− toSwagger = mkEndpointNoContentVerb "/"
280−instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
281− toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
283−-- | @'Vault'@ combinator does not change our specification at all.
284−instance (HasSwagger sub) => HasSwagger (Vault :> sub) where
285− toSwagger _ = toSwagger (Proxy :: Proxy sub)
287−-- | @'IsSecure'@ combinator does not change our specification at all.
288−instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where
289− toSwagger _ = toSwagger (Proxy :: Proxy sub)
291−-- | @'RemoteHost'@ combinator does not change our specification at all.
292−instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where
293− toSwagger _ = toSwagger (Proxy :: Proxy sub)
295−-- | @'Fragment'@ combinator does not change our specification at all.
296−instance HasSwagger sub => HasSwagger (Fragment a :> sub) where
297− toSwagger _ = toSwagger (Proxy :: Proxy sub)
299−-- | @'HttpVersion'@ combinator does not change our specification at all.
300−instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
301− toSwagger _ = toSwagger (Proxy :: Proxy sub)
303−-- | @'WithNamedContext'@ combinator does not change our specification at all.
304−instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
305− toSwagger _ = toSwagger (Proxy :: Proxy sub)
307−instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
308− toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
310− piece = symbolVal (Proxy :: Proxy sym)
312−instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where
313− toSwagger _ = toSwagger (Proxy :: Proxy sub)
315− & prependPath capture
316− & addDefaultResponse400 tname
318− symbol = symbolVal (Proxy :: Proxy sym)
319− pname = if symbol == ""
320− then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
322− tname = Text.pack pname
323− transDesc "" = Nothing
324− transDesc desc = Just (Text.pack desc)
325− capture = "{" <> pname <> "}"
328− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
330− & schema .~ ParamOther (mempty
332− & paramSchema .~ toParamSchema (Proxy :: Proxy a))
334−-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
335−instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
336− toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
338−instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where
339− toSwagger _ = toSwagger (Proxy :: Proxy api)
340− & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
342−instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where
343− toSwagger _ = toSwagger (Proxy :: Proxy api)
344− & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
346−instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where
347− toSwagger _ = toSwagger (Proxy :: Proxy sub)
349− & addDefaultResponse400 tname
351− tname = Text.pack (symbolVal (Proxy :: Proxy sym))
352− transDesc "" = Nothing
353− transDesc desc = Just (Text.pack desc)
356− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
357− & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
358− & schema .~ ParamOther sch
361− & paramSchema .~ toParamSchema (Proxy :: Proxy a)
363−instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
364− toSwagger _ = toSwagger (Proxy :: Proxy sub)
366− & addDefaultResponse400 tname
368− tname = Text.pack (symbolVal (Proxy :: Proxy sym))
371− & schema .~ ParamOther sch
374− & paramSchema .~ pschema
376−#if MIN_VERSION_swagger2(2,4,0)
377− & type_ ?~ SwaggerArray
379− & type_ .~ SwaggerArray
381− & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
383−instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
384− toSwagger _ = toSwagger (Proxy :: Proxy sub)
386− & addDefaultResponse400 tname
388− tname = Text.pack (symbolVal (Proxy :: Proxy sym))
391− & schema .~ ParamOther (mempty
393− & allowEmptyValue ?~ True
394− & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
395− & default_ ?~ toJSON False))
397−instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
398− toSwagger _ = toSwagger (Proxy :: Proxy sub)
400− & addDefaultResponse400 tname
402− tname = Text.pack (symbolVal (Proxy :: Proxy sym))
403− transDesc "" = Nothing
404− transDesc desc = Just (Text.pack desc)
407− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
408− & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
409− & schema .~ ParamOther (mempty
410− & in_ .~ ParamHeader
411− & paramSchema .~ toParamSchema (Proxy :: Proxy a))
413−instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where
414− toSwagger _ = toSwagger (Proxy :: Proxy sub)
416− & addConsumes (allContentType (Proxy :: Proxy cs))
417− & addDefaultResponse400 tname
418− & definitions %~ (<> defs)
421− transDesc "" = Nothing
422− transDesc desc = Just (Text.pack desc)
423− (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
426− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
428− & schema .~ ParamBody ref
430−-- | This instance is an approximation.
433−instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
434− toSwagger _ = toSwagger (Proxy :: Proxy sub)
436− & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
437− & addDefaultResponse400 tname
438− & definitions %~ (<> defs)
441− transDesc "" = Nothing
442− transDesc desc = Just (Text.pack desc)
443− (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
446− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
448− & schema .~ ParamBody ref
450−instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
451− toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
453−-- =======================================================================
454−-- Below are the definitions that should be in Servant.API.ContentTypes
455−-- =======================================================================
457−class AllAccept cs where
458− allContentType :: Proxy cs -> [MediaType]
460−instance AllAccept '[] where
461− allContentType _ = []
463−instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
464− allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
466−class ToResponseHeader h where
467− toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
469−instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
470− toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
472− hname = Text.pack (symbolVal (Proxy :: Proxy sym))
473− hschema = toParamSchema (Proxy :: Proxy a)
475−class AllToResponseHeader hs where
476− toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
478−instance AllToResponseHeader '[] where
479− toAllResponseHeaders _ = mempty
481−instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
482− toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
484− (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
485− hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
487−instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
488− toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)