Merge remote-tracking branch 'origin/master' into wip-note-api

README.md

@@ -27,10 +27,15 @@ import Servant
 data Greet = Greet { _msg :: Text }
   deriving (Generic, Show)
 
--- we get our JSON serialization for free
+-- we get our JSON serialization for free. This will be used by the default
+-- 'MimeRender' instance for 'JSON'.
 instance FromJSON Greet
 instance ToJSON Greet
 
+-- We can also implement 'MimeRender' explicitly for additional formats.
+instance MimeRender PlainText Greet where
+    toByteString Proxy (Greet s) = "<h1>" <> cs s <> "</h1>"
+
 -- we provide a sample value for the 'Greet' type
 instance ToSample Greet where
   toSample = Just g
@@ -51,8 +56,8 @@ instance ToCapture (Capture "greetid" Text) where
 
 -- API specification
 type TestApi =
-       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
-  :<|> "greet" :> RQBody Greet :> Post Greet
+  :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet
   :<|> "delete" :> Capture "greetid" Text :> Delete
 
 testApi :: Proxy TestApi

example/greet.hs

@@ -1,12 +1,14 @@
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeOperators         #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 import Data.Aeson
 import Data.Proxy
-import Data.Text(Text)
+import Data.String.Conversions
+import Data.Text (Text)
 import GHC.Generics
 import Servant.API
 import Servant.Docs
@@ -17,9 +19,15 @@ import Servant.Docs
 newtype Greet = Greet Text
   deriving (Generic, Show)
 
+-- | We can get JSON support automatically. This will be used to parse
+-- and encode a Greeting as 'JSON'.
 instance FromJSON Greet
 instance ToJSON Greet
 
+-- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
+instance MimeRender PlainText Greet where
+    toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
+
 -- We add some useful annotations to our captures,
 -- query parameters and request body to make the docs
 -- really helpful.
@@ -70,12 +78,12 @@ intro2 = DocIntro "This title is below the last"
 
 -- API specification
 type TestApi =
-       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText
-       "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
+       "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
 
        -- POST /greet with a Greet as JSON in the request body,
        --             returns a Greet as JSON
-  :<|> "greet" :> ReqBody Greet :> Post Greet
+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
 
        -- DELETE /greet/:greetid
   :<|> "greet" :> Capture "greetid" Text :> Delete

example/greet.md

@@ -10,24 +10,35 @@ You'll also note that multiple intros are possible.
 
 ## POST /greet
 
-#### Request Body:
+#### Request:
 
-``` javascript
+- Supported content types are:
+
+    - `application/json`
+
+- Example: `application/json`
+
+```javascript
 "Hello, haskeller!"
 ```
 
 #### Response:
 
- - Status code 201
+- Status code 201
- - If you use ?capital=true
 
-``` javascript
+- Supported content types are:
+
+    - `application/json`
+
+- If you use ?capital=true
+
+```javascript
 "HELLO, HASKELLER"
 ```
 
- - If you use ?capital=false
+- If you use ?capital=false
 
-``` javascript
+```javascript
 "Hello, haskeller"
 ```
 
@@ -41,7 +52,7 @@ You'll also note that multiple intros are possible.
 
 **hello**:
 
- - lang
+- lang
      - **Values**: *en, sv, fr*
      - **Description**: Get the greeting message selected language. Default is en.
 
@@ -49,23 +60,41 @@ You'll also note that multiple intros are possible.
 
 #### GET Parameters:
 
- - capital
+- capital
      - **Values**: *true, false*
      - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
 
 
 #### Response:
 
- - Status code 200
+- Status code 200
- - If you use ?capital=true
 
-``` javascript
+- Supported content types are:
+
+    - `application/json`
+    - `text/plain;charset=utf-8`
+
+- If you use ?capital=true
+
+```javascript
 "HELLO, HASKELLER"
 ```
 
- - If you use ?capital=false
+- If you use ?capital=true
 
-``` javascript
+```
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=false
+
+```javascript
+"Hello, haskeller"
+```
+
+- If you use ?capital=false
+
+```
 "Hello, haskeller"
 ```
 
@@ -88,7 +117,8 @@ And some more
 
 #### Response:
 
- - Status code 200
+- Status code 200
- - No response body
+
+- No response body
 
 

servant-docs.cabal

@@ -29,13 +29,12 @@ library
   build-depends:
       base >=4.7 && <5
     , aeson
-    , aeson-pretty < 0.8
     , bytestring
     , hashable
+    , http-media
     , lens
     , servant >= 0.2.1
     , string-conversions
-    , system-filepath
     , text
     , unordered-containers
   hs-source-dirs: src
@@ -46,5 +45,5 @@ executable greet-docs
   main-is: greet.hs
   hs-source-dirs: example
   ghc-options: -Wall
-  build-depends: base, aeson, servant, servant-docs, text
+  build-depends: base, aeson, servant, servant-docs, string-conversions, text
   default-language: Haskell2010

src/Servant/Docs.hs

@@ -37,15 +37,17 @@
 -- Here's a little (but complete) example that you can run to see the
 -- markdown pretty printer in action:
 --
--- > {-# LANGUAGE DataKinds #-}
+-- > {-# LANGUAGE DataKinds             #-}
--- > {-# LANGUAGE DeriveGeneric #-}
+-- > {-# LANGUAGE DeriveGeneric         #-}
--- > {-# LANGUAGE TypeOperators #-}
+-- > {-# LANGUAGE FlexibleInstances     #-}
--- > {-# LANGUAGE FlexibleInstances #-}
+-- > {-# LANGUAGE MultiParamTypeClasses #-}
--- > {-# LANGUAGE OverloadedStrings #-}
+-- > {-# LANGUAGE OverloadedStrings     #-}
+-- > {-# LANGUAGE TypeOperators         #-}
 -- > {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- > import Data.Aeson
 -- > import Data.Proxy
--- > import Data.Text(Text)
+-- > import Data.String.Conversions
+-- > import Data.Text (Text)
 -- > import GHC.Generics
 -- > import Servant.API
 -- > import Servant.Docs
@@ -56,9 +58,15 @@
 -- > newtype Greet = Greet Text
 -- >   deriving (Generic, Show)
 -- >
+-- > -- | We can get JSON support automatically. This will be used to parse
+-- > -- and encode a Greeting as 'JSON'.
 -- > instance FromJSON Greet
 -- > instance ToJSON Greet
 -- >
+-- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
+-- > instance MimeRender PlainText Greet where
+-- >     toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
+-- >
 -- > -- We add some useful annotations to our captures,
 -- > -- query parameters and request body to make the docs
 -- > -- really helpful.
@@ -109,12 +117,12 @@
 -- >
 -- > -- API specification
 -- > type TestApi =
--- >        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
+-- >        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText
--- >        "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
+-- >        "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
 -- >
 -- >        -- POST /greet with a Greet as JSON in the request body,
 -- >        --             returns a Greet as JSON
--- >   :<|> "greet" :> ReqBody Greet :> Post Greet
+-- >   :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
 -- >
 -- >        -- DELETE /greet/:greetid
 -- >   :<|> "greet" :> Capture "greetid" Text :> Delete
@@ -166,8 +174,8 @@ module Servant.Docs
   , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
   , DocNote(..), noteTitle, noteBody
   , DocIntro(..)
-  , Response, respStatus, respBody, defResponse
+  , Response, respStatus, respTypes, respBody, defResponse
-  , Action, captures, headers, notes, params, rqbody, response, defAction
+  , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
   , single
 
   , -- * Useful modules when defining your doc printers
@@ -175,27 +183,29 @@ module Servant.Docs
   , module Data.Monoid
   ) where
 
+import Control.Applicative
 import Control.Lens hiding (Action)
 import Data.Aeson
-import Data.Aeson.Encode.Pretty (encodePretty)
-import Data.Ord(comparing)
 import Data.ByteString.Lazy.Char8 (ByteString)
 import Data.Hashable
 import Data.HashMap.Strict (HashMap)
 import Data.List
-import Data.Maybe (listToMaybe)
+import Data.Maybe
 import Data.Monoid
+import Data.Ord (comparing)
 import Data.Proxy
-import Data.Text (Text, pack, unpack)
 import Data.String.Conversions
+import Data.Text (Text, pack, unpack)
 import GHC.Generics
 import GHC.TypeLits
 import GHC.Exts(Constraint)
 import Servant.API
 import Servant.Utils.Links
+import Servant.API.ContentTypes
 
 import qualified Data.HashMap.Strict as HM
-import qualified Data.Text           as T
+import qualified Data.Text as T
+import qualified Network.HTTP.Media as M
 
 -- | Supported HTTP request methods
 data Method = DocDELETE -- ^ the DELETE method
@@ -333,23 +343,25 @@ instance Monoid (ExtraInfo a) where
 data ParamKind = Normal | List | Flag
   deriving (Eq, Show)
 
--- | A type to represent an HTTP response. Has an 'Int' status and
+-- | A type to represent an HTTP response. Has an 'Int' status, a list of
--- a 'Maybe ByteString' response body. Tweak 'defResponse' using
+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
--- the 'respStatus' and 'respBody' lenses if you want.
+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'
+-- lenses if you want.
 --
 -- If you want to respond with a non-empty response body, you'll most likely
 -- want to write a 'ToSample' instance for the type that'll be represented
--- as some JSON in the response.
+-- as encoded data in the response.
 --
--- Can be tweaked with two lenses.
+-- Can be tweaked with three lenses.
 --
 -- > λ> defResponse
--- > Response {_respStatus = 200, _respBody = []}
+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
 -- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
--- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
 data Response = Response
   { _respStatus :: Int
-  , _respBody   :: [(Text, ByteString)]
+  , _respTypes  :: [M.MediaType]
+  , _respBody   :: [(Text, M.MediaType, ByteString)]
   } deriving (Eq, Show)
 
 -- | Default response: status code 200, no response body.
@@ -361,7 +373,7 @@ data Response = Response
 -- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
 -- > Response {_respStatus = 204, _respBody = Just "[]"}
 defResponse :: Response
-defResponse = Response 200 []
+defResponse = Response 200 [] []
 
 -- | A datatype that represents everything that can happen
 -- at an endpoint, with its lenses:
@@ -374,23 +386,25 @@ defResponse = Response 200 []
 -- You can tweak an 'Action' (like the default 'defAction') with these lenses
 -- to transform an action and add some information to it.
 data Action = Action
-  { _captures :: [DocCapture]                 -- type collected + user supplied info
+  { _captures :: [DocCapture]                -- type collected + user supplied info
-  , _headers  :: [Text]                       -- type collected
+  , _headers  :: [Text]                      -- type collected
-  , _params   :: [DocQueryParam]              -- type collected + user supplied info
+  , _params   :: [DocQueryParam]             -- type collected + user supplied info
-  , _mxParams :: [(String, [DocQueryParam])]  -- type collected + user supplied info
+  , _notes    :: [DocNote]                   -- user supplied
-  , _notes    :: [DocNote]                    -- user supplied
+  , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
-  , _rqbody   :: Maybe ByteString             -- user supplied
+  , _rqtypes  :: [M.MediaType]               -- type collected
-  , _response :: Response                     -- user supplied
+  , _rqbody   :: [(M.MediaType, ByteString)] -- user supplied
+  , _response :: Response                    -- user supplied
   } deriving (Eq, Show)
 
 -- | Combine two Actions, we can't make a monoid as merging Response breaks the
 -- laws.
 --
 -- As such, we invent a non-commutative, left associative operation
--- 'combineAction' to mush two together taking the response from the very left.
+-- 'combineAction' to mush two together taking the response, body and content
+-- types from the very left.
 combineAction :: Action -> Action -> Action
-Action c h p m n r resp `combineAction` Action c' h' p' m' n' r' _ =
+Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
-        Action (c <> c') (h <> h') (p <> p') (m <> m') (n <> n') (r <> r') resp
+        Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
 
 -- Default 'Action'. Has no 'captures', no GET 'params', expects
 -- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -408,7 +422,8 @@ defAction =
          []
          []
          []
-         Nothing
+         []
+         []
          defResponse
 
 -- | Create an API that's comprised of a single endpoint.
@@ -455,7 +470,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
 -- >                                      ]
 
 extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
-         => Proxy endpoint -> Action -> ExtraInfo layout
+          => Proxy endpoint -> Action -> ExtraInfo layout
 extraInfo p action =
     let api = docsFor p (defEndpoint, defAction)
     -- Assume one endpoint, HasLink constraint means that we should only ever
@@ -527,20 +542,46 @@ class HasDocs layout where
 class ToJSON a => ToSample a where
   {-# MINIMAL (toSample | toSamples) #-}
   toSample :: Maybe a
-  toSample = fmap snd $ listToMaybe samples
+  toSample = snd <$> listToMaybe samples
     where samples = toSamples :: [(Text, a)]
 
   toSamples :: [(Text, a)]
   toSamples = maybe [] (return . ("",)) s
     where s = toSample :: Maybe a
 
-sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString
+-- | Synthesise a sample value of a type, encoded in the specified media types.
-sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)
+sampleByteString
+    :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
+    => Proxy ctypes
+    -> Proxy a
+    -> [(M.MediaType, ByteString)]
+sampleByteString ctypes@Proxy Proxy =
+    maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
 
-sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]
+-- | Synthesise a list of sample values of a particular type, encoded in the
-sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty
+-- specified media types.
+sampleByteStrings
+    :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
+    => Proxy ctypes
+    -> Proxy a
+    -> [(Text, M.MediaType, ByteString)]
+sampleByteStrings ctypes@Proxy Proxy =
+    let samples = toSamples :: [(Text, a)]
+        enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
+    in concatMap enc samples
 
-  where samples = toSamples :: [(Text, a)]
+-- | Generate a list of 'MediaType' values describing the content types
+-- accepted by an API component.
+class SupportedTypes (list :: [*]) where
+    supportedTypes :: Proxy list -> [M.MediaType]
+
+instance SupportedTypes '[] where
+    supportedTypes Proxy = []
+
+instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
+  where
+    supportedTypes Proxy =
+        contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
 
 -- | The class that helps us automatically get documentation
 --   for GET parameters.
@@ -581,7 +622,7 @@ markdown api = unlines $
           mxParamsStr (action ^. mxParams) ++
           headersStr (action ^. headers) ++
           paramsStr (action ^. params) ++
-          rqbodyStr (action ^. rqbody) ++
+          rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
           responseStr (action ^. response) ++
           []
 
@@ -595,7 +636,7 @@ markdown api = unlines $
         introStr i =
             ("#### " ++ i ^. introTitle) :
             "" :
-            intersperse ""  (i ^. introBody) ++
+            intersperse "" (i ^. introBody) ++
             "" :
             []
 
@@ -618,6 +659,7 @@ markdown api = unlines $
           map captureStr l ++
           "" :
           []
+
         captureStr cap =
           "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
 
@@ -650,8 +692,9 @@ markdown api = unlines $
           map paramStr l ++
           "" :
           []
+
         paramStr param = unlines $
-          (" - " ++ param ^. paramName) :
+          ("- " ++ param ^. paramName) :
           (if (not (null values) || param ^. paramKind /= Flag)
             then ["     - **Values**: *" ++ intercalate ", " values ++ "*"]
             else []) ++
@@ -667,16 +710,35 @@ markdown api = unlines $
 
           where values = param ^. paramValues
 
-        rqbodyStr :: Maybe ByteString -> [String]
+        rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
-        rqbodyStr Nothing = []
+        rqbodyStr [] [] = []
-        rqbodyStr (Just b) =
+        rqbodyStr types samples =
-          "#### Request Body:" :
+            ["#### Request:", ""]
-          jsonStr b
+            <> formatTypes types
+            <> concatMap formatBody samples
 
-        jsonStr b =
+        formatTypes [] = []
+        formatTypes ts = ["- Supported content types are:", ""]
+            <> map (\t -> "    - `" <> show t <> "`") ts
+            <> [""]
+
+        formatBody (m, b) =
+          "- Example: `" <> cs (show m) <> "`" :
+          contentStr m b
+
+        markdownForType mime_type =
+            case (M.mainType mime_type, M.subType mime_type) of
+                ("text", "html") -> "html"
+                ("application", "xml") -> "xml"
+                ("application", "json") -> "javascript"
+                ("application", "javascript") -> "javascript"
+                ("text", "css") -> "css"
+                (_, _) -> ""
+
+        contentStr mime_type body =
           "" :
-          "``` javascript" :
+          "```" <> markdownForType mime_type :
-          cs b :
+          cs body :
           "```" :
           "" :
           []
@@ -685,14 +747,16 @@ markdown api = unlines $
         responseStr resp =
           "#### Response:" :
           "" :
-          (" - Status code " ++ show (resp ^. respStatus)) :
+          ("- Status code " ++ show (resp ^. respStatus)) :
+          "" :
+          formatTypes (resp ^. respTypes) ++
           bodies
 
           where bodies = case resp ^. respBody of
-                  []        -> [" - No response body\n"]
+                  []        -> ["- No response body\n"]
-                  [("", r)] -> " - Response body as below." : jsonStr r
+                  [("", t, r)] -> "- Response body as below." : contentStr t r
                   xs        ->
-                    concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
+                    concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
 
 -- * Instances
 
@@ -734,12 +798,15 @@ instance HasDocs Delete where
           action' = action & response.respBody .~ []
                            & response.respStatus .~ 204
 
-instance ToSample a => HasDocs (Get a) where
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+    => HasDocs (Get cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocGET
-          action' = action & response.respBody .~ sampleByteStrings p
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes t
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
 instance (KnownSymbol sym, HasDocs sublayout)
@@ -751,29 +818,30 @@ instance (KnownSymbol sym, HasDocs sublayout)
           action' = over headers (|> headername) action
           headername = pack $ symbolVal (Proxy :: Proxy sym)
 
-instance ToSample a => HasDocs (Post a) where
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+    => HasDocs (Post cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocPOST
-
+          action' = action & response.respBody .~ sampleByteStrings t p
-          action' = action & response.respBody .~ sampleByteStrings p
+                           & response.respTypes .~ supportedTypes t
                            & response.respStatus .~ 201
-
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
-instance ToSample a => HasDocs (Put a) where
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+    => HasDocs (Put cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocPUT
-
+          action' = action & response.respBody .~ sampleByteStrings t p
-          action' = action & response.respBody .~ sampleByteStrings p
+                           & response.respTypes .~ supportedTypes t
                            & response.respStatus .~ 200
-
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
-
 instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
       => HasDocs (QueryParam sym a :> sublayout) where
 
@@ -848,20 +916,24 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
           endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
           symP = Proxy :: Proxy sym
 
-
 instance HasDocs Raw where
   docsFor _proxy (endpoint, action) =
     single endpoint action
 
-instance (ToSample a, HasDocs sublayout)
+-- TODO: We use 'AllMimeRender' here because we need to be able to show the
-      => HasDocs (ReqBody a :> sublayout) where
+-- example data. However, there's no reason to believe that the instances of
+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
+-- both are even defined) for any particular type.
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
+      => HasDocs (ReqBody cts a :> sublayout) where
 
   docsFor Proxy (endpoint, action) =
     docsFor sublayoutP (endpoint, action')
 
     where sublayoutP = Proxy :: Proxy sublayout
-
+          action' = action & rqbody .~ sampleByteString t p
-          action' = action & rqbody .~ sampleByteString p
+                           & rqtypes .~ supportedTypes t
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
 instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where