servant-docs 0.7.1 → 0.13.1
raw patch · 12 files changed
Files
- CHANGELOG.md +139/−0
- LICENSE +1/−1
- README.md +45/−12
- example/greet.hs +14/−14
- golden/comprehensive.md +610/−0
- include/overlapping-compat.h +0/−8
- servant-docs.cabal +54/−32
- src/Servant/Docs.hs +7/−3
- src/Servant/Docs/Internal.hs +506/−173
- src/Servant/Docs/Internal/Pretty.hs +31/−8
- test/Servant/DocsSpec.hs +108/−25
- test/Spec.hs +8/−1
CHANGELOG.md view
@@ -1,3 +1,142 @@+[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++0.13.1+------++- Compatibility with newer dependencies and newer GHCs.++0.13+----++- WithResource combinator for Servant-managed resources. [#1630](https://github.com/haskell-servant/servant/pull/1630)++ For servant-docs, this meant the addition of `instance HasDocs api => HasDocs (WithResource res :> api)`++- Compatibility with GHC series 9.2, 9.4, 9.6++0.12+----++### Significant changes++- Generate sample cURL requests+ ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).+ Breaking change: requires sample header values to be supplied with `headers`.++0.11.9+------++### Significant changes++- Use Capture Description if available (#1423).++### Other changes++- Support GHC-9.0.1.+- Bump `bytestring` and `lens` dependencies.++0.11.8+------++### Significant changes++- Support `Fragment` combinator.++0.11.7+------++### Significant changes++- Add instance for ToSample NonEmpty++### Other changes++- Bump "tested-with" ghc versions+- Fix servant-docs code sample in README++0.11.5+----+++- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)++ The `NoContent` API endpoints should now use `NoContentVerb` combinator.+ The API type changes are usually of the kind++ ```diff+ - :<|> PostNoContent '[JSON] NoContent+ + :<|> PostNoContent+ ```++ i.e. one doesn't need to specify the content-type anymore. There is no content.++- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)++ You can specify a lenient capture as++ ```haskell+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET+ ```++ which will make the capture always succeed. Handlers will be of the+ type `Either String CapturedType`, where `Left err` represents+ the possible parse failure.++- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241)++ Servant supports defining the same route multiple times with different+ content-types and result-types, but servant-docs was only documenting+ the first of copy of such duplicated routes. It now combines the+ documentation from all the copies.++ Unfortunately, it is not yet possible for the documentation to specify+ multiple status codes.++- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194)++0.11.4+------++- Drop dependency on `control-monad-omega` in favor of `Data.Universe.Helpers` from `universe-base`.++0.11.3+------++- Support `servant-0.15`+ - Instances for 'Stream' and 'StreamBody'++0.11.2+------++* Allow `servant-0.13`:+ - Doesn't have instances for streaming.+ - Servant.API.Modifiers extra information isn't used.++0.11.1+------++* Export `DocAuthentication` and related lenses.+* Make `defAction`'s documentation visible in Haddock documentation.+* Add a markdown header for the Headers an endpoint is sensitive to.+* 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 customise various aspects of how the document is produced+ using `markdownWith` and `RenderingOptions`:+ - How many content-types for each example are shown+ - Whether notes should be grouped together under their own header.++0.11+----++* changed the type of `rqbody`.++0.10+----++There are no changes. Released as a part of `servant` suite.+ 0.7.1 -----
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved.
README.md view
@@ -2,24 +2,56 @@  -Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.+Generate API docs for your _servant_ webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**. ## Example See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program. -``` haskell+```haskell {-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -import Data.Proxy-import Data.Text-import Servant+import Data.Aeson (FromJSON, ToJSON)+import Data.Proxy (Proxy (..))+import Data.String.Conversions (cs)+import Data.Text (Text)+import GHC.Generics (Generic)+import Servant.API+ ( (:<|>),+ (:>),+ Capture,+ Delete,+ Get,+ JSON,+ MimeRender,+ PlainText,+ Post,+ QueryParam,+ ReqBody,+ mimeRender,+ )+import Servant.Docs+ ( API,+ DocCapture (..),+ DocQueryParam (..),+ ParamKind (..),+ ToCapture,+ ToParam,+ ToSample,+ docs,+ markdown,+ singleSample,+ toCapture,+ toParam,+ toSamples,+ ) -- our type for a Greeting message data Greet = Greet { _msg :: Text }@@ -29,6 +61,7 @@ -- 'MimeRender' instance for 'JSON'. instance FromJSON Greet instance ToJSON Greet+instance ToSample () -- We can also implement 'MimeRender' explicitly for additional formats. instance MimeRender PlainText Greet where@@ -36,8 +69,7 @@ -- we provide a sample value for the 'Greet' type instance ToSample Greet where- toSample = Just g-+ toSamples _ = singleSample g where g = Greet "Hello, haskeller!" instance ToParam (QueryParam "capital" Bool) where@@ -45,6 +77,7 @@ DocQueryParam "capital" ["true", "false"] "Get the greeting message in uppercase (true) or not (false). Default is false."+ Normal instance ToCapture (Capture "name" Text) where toCapture _ = DocCapture "name" "name of the person to greet"@@ -55,8 +88,8 @@ -- API specification type TestApi = "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet- :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet- :<|> "delete" :> Capture "greetid" Text :> Delete '[] ()+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet+ :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] () testApi :: Proxy TestApi testApi = Proxy
example/greet.hs view
@@ -5,14 +5,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-import Control.Lens-import Data.Aeson-import Data.Proxy-import Data.String.Conversions-import Data.Text (Text)-import GHC.Generics-import Servant.API-import Servant.Docs+import Control.Lens+import Data.Aeson+import Data.Proxy+import Data.String.Conversions+import Data.Text (Text)+import GHC.Generics+import Servant.API+import Servant.Docs -- * Example @@ -74,14 +74,14 @@ -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText- "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet+ "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> 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 '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet) -- DELETE /greet/:greetid- :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent testApi :: Proxy TestApi testApi = Proxy@@ -91,10 +91,10 @@ -- notes. extra :: ExtraInfo TestApi extra =- extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $- defAction & headers <>~ ["unicorns"]+ extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $+ defAction & headers <>~ [("X-Num-Unicorns", "1")] & notes <>~ [ DocNote "Title" ["This is some text"]- , DocNote "Second secton" ["And some more"]+ , DocNote "Second section" ["And some more"] ] -- Generate the data that lets us have API docs. This@@ -108,4 +108,4 @@ docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi main :: IO ()-main = putStrLn $ markdown docsGreet+main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet
+ golden/comprehensive.md view
@@ -0,0 +1,610 @@+## 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`):++```json++```++## GET /alternative/left++### Response:++- Status code 200+- Headers: []++- Supported content types are:++ - `application/json;charset=utf-8`+ - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /alternative/right++### Response:++- Status code 200+- Headers: []++- Supported content types are:++ - `application/json;charset=utf-8`+ - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /capture/:bar++### Captures:++- *bar*: example description++### Response:++- Status code 200+- Headers: []++- Supported content types are:++ - `application/json;charset=utf-8`+ - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## 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`):++```json++```++## GET /capture-lenient/: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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## GET /fragment++### Fragment:++- *foo*: Fragment 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`):++```json++```++## 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`):++```json+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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json++```++## 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`):++```json+17+```++## POST /post-no-content++### Response:++- Status code 204+- Headers: []++- No response body++## 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`):++```json++```++## GET /req-body++### Request:++- Supported content types are:++ - `application/json;charset=utf-8`+ - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json+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`):++```json++```++## GET /req-body-lenient++### Request:++- Supported content types are:++ - `application/json;charset=utf-8`+ - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json+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`):++```json++```++## 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`):++```json++```++## GET /resource++### Response:++- Status code 200+- Headers: []++- Supported content types are:++ - `application/json;charset=utf-8`+ - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## 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`):++```json++```++## 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`):++```json++```+
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant-docs.cabal view
@@ -1,27 +1,31 @@+cabal-version: 2.2 name: servant-docs-version: 0.7.1+version: 0.13.1+ synopsis: generate API docs for your servant webservice+category: Servant, Web description: Library for generating API docs from a servant API definition. .- Runnable example <https://github.com/haskell-servant/servant-docs/blob/master/example/greet.hs here>.+ Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>. . <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>-license: BSD3++homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors-category: Web+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple-cabal-version: >=1.10-tested-with: GHC >= 7.8-homepage: http://haskell-servant.readthedocs.org/-Bug-reports: http://github.com/haskell-servant/servant/issues+tested-with: GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.8, GHC ==9.4.8, GHC ==9.6.4, GHC ==9.8.2, GHC ==9.10.1+ extra-source-files:- include/*.h CHANGELOG.md README.md+ golden/comprehensive.md+ source-repository head type: git location: http://github.com/haskell-servant/servant.git@@ -31,28 +35,38 @@ Servant.Docs , Servant.Docs.Internal , Servant.Docs.Internal.Pretty++ -- Bundled with GHC: Lower bound to not force re-installs+ -- text and mtl are bundled starting with GHC-8.4+ --+ -- note: mtl lower bound is so low because of GHC-7.8 build-depends:- base >=4.7 && <5- , aeson- , aeson-pretty- , bytestring- , bytestring-conversion- , case-insensitive- , hashable- , http-media >= 0.6- , http-types >= 0.7- , lens- , servant == 0.7.*- , string-conversions- , text- , unordered-containers- , control-monad-omega == 0.3.*+ base >= 4.14 && < 4.21+ , bytestring >= 0.10.8.1 && < 0.13+ , text >= 1.2.3.0 && < 2.2++ -- Servant dependencies+ build-depends:+ servant >= 0.20.2 && <0.21++ -- Other dependencies: Lower bound around what is in the latest Stackage LTS.+ -- Here can be exceptions if we really need features from the newer versions.+ build-depends:+ aeson >= 1.4.1.0 && < 3+ , aeson-pretty >= 0.8.5 && < 0.9+ , base-compat >= 0.10.5 && < 0.15+ , case-insensitive >= 1.2.0.11 && < 1.3+ , hashable >= 1.2.7.0 && < 1.6+ , http-media >= 0.7.1.3 && < 0.9+ , http-types >= 0.12.2 && < 0.13+ , lens >= 4.17 && < 5.4+ , string-conversions >= 0.4.0.1 && < 0.5+ , universe-base >= 1.1.1 && < 1.2+ , unordered-containers >= 0.2.9.0 && < 0.3+ hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include+ ghc-options: -Wall -Wno-redundant-constraints executable greet-docs main-is: greet.hs@@ -61,7 +75,6 @@ build-depends: base , aeson- , bytestring-conversion , lens , servant , servant-docs@@ -70,17 +83,26 @@ default-language: Haskell2010 test-suite spec+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Servant.DocsSpec hs-source-dirs: test ghc-options: -Wall++ -- Dependencies inherited from the library. No need to specify bounds. build-depends: base+ , base-compat , aeson- , hspec , lens , servant , servant-docs , string-conversions- default-language: Haskell2010++ -- Additional dependencies+ build-depends:+ tasty >= 1.1.0.4 && < 1.6,+ tasty-golden >= 2.3.2 && < 2.4,+ tasty-hunit >= 0.10.0.1 && < 0.11,+ transformers >= 0.5.2.0 && < 0.7
src/Servant/Docs.hs view
@@ -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(..), notesHeading -- * Generating docs with extra information , docsWith, docsWithIntros, docsWithOptions , ExtraInfo(..), extraInfo@@ -43,14 +46,15 @@ , -- * ADTs to represent an 'API' Endpoint, path, method, defEndpoint , API, apiIntros, apiEndpoints, emptyAPI+ , DocAuthentication(..), authIntro, authDataRequired , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind , DocNote(..), noteTitle, noteBody , DocIntro(..), introTitle, introBody , Response(..), respStatus, respTypes, respBody, defResponse- , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction+ , Action, authInfo, captures, headers, notes, params, rqtypes, rqbody, response, defAction , single ) where -import Servant.Docs.Internal-import Servant.Docs.Internal.Pretty+import Servant.Docs.Internal+import Servant.Docs.Internal.Pretty
src/Servant/Docs/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}@@ -17,34 +16,57 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#include "overlapping-compat.h" 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 qualified Control.Monad.Omega as Omega-import Data.ByteString.Conversion (ToByteString, toByteString)-import Data.ByteString.Lazy.Char8 (ByteString)+import Control.Arrow+ (second)+import Control.Lens+ (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,+ _1, (%~), (&), (.~), (<>~), (^.), (|>)) import qualified Data.ByteString.Char8 as BSC+import Data.ByteString.Lazy.Char8+ (ByteString) import qualified Data.CaseInsensitive as CI-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import Data.List+import Data.Foldable+ (fold, toList)+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-import Data.Ord (comparing)-import Data.Proxy (Proxy(Proxy))-import Data.String.Conversions (cs)-import Data.Text (Text, unpack)-import GHC.Exts (Constraint)+ (All (..), Any (..), Dual (..), First (..), Last (..),+ Product (..), Sum (..))+import Data.Ord+ (comparing)+import Data.Proxy+ (Proxy (Proxy))+import Data.String.Conversions+ (cs)+import Data.Text+ (Text, unpack) import GHC.Generics+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,+ (:*:)((:*:)), (:+:)(L1, R1))+import qualified GHC.Generics as G import GHC.TypeLits import Servant.API import Servant.API.ContentTypes-import Servant.Utils.Links+import Servant.API.TypeErrors+import Servant.API.TypeLevel+import Servant.API.Generic +import qualified Data.Universe.Helpers as U+ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Network.HTTP.Media as M@@ -56,14 +78,15 @@ -- or any 'Endpoint' value you want using the 'path' and 'method' -- lenses to tweak. ----- @--- λ> 'defEndpoint'--- GET /--- λ> 'defEndpoint' & 'path' '<>~' ["foo"]--- GET /foo--- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'--- POST /foo--- @+-- >>> defEndpoint+-- "GET" /+--+-- >>> defEndpoint & path <>~ ["foo"]+-- "GET" /foo+--+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost+-- "POST" /foo+-- data Endpoint = Endpoint { _path :: [String] -- type collected , _method :: HTTP.Method -- type collected@@ -84,14 +107,15 @@ -- -- Here's how you can modify it: ----- @--- λ> 'defEndpoint'--- GET /--- λ> 'defEndpoint' & 'path' '<>~' ["foo"]--- GET /foo--- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'--- POST /foo--- @+-- >>> defEndpoint+-- "GET" /+--+-- >>> defEndpoint & path <>~ ["foo"]+-- "GET" /foo+--+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost+-- "POST" /foo+-- defEndpoint :: Endpoint defEndpoint = Endpoint [] HTTP.methodGet @@ -104,8 +128,12 @@ , _apiEndpoints :: HashMap Endpoint Action } deriving (Eq, Show) +instance Semigroup API where+ (<>) = mappend+ instance Monoid API where- API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)+ (HM.unionWith combineAction b1 b2) mempty = API mempty mempty -- | An empty 'API'@@ -121,9 +149,10 @@ , _capDesc :: String -- user supplied } deriving (Eq, Ord, Show) --- | A type to represent a /GET/ parameter from the Query String. Holds its name,--- the possible values (leave empty if there isn't a finite number of them),--- and a description of how it influences the output or behavior.+-- | A type to represent a /GET/ (or other possible 'HTTP.Method')+-- parameter from the Query String. Holds its name, the possible+-- values (leave empty if there isn't a finite number of them), and+-- a description of how it influences the output or behavior. -- -- Write a 'ToParam' instance for your GET parameter types data DocQueryParam = DocQueryParam@@ -133,6 +162,20 @@ , _paramKind :: ParamKind } deriving (Eq, Ord, Show) +-- | A type to represent fragment. Holds the name of the fragment and its description.+--+-- Write a 'ToFragment' instance for your fragment types.+data DocFragment = DocFragment+ { _fragSymbol :: String -- type supplied+ , _fragDesc :: String -- user supplied+ } deriving (Eq, Ord, Show)++-- | There should be at most one 'Fragment' per API endpoint.+-- So here we are keeping the first occurrence.+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment+Nothing `combineFragment` mdocFragment = mdocFragment+Just docFragment `combineFragment` _ = Just docFragment+ -- | An introductory paragraph for your documentation. You can pass these to -- 'docsWithIntros'. data DocIntro = DocIntro@@ -163,7 +206,9 @@ -- -- These are intended to be built using extraInfo. -- Multiple ExtraInfo may be combined with the monoid instance.-newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)+newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action)+instance Semigroup (ExtraInfo a) where+ (<>) = mappend instance Monoid (ExtraInfo a) where mempty = ExtraInfo mempty ExtraInfo a `mappend` ExtraInfo b =@@ -179,7 +224,7 @@ defaultDocOptions = DocOptions { _maxSamples = 5 } --- | Type of GET parameter:+-- | Type of GET (or other 'HTTP.Method') parameter: -- -- - Normal corresponds to @QueryParam@, i.e your usual GET parameter -- - List corresponds to @QueryParams@, i.e GET parameters with multiple values@@ -196,12 +241,14 @@ -- want to write a 'ToSample' instance for the type that'll be represented -- as encoded data in the response. ----- Can be tweaked with three lenses.+-- Can be tweaked with four lenses. ----- > λ> defResponse--- > Response {_respStatus = 200, _respTypes = [], _respBody = []}--- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]--- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}+-- >>> defResponse+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}+--+-- >>> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "application/json", "{ \"status\": \"ok\" }")]+-- Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well",application/json,"{ \"status\": \"ok\" }")], _respHeaders = []}+-- data Response = Response { _respStatus :: Int , _respTypes :: [M.MediaType]@@ -209,14 +256,25 @@ , _respHeaders :: [HTTP.Header] } deriving (Eq, Ord, Show) +-- | Combine two Responses, we can't make a monoid because merging Status breaks+-- the laws.+--+-- As such, we invent a non-commutative, left associative operation+-- 'combineResponse' to mush two together taking the status from the very left.+combineResponse :: Response -> Response -> Response+Response s ts bs hs `combineResponse` Response _ ts' bs' hs'+ = Response s (ts <> ts') (bs <> bs') (hs <> hs')+ -- | Default response: status code 200, no response body. ----- Can be tweaked with two lenses.+-- Can be tweaked with four lenses. ----- > λ> defResponse--- > Response {_respStatus = 200, _respBody = Nothing}--- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"--- > Response {_respStatus = 204, _respBody = Just "[]"}+-- >>> defResponse+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}+--+-- >>> defResponse & respStatus .~ 204+-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []}+-- defResponse :: Response defResponse = Response { _respStatus = 200@@ -229,7 +287,7 @@ -- at an endpoint, with its lenses: -- -- - List of captures ('captures')--- - List of GET parameters ('params')+-- - List of GET (or other 'HTTP.Method') parameters ('params') -- - What the request body should look like, if any is requested ('rqbody') -- - What the response should be if everything goes well ('response') --@@ -238,12 +296,13 @@ data Action = Action { _authInfo :: [DocAuthentication] -- user supplied info , _captures :: [DocCapture] -- type collected + user supplied info- , _headers :: [Text] -- type collected+ , _headers :: [HTTP.Header] -- type collected , _params :: [DocQueryParam] -- type collected + user supplied info+ , _fragment :: Maybe DocFragment -- type collected + user supplied info , _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) @@ -251,27 +310,30 @@ -- laws. -- -- As such, we invent a non-commutative, left associative operation--- 'combineAction' to mush two together taking the response, body and content--- types from the very left.+-- 'combineAction' to mush two together taking the response from the very left. combineAction :: Action -> Action -> Action-Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =- Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp+Action a c h p f n m ts body resp+ `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =+ Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') --- Default 'Action'. Has no 'captures', no GET 'params', expects+-- | Default 'Action'. Has no 'captures', no query 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. -- -- Tweakable with lenses. ----- > λ> defAction--- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}--- > λ> defAction & response.respStatus .~ 201--- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}+-- >>> defAction+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}+--+-- >>> defAction & response.respStatus .~ 201+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}+-- defAction :: Action defAction = Action [] [] [] []+ Nothing [] [] []@@ -284,6 +346,42 @@ 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?+ , _notesHeading :: !(Maybe String)+ -- ^ Optionally group all 'notes' together under a common heading.+ , _renderCurlBasePath :: !(Maybe String)+ -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`).+ } deriving (Show)++-- | Default API generation options.+--+-- All content types are shown for both 'requestExamples' and+-- 'responseExamples'; 'notesHeading' is set to 'Nothing'+-- (i.e. un-grouped).+--+-- @since 0.11.1+defRenderingOptions :: RenderingOptions+defRenderingOptions = RenderingOptions+ { _requestExamples = AllContentTypes+ , _responseExamples = AllContentTypes+ , _notesHeading = Nothing+ , _renderCurlBasePath = Nothing+ }+ -- gimme some lenses makeLenses ''DocAuthentication makeLenses ''DocOptions@@ -291,32 +389,26 @@ makeLenses ''Endpoint makeLenses ''DocCapture makeLenses ''DocQueryParam+makeLenses ''DocFragment 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. ----- prop> docs == docsWithOptions defaultDocOptions-docs :: HasDocs layout => Proxy layout -> API+-- > docs == docsWithOptions defaultDocOptions+--+docs :: HasDocs api => Proxy api -> API docs p = docsWithOptions p defaultDocOptions -- | Generate the docs for a given API that implements 'HasDocs'.-docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API+docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API docsWithOptions p = docsFor p (defEndpoint, defAction) --- | Closed type family, check if endpoint is exactly within API.---- We aren't sure what affects how an Endpoint is built up, so we require an--- exact match.-type family IsIn (endpoint :: *) (api :: *) :: Constraint where- IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)- IsIn (e :> sa) (e :> sb) = IsIn sa sb- IsIn e e = ()---- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.+-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout. -- -- The safety here is to ensure that you only add custom documentation to an -- endpoint that actually exists within your API.@@ -324,13 +416,13 @@ -- > extra :: ExtraInfo TestApi -- > extra = -- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $--- > defAction & headers <>~ ["unicorns"]+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)] -- > & notes <>~ [ DocNote "Title" ["This is some text"]--- > , DocNote "Second secton" ["And some more"]+-- > , DocNote "Second section" ["And some more"] -- > ] -extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)- => Proxy endpoint -> Action -> ExtraInfo layout+extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)+ => Proxy endpoint -> Action -> ExtraInfo api extraInfo p action = let api = docsFor p (defEndpoint, defAction) defaultDocOptions -- Assume one endpoint, HasLink constraint means that we should only ever@@ -349,22 +441,22 @@ -- 'extraInfo'. -- -- If you only want to add an introduction, use 'docsWithIntros'.-docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API+docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API docsWith opts intros (ExtraInfo endpoints) p = docsWithOptions p opts & apiIntros <>~ intros & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints --- | Generate the docs for a given API that implements 'HasDocs' with with any+-- | Generate the docs for a given API that implements 'HasDocs' with any -- number of introduction(s)-docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API+docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API docsWithIntros intros = docsWith defaultDocOptions intros mempty -- | The class that abstracts away the impact of API combinators -- on documentation generation.-class HasDocs layout where- docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API+class HasDocs api where+ docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API -- | The class that lets us display a sample input or output in the supported -- content-types when generating documentation for endpoints that either:@@ -419,22 +511,22 @@ -- | Default sample Generic-based inputs/outputs. defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]-defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a)) -- | @'ToSample'@ for Generics. ----- The use of @'Omega'@ allows for more productive sample generation.+-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation. class GToSample t where- gtoSamples :: proxy t -> Omega.Omega (Text, t x)+ gtoSamples :: proxy t -> [(Text, t x)] instance GToSample U1 where- gtoSamples _ = Omega.each (singleSample U1)+ gtoSamples _ = singleSample U1 instance GToSample V1 where gtoSamples _ = empty instance (GToSample p, GToSample q) => GToSample (p :*: q) where- gtoSamples _ = render <$> ps <*> qs+ gtoSamples _ = U.cartesianProduct render ps qs where ps = gtoSamples (Proxy :: Proxy p) qs = gtoSamples (Proxy :: Proxy q)@@ -443,13 +535,13 @@ | otherwise = (ta <> ", " <> tb, a :*: b) instance (GToSample p, GToSample q) => GToSample (p :+: q) where- gtoSamples _ = lefts <|> rights+ gtoSamples _ = lefts U.+++ rights where lefts = second L1 <$> gtoSamples (Proxy :: Proxy p) rights = second R1 <$> gtoSamples (Proxy :: Proxy q) instance ToSample a => GToSample (K1 i a) where- gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))+ gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a) instance (GToSample f) => GToSample (M1 i a f) where gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)@@ -461,12 +553,12 @@ instance AllHeaderSamples '[] where allHeaderToSample _ = [] -instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)+instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h) => AllHeaderSamples (Header h l ': ls) where allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) : allHeaderToSample (Proxy :: Proxy ls) where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)- mkHeader (Just x) = (headerName, cs $ toByteString x)+ mkHeader (Just x) = (headerName, cs $ toHeader x) mkHeader Nothing = (headerName, "<no header sample provided>") -- | Synthesise a sample value of a type, encoded in the specified media types.@@ -490,12 +582,12 @@ enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s in concatMap enc samples' --- | The class that helps us automatically get documentation--- for GET parameters.+-- | The class that helps us automatically get documentation for GET+-- (or other 'HTTP.Method') parameters. -- -- Example of an instance: ----- > instance ToParam (QueryParam "capital" Bool) where+-- > instance ToParam (QueryParam' mods "capital" Bool) where -- > toParam _ = -- > DocQueryParam "capital" -- > ["true", "false"]@@ -517,10 +609,45 @@ class ToAuthInfo a where toAuthInfo :: Proxy a -> DocAuthentication +-- | The class that helps us get documentation for URL fragments.+--+-- Example of an instance:+--+-- > instance ToFragment (Fragment a) where+-- > toFragment _ = DocFragment "fragment" "fragment description"+class ToFragment t where+ toFragment :: Proxy t -> DocFragment+ -- | 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) @@ -531,15 +658,19 @@ notesStr (action ^. notes) ++ authStr (action ^. authInfo) ++ capturesStr (action ^. captures) ++- headersStr (action ^. headers) ++- paramsStr (action ^. params) +++ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) +++ paramsStr meth (action ^. params) +++ fragmentStr (action ^. fragment) ++ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++ responseStr (action ^. response) +++ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++ [] - where str = "## " ++ BSC.unpack (endpoint^.method)+ where str = "## " ++ BSC.unpack meth ++ " " ++ showPath (endpoint^.path) + meth = endpoint ^. method+ introsStr :: [DocIntro] -> [String] introsStr = concatMap introStr @@ -552,22 +683,28 @@ [] notesStr :: [DocNote] -> [String]- notesStr = concatMap noteStr+ notesStr = addHeading+ . concatMap noteStr+ where+ addHeading nts = maybe nts (\hd -> ("### " ++ hd) : "" : nts) _notesHeading noteStr :: DocNote -> [String] noteStr nt =- ("#### " ++ nt ^. noteTitle) :+ (hdr ++ nt ^. noteTitle) : "" : intersperse "" (nt ^. noteBody) ++ "" : []-+ where+ hdr | isJust _notesHeading = "#### "+ | otherwise = "### " authStr :: [DocAuthentication] -> [String]+ authStr [] = [] authStr auths = let authIntros = mapped %~ view authIntro $ auths clientInfos = mapped %~ view authDataRequired $ auths- in "#### Authentication":+ in "### Authentication": "": unlines authIntros : "":@@ -579,7 +716,7 @@ capturesStr :: [DocCapture] -> [String] capturesStr [] = [] capturesStr l =- "#### Captures:" :+ "### Captures:" : "" : map captureStr l ++ "" :@@ -590,28 +727,33 @@ headersStr :: [Text] -> [String] headersStr [] = []- headersStr l = [""] ++ map headerStr l ++ [""]+ headersStr l =+ "### Headers:" :+ "" :+ map headerStr l +++ "" :+ [] where headerStr hname = "- This endpoint is sensitive to the value of the **" ++ unpack hname ++ "** HTTP header." - paramsStr :: [DocQueryParam] -> [String]- paramsStr [] = []- paramsStr l =- "#### GET Parameters:" :+ paramsStr :: HTTP.Method -> [DocQueryParam] -> [String]+ paramsStr _ [] = []+ paramsStr m l =+ ("### " ++ cs m ++ " Parameters:") : "" :- map paramStr l +++ map (paramStr m) l ++ "" : [] - paramStr param = unlines $+ paramStr m param = unlines $ ("- " ++ param ^. paramName) : (if (not (null values) || param ^. paramKind /= Flag) then [" - **Values**: *" ++ intercalate ", " values ++ "*"] else []) ++ (" - **Description**: " ++ param ^. paramDesc) : (if (param ^. paramKind == List)- then [" - This parameter is a **list**. All GET parameters with the name "+ then [" - This parameter is a **list**. All " ++ cs m ++ " parameters with the name " ++ param ^. paramName ++ "[] will forward their values in a list to the handler."] else []) ++ (if (param ^. paramKind == Flag)@@ -621,27 +763,58 @@ where values = param ^. paramValues - rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]+ fragmentStr :: Maybe DocFragment -> [String]+ fragmentStr Nothing = []+ fragmentStr (Just frag) =+ [ "### Fragment:", ""+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)+ , ""+ ]++ rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String] rqbodyStr [] [] = [] rqbodyStr types s =- ["#### Request:", ""]+ ["### Request:", ""] <> formatTypes types- <> concatMap formatBody s+ <> formatBodies _requestExamples s formatTypes [] = [] formatTypes ts = ["- Supported content types are:", ""] <> map (\t -> " - `" <> show t <> "`") ts <> [""] - formatBody (m, b) =- "- Example: `" <> cs (show m) <> "`" :- contentStr m b+ -- This assumes that when the bodies are created, identical+ -- labels and representations are located next to each other.+ 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"- ("application", "json") -> "javascript"+ ("text", "xml") -> "xml"+ ("application", "json") -> "json" ("application", "javascript") -> "javascript" ("text", "css") -> "css" (_, _) -> ""@@ -656,7 +829,7 @@ responseStr :: Response -> [String] responseStr resp =- "#### Response:" :+ "### Response:" : "" : ("- Status code " ++ show (resp ^. respStatus)) : ("- Headers: " ++ show (resp ^. respHeaders)) :@@ -668,41 +841,113 @@ [] -> ["- No response body\n"] [("", t, r)] -> "- Response body as below." : contentStr t r xs ->- concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs+ formatBodies _responseExamples xs + curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]+ curlStr endpoint hdrs reqBodies basePath =+ [ "### Sample Request:"+ , ""+ , "```bash"+ , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"+ ] <>+ maybe [] pure mbMediaTypeStr <>+ headersStrs <>+ maybe [] pure mbReqBodyStr <>+ [ " " ++ basePath ++ showPath (endpoint ^. path)+ , "```"+ , ""+ ]++ where escapeQuotes :: String -> String+ escapeQuotes = concatMap $ \c -> case c of+ '\"' -> "\\\""+ _ -> [c]+ mbReqBody = listToMaybe reqBodies+ mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody+ headersStrs = mkHeaderStr <$> hdrs+ mbReqBodyStr = mkReqBodyStr <$> mbReqBody+ mkMediaTypeStr (_, media_type, _) =+ " -H \"Content-Type: " ++ show media_type ++ "\" \\"+ mkHeaderStr (hdrName, hdrVal) =+ " -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " +++ escapeQuotes (cs hdrVal) ++ "\" \\"+ mkReqBodyStr (_, _, body) = " -d \"" ++ escapeQuotes (cs body) ++ "\" \\"+ -- * Instances -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@.-instance OVERLAPPABLE_- (HasDocs layout1, HasDocs layout2)- => HasDocs (layout1 :<|> layout2) where+instance {-# OVERLAPPABLE #-}+ (HasDocs a, HasDocs b)+ => HasDocs (a :<|> b) where docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) - where p1 :: Proxy layout1+ where p1 :: Proxy a p1 = Proxy - p2 :: Proxy layout2+ p2 :: Proxy b p2 = Proxy +-- | The generated docs for @'EmptyAPI'@ are empty.+instance HasDocs EmptyAPI where+ docsFor Proxy _ _ = emptyAPI+ -- | @"books" :> 'Capture' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs.-instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)- => HasDocs (Capture sym a :> sublayout) where+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)+ => HasDocs (Capture' '[] sym a :> api) where docsFor Proxy (endpoint, action) =+ docsFor subApiP (endpoint', action')++ where subApiP = Proxy :: Proxy api+ captureP = Proxy :: Proxy (Capture sym a)++ action' = over captures (|> toCapture captureP) action+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint+ symP = Proxy :: Proxy sym++instance (KnownSymbol descr, KnownSymbol sym, HasDocs api)+ => HasDocs (Capture' (Description descr ': mods) sym a :> api) where++ docsFor Proxy (endpoint, action) =+ docsFor subApiP (endpoint', action')++ where subApiP = Proxy :: Proxy api++ docCapture = DocCapture (symbolVal symP) (symbolVal descrP)+ action' = over captures (|> docCapture) action+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint+ descrP = Proxy :: Proxy descr+ symP = Proxy :: Proxy sym++instance {-# OVERLAPPABLE #-} HasDocs (Capture' mods sym a :> api)+ => HasDocs (Capture' (mod ': mods) sym a :> api) where++ docsFor Proxy =+ docsFor apiP++ where apiP = Proxy :: Proxy (Capture' mods sym a :> api)+++-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as+-- @/books/:isbn@ in the docs.+instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)+ => HasDocs (CaptureAll sym a :> sublayout) where++ docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint', action') where sublayoutP = Proxy :: Proxy sublayout- captureP = Proxy :: Proxy (Capture sym a)+ captureP = Proxy :: Proxy (CaptureAll sym a) action' = over captures (|> toCapture captureP) action endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint symP = Proxy :: Proxy sym -instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status , ReflectMethod method) => HasDocs (Verb method status (ct ': cts) a) where@@ -718,7 +963,37 @@ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance OVERLAPPING_+instance (ReflectMethod method) =>+ HasDocs (NoContentVerb method) where+ docsFor Proxy (endpoint, action) DocOptions{..} =+ single endpoint' action'++ where endpoint' = endpoint & method .~ method'+ action' = action & response.respStatus .~ 204+ & response.respTypes .~ []+ & response.respBody .~ []+ & response.respHeaders .~ []+ method' = reflectMethod (Proxy :: Proxy method)++-- | TODO: mention the endpoint is streaming, its framing strategy+--+-- Also there are no samples.+--+-- TODO: AcceptFraming for content-type+instance {-# OVERLAPPABLE #-}+ (Accept ct, KnownNat status, ReflectMethod method)+ => HasDocs (Stream method status framing ct a) where+ docsFor Proxy (endpoint, action) DocOptions{..} =+ single endpoint' action'++ where endpoint' = endpoint & method .~ method'+ action' = action & response.respTypes .~ allMime t+ & response.respStatus .~ status+ t = Proxy :: Proxy '[ct]+ method' = reflectMethod (Proxy :: Proxy method)+ status = fromInteger $ natVal (Proxy :: Proxy status)++instance {-# OVERLAPPING #-} (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls)) => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where@@ -736,104 +1011,158 @@ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance (KnownSymbol sym, HasDocs sublayout)- => HasDocs (Header sym a :> sublayout) where+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)+ => HasDocs (Header' mods sym a :> api) where docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')+ docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout- action' = over headers (|> headername) action- headername = T.pack $ symbolVal (Proxy :: Proxy sym)+ where subApiP = Proxy :: Proxy api+ action' = over headers (|> (headerName, headerVal)) action+ headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)+ headerVal = case toSample (Proxy :: Proxy a) of+ Just x -> cs $ toHeader x+ Nothing -> "<no header sample provided>" -instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)- => HasDocs (QueryParam sym a :> sublayout) where+instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)+ => HasDocs (QueryParam' mods sym a :> api) where docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')+ docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout- paramP = Proxy :: Proxy (QueryParam sym a)+ where subApiP = Proxy :: Proxy api+ paramP = Proxy :: Proxy (QueryParam' mods sym a) action' = over params (|> toParam paramP) action -instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)- => HasDocs (QueryParams sym a :> sublayout) where+instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)+ => HasDocs (QueryParams sym a :> api) where docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')+ docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout+ where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryParams sym a) action' = over params (|> toParam paramP) action -instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)- => HasDocs (QueryFlag sym :> sublayout) where+instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)+ => HasDocs (QueryFlag sym :> api) where docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')+ docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout+ where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryFlag sym) action' = over params (|> toParam paramP) action +instance (ToFragment (Fragment a), HasDocs api)+ => HasDocs (Fragment a :> api) where + docsFor Proxy (endpoint, action) =+ docsFor subApiP (endpoint, action')++ where subApiP = Proxy :: Proxy api+ fragmentP = Proxy :: Proxy (Fragment a)+ action' = set fragment (Just (toFragment fragmentP)) action+ instance HasDocs Raw where docsFor _proxy (endpoint, action) _ = single endpoint action ++instance (KnownSymbol desc, HasDocs api)+ => HasDocs (Description desc :> api) where++ docsFor Proxy (endpoint, action) =+ docsFor subApiP (endpoint, action')++ where subApiP = Proxy :: Proxy api+ action' = over notes (|> note) action+ note = DocNote (symbolVal (Proxy :: Proxy desc)) []++instance (KnownSymbol desc, HasDocs api)+ => HasDocs (Summary desc :> api) where++ docsFor Proxy (endpoint, action) =+ docsFor subApiP (endpoint, action')++ where subApiP = Proxy :: Proxy api+ action' = over notes (|> note) action+ note = DocNote (symbolVal (Proxy :: Proxy desc)) []+ -- 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, AllMimeRender (ct ': cts) a, HasDocs sublayout)- => HasDocs (ReqBody (ct ': cts) a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')+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 - where sublayoutP = Proxy :: Proxy sublayout- action' = action & rqbody .~ sampleByteString t p+ where subApiP = Proxy :: Proxy api+ action' :: Action+ action' = action & rqbody .~ take _maxSamples (sampleByteStrings t p) & rqtypes .~ allMime t t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a -instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where+-- | TODO: this instance is incomplete.+instance (HasDocs api, Accept ctype) => HasDocs (StreamBody' mods 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+ docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint', action)+ docsFor subApiP (endpoint', action) - where sublayoutP = Proxy :: Proxy sublayout+ where subApiP = Proxy :: Proxy api endpoint' = endpoint & path <>~ [symbolVal pa] pa = Proxy :: Proxy path -instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where+instance HasDocs api => HasDocs (RemoteHost :> api) where docsFor Proxy ep =- docsFor (Proxy :: Proxy sublayout) ep+ docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where+instance HasDocs api => HasDocs (IsSecure :> api) where docsFor Proxy ep =- docsFor (Proxy :: Proxy sublayout) ep+ docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where+instance HasDocs api => HasDocs (HttpVersion :> api) where docsFor Proxy ep =- docsFor (Proxy :: Proxy sublayout) ep+ docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (Vault :> sublayout) where+instance HasDocs api => HasDocs (Vault :> api) where docsFor Proxy ep =- docsFor (Proxy :: Proxy sublayout) ep+ docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where- docsFor Proxy = docsFor (Proxy :: Proxy sublayout)+instance HasDocs api => HasDocs (WithNamedContext name context api) where+ docsFor Proxy = docsFor (Proxy :: Proxy api) -instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where+instance HasDocs api => HasDocs (WithResource res :> api) where+ docsFor Proxy = docsFor (Proxy :: Proxy api)++instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where docsFor Proxy (endpoint, action) =- docsFor (Proxy :: Proxy sublayout) (endpoint, action')+ docsFor (Proxy :: Proxy api) (endpoint, action') where authProxy = Proxy :: Proxy (BasicAuth realm usr) action' = over authInfo (|> toAuthInfo authProxy) action +instance+ ( HasDocs (ToServantApi api)+ , ErrorIfNoGeneric api+ ) => HasDocs (NamedRoutes api) where+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))+ -- ToSample instances for simple types-instance ToSample ()+instance ToSample NoContent instance ToSample Bool instance ToSample Ordering @@ -848,6 +1177,7 @@ instance ToSample a => ToSample (Maybe a) instance (ToSample a, ToSample b) => ToSample (Either a b) instance ToSample a => ToSample [a]+instance ToSample a => ToSample (NonEmpty a) -- ToSample instances for Control.Applicative types instance ToSample a => ToSample (Const a b)@@ -861,3 +1191,6 @@ instance ToSample a => ToSample (First a) instance ToSample a => ToSample (Last a) instance ToSample a => ToSample (Dual a)++-- $setup+-- >>> :set -XOverloadedStrings
src/Servant/Docs/Internal/Pretty.hs view
@@ -4,16 +4,21 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Servant.Docs.Internal.Pretty where -import Data.Aeson (ToJSON(..))-import Data.Aeson.Encode.Pretty (encodePretty)-import Data.Proxy (Proxy(Proxy))-import Network.HTTP.Media ((//))-import Servant.API+import Data.Aeson+ (ToJSON (..))+import Data.Aeson.Encode.Pretty+ (encodePretty)+import Data.Proxy+ (Proxy (Proxy))+import Network.HTTP.Media+ ((//))+import Servant.API+import Servant.API.Verbs -- | PrettyJSON content type. data PrettyJSON@@ -29,12 +34,12 @@ -- @ -- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) -- @-pretty :: Proxy layout -> Proxy (Pretty layout)+pretty :: Proxy api -> Proxy (Pretty api) pretty Proxy = Proxy -- | Replace all JSON content types with PrettyJSON. -- Kind-polymorphic so it can operate on kinds @*@ and @[*]@.-type family Pretty (layout :: k) :: k where+type family Pretty (api :: k) :: k where Pretty (x :<|> y) = Pretty x :<|> Pretty y Pretty (x :> y) = Pretty x :> Pretty y Pretty (Get cs r) = Get (Pretty cs) r@@ -42,6 +47,24 @@ Pretty (Put cs r) = Put (Pretty cs) r Pretty (Delete cs r) = Delete (Pretty cs) r Pretty (Patch cs r) = Patch (Pretty cs) r+ Pretty (GetPartialContent cs r) = GetPartialContent (Pretty cs) r+ Pretty (PutResetContent cs r) = PutResetContent (Pretty cs) r+ Pretty (PatchResetContent cs r) = PatchResetContent (Pretty cs) r+ Pretty (DeleteResetContent cs r) = DeleteResetContent (Pretty cs) r+ Pretty (PostResetContent cs r) = PostResetContent (Pretty cs) r+ Pretty (GetResetContent cs r) = GetResetContent (Pretty cs) r+ Pretty (PutNonAuthoritative cs r) = PutNonAuthoritative (Pretty cs) r+ Pretty (PatchNonAuthoritative cs r) = PatchNonAuthoritative (Pretty cs) r+ Pretty (DeleteNonAuthoritative cs r) = DeleteNonAuthoritative (Pretty cs) r+ Pretty (PostNonAuthoritative cs r) = PostNonAuthoritative (Pretty cs) r+ Pretty (GetNonAuthoritative cs r) = GetNonAuthoritative (Pretty cs) r+ Pretty (PutAccepted cs r) = PutAccepted (Pretty cs) r+ Pretty (PatchAccepted cs r) = PatchAccepted (Pretty cs) r+ Pretty (DeleteAccepted cs r) = DeleteAccepted (Pretty cs) r+ Pretty (PostAccepted cs r) = PostAccepted (Pretty cs) r+ Pretty (GetAccepted cs r) = GetAccepted (Pretty cs) r+ Pretty (PutCreated cs r) = PutCreated (Pretty cs) r+ Pretty (PostCreated cs r) = PostCreated (Pretty cs) r Pretty (ReqBody cs r) = ReqBody (Pretty cs) r Pretty (JSON ': xs) = PrettyJSON ': xs Pretty (x ': xs) = x ': Pretty xs
test/Servant/DocsSpec.hs view
@@ -1,48 +1,77 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}+ module Servant.DocsSpec where import Control.Lens+ ((&), (<>~))+import Control.Monad+ (unless)+import Control.Monad.Trans.Writer+ (Writer, runWriter, tell) import Data.Aeson-import Data.Monoid+import Data.List+ (isInfixOf) import Data.Proxy-import Data.String.Conversions (cs)+import Data.String.Conversions+ (cs) import GHC.Generics-import Test.Hspec+import Prelude ()+import Prelude.Compat+import Test.Tasty+ (TestName, TestTree, testGroup)+import Test.Tasty.Golden+ (goldenVsString)+import Test.Tasty.HUnit+ (Assertion, HasCallStack, assertFailure, testCase, (@?=)) import Servant.API-import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Docs.Internal+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 "foo" Int) where- toParam = error "unused"+instance ToParam (QueryParam' mods "foo" Int) where+ toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal+instance ToParam (QueryParam' mods "bar" Int) where+ 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 _ = DocCapture "foo" "Capture all foo Int"+instance ToFragment (Fragment Int) where+ toFragment _ = DocFragment "foo" "Fragment Int" -- * specs -spec :: Spec+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))- tests md+ let md1 = markdown (docs (Proxy :: Proxy TestApi1))+ tests1 md1+ let md2 = markdown (docs (Proxy :: Proxy TestApi2))+ tests2 md2 describe "markdown with extra info" $ do let@@ -54,7 +83,7 @@ (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))- tests md+ tests1 md it "contains the extra info provided" $ do md `shouldContain` "Get an Integer" md `shouldContain` "Post data"@@ -82,7 +111,7 @@ where- tests md = do+ tests1 md = do it "mentions supported content-types" $ do md `shouldContain` "application/json" md `shouldContain` "text/plain;charset=utf-8"@@ -97,12 +126,22 @@ it "mentions headers" $ do md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." - it "contains response samples" $- md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"+ it "contains response samples - dt1field1" $+ md `shouldContain` "\"dt1field1\":\"field 1\""+ it "contains response samples - dt1field2" $+ md `shouldContain` "\"dt1field2\":13" it "contains request body samples" $ md `shouldContain` "17" + it "does not generate any docs mentioning the 'empty-api' path" $+ md `shouldNotContain` "empty-api" + tests2 md = do+ it "mentions the content-types from both copies of the route" $ do+ md `shouldContain` "application/json"+ md `shouldContain` "text/plain;charset=utf-8"++ -- * APIs data Datatype1 = Datatype1 { dt1field1 :: String@@ -126,7 +165,12 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 :<|> Header "X-Test" Int :> Put '[JSON] Int+ :<|> "empty-api" :> EmptyAPI +type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1+ :<|> "duplicate-endpoint" :> Get '[PlainText] Int++ data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq) @@ -135,3 +179,42 @@ instance ToSample UT where toSamples _ = [("yks", UT1), ("kaks", UT2)]++-------------------------------------------------------------------------------+-- HSpec like DSL for tasty+-------------------------------------------------------------------------------++newtype TestTreeM a = TestTreeM (Writer [TestTree] a)+ deriving (Functor, Applicative, Monad)++runTestTreeM :: TestTreeM () -> [TestTree]+runTestTreeM (TestTreeM m) = snd (runWriter m)++class Describe r where+ describe :: TestName -> TestTreeM () -> r++instance a ~ () => Describe (TestTreeM a) where+ describe n t = TestTreeM $ tell [ describe n t ]++instance Describe TestTree where+ describe n t = testGroup n $ runTestTreeM t++it :: TestName -> Assertion -> TestTreeM ()+it n assertion = TestTreeM $ tell [ testCase n assertion ]++shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion+shouldBe = (@?=)++shouldContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion+shouldContain = compareWith (flip isInfixOf) "does not contain"++shouldNotContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion+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)) ]
test/Spec.hs view
@@ -1,1 +1,8 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main (main) where++import Test.Tasty+ (defaultMain)+import qualified Servant.DocsSpec++main :: IO ()+main = defaultMain Servant.DocsSpec.spec