From 7bed805cf78edb44600a82bf2ca8a819fceac968 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Thu, 8 Nov 2018 15:57:04 +0200
Subject: [PATCH] Golden test for comprehensive API docs

---
 servant-docs/golden/comprehensive.md         | 521 +++++++++++++++++++
 servant-docs/servant-docs.cabal              |   2 +
 servant-docs/src/Servant/Docs/Internal.hs    |  16 +-
 servant-docs/test/Servant/DocsSpec.hs        |  24 +-
 servant/src/Servant/Test/ComprehensiveAPI.hs |  50 +-
 5 files changed, 577 insertions(+), 36 deletions(-)
 create mode 100644 servant-docs/golden/comprehensive.md

diff --git a/servant-docs/golden/comprehensive.md b/servant-docs/golden/comprehensive.md
new file mode 100644
index 00000000..7210143f
--- /dev/null
+++ b/servant-docs/golden/comprehensive.md
@@ -0,0 +1,521 @@
+## GET /
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /capture/:foo
+
+### Captures:
+
+- *foo*: Capture foo Int
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /capture-all/:foo
+
+### Captures:
+
+- *foo*: Capture all foo Int
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /description
+
+### foo
+
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /flag
+
+### GET Parameters:
+
+- foo
+     - **Description**: QueryFlag
+     - This parameter is a **flag**. This means no value is expected to be associated to this parameter.
+
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /foo
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /get-int
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+17
+```
+
+## GET /header
+
+### Headers:
+
+- This endpoint is sensitive to the value of the **foo** HTTP header.
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /header-lenient
+
+### Headers:
+
+- This endpoint is sensitive to the value of the **bar** HTTP header.
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /http-version
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /is-secure
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /named-context
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /param
+
+### GET Parameters:
+
+- foo
+     - **Values**: *1, 2, 3*
+     - **Description**: QueryParams Int
+
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /param-lenient
+
+### GET Parameters:
+
+- bar
+     - **Values**: *1, 2, 3*
+     - **Description**: QueryParams Int
+
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /params
+
+### GET Parameters:
+
+- foo
+     - **Values**: *1, 2, 3*
+     - **Description**: QueryParams Int
+     - This parameter is a **list**. All GET parameters with the name foo[] will forward their values in a list to the handler.
+
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## POST /post-int
+
+### Response:
+
+- Status code 204
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+17
+```
+
+## POST /post-no-content
+
+### Response:
+
+- Status code 204
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /raw
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- No response body
+
+## GET /remote-host
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /req-body
+
+### Request:
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+17
+```
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /req-body-lenient
+
+### Request:
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+17
+```
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /res-headers
+
+### Response:
+
+- Status code 200
+- Headers: [("foo","17")]
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /streaming
+
+### Request:
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- No response body
+
+## GET /summary
+
+### foo
+
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
+## GET /vault
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal
index 66fed9cc..a40c635f 100644
--- a/servant-docs/servant-docs.cabal
+++ b/servant-docs/servant-docs.cabal
@@ -26,6 +26,8 @@ Bug-reports:         http://github.com/haskell-servant/servant/issues
 extra-source-files:
   CHANGELOG.md
   README.md
+  golden/comprehensive.md
+
 source-repository head
   type: git
   location: http://github.com/haskell-servant/servant.git
diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
index 63b2bb61..ae74d42f 100644
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@@ -32,6 +32,8 @@ import qualified Data.ByteString.Char8      as BSC
 import           Data.ByteString.Lazy.Char8
                  (ByteString)
 import qualified Data.CaseInsensitive       as CI
+import           Data.Foldable
+                 (toList)
 import           Data.Foldable
                  (fold)
 import           Data.Hashable
@@ -958,7 +960,6 @@ instance (KnownSymbol desc, HasDocs api)
 -- both are even defined) for any particular type.
 instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
       => HasDocs (ReqBody' mods (ct ': cts) a :> api) where
-
   docsFor Proxy (endpoint, action) opts@DocOptions{..} =
     docsFor subApiP (endpoint, action') opts
 
@@ -969,8 +970,17 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
           t = Proxy :: Proxy (ct ': cts)
           p = Proxy :: Proxy a
 
-instance HasDocs api => HasDocs (StreamBody framing ctype a :> api) where
-    docsFor Proxy _ _ = error "HasDocs @StreamBody"
+-- | TODO: this instance is incomplete.
+instance (HasDocs api, Accept ctype) => HasDocs (StreamBody framing ctype a :> api) where
+    docsFor Proxy (endpoint, action) opts =
+        docsFor subApiP (endpoint, action') opts
+      where
+        subApiP = Proxy :: Proxy api
+
+        action' :: Action
+        action' = action & rqtypes .~ toList (contentTypes t)
+
+        t = Proxy :: Proxy ctype
 
 instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
 
diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs
index 5a890926..bda291a6 100644
--- a/servant-docs/test/Servant/DocsSpec.hs
+++ b/servant-docs/test/Servant/DocsSpec.hs
@@ -15,6 +15,7 @@
 module Servant.DocsSpec where
 
 import           Control.Lens
+                 ((&), (<>~))
 import           Control.Monad
                  (unless)
 import           Control.Monad.Trans.Writer
@@ -22,7 +23,6 @@ import           Control.Monad.Trans.Writer
 import           Data.Aeson
 import           Data.List
                  (isInfixOf)
-import           Data.Monoid
 import           Data.Proxy
 import           Data.String.Conversions
                  (cs)
@@ -31,6 +31,8 @@ import           Prelude ()
 import           Prelude.Compat
 import           Test.Tasty
                  (TestName, TestTree, testGroup)
+import           Test.Tasty.Golden
+                 (goldenVsString)
 import           Test.Tasty.HUnit
                  (Assertion, HasCallStack, assertFailure, testCase, (@?=))
 
@@ -41,25 +43,27 @@ import           Servant.Test.ComprehensiveAPI
 -- * comprehensive api
 
 -- This declaration simply checks that all instances are in place.
-_ = docs comprehensiveAPI
+comprehensiveDocs :: API
+comprehensiveDocs = docs comprehensiveAPI
 
 instance ToParam (QueryParam' mods "foo" Int) where
-  toParam = error "unused"
+  toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal
 instance ToParam (QueryParam' mods "bar" Int) where
-  toParam = error "unused"
+  toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal
 instance ToParam (QueryParams "foo" Int) where
-  toParam = error "unused"
+  toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List
 instance ToParam (QueryFlag "foo") where
-  toParam = error "unused"
+  toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag
 instance ToCapture (Capture "foo" Int) where
-  toCapture = error "unused"
+  toCapture _ = DocCapture "foo" "Capture foo Int"
 instance ToCapture (CaptureAll "foo" Int) where
-  toCapture = error "unused"
+  toCapture _ = DocCapture "foo" "Capture all foo Int"
 
 -- * specs
 
 spec :: TestTree
 spec = describe "Servant.Docs" $ do
+  golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
 
   describe "markdown" $ do
     let md = markdown (docs (Proxy :: Proxy TestApi1))
@@ -195,3 +199,7 @@ shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains"
 compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion
 compareWith f msg x y = unless (f x y) $ assertFailure $
     show x ++ " " ++ msg ++ " " ++ show y
+
+golden :: TestName -> FilePath -> String -> TestTreeM ()
+golden n fp contents = TestTreeM $ tell
+    [ goldenVsString n fp (return (cs contents)) ]
diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs
index 768c517e..c300465d 100644
--- a/servant/src/Servant/Test/ComprehensiveAPI.hs
+++ b/servant/src/Servant/Test/ComprehensiveAPI.hs
@@ -16,37 +16,37 @@ type GET = Get '[JSON] NoContent
 
 type ComprehensiveAPI =
   ComprehensiveAPIWithoutRaw :<|>
-  Raw
+  "raw" :> Raw
 
 comprehensiveAPI :: Proxy ComprehensiveAPI
 comprehensiveAPI = Proxy
 
 type ComprehensiveAPIWithoutRaw =
   GET :<|>
-  Get '[JSON] Int :<|>
-  Capture' '[Description "example description"] "foo" Int :> GET :<|>
-  Header "foo" Int :> GET :<|>
-  Header' '[Required, Lenient] "bar" Int :> GET :<|>
-  HttpVersion :> GET :<|>
-  IsSecure :> GET :<|>
-  QueryParam "foo" Int :> GET :<|>
-  QueryParam' '[Required, Lenient] "bar" Int :> GET :<|>
-  QueryParams "foo" Int :> GET :<|>
-  QueryFlag "foo" :> GET :<|>
-  RemoteHost :> GET :<|>
-  ReqBody '[JSON] Int :> GET :<|>
-  ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
-  Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
-  "foo" :> GET :<|>
-  Vault :> GET :<|>
-  Verb 'POST 204 '[JSON] NoContent :<|>
-  Verb 'POST 204 '[JSON] Int :<|>
-  StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) :<|>
-  WithNamedContext "foo" '[] GET :<|>
-  CaptureAll "foo" Int :> GET :<|>
-  Summary "foo" :> GET :<|>
-  Description "foo" :> GET :<|>
-  EmptyAPI
+  "get-int"          :> Get '[JSON] Int :<|>
+  "capture"          :> Capture' '[Description "example description"] "foo" Int :> GET :<|>
+  "header"           :> Header "foo" Int :> GET :<|>
+  "header-lenient"   :> Header' '[Required, Lenient] "bar" Int :> GET :<|>
+  "http-version"     :> HttpVersion :> GET :<|>
+  "is-secure"        :> IsSecure :> GET :<|>
+  "param"            :> QueryParam "foo" Int :> GET :<|>
+  "param-lenient"    :>  QueryParam' '[Required, Lenient] "bar" Int :> GET :<|>
+  "params"           :> QueryParams "foo" Int :> GET :<|>
+  "flag"             :> QueryFlag "foo" :> GET :<|>
+  "remote-host"      :> RemoteHost :> GET :<|>
+  "req-body"         :> ReqBody '[JSON] Int :> GET :<|>
+  "req-body-lenient" :> ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
+  "res-headers"      :> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
+  "foo"              :> GET :<|>
+  "vault"            :> Vault :> GET :<|>
+  "post-no-content"  :> Verb 'POST 204 '[JSON] NoContent :<|>
+  "post-int"         :> Verb 'POST 204 '[JSON] Int :<|>
+  "streaming"        :> StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) :<|>
+  "named-context"    :> WithNamedContext "foo" '[] GET :<|>
+  "capture-all"      :>  CaptureAll "foo" Int :> GET :<|>
+  "summary"          :> Summary "foo" :> GET :<|>
+  "description"      :> Description "foo" :> GET :<|>
+  "empty-api"        :> EmptyAPI
 
 comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw
 comprehensiveAPIWithoutRaw = Proxy