From d8dd1cb90a887e2a235179a03069c9552f6ba8e0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= <omeragacan@gmail.com>
Date: Tue, 16 May 2017 14:19:52 +0300
Subject: [PATCH] Don't drop samples in `HasDocs ReqBody` instance

As reported in #754, `HasDocs` instance of `ReqBody` was dropping samples other
than the first one. With this patch we show at most `_maxSamples` samples for
`ReqBody`, and also include the sample title in the docs.
---
 servant-docs/src/Servant/Docs/Internal.hs | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
index 2884473c..bb3d9c70 100644
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@@ -249,7 +249,7 @@ data Action = Action
   , _notes    :: [DocNote]                   -- user supplied
   , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
   , _rqtypes  :: [M.MediaType]               -- type collected
-  , _rqbody   :: [(M.MediaType, ByteString)] -- user supplied
+  , _rqbody   :: [(Text, M.MediaType, ByteString)] -- user supplied
   , _response :: Response                    -- user supplied
   } deriving (Eq, Ord, Show)
 
@@ -618,7 +618,7 @@ markdown api = unlines $
 
           where values = param ^. paramValues
 
-        rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
+        rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
         rqbodyStr [] [] = []
         rqbodyStr types s =
             ["#### Request:", ""]
@@ -630,8 +630,8 @@ markdown api = unlines $
             <> map (\t -> "    - `" <> show t <> "`") ts
             <> [""]
 
-        formatBody (m, b) =
-          "- Example: `" <> cs (show m) <> "`" :
+        formatBody (t, m, b) =
+          "- Example (" <> cs t <> "): `" <> cs (show m) <> "`" :
           contentStr m b
 
         markdownForType mime_type =
@@ -801,11 +801,12 @@ instance HasDocs Raw where
 instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
       => HasDocs (ReqBody (ct ': cts) a :> api) where
 
-  docsFor Proxy (endpoint, action) =
-    docsFor subApiP (endpoint, action')
+  docsFor Proxy (endpoint, action) opts@DocOptions{..} =
+    docsFor subApiP (endpoint, action') opts
 
     where subApiP = Proxy :: Proxy api
-          action' = action & rqbody .~ sampleByteString t p
+          action' :: Action
+          action' = action & rqbody .~ take _maxSamples (sampleByteStrings t p)
                            & rqtypes .~ allMime t
           t = Proxy :: Proxy (ct ': cts)
           p = Proxy :: Proxy a