@@ -148,8 +148,8 @@ module Servant.Docs
148148 , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
149149 , DocNote(..), noteTitle, noteBody
150150 , DocIntro(..)
151− , Response, respStatus, respBody, defResponse
152− , Action, captures, headers, notes, params, rqbody, response, defAction
151+ , Response, respStatus, respTypes, respBody, defResponse
152+ , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
153153 , single
154154
155155 , -- * Useful modules when defining your doc printers
@@ -304,22 +304,24 @@ data DocNote = DocNote
304304data ParamKind = Normal | List | Flag
305305 deriving (Eq, Show)
306306
307−-- | A type to represent an HTTP response. Has an 'Int' status and
308−-- a 'Maybe ByteString' response body. Tweak 'defResponse' using
309−-- the 'respStatus' and 'respBody' lenses if you want.
307+-- | A type to represent an HTTP response. Has an 'Int' status, a list of
308+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
309+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'
310+-- lenses if you want.
310311--
311312-- If you want to respond with a non-empty response body, you'll most likely
312313-- want to write a 'ToSample' instance for the type that'll be represented
313−-- as some JSON in the response.
314+-- as encoded data in the response.
314315--
315−-- Can be tweaked with two lenses.
316+-- Can be tweaked with three lenses.
316317--
317318-- > λ> defResponse
318−-- > Response {_respStatus = 200, _respBody = []}
319+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
319320-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
320−-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
321+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
321322data Response = Response
322323 { _respStatus :: Int
324+ , _respTypes :: [M.MediaType]
323325 , _respBody :: [(Text, M.MediaType, ByteString)]
324326 } deriving (Eq, Show)
325327
@@ -332,7 +334,7 @@ data Response = Response
332334-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
333335-- > Response {_respStatus = 204, _respBody = Just "[]"}
334336defResponse :: Response
335−defResponse = Response 200 []
337+defResponse = Response 200 [] []
336338
337339-- | A datatype that represents everything that can happen
338340-- at an endpoint, with its lenses:
@@ -345,13 +347,14 @@ defResponse = Response 200 []
345347-- You can tweak an 'Action' (like the default 'defAction') with these lenses
346348-- to transform an action and add some information to it.
347349data Action = Action
348− { _captures :: [DocCapture] -- type collected + user supplied info
349− , _headers :: [Text] -- type collected
350− , _params :: [DocQueryParam] -- type collected + user supplied info
351− , _notes :: [DocNote] -- user supplied
352− , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
353− , _rqbody :: Maybe [(M.MediaType, ByteString)] -- user supplied
354− , _response :: Response -- user supplied
350+ { _captures :: [DocCapture] -- type collected + user supplied info
351+ , _headers :: [Text] -- type collected
352+ , _params :: [DocQueryParam] -- type collected + user supplied info
353+ , _notes :: [DocNote] -- user supplied
354+ , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
355+ , _rqtypes :: [M.MediaType] -- type collected
356+ , _rqbody :: [(M.MediaType, ByteString)] -- user supplied
357+ , _response :: Response -- user supplied
355358 } deriving (Eq, Show)
356359
357360-- Default 'Action'. Has no 'captures', no GET 'params', expects
@@ -370,7 +373,8 @@ defAction =
370373 []
371374 []
372375 []
373− Nothing
376+ []
377+ []
374378 defResponse
375379
376380-- | Create an API that's comprised of a single endpoint.
@@ -449,9 +453,9 @@ sampleByteString
449453 :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
450454 => Proxy ctypes
451455 -> Proxy a
452− -> Maybe [(M.MediaType, ByteString)]
456+ -> [(M.MediaType, ByteString)]
453457sampleByteString ctypes@Proxy Proxy =
454− fmap (amr ctypes) (toSample :: Maybe a)
458+ maybe [] (amr ctypes) (toSample :: Maybe a)
455459
456460-- | Synthesise a list of sample values of a particular type, encoded in the
457461-- specified media types.
@@ -465,6 +469,25 @@ sampleByteStrings ctypes@Proxy Proxy =
465469 enc (t, s) = uncurry (t,,) <$> amr ctypes s
466470 in concatMap enc samples
467471
472+-- | Generate a list of 'MediaType' values describing the content types
473+-- accepted by an API component.
474+class SupportedTypes (list :: [*]) where
475+ supportedTypes :: Proxy list -> [M.MediaType]
476+
477+instance SupportedTypes '[] where
478+ supportedTypes Proxy = []
479+
480+instance (Accept ctype) => SupportedTypes '[ctype] where
481+ supportedTypes Proxy = [ contentType (Proxy :: Proxy ctype) ]
482+
483+instance (Accept ctype, Accept ctype', SupportedTypes rest)
484+ => SupportedTypes (ctype ': ctype' ': rest) where
485+
486+ supportedTypes Proxy =
487+ [ contentType (Proxy :: Proxy ctype)
488+ , contentType (Proxy :: Proxy ctype')
489+ ] <> supportedTypes (Proxy :: Proxy rest)
490+
468491-- | The class that helps us automatically get documentation
469492-- for GET parameters.
470493--
@@ -504,7 +527,7 @@ markdown api = unlines $
504527 mxParamsStr (action ^. mxParams) ++
505528 headersStr (action ^. headers) ++
506529 paramsStr (action ^. params) ++
507− rqbodyStr (action ^. rqbody) ++
530+ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
508531 responseStr (action ^. response) ++
509532 []
510533
@@ -518,7 +541,7 @@ markdown api = unlines $
518541 introStr i =
519542 ("#### " ++ i ^. introTitle) :
520543 "" :
521− intersperse "" (i ^. introBody) ++
544+ intersperse "" (i ^. introBody) ++
522545 "" :
523546 []
524547
@@ -541,6 +564,7 @@ markdown api = unlines $
541564 map captureStr l ++
542565 "" :
543566 []
567+
544568 captureStr cap =
545569 "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
546570
@@ -552,6 +576,7 @@ markdown api = unlines $
552576 map segmentStr l ++
553577 "" :
554578 []
579+
555580 segmentStr :: (String, [DocQueryParam]) -> String
556581 segmentStr (segment, l) = unlines $
557582 ("**" ++ segment ++ "**:") :
@@ -575,8 +600,9 @@ markdown api = unlines $
575600 map paramStr l ++
576601 "" :
577602 []
603+
578604 paramStr param = unlines $
579− (" - " ++ param ^. paramName) :
605+ ("- " ++ param ^. paramName) :
580606 (if (not (null values) || param ^. paramKind /= Flag)
581607 then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
582608 else []) ++
@@ -592,12 +618,20 @@ markdown api = unlines $
592618
593619 where values = param ^. paramValues
594620
595− rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String]
596− rqbodyStr Nothing = []
597− rqbodyStr (Just b) = concatMap formatBody b
621+ rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
622+ rqbodyStr [] [] = []
623+ rqbodyStr types samples =
624+ ["#### Request:", ""]
625+ <> formatTypes types
626+ <> concatMap formatBody samples
627+
628+ formatTypes [] = []
629+ formatTypes ts = ["- Supported content types are: ", ""]
630+ <> map (\t -> " - `" <> show t <> "`") ts
631+ <> [""]
598632
599633 formatBody (m, b) =
600− "#### Request Body: `" <> show (M.mainType m <> "/" <> M.subType m) <> "`" :
634+ "- Example: `" <> cs (M.mainType m <> "/" <> M.subType m) <> "`" :
601635 contentStr m b
602636
603637 markdownForType mime_type =
@@ -606,6 +640,7 @@ markdown api = unlines $
606640 ("application", "xml") -> "xml"
607641 ("application", "json") -> "javascript"
608642 ("application", "javascript") -> "javascript"
643+ ("text", "css") -> "css"
609644 (_, _) -> ""
610645
611646 contentStr mime_type body =
@@ -620,14 +655,16 @@ markdown api = unlines $
620655 responseStr resp =
621656 "#### Response:" :
622657 "" :
623− (" - Status code " ++ show (resp ^. respStatus)) :
658+ ("- Status code " ++ show (resp ^. respStatus)) :
659+ "" :
660+ formatTypes (resp ^. respTypes) ++
624661 bodies
625662
626663 where bodies = case resp ^. respBody of
627− [] -> [" - No response body\n"]
628− [("", t, r)] -> " - Response body as below." : contentStr t r
664+ [] -> ["- No response body\n"]
665+ [("", t, r)] -> "- Response body as below." : contentStr t r
629666 xs ->
630− concatMap (\(ctx, t, r) -> (" - " <> T.unpack ctx) : contentStr t r) xs
667+ concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
631668
632669-- * Instances
633670
@@ -669,16 +706,17 @@ instance HasDocs Delete where
669706 action' = action & response.respBody .~ []
670707 & response.respStatus .~ 204
671708
672−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts a) where
709+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
710+ => HasDocs (Get cts a) where
673711 docsFor Proxy (endpoint, action) =
674712 single endpoint' action'
675713
676714 where endpoint' = endpoint & method .~ DocGET
677715 action' = action & response.respBody .~ sampleByteStrings t p
716+ & response.respTypes .~ supportedTypes t
678717 t = Proxy :: Proxy cts
679718 p = Proxy :: Proxy a
680719
681−
682720instance (KnownSymbol sym, HasDocs sublayout)
683721 => HasDocs (Header sym a :> sublayout) where
684722 docsFor Proxy (endpoint, action) =
@@ -688,22 +726,26 @@ instance (KnownSymbol sym, HasDocs sublayout)
688726 action' = over headers (|> headername) action
689727 headername = pack $ symbolVal (Proxy :: Proxy sym)
690728
691−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts a) where
729+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
730+ => HasDocs (Post cts a) where
692731 docsFor Proxy (endpoint, action) =
693732 single endpoint' action'
694733
695734 where endpoint' = endpoint & method .~ DocPOST
696735 action' = action & response.respBody .~ sampleByteStrings t p
736+ & response.respTypes .~ supportedTypes t
697737 & response.respStatus .~ 201
698738 t = Proxy :: Proxy cts
699739 p = Proxy :: Proxy a
700740
701−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts a) where
741+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
742+ => HasDocs (Put cts a) where
702743 docsFor Proxy (endpoint, action) =
703744 single endpoint' action'
704745
705746 where endpoint' = endpoint & method .~ DocPUT
706747 action' = action & response.respBody .~ sampleByteStrings t p
748+ & response.respTypes .~ supportedTypes t
707749 & response.respStatus .~ 200
708750 t = Proxy :: Proxy cts
709751 p = Proxy :: Proxy a
@@ -790,7 +832,7 @@ instance HasDocs Raw where
790832-- example data. However, there's no reason to believe that the instances of
791833-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
792834-- both are even defined) for any particular type.
793−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
835+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
794836 => HasDocs (ReqBody cts a :> sublayout) where
795837
796838 docsFor Proxy (endpoint, action) =
@@ -798,6 +840,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
798840
799841 where sublayoutP = Proxy :: Proxy sublayout
800842 action' = action & rqbody .~ sampleByteString t p
843+ & rqtypes .~ supportedTypes t
801844 t = Proxy :: Proxy cts
802845 p = Proxy :: Proxy a
803846