@@ -0,0 +1,477 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeOperators #-}
11+#if __GLASGOW_HASKELL__ >= 806
12+{-# LANGUAGE UndecidableInstances #-}
13+#endif
14+module Servant.Swagger.Internal where
15+
16+import Prelude ()
17+import Prelude.Compat
18+
19+import Control.Applicative ((<|>))
20+import Control.Lens
21+import Data.Aeson
22+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
23+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
24+import Data.Foldable (toList)
25+import Data.Proxy
26+import Data.Typeable
27+import Data.Singletons.Bool
28+import Data.Swagger hiding (Header)
29+import qualified Data.Swagger as Swagger
30+import Data.Swagger.Declare
31+import Data.Text (Text)
32+import qualified Data.Text as Text
33+import GHC.TypeLits
34+import Network.HTTP.Media (MediaType)
35+import Servant.API
36+import Servant.API.Description (FoldDescription,
37+ reflectDescription)
38+import Servant.API.Modifiers (FoldRequired)
39+
40+import Servant.Swagger.Internal.TypeLevel.API
41+
42+-- | Generate a Swagger specification for a servant API.
43+--
44+-- To generate Swagger specification, your data types need
45+-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
46+--
47+-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.
48+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
49+--
50+-- You can easily derive those instances via @Generic@.
51+-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
52+--
53+-- Example:
54+--
55+-- @
56+-- newtype Username = Username String deriving (Generic, ToText)
57+--
58+-- instance ToParamSchema Username
59+--
60+-- data User = User
61+-- { username :: Username
62+-- , fullname :: String
63+-- } deriving (Generic)
64+--
65+-- instance ToJSON User
66+-- instance ToSchema User
67+--
68+-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
69+--
70+-- mySwagger :: Swagger
71+-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)
72+-- @
73+class HasSwagger api where
74+ -- | Generate a Swagger specification for a servant API.
75+ toSwagger :: Proxy api -> Swagger
76+
77+instance HasSwagger Raw where
78+ toSwagger _ = mempty & paths . at "/" ?~ mempty
79+
80+instance HasSwagger EmptyAPI where
81+ toSwagger _ = mempty
82+
83+-- | All operations of sub API.
84+-- This is similar to @'operationsOf'@ but ensures that operations
85+-- indeed belong to the API at compile time.
86+subOperations :: (IsSubAPI sub api, HasSwagger sub) =>
87+ Proxy sub -- ^ Part of a servant API.
88+ -> Proxy api -- ^ The whole servant API.
89+ -> Traversal' Swagger Operation
90+subOperations sub _ = operationsOf (toSwagger sub)
91+
92+-- | Make a singleton Swagger spec (with only one endpoint).
93+-- For endpoints with no content see 'mkEndpointNoContent'.
94+mkEndpoint :: forall a cs hs proxy method status.
95+ (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
96+ => FilePath -- ^ Endpoint path.
97+ -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.
98+ -> Swagger
99+mkEndpoint path proxy
100+ = mkEndpointWithSchemaRef (Just ref) path proxy
101+ & definitions .~ defs
102+ where
103+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
104+
105+-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.
106+mkEndpointNoContent :: forall nocontent cs hs proxy method status.
107+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
108+ => FilePath -- ^ Endpoint path.
109+ -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.
110+ -> Swagger
111+mkEndpointNoContent path proxy
112+ = mkEndpointWithSchemaRef Nothing path proxy
113+
114+-- | Like @'mkEndpoint'@ but with explicit schema reference.
115+-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.
116+mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
117+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
118+ => Maybe (Referenced Schema)
119+ -> FilePath
120+ -> proxy (Verb method status cs (Headers hs a))
121+ -> Swagger
122+mkEndpointWithSchemaRef mref path _ = mempty
123+ & paths.at path ?~
124+ (mempty & method ?~ (mempty
125+ & produces ?~ MimeList responseContentTypes
126+ & at code ?~ Inline (mempty
127+ & schema .~ mref
128+ & headers .~ responseHeaders)))
129+ where
130+ method = swaggerMethod (Proxy :: Proxy method)
131+ code = fromIntegral (natVal (Proxy :: Proxy status))
132+ responseContentTypes = allContentType (Proxy :: Proxy cs)
133+ responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
134+
135+mkEndpointNoContentVerb :: forall proxy method.
136+ (SwaggerMethod method)
137+ => FilePath -- ^ Endpoint path.
138+ -> proxy (NoContentVerb method) -- ^ Method
139+ -> Swagger
140+mkEndpointNoContentVerb path _ = mempty
141+ & paths.at path ?~
142+ (mempty & method ?~ (mempty
143+ & at code ?~ Inline mempty))
144+ where
145+ method = swaggerMethod (Proxy :: Proxy method)
146+ code = 204 -- hardcoded in servant-server
147+
148+-- | Add parameter to every operation in the spec.
149+addParam :: Param -> Swagger -> Swagger
150+addParam param = allOperations.parameters %~ (Inline param :)
151+
152+-- | Add accepted content types to every operation in the spec.
153+addConsumes :: [MediaType] -> Swagger -> Swagger
154+addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
155+
156+-- | Format given text as inline code in Markdown.
157+markdownCode :: Text -> Text
158+markdownCode s = "`" <> s <> "`"
159+
160+addDefaultResponse400 :: ParamName -> Swagger -> Swagger
161+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
162+ where
163+ sname = markdownCode pname
164+ description400 = "Invalid " <> sname
165+ alter400 = description %~ (<> (" or " <> sname))
166+ response400 = mempty & description .~ description400
167+
168+-- | Methods, available for Swagger.
169+class SwaggerMethod method where
170+ swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)
171+
172+instance SwaggerMethod 'GET where swaggerMethod _ = get
173+instance SwaggerMethod 'PUT where swaggerMethod _ = put
174+instance SwaggerMethod 'POST where swaggerMethod _ = post
175+instance SwaggerMethod 'DELETE where swaggerMethod _ = delete
176+instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
177+instance SwaggerMethod 'HEAD where swaggerMethod _ = head_
178+instance SwaggerMethod 'PATCH where swaggerMethod _ = patch
179+
180+instance HasSwagger (UVerb method cs '[]) where
181+ toSwagger _ = mempty
182+
183+-- | @since <TODO>
184+instance
185+ {-# OVERLAPPABLE #-}
186+ ( ToSchema a,
187+ HasStatus a,
188+ AllAccept cs,
189+ SwaggerMethod method,
190+ HasSwagger (UVerb method cs as)
191+ ) =>
192+ HasSwagger (UVerb method cs (a ': as))
193+ where
194+ toSwagger _ =
195+ toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
196+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
197+
198+-- ATTENTION: do not remove this instance!
199+-- A similar instance above will always use the more general
200+-- polymorphic -- HasSwagger instance and will result in a type error
201+-- since 'NoContent' does not have a 'ToSchema' instance.
202+instance
203+ ( KnownNat status,
204+ AllAccept cs,
205+ SwaggerMethod method,
206+ HasSwagger (UVerb method cs as)
207+ ) =>
208+ HasSwagger (UVerb method cs (WithStatus status NoContent ': as))
209+ where
210+ toSwagger _ =
211+ toSwagger (Proxy :: Proxy (Verb method status cs NoContent))
212+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
213+
214+
215+-- workaround for https://github.com/GetShopTV/swagger2/issues/218
216+-- We'd like to juse use (<>) but the instances are wrong
217+combinePathItem :: PathItem -> PathItem -> PathItem
218+combinePathItem s t = PathItem
219+ { _pathItemGet = _pathItemGet s <> _pathItemGet t
220+ , _pathItemPut = _pathItemPut s <> _pathItemPut t
221+ , _pathItemPost = _pathItemPost s <> _pathItemPost t
222+ , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
223+ , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
224+ , _pathItemHead = _pathItemHead s <> _pathItemHead t
225+ , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
226+ , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
227+ }
228+
229+combineSwagger :: Swagger -> Swagger -> Swagger
230+combineSwagger s t = Swagger
231+ { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
232+ , _swaggerHost = _swaggerHost s <|> _swaggerHost t
233+ , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
234+ , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
235+ , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
236+ , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
237+ , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
238+ , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
239+ , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
240+ , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
241+ , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
242+ , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
243+ , _swaggerTags = _swaggerTags s <> _swaggerTags t
244+ , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
245+ }
246+
247+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
248+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
249+
250+-- | @since 1.1.7
251+instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where
252+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))
253+
254+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
255+ => HasSwagger (Verb method status cs (Headers hs a)) where
256+ toSwagger = mkEndpoint "/"
257+
258+-- ATTENTION: do not remove this instance!
259+-- A similar instance above will always use the more general
260+-- polymorphic -- HasSwagger instance and will result in a type error
261+-- since 'NoContent' does not have a 'ToSchema' instance.
262+instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
263+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
264+
265+instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
266+ => HasSwagger (Verb method status cs (Headers hs NoContent)) where
267+ toSwagger = mkEndpointNoContent "/"
268+
269+instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where
270+ toSwagger = mkEndpointNoContentVerb "/"
271+
272+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
273+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
274+
275+-- | @'Vault'@ combinator does not change our specification at all.
276+instance (HasSwagger sub) => HasSwagger (Vault :> sub) where
277+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
278+
279+-- | @'IsSecure'@ combinator does not change our specification at all.
280+instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where
281+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
282+
283+-- | @'RemoteHost'@ combinator does not change our specification at all.
284+instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where
285+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
286+
287+-- | @'Fragment'@ combinator does not change our specification at all.
288+instance HasSwagger sub => HasSwagger (Fragment a :> sub) where
289+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
290+
291+-- | @'HttpVersion'@ combinator does not change our specification at all.
292+instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
293+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
294+
295+-- | @'WithNamedContext'@ combinator does not change our specification at all.
296+instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
297+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
298+
299+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
300+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
301+ where
302+ piece = symbolVal (Proxy :: Proxy sym)
303+
304+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where
305+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
306+ & addParam param
307+ & prependPath capture
308+ & addDefaultResponse400 tname
309+ where
310+ symbol = symbolVal (Proxy :: Proxy sym)
311+ pname = if symbol == ""
312+ then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
313+ else symbol
314+ tname = Text.pack pname
315+ transDesc "" = Nothing
316+ transDesc desc = Just (Text.pack desc)
317+ capture = "{" <> pname <> "}"
318+ param = mempty
319+ & name .~ tname
320+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
321+ & required ?~ True
322+ & schema .~ ParamOther (mempty
323+ & in_ .~ ParamPath
324+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
325+
326+-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
327+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
328+ toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
329+
330+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where
331+ toSwagger _ = toSwagger (Proxy :: Proxy api)
332+ & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
333+
334+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where
335+ toSwagger _ = toSwagger (Proxy :: Proxy api)
336+ & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
337+
338+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where
339+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
340+ & addParam param
341+ & addDefaultResponse400 tname
342+ where
343+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
344+ transDesc "" = Nothing
345+ transDesc desc = Just (Text.pack desc)
346+ param = mempty
347+ & name .~ tname
348+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
349+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
350+ & schema .~ ParamOther sch
351+ sch = mempty
352+ & in_ .~ ParamQuery
353+ & paramSchema .~ toParamSchema (Proxy :: Proxy a)
354+
355+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
356+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
357+ & addParam param
358+ & addDefaultResponse400 tname
359+ where
360+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
361+ param = mempty
362+ & name .~ tname
363+ & schema .~ ParamOther sch
364+ sch = mempty
365+ & in_ .~ ParamQuery
366+ & paramSchema .~ pschema
367+ pschema = mempty
368+#if MIN_VERSION_swagger2(2,4,0)
369+ & type_ ?~ SwaggerArray
370+#else
371+ & type_ .~ SwaggerArray
372+#endif
373+ & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
374+
375+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
376+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
377+ & addParam param
378+ & addDefaultResponse400 tname
379+ where
380+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
381+ param = mempty
382+ & name .~ tname
383+ & schema .~ ParamOther (mempty
384+ & in_ .~ ParamQuery
385+ & allowEmptyValue ?~ True
386+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
387+ & default_ ?~ toJSON False))
388+
389+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
390+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
391+ & addParam param
392+ & addDefaultResponse400 tname
393+ where
394+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
395+ transDesc "" = Nothing
396+ transDesc desc = Just (Text.pack desc)
397+ param = mempty
398+ & name .~ tname
399+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
400+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
401+ & schema .~ ParamOther (mempty
402+ & in_ .~ ParamHeader
403+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
404+
405+instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where
406+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
407+ & addParam param
408+ & addConsumes (allContentType (Proxy :: Proxy cs))
409+ & addDefaultResponse400 tname
410+ & definitions %~ (<> defs)
411+ where
412+ tname = "body"
413+ transDesc "" = Nothing
414+ transDesc desc = Just (Text.pack desc)
415+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
416+ param = mempty
417+ & name .~ tname
418+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
419+ & required ?~ True
420+ & schema .~ ParamBody ref
421+
422+-- | This instance is an approximation.
423+--
424+-- @since 1.1.7
425+instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
426+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
427+ & addParam param
428+ & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
429+ & addDefaultResponse400 tname
430+ & definitions %~ (<> defs)
431+ where
432+ tname = "body"
433+ transDesc "" = Nothing
434+ transDesc desc = Just (Text.pack desc)
435+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
436+ param = mempty
437+ & name .~ tname
438+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
439+ & required ?~ True
440+ & schema .~ ParamBody ref
441+
442+-- =======================================================================
443+-- Below are the definitions that should be in Servant.API.ContentTypes
444+-- =======================================================================
445+
446+class AllAccept cs where
447+ allContentType :: Proxy cs -> [MediaType]
448+
449+instance AllAccept '[] where
450+ allContentType _ = []
451+
452+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
453+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
454+
455+class ToResponseHeader h where
456+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
457+
458+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
459+ toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
460+ where
461+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))
462+ hschema = toParamSchema (Proxy :: Proxy a)
463+
464+class AllToResponseHeader hs where
465+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
466+
467+instance AllToResponseHeader '[] where
468+ toAllResponseHeaders _ = mempty
469+
470+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
471+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
472+ where
473+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
474+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
475+
476+instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
477+ toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)