@@ -0,0 +1,488 @@
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)