Generate docs with samples encoded in all types

Request and response body documentation now includes sample values
encoded in all supported media types.

src/Servant/Docs.hs

@@ -1,13 +1,16 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 -------------------------------------------------------------------------------
 -- | This module lets you get API docs for free. It lets generate
@@ -154,25 +157,27 @@ module Servant.Docs
   , module Data.Monoid
   ) where
 
+import Control.Applicative
 import Control.Lens
 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 Servant.API
+import Servant.API.ContentTypes
 
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as T
+import qualified Network.HTTP.Media as M
 
 -- | Supported HTTP request methods
 data Method = DocDELETE -- ^ the DELETE method
@@ -315,7 +320,7 @@ data ParamKind = Normal | List | Flag
 -- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
 data Response = Response
   { _respStatus :: Int
-  , _respBody   :: [(Text, ByteString)]
+  , _respBody   :: [(Text, M.MediaType, ByteString)]
   } deriving (Eq, Show)
 
 -- | Default response: status code 200, no response body.
@@ -345,7 +350,7 @@ data Action = Action
   , _params   :: [DocQueryParam]              -- type collected + user supplied info
   , _notes    :: [DocNote]           -- user supplied
   , _mxParams :: [(String, [DocQueryParam])]  -- type collected + user supplied info
-  , _rqbody   :: Maybe ByteString             -- user supplied
+  , _rqbody   :: Maybe [(M.MediaType, ByteString)] -- user supplied
   , _response :: Response                     -- user supplied
   } deriving (Eq, Show)
 
@@ -432,20 +437,34 @@ 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
+    -> Maybe [(M.MediaType, ByteString)]
+sampleByteString ctypes@Proxy Proxy =
+    fmap (amr 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
-  where samples = toSamples :: [(Text, a)]
+    :: 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)]
+        ext t (a,b) = (t,a,b)
+        enc (t, s) = ext t <$> amr ctypes s
+    in concatMap enc samples
 
 -- | The class that helps us automatically get documentation
 --   for GET parameters.
@@ -574,16 +593,26 @@ markdown api = unlines $
 
           where values = param ^. paramValues
 
-        rqbodyStr :: Maybe ByteString -> [String]
+        rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String]
         rqbodyStr Nothing = []
-        rqbodyStr (Just b) =
+        rqbodyStr (Just b) = concatMap formatBody b
-          "#### Request Body:" :
-          jsonStr b
 
-        jsonStr b =
+        formatBody (m, b) =
+          "#### Request Body: `" <> show (M.mainType m <> "/" <> M.subType 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"
+                (_, _) -> ""
+
+        contentStr mime_type body =
           "" :
-          "``` javascript" :
+          "``` " <> markdownForType mime_type :
-          cs b :
+          cs body :
           "```" :
           "" :
           []
@@ -597,9 +626,9 @@ markdown api = unlines $
 
           where bodies = case resp ^. respBody of
                   []        -> [" - 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
 
@@ -641,14 +670,16 @@ instance HasDocs Delete where
           action' = action & response.respBody .~ []
                            & response.respStatus .~ 204
 
-instance ToSample a => HasDocs (Get cts a) where
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => 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
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
+
 instance (KnownSymbol sym, HasDocs sublayout)
       => HasDocs (Header sym a :> sublayout) where
   docsFor Proxy (endpoint, action) =
@@ -658,29 +689,26 @@ instance (KnownSymbol sym, HasDocs sublayout)
           action' = over headers (|> headername) action
           headername = pack $ symbolVal (Proxy :: Proxy sym)
 
-instance ToSample a => HasDocs (Post cts a) where
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => 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.respStatus .~ 201
-
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
-instance ToSample a => HasDocs (Put cts a) where
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => 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.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
 
@@ -755,20 +783,23 @@ 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
+-- 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)
       => 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
+          t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
 instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where