Merge pull request #829 from ivan-m/multiple-content-types

servant-docs: configurable rendering for multiple content types

doc/tutorial/Docs.lhs

@@ -23,6 +23,7 @@ import Network.Wai
 import Servant.API
 import Servant.Docs
 import Servant.Server
+import Web.FormUrlEncoded(FromForm(..), ToForm(..))
 ```
 
 And we'll import some things from one of our earlier modules
@@ -110,12 +111,6 @@ markdown :: API -> String
 That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`.
 
 ````````` text
-## Welcome
-
-This is our super webservice's API.
-
-Enjoy!
-
 ## GET /hello
 
 #### GET Parameters:
@@ -132,15 +127,16 @@ Enjoy!
 
 - Supported content types are:
 
+    - `application/json;charset=utf-8`
     - `application/json`
 
-- When a value is provided for 'name'
+- When a value is provided for 'name' (`application/json;charset=utf-8`, `application/json`):
 
     ```javascript
 {"msg":"Hello, Alp"}
     ```
 
-- When 'name' is not specified
+- When 'name' is not specified (`application/json;charset=utf-8`, `application/json`):
 
     ```javascript
 {"msg":"Hello, anonymous coward"}
@@ -152,24 +148,26 @@ Enjoy!
 
 - Supported content types are:
 
+    - `application/json;charset=utf-8`
     - `application/json`
 
-- Example: `application/json`
+- Example (`application/json;charset=utf-8`, `application/json`):
 
     ```javascript
-  {"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"}
+{"clientAge":26,"clientEmail":"alp@foo.com","clientName":"Alp","clientInterestedIn":["haskell","mathematics"]}
     ```
 
 #### Response:
 
-- Status code 201
+- Status code 200
 - Headers: []
 
 - Supported content types are:
 
+    - `application/json;charset=utf-8`
     - `application/json`
 
-- Response body as below.
+- Example (`application/json;charset=utf-8`, `application/json`):
 
     ```javascript
 {"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"}
@@ -189,13 +187,14 @@ Enjoy!
 
 - Supported content types are:
 
+    - `application/json;charset=utf-8`
     - `application/json`
 
-- Response body as below.
+- Example (`application/json;charset=utf-8`, `application/json`):
 
     ```javascript
-  {"x":3,"y":14}
+{"yCoord":14,"xCoord":3}
-  ```
+    ````
 
 `````````
 
@@ -213,6 +212,49 @@ docsBS = encodeUtf8
 
 `docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs.
 
+More customisation can be done with the `markdownWith` function, which allows customising some of the parameters used when generating Markdown.  The most obvious of these is how to handle when a request or response body has multiple content types.  For example, if we make a slight change to the `/marketing` endpoint of our API so that the request body can also be encoded as a form:
+
+``` haskell
+type ExampleAPI2 = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position
+      :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage
+      :<|> "marketing" :> ReqBody '[JSON, FormUrlEncoded] ClientInfo :> Post '[JSON] Email
+
+instance ToForm ClientInfo
+instance FromForm ClientInfo
+
+exampleAPI2 :: Proxy ExampleAPI2
+exampleAPI2 = Proxy
+
+api2Docs :: API
+api2Docs = docs exampleAPI2
+```
+
+The relevant output of `markdown api2Docs` is now:
+
+```````` text
+#### Request:
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+    - `application/x-www-form-urlencoded`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+    ```javascript
+{"clientAge":26,"clientEmail":"alp@foo.com","clientName":"Alp","clientInterestedIn":["haskell","mathematics"]}
+    ```
+
+- Example (`application/x-www-form-urlencoded`):
+
+    ```
+clientAge=26&clientEmail=alp%40foo.com&clientName=Alp&clientInterestedIn=haskell&clientInterestedIn=mathematics
+    ```
+````````
+
+If, however, you don't want the extra example encoding shown, then you can use `markdownWith (defRenderingOptions & requestExamples .~ FirstContentType)` to get behaviour identical to `markdown apiDocs`.
+
 We can now serve the API *and* the API docs with a simple server.
 
 ``` haskell

doc/tutorial/tutorial.cabal

@@ -31,6 +31,7 @@ library
                      , servant-docs == 0.11.*
                      , servant-js >= 0.9 && <0.10
                      , warp
+                     , http-api-data
                      , http-media
                      , lucid
                      , time

servant-docs/CHANGELOG.md

@@ -7,6 +7,8 @@
 * Document the HTTP Method the parameters of an endpoint belong to
   (rather than assuming `GET` for all of them).
 * Content type of sample response body is also displayed.
+* Can now control how many content-types for each example are shown
+  with `markdownWith` and `RenderingOptions`.
 
 0.11
 ----

servant-docs/servant-docs.cabal

@@ -49,7 +49,7 @@ library
     , control-monad-omega == 0.3.*
   if !impl(ghc >= 8.0)
     build-depends:
-      semigroups          >=0.16.2.2 && <0.19
+      semigroups          >=0.17 && <0.19
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -Wall

servant-docs/src/Servant/Docs.hs

@@ -24,6 +24,9 @@
 module Servant.Docs
   ( -- * 'HasDocs' class and key functions
     HasDocs(..), docs, pretty, markdown
+    -- ** Customising generated documentation
+  , markdownWith, RenderingOptions(..), defRenderingOptions
+  , requestExamples, responseExamples, ShowContentTypes(..)
     -- * Generating docs with extra information
   , docsWith, docsWithIntros, docsWithOptions
   , ExtraInfo(..), extraInfo

servant-docs/src/Servant/Docs/Internal.hs

@@ -22,22 +22,29 @@ module Servant.Docs.Internal where
 
 import           Prelude                    ()
 import           Prelude.Compat
+
 import           Control.Applicative
 import           Control.Arrow              (second)
-import           Control.Lens               (makeLenses, mapped, over, traversed, view, (%~),
+import           Control.Lens               (makeLenses, mapped, over,
-                                             (&), (.~), (<>~), (^.), (|>))
+                                             traversed, view, (%~), (&), (.~),
+                                             (<>~), (^.), (|>))
 import qualified Control.Monad.Omega        as Omega
-import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Char8      as BSC
+import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.CaseInsensitive       as CI
+import           Data.Foldable              (fold)
 import           Data.Hashable              (Hashable)
 import           Data.HashMap.Strict        (HashMap)
 import           Data.List.Compat           (intercalate, intersperse, sort)
+import           Data.List.NonEmpty         (NonEmpty ((:|)), groupWith)
+import qualified Data.List.NonEmpty         as NE
 import           Data.Maybe
-import           Data.Monoid                (All (..), Any (..), Sum (..), Product (..), First (..), Last (..), Dual (..))
+import           Data.Monoid                (All (..), Any (..), Dual (..),
-import           Data.Semigroup             (Semigroup (..))
+                                             First (..), Last (..),
+                                             Product (..), Sum (..))
 import           Data.Ord                   (comparing)
 import           Data.Proxy                 (Proxy (Proxy))
+import           Data.Semigroup             (Semigroup (..))
 import           Data.String.Conversions    (cs)
 import           Data.Text                  (Text, unpack)
 import           GHC.Generics
@@ -291,6 +298,35 @@ defAction =
 single :: Endpoint -> Action -> API
 single e a = API mempty (HM.singleton e a)
 
+-- | How many content-types for each example should be shown?
+--
+--   @since 0.11.1
+data ShowContentTypes = AllContentTypes  -- ^ For each example, show each content type.
+                      | FirstContentType -- ^ For each example, show only one content type.
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+-- | Customise how an 'API' is converted into documentation.
+--
+--   @since 0.11.1
+data RenderingOptions = RenderingOptions
+  { _requestExamples  :: !ShowContentTypes
+    -- ^ How many content types to display for request body examples?
+  , _responseExamples :: !ShowContentTypes
+    -- ^ How many content types to display for response body examples?
+  } deriving (Show)
+
+-- | Default API generation options.
+--
+--   All content types are shown for both 'requestExamples' and
+--   'responseExamples'.
+--
+--   @since 0.11.1
+defRenderingOptions :: RenderingOptions
+defRenderingOptions = RenderingOptions
+  { _requestExamples  = AllContentTypes
+  , _responseExamples = AllContentTypes
+  }
+
 -- gimme some lenses
 makeLenses ''DocAuthentication
 makeLenses ''DocOptions
@@ -302,6 +338,7 @@ makeLenses ''DocIntro
 makeLenses ''DocNote
 makeLenses ''Response
 makeLenses ''Action
+makeLenses ''RenderingOptions
 
 -- | Generate the docs for a given API that implements 'HasDocs'. This is the
 -- default way to create documentation.
@@ -517,8 +554,34 @@ class ToAuthInfo a where
 
 -- | Generate documentation in Markdown format for
 --   the given 'API'.
+--
+--   This is equivalent to @'markdownWith' 'defRenderingOptions'@.
 markdown :: API -> String
-markdown api = unlines $
+markdown = markdownWith defRenderingOptions
+
+-- | Generate documentation in Markdown format for
+--   the given 'API' using the specified options.
+--
+--   These options allow you to customise aspects such as:
+--
+--   * Choose how many content-types for each request body example are
+--     shown with 'requestExamples'.
+--
+--   * Choose how many content-types for each response body example
+--     are shown with 'responseExamples'.
+--
+--   For example, to only show the first content-type of each example:
+--
+--   @
+--   markdownWith ('defRenderingOptions'
+--                   & 'requestExamples'  '.~' 'FirstContentType'
+--                   & 'responseExamples' '.~' 'FirstContentType' )
+--                myAPI
+--   @
+--
+--   @since 0.11.1
+markdownWith :: RenderingOptions -> API -> String
+markdownWith RenderingOptions{..}  api = unlines $
        introsStr (api ^. apiIntros)
     ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
 
@@ -632,26 +695,50 @@ markdown api = unlines $
         rqbodyStr types s =
             ["#### Request:", ""]
             <> formatTypes types
-            <> concatMap formatBody s
+            <> formatBodies _requestExamples s
 
         formatTypes [] = []
         formatTypes ts = ["- Supported content types are:", ""]
             <> map (\t -> "    - `" <> show t <> "`") ts
             <> [""]
 
-        formatBody (t, m, b) =
+        -- This assumes that when the bodies are created, identical
-          "- Example (" <> cs t <> "): `" <> cs (show m) <> "`" :
+        -- labels and representations are located next to each other.
-          contentStr m b
+        formatBodies :: ShowContentTypes -> [(Text, M.MediaType, ByteString)] -> [String]
+        formatBodies ex bds = concatMap formatBody (select bodyGroups)
+          where
+            bodyGroups :: [(Text, NonEmpty M.MediaType, ByteString)]
+            bodyGroups =
+              map (\grps -> let (t,_,b) = NE.head grps in (t, fmap (\(_,m,_) -> m) grps, b))
+              . groupWith (\(t,_,b) -> (t,b))
+              $ bds
+
+            select = case ex of
+                       AllContentTypes  -> id
+                       FirstContentType -> map (\(t,ms,b) -> (t, NE.head ms :| [], b))
+
+        formatBody :: (Text, NonEmpty M.MediaType, ByteString) -> [String]
+        formatBody (t, ms, b) =
+          "- " <> title <> " (" <> mediaList ms <> "):" :
+          contentStr (NE.head ms) b
+          where
+            mediaList = fold . NE.intersperse ", " . fmap (\m -> "`" ++ show m ++ "`")
+
+            title
+              | T.null t  = "Example"
+              | otherwise = cs t
 
         markdownForType mime_type =
             case (M.mainType mime_type, M.subType mime_type) of
                 ("text", "html") -> "html"
                 ("application", "xml") -> "xml"
+                ("text", "xml") -> "xml"
                 ("application", "json") -> "javascript"
                 ("application", "javascript") -> "javascript"
                 ("text", "css") -> "css"
                 (_, _) -> ""
 
+
         contentStr mime_type body =
           "" :
           "    ```" <> markdownForType mime_type :
@@ -674,7 +761,7 @@ markdown api = unlines $
                   []        -> ["- No response body\n"]
                   [("", t, r)] -> "- Response body as below." : contentStr t r
                   xs        ->
-                    concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx <> " (`" <> cs (show t) <> "`)") : contentStr t r) xs
+                    formatBodies _responseExamples xs
 
 -- * Instances
 

stack-ghc-7.8.4.yaml

@@ -23,9 +23,11 @@ extra-deps:
 - http-client-0.4.30
 - natural-transformation-0.4
 - primitive-0.6.1.0
+- semigroups-0.17
 - servant-js-0.9.3
 - should-not-typecheck-2.1.0
 - time-locale-compat-0.1.1.1
 - uri-bytestring-0.2.2.0
+- void-0.7.1
 - wai-app-static-3.1.5
 resolver: lts-2.22