@@ -0,0 +1,803 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+module Servant.Docs.Internal where
15+
16+import Control.Applicative
17+import Control.Lens
18+import Data.ByteString.Lazy.Char8 (ByteString)
19+import Data.Hashable
20+import Data.HashMap.Strict (HashMap)
21+import Data.List
22+import Data.Maybe
23+import Data.Monoid
24+import Data.Ord (comparing)
25+import Data.Proxy
26+import Data.String.Conversions
27+import Data.Text (Text, pack, unpack)
28+import GHC.Exts (Constraint)
29+import GHC.Generics
30+import GHC.TypeLits
31+import Servant.API
32+import Servant.API.ContentTypes
33+import Servant.Utils.Links
34+
35+import qualified Data.HashMap.Strict as HM
36+import qualified Data.Text as T
37+import qualified Network.HTTP.Media as M
38+
39+-- | Supported HTTP request methods
40+data Method = DocDELETE -- ^ the DELETE method
41+ | DocGET -- ^ the GET method
42+ | DocPOST -- ^ the POST method
43+ | DocPUT -- ^ the PUT method
44+ deriving (Eq, Ord, Generic)
45+
46+instance Show Method where
47+ show DocGET = "GET"
48+ show DocPOST = "POST"
49+ show DocDELETE = "DELETE"
50+ show DocPUT = "PUT"
51+
52+instance Hashable Method
53+
54+-- | An 'Endpoint' type that holds the 'path' and the 'method'.
55+--
56+-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'
57+-- or any 'Endpoint' value you want using the 'path' and 'method'
58+-- lenses to tweak.
59+--
60+-- @
61+-- λ> 'defEndpoint'
62+-- GET /
63+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
64+-- GET /foo
65+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
66+-- POST /foo
67+-- @
68+data Endpoint = Endpoint
69+ { _path :: [String] -- type collected
70+ , _method :: Method -- type collected
71+ } deriving (Eq, Ord, Generic)
72+
73+instance Show Endpoint where
74+ show (Endpoint p m) =
75+ show m ++ " " ++ showPath p
76+
77+-- |
78+-- Render a path as a '/'-delimited string
79+--
80+showPath :: [String] -> String
81+showPath [] = "/"
82+showPath ps = concatMap ('/' :) ps
83+
84+-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
85+--
86+-- Here's how you can modify it:
87+--
88+-- @
89+-- λ> 'defEndpoint'
90+-- GET /
91+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
92+-- GET /foo
93+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
94+-- POST /foo
95+-- @
96+defEndpoint :: Endpoint
97+defEndpoint = Endpoint [] DocGET
98+
99+instance Hashable Endpoint
100+
101+-- | Our API documentation type, a product of top-level information and a good
102+-- old hashmap from 'Endpoint' to 'Action'
103+data API = API
104+ { _apiIntros :: [DocIntro]
105+ , _apiEndpoints :: HashMap Endpoint Action
106+ } deriving (Eq, Show)
107+
108+instance Monoid API where
109+ API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)
110+ mempty = API mempty mempty
111+
112+-- | An empty 'API'
113+emptyAPI :: API
114+emptyAPI = mempty
115+
116+-- | A type to represent captures. Holds the name of the capture
117+-- and a description.
118+--
119+-- Write a 'ToCapture' instance for your captured types.
120+data DocCapture = DocCapture
121+ { _capSymbol :: String -- type supplied
122+ , _capDesc :: String -- user supplied
123+ } deriving (Eq, Ord, Show)
124+
125+-- | A type to represent a /GET/ parameter from the Query String. Holds its name,
126+-- the possible values (leave empty if there isn't a finite number of them),
127+-- and a description of how it influences the output or behavior.
128+--
129+-- Write a 'ToParam' instance for your GET parameter types
130+data DocQueryParam = DocQueryParam
131+ { _paramName :: String -- type supplied
132+ , _paramValues :: [String] -- user supplied
133+ , _paramDesc :: String -- user supplied
134+ , _paramKind :: ParamKind
135+ } deriving (Eq, Ord, Show)
136+
137+-- | An introductory paragraph for your documentation. You can pass these to
138+-- 'docsWithIntros'.
139+data DocIntro = DocIntro
140+ { _introTitle :: String -- ^ Appears above the intro blob
141+ , _introBody :: [String] -- ^ Each String is a paragraph.
142+ } deriving (Eq, Show)
143+
144+instance Ord DocIntro where
145+ compare = comparing _introTitle
146+
147+-- | A type to represent extra notes that may be attached to an 'Action'.
148+--
149+-- This is intended to be used when writing your own HasDocs instances to
150+-- add extra sections to your endpoint's documentation.
151+data DocNote = DocNote
152+ { _noteTitle :: String
153+ , _noteBody :: [String]
154+ } deriving (Eq, Ord, Show)
155+
156+-- | Type of extra information that a user may wish to "union" with their
157+-- documentation.
158+--
159+-- These are intended to be built using extraInfo.
160+-- Multiple ExtraInfo may be combined with the monoid instance.
161+newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
162+instance Monoid (ExtraInfo a) where
163+ mempty = ExtraInfo mempty
164+ ExtraInfo a `mappend` ExtraInfo b =
165+ ExtraInfo $ HM.unionWith combineAction a b
166+
167+-- | Type of GET parameter:
168+--
169+-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
170+-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values
171+-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter
172+data ParamKind = Normal | List | Flag
173+ deriving (Eq, Ord, Show)
174+
175+-- | A type to represent an HTTP response. Has an 'Int' status, a list of
176+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
177+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'
178+-- lenses if you want.
179+--
180+-- If you want to respond with a non-empty response body, you'll most likely
181+-- want to write a 'ToSample' instance for the type that'll be represented
182+-- as encoded data in the response.
183+--
184+-- Can be tweaked with three lenses.
185+--
186+-- > λ> defResponse
187+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
188+-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
189+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
190+data Response = Response
191+ { _respStatus :: Int
192+ , _respTypes :: [M.MediaType]
193+ , _respBody :: [(Text, M.MediaType, ByteString)]
194+ } deriving (Eq, Ord, Show)
195+
196+-- | Default response: status code 200, no response body.
197+--
198+-- Can be tweaked with two lenses.
199+--
200+-- > λ> defResponse
201+-- > Response {_respStatus = 200, _respBody = Nothing}
202+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
203+-- > Response {_respStatus = 204, _respBody = Just "[]"}
204+defResponse :: Response
205+defResponse = Response 200 [] []
206+
207+-- | A datatype that represents everything that can happen
208+-- at an endpoint, with its lenses:
209+--
210+-- - List of captures ('captures')
211+-- - List of GET parameters ('params')
212+-- - What the request body should look like, if any is requested ('rqbody')
213+-- - What the response should be if everything goes well ('response')
214+--
215+-- You can tweak an 'Action' (like the default 'defAction') with these lenses
216+-- to transform an action and add some information to it.
217+data Action = Action
218+ { _captures :: [DocCapture] -- type collected + user supplied info
219+ , _headers :: [Text] -- type collected
220+ , _params :: [DocQueryParam] -- type collected + user supplied info
221+ , _notes :: [DocNote] -- user supplied
222+ , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
223+ , _rqtypes :: [M.MediaType] -- type collected
224+ , _rqbody :: [(M.MediaType, ByteString)] -- user supplied
225+ , _response :: Response -- user supplied
226+ } deriving (Eq, Ord, Show)
227+
228+-- | Combine two Actions, we can't make a monoid as merging Response breaks the
229+-- laws.
230+--
231+-- As such, we invent a non-commutative, left associative operation
232+-- 'combineAction' to mush two together taking the response, body and content
233+-- types from the very left.
234+combineAction :: Action -> Action -> Action
235+Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
236+ Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
237+
238+-- Default 'Action'. Has no 'captures', no GET 'params', expects
239+-- no request body ('rqbody') and the typical response is 'defResponse'.
240+--
241+-- Tweakable with lenses.
242+--
243+-- > λ> defAction
244+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
245+-- > λ> defAction & response.respStatus .~ 201
246+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
247+defAction :: Action
248+defAction =
249+ Action []
250+ []
251+ []
252+ []
253+ []
254+ []
255+ []
256+ defResponse
257+
258+-- | Create an API that's comprised of a single endpoint.
259+-- 'API' is a 'Monoid', so combine multiple endpoints with
260+-- 'mappend' or '<>'.
261+single :: Endpoint -> Action -> API
262+single e a = API mempty (HM.singleton e a)
263+
264+-- gimme some lenses
265+makeLenses ''API
266+makeLenses ''Endpoint
267+makeLenses ''DocCapture
268+makeLenses ''DocQueryParam
269+makeLenses ''DocIntro
270+makeLenses ''DocNote
271+makeLenses ''Response
272+makeLenses ''Action
273+
274+-- | Generate the docs for a given API that implements 'HasDocs'. This is the
275+-- default way to create documentation.
276+docs :: HasDocs (Canonicalize layout) => Proxy layout -> API
277+docs p = docsFor (canonicalize p) (defEndpoint, defAction)
278+
279+-- | Closed type family, check if endpoint is exactly within API.
280+
281+-- We aren't sure what affects how an Endpoint is built up, so we require an
282+-- exact match.
283+type family IsIn (endpoint :: *) (api :: *) :: Constraint where
284+ IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
285+ IsIn (e :> sa) (e :> sb) = IsIn sa sb
286+ IsIn e e = ()
287+
288+-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.
289+--
290+-- The safety here is to ensure that you only add custom documentation to an
291+-- endpoint that actually exists within your API.
292+--
293+-- > extra :: ExtraInfo TestApi
294+-- > extra =
295+-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
296+-- > defAction & headers <>~ ["unicorns"]
297+-- > & notes <>~ [ DocNote "Title" ["This is some text"]
298+-- > , DocNote "Second secton" ["And some more"]
299+-- > ]
300+
301+extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
302+ => Proxy endpoint -> Action -> ExtraInfo layout
303+extraInfo p action =
304+ let api = docsFor p (defEndpoint, defAction)
305+ -- Assume one endpoint, HasLink constraint means that we should only ever
306+ -- point at one endpoint.
307+ in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
308+
309+-- | Generate documentation given some extra introductions (in the form of
310+-- 'DocInfo') and some extra endpoint documentation (in the form of
311+-- 'ExtraInfo'.
312+--
313+-- The extra introductions will be prepended to the top of the documentation,
314+-- before the specific endpoint documentation. The extra endpoint documentation
315+-- will be "unioned" with the automatically generated endpoint documentation.
316+--
317+-- You are expected to build up the ExtraInfo with the Monoid instance and
318+-- 'extraInfo'.
319+--
320+-- If you only want to add an introduction, use 'docsWithIntros'.
321+docsWith :: HasDocs (Canonicalize layout)
322+ => [DocIntro]
323+ -> ExtraInfo layout
324+ -> Proxy layout
325+ -> API
326+docsWith intros (ExtraInfo endpoints) p =
327+ docs p & apiIntros <>~ intros
328+ & apiEndpoints %~ HM.unionWith combineAction endpoints
329+
330+
331+-- | Generate the docs for a given API that implements 'HasDocs' with with any
332+-- number of introduction(s)
333+docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API
334+docsWithIntros intros = docsWith intros mempty
335+
336+-- | The class that abstracts away the impact of API combinators
337+-- on documentation generation.
338+class HasDocs layout where
339+ docsFor :: Proxy layout -> (Endpoint, Action) -> API
340+
341+-- | The class that lets us display a sample input or output in the supported
342+-- content-types when generating documentation for endpoints that either:
343+--
344+-- - expect a request body, or
345+-- - return a non empty response body
346+--
347+-- Example of an instance:
348+--
349+-- > {-# LANGUAGE DeriveGeneric #-}
350+-- > {-# LANGUAGE OverloadedStrings #-}
351+-- >
352+-- > import Data.Aeson
353+-- > import Data.Text
354+-- > import GHC.Generics
355+-- >
356+-- > data Greet = Greet { _msg :: Text }
357+-- > deriving (Generic, Show)
358+-- >
359+-- > instance FromJSON Greet
360+-- > instance ToJSON Greet
361+-- >
362+-- > instance ToSample Greet where
363+-- > toSample = Just g
364+-- >
365+-- > where g = Greet "Hello, haskeller!"
366+--
367+-- You can also instantiate this class using 'toSamples' instead of
368+-- 'toSample': it lets you specify different responses along with
369+-- some context (as 'Text') that explains when you're supposed to
370+-- get the corresponding response.
371+class ToSample a where
372+ {-# MINIMAL (toSample | toSamples) #-}
373+ toSample :: Maybe a
374+ toSample = snd <$> listToMaybe samples
375+ where samples = toSamples :: [(Text, a)]
376+
377+ toSamples :: [(Text, a)]
378+ toSamples = maybe [] (return . ("",)) s
379+ where s = toSample :: Maybe a
380+
381+-- | Synthesise a sample value of a type, encoded in the specified media types.
382+sampleByteString
383+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
384+ => Proxy ctypes
385+ -> Proxy a
386+ -> [(M.MediaType, ByteString)]
387+sampleByteString ctypes@Proxy Proxy =
388+ maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
389+
390+-- | Synthesise a list of sample values of a particular type, encoded in the
391+-- specified media types.
392+sampleByteStrings
393+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
394+ => Proxy ctypes
395+ -> Proxy a
396+ -> [(Text, M.MediaType, ByteString)]
397+sampleByteStrings ctypes@Proxy Proxy =
398+ let samples = toSamples :: [(Text, a)]
399+ enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
400+ in concatMap enc samples
401+
402+-- | Generate a list of 'MediaType' values describing the content types
403+-- accepted by an API component.
404+class SupportedTypes (list :: [*]) where
405+ supportedTypes :: Proxy list -> [M.MediaType]
406+
407+instance SupportedTypes '[] where
408+ supportedTypes Proxy = []
409+
410+instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
411+ where
412+ supportedTypes Proxy =
413+ contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
414+
415+-- | The class that helps us automatically get documentation
416+-- for GET parameters.
417+--
418+-- Example of an instance:
419+--
420+-- > instance ToParam (QueryParam "capital" Bool) where
421+-- > toParam _ =
422+-- > DocQueryParam "capital"
423+-- > ["true", "false"]
424+-- > "Get the greeting message in uppercase (true) or not (false). Default is false."
425+class ToParam t where
426+ toParam :: Proxy t -> DocQueryParam
427+
428+-- | The class that helps us automatically get documentation
429+-- for URL captures.
430+--
431+-- Example of an instance:
432+--
433+-- > instance ToCapture (Capture "name" Text) where
434+-- > toCapture _ = DocCapture "name" "name of the person to greet"
435+class ToCapture c where
436+ toCapture :: Proxy c -> DocCapture
437+
438+-- | Generate documentation in Markdown format for
439+-- the given 'API'.
440+markdown :: API -> String
441+markdown api = unlines $
442+ introsStr (api ^. apiIntros)
443+ ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
444+
445+ where printEndpoint :: Endpoint -> Action -> [String]
446+ printEndpoint endpoint action =
447+ str :
448+ "" :
449+ notesStr (action ^. notes) ++
450+ capturesStr (action ^. captures) ++
451+ mxParamsStr (action ^. mxParams) ++
452+ headersStr (action ^. headers) ++
453+ paramsStr (action ^. params) ++
454+ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
455+ responseStr (action ^. response) ++
456+ []
457+
458+ where str = "## " ++ show (endpoint^.method)
459+ ++ " " ++ showPath (endpoint^.path)
460+
461+ introsStr :: [DocIntro] -> [String]
462+ introsStr = concatMap introStr
463+
464+ introStr :: DocIntro -> [String]
465+ introStr i =
466+ ("#### " ++ i ^. introTitle) :
467+ "" :
468+ intersperse "" (i ^. introBody) ++
469+ "" :
470+ []
471+
472+ notesStr :: [DocNote] -> [String]
473+ notesStr = concatMap noteStr
474+
475+ noteStr :: DocNote -> [String]
476+ noteStr nt =
477+ ("#### " ++ nt ^. noteTitle) :
478+ "" :
479+ intersperse "" (nt ^. noteBody) ++
480+ "" :
481+ []
482+
483+ capturesStr :: [DocCapture] -> [String]
484+ capturesStr [] = []
485+ capturesStr l =
486+ "#### Captures:" :
487+ "" :
488+ map captureStr l ++
489+ "" :
490+ []
491+
492+ captureStr cap =
493+ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
494+
495+ mxParamsStr :: [(String, [DocQueryParam])] -> [String]
496+ mxParamsStr [] = []
497+ mxParamsStr l =
498+ "#### Matrix Parameters:" :
499+ "" :
500+ map segmentStr l
501+ segmentStr :: (String, [DocQueryParam]) -> String
502+ segmentStr (segment, l) = unlines $
503+ ("**" ++ segment ++ "**:") :
504+ "" :
505+ map paramStr l ++
506+ "" :
507+ []
508+
509+ headersStr :: [Text] -> [String]
510+ headersStr [] = []
511+ headersStr l = [""] ++ map headerStr l ++ [""]
512+
513+ where headerStr hname = "- This endpoint is sensitive to the value of the **"
514+ ++ unpack hname ++ "** HTTP header."
515+
516+ paramsStr :: [DocQueryParam] -> [String]
517+ paramsStr [] = []
518+ paramsStr l =
519+ "#### GET Parameters:" :
520+ "" :
521+ map paramStr l ++
522+ "" :
523+ []
524+
525+ paramStr param = unlines $
526+ ("- " ++ param ^. paramName) :
527+ (if (not (null values) || param ^. paramKind /= Flag)
528+ then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
529+ else []) ++
530+ (" - **Description**: " ++ param ^. paramDesc) :
531+ (if (param ^. paramKind == List)
532+ then [" - This parameter is a **list**. All GET parameters with the name "
533+ ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
534+ else []) ++
535+ (if (param ^. paramKind == Flag)
536+ then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
537+ else []) ++
538+ []
539+
540+ where values = param ^. paramValues
541+
542+ rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
543+ rqbodyStr [] [] = []
544+ rqbodyStr types samples =
545+ ["#### Request:", ""]
546+ <> formatTypes types
547+ <> concatMap formatBody samples
548+
549+ formatTypes [] = []
550+ formatTypes ts = ["- Supported content types are:", ""]
551+ <> map (\t -> " - `" <> show t <> "`") ts
552+ <> [""]
553+
554+ formatBody (m, b) =
555+ "- Example: `" <> cs (show m) <> "`" :
556+ contentStr m b
557+
558+ markdownForType mime_type =
559+ case (M.mainType mime_type, M.subType mime_type) of
560+ ("text", "html") -> "html"
561+ ("application", "xml") -> "xml"
562+ ("application", "json") -> "javascript"
563+ ("application", "javascript") -> "javascript"
564+ ("text", "css") -> "css"
565+ (_, _) -> ""
566+
567+ contentStr mime_type body =
568+ "" :
569+ "```" <> markdownForType mime_type :
570+ cs body :
571+ "```" :
572+ "" :
573+ []
574+
575+ responseStr :: Response -> [String]
576+ responseStr resp =
577+ "#### Response:" :
578+ "" :
579+ ("- Status code " ++ show (resp ^. respStatus)) :
580+ "" :
581+ formatTypes (resp ^. respTypes) ++
582+ bodies
583+
584+ where bodies = case resp ^. respBody of
585+ [] -> ["- No response body\n"]
586+ [("", t, r)] -> "- Response body as below." : contentStr t r
587+ xs ->
588+ concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
589+
590+-- * Instances
591+
592+-- | The generated docs for @a ':<|>' b@ just appends the docs
593+-- for @a@ with the docs for @b@.
594+instance (HasDocs layout1, HasDocs layout2)
595+ => HasDocs (layout1 :<|> layout2) where
596+
597+ docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
598+
599+ where p1 :: Proxy layout1
600+ p1 = Proxy
601+
602+ p2 :: Proxy layout2
603+ p2 = Proxy
604+
605+-- | @"books" :> 'Capture' "isbn" Text@ will appear as
606+-- @/books/:isbn@ in the docs.
607+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
608+ => HasDocs (Capture sym a :> sublayout) where
609+
610+ docsFor Proxy (endpoint, action) =
611+ docsFor sublayoutP (endpoint', action')
612+
613+ where sublayoutP = Proxy :: Proxy sublayout
614+ captureP = Proxy :: Proxy (Capture sym a)
615+
616+ action' = over captures (|> toCapture captureP) action
617+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
618+ symP = Proxy :: Proxy sym
619+
620+
621+instance HasDocs Delete where
622+ docsFor Proxy (endpoint, action) =
623+ single endpoint' action'
624+
625+ where endpoint' = endpoint & method .~ DocDELETE
626+
627+ action' = action & response.respBody .~ []
628+ & response.respStatus .~ 204
629+
630+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
631+ => HasDocs (Get cts a) where
632+ docsFor Proxy (endpoint, action) =
633+ single endpoint' action'
634+
635+ where endpoint' = endpoint & method .~ DocGET
636+ action' = action & response.respBody .~ sampleByteStrings t p
637+ & response.respTypes .~ supportedTypes t
638+ t = Proxy :: Proxy cts
639+ p = Proxy :: Proxy a
640+
641+instance (KnownSymbol sym, HasDocs sublayout)
642+ => HasDocs (Header sym a :> sublayout) where
643+ docsFor Proxy (endpoint, action) =
644+ docsFor sublayoutP (endpoint, action')
645+
646+ where sublayoutP = Proxy :: Proxy sublayout
647+ action' = over headers (|> headername) action
648+ headername = pack $ symbolVal (Proxy :: Proxy sym)
649+
650+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
651+ => HasDocs (Post cts a) where
652+ docsFor Proxy (endpoint, action) =
653+ single endpoint' action'
654+
655+ where endpoint' = endpoint & method .~ DocPOST
656+ action' = action & response.respBody .~ sampleByteStrings t p
657+ & response.respTypes .~ supportedTypes t
658+ & response.respStatus .~ 201
659+ t = Proxy :: Proxy cts
660+ p = Proxy :: Proxy a
661+
662+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
663+ => HasDocs (Put cts a) where
664+ docsFor Proxy (endpoint, action) =
665+ single endpoint' action'
666+
667+ where endpoint' = endpoint & method .~ DocPUT
668+ action' = action & response.respBody .~ sampleByteStrings t p
669+ & response.respTypes .~ supportedTypes t
670+ & response.respStatus .~ 200
671+ t = Proxy :: Proxy cts
672+ p = Proxy :: Proxy a
673+
674+instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
675+ => HasDocs (QueryParam sym a :> sublayout) where
676+
677+ docsFor Proxy (endpoint, action) =
678+ docsFor sublayoutP (endpoint, action')
679+
680+ where sublayoutP = Proxy :: Proxy sublayout
681+ paramP = Proxy :: Proxy (QueryParam sym a)
682+ action' = over params (|> toParam paramP) action
683+
684+instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
685+ => HasDocs (QueryParams sym a :> sublayout) where
686+
687+ docsFor Proxy (endpoint, action) =
688+ docsFor sublayoutP (endpoint, action')
689+
690+ where sublayoutP = Proxy :: Proxy sublayout
691+ paramP = Proxy :: Proxy (QueryParams sym a)
692+ action' = over params (|> toParam paramP) action
693+
694+
695+instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
696+ => HasDocs (QueryFlag sym :> sublayout) where
697+
698+ docsFor Proxy (endpoint, action) =
699+ docsFor sublayoutP (endpoint, action')
700+
701+ where sublayoutP = Proxy :: Proxy sublayout
702+ paramP = Proxy :: Proxy (QueryFlag sym)
703+ action' = over params (|> toParam paramP) action
704+
705+
706+instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)
707+ => HasDocs (MatrixParam sym a :> sublayout) where
708+
709+ docsFor Proxy (endpoint, action) =
710+ docsFor sublayoutP (endpoint', action')
711+
712+ where sublayoutP = Proxy :: Proxy sublayout
713+ paramP = Proxy :: Proxy (MatrixParam sym a)
714+ segment = endpoint ^. (path._last)
715+ segment' = action ^. (mxParams._last._1)
716+ endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint
717+
718+ action' = if segment' /= segment
719+ -- This is the first matrix parameter for this segment, insert a new entry into the mxParams list
720+ then over mxParams (|> (segment, [toParam paramP])) action
721+ -- We've already inserted a matrix parameter for this segment, append to the existing list
722+ else action & mxParams._last._2 <>~ [toParam paramP]
723+ symP = Proxy :: Proxy sym
724+
725+
726+instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)
727+ => HasDocs (MatrixParams sym a :> sublayout) where
728+
729+ docsFor Proxy (endpoint, action) =
730+ docsFor sublayoutP (endpoint', action)
731+
732+ where sublayoutP = Proxy :: Proxy sublayout
733+ endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint
734+ symP = Proxy :: Proxy sym
735+
736+
737+instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
738+ => HasDocs (MatrixFlag sym :> sublayout) where
739+
740+ docsFor Proxy (endpoint, action) =
741+ docsFor sublayoutP (endpoint', action)
742+
743+ where sublayoutP = Proxy :: Proxy sublayout
744+
745+ endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
746+ symP = Proxy :: Proxy sym
747+
748+instance HasDocs Raw where
749+ docsFor _proxy (endpoint, action) =
750+ single endpoint action
751+
752+-- TODO: We use 'AllMimeRender' here because we need to be able to show the
753+-- example data. However, there's no reason to believe that the instances of
754+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
755+-- both are even defined) for any particular type.
756+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
757+ => HasDocs (ReqBody cts a :> sublayout) where
758+
759+ docsFor Proxy (endpoint, action) =
760+ docsFor sublayoutP (endpoint, action')
761+
762+ where sublayoutP = Proxy :: Proxy sublayout
763+ action' = action & rqbody .~ sampleByteString t p
764+ & rqtypes .~ supportedTypes t
765+ t = Proxy :: Proxy cts
766+ p = Proxy :: Proxy a
767+
768+instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
769+
770+ docsFor Proxy (endpoint, action) =
771+ docsFor sublayoutP (endpoint', action)
772+
773+ where sublayoutP = Proxy :: Proxy sublayout
774+ endpoint' = endpoint & path <>~ [symbolVal pa]
775+ pa = Proxy :: Proxy path
776+
777+{-
778+
779+-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
780+--
781+-- > type MyApi = "users" :> Get [User]
782+-- > :<|> "docs :> Raw
783+-- >
784+-- > apiProxy :: Proxy MyApi
785+-- > apiProxy = Proxy
786+-- >
787+-- > server :: Server MyApi
788+-- > server = listUsers
789+-- > :<|> serveDocumentation apiProxy
790+serveDocumentation :: HasDocs api => Proxy api -> Server Raw
791+serveDocumentation proxy _request respond =
792+ respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
793+
794+toHtml :: String -> String
795+toHtml md =
796+ "<html>" ++
797+ "<body>" ++
798+ "<pre>" ++
799+ md ++
800+ "</pre>" ++
801+ "</body>" ++
802+ "</html>"
803+-}