diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,164 @@ -0.4.3 +[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 ----- -* docsWith will no longer eat your documentation (https://github.com/haskell-servant/servant/pull/124) + +* Support GHC 8.0 + +0.7 +--- + +* Use `throwError` instead of `throwE` in documentation + +0.5 +---- + +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators +* Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`) +* Remove redundant second parameter of ToSample +* Add Generic-based default implementation for `ToSample` class +* Add more `ToSamples` instances: `Bool`, `Ordering`, tuples (up to 7), `[]`, `Maybe`, `Either`, `Const`, `ZipList` and some monoids +* Move `toSample` out of `ToSample` class +* Add a few helper functions to define `toSamples` +* Remove matrix params. +* Added support for Basic authentication 0.4 --- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,24 +2,56 @@ ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) -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/tree/master/servant-docs/blob/master/example/greet.md) for the output of the following program. +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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -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 @@ -46,26 +46,14 @@ \Default is false." Normal -instance ToParam (MatrixParam "lang" String) where - toParam _ = - DocQueryParam "lang" - ["en", "sv", "fr"] - "Get the greeting message selected language. Default is en." - Normal - -instance ToSample () () where - toSample _ = Just () - -instance ToSample Greet Greet where - toSample _ = Just $ Greet "Hello, haskeller!" - +instance ToSample Greet where toSamples _ = [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") , ("If you use ?capital=false", Greet "Hello, haskeller") ] -instance ToSample Int Int where - toSample _ = Just 1729 +instance ToSample Int where + toSamples _ = singleSample 1729 -- We define some introductory sections, these will appear at the top of the -- documentation. @@ -86,14 +74,14 @@ -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText - "hello" :> MatrixParam "lang" String :> 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 @@ -103,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 @@ -117,7 +105,7 @@ -- -- > docs testAPI :: API docsGreet :: API -docsGreet = docsWith [intro1, intro2] extra testApi +docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi main :: IO () -main = putStrLn $ markdown docsGreet +main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet diff --git a/golden/comprehensive.md b/golden/comprehensive.md new file mode 100644 --- /dev/null +++ b/golden/comprehensive.md @@ -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 + +``` + diff --git a/servant-docs.cabal b/servant-docs.cabal --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -1,26 +1,31 @@ +cabal-version: 2.2 name: servant-docs -version: 0.4.4.7 +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 . + Runnable example . . -license: BSD3 + +homepage: http://docs.servant.dev/ +bug-reports: http://github.com/haskell-servant/servant/issues +license: BSD-3-Clause license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014-2015 Zalora South East Asia Pte Ltd -category: Web +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +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.github.io/ -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: CHANGELOG.md README.md + golden/comprehensive.md + source-repository head type: git location: http://github.com/haskell-servant/servant.git @@ -29,22 +34,39 @@ exposed-modules: 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 - , bytestring - , bytestring-conversion - , case-insensitive - , hashable - , http-media >= 0.6 - , http-types >= 0.7 - , lens - , servant == 0.4.* - , string-conversions - , text - , unordered-containers + 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 + ghc-options: -Wall -Wno-redundant-constraints executable greet-docs main-is: greet.hs @@ -53,7 +75,6 @@ build-depends: base , aeson - , bytestring-conversion , lens , servant , servant-docs @@ -62,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 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -20,150 +20,41 @@ -- The only thing you'll need to do will be to implement some classes -- for your captures, get parameters and request or response bodies. -- --- Here is a complete example that you can run to see the markdown pretty --- printer in action: --- --- > {-# LANGUAGE DataKinds #-} --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE FlexibleInstances #-} --- > {-# LANGUAGE MultiParamTypeClasses #-} --- > {-# 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 --- > --- > -- * Example --- > --- > -- | A greet message data type --- > newtype Greet = Greet Text --- > deriving (Generic, Show) --- > --- > -- | We can get JSON support automatically. This will be used to parse --- > -- and encode a Greeting as 'JSON'. --- > instance FromJSON Greet --- > instance ToJSON Greet --- > --- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'. --- > instance MimeRender PlainText Greet where --- > mimeRender Proxy (Greet s) = "\"" <> cs s <> "\"" --- > --- > -- We add some useful annotations to our captures, --- > -- query parameters and request body to make the docs --- > -- really helpful. --- > instance ToCapture (Capture "name" Text) where --- > toCapture _ = DocCapture "name" "name of the person to greet" --- > --- > instance ToCapture (Capture "greetid" Text) where --- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove" --- > --- > instance ToParam (QueryParam "capital" Bool) where --- > toParam _ = --- > DocQueryParam "capital" --- > ["true", "false"] --- > "Get the greeting message in uppercase (true) or not (false).\ --- > \Default is false." --- > Normal --- > --- > instance ToParam (MatrixParam "lang" String) where --- > toParam _ = --- > DocQueryParam "lang" --- > ["en", "sv", "fr"] --- > "Get the greeting message selected language. Default is en." --- > Normal --- > --- > instance ToSample Greet Greet where --- > toSample _ = Just $ Greet "Hello, haskeller!" --- > --- > toSamples _ = --- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") --- > , ("If you use ?capital=false", Greet "Hello, haskeller") --- > ] --- > --- > -- We define some introductory sections, these will appear at the top of the --- > -- documentation. --- > -- --- > -- We pass them in with 'docsWith', below. If you only want to add --- > -- introductions, you may use 'docsWithIntros' --- > intro1 :: DocIntro --- > intro1 = DocIntro "On proper introductions." -- The title --- > [ "Hello there." --- > , "As documentation is usually written for humans, it's often useful \ --- > \to introduce concepts with a few words." ] -- Elements are paragraphs --- > --- > intro2 :: DocIntro --- > intro2 = DocIntro "This title is below the last" --- > [ "You'll also note that multiple intros are possible." ] --- > --- > --- > -- API specification --- > type TestApi = --- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText --- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> 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] Greet --- > --- > -- DELETE /greet/:greetid --- > :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () --- > --- > testApi :: Proxy TestApi --- > testApi = Proxy --- > --- > -- Build some extra information for the DELETE /greet/:greetid endpoint. We --- > -- want to add documentation about a secret unicorn header and some extra --- > -- notes. --- > extra :: ExtraInfo TestApi --- > extra = --- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $ --- > defAction & headers <>~ ["unicorns"] --- > & notes <>~ [ DocNote "Title" ["This is some text"] --- > , DocNote "Second secton" ["And some more"] --- > ] --- > --- > -- Generate the data that lets us have API docs. This --- > -- is derived from the type as well as from --- > -- the 'ToCapture', 'ToParam' and 'ToSample' instances from above. --- > -- --- > -- If you didn't want intros and extra information, you could just call: --- > -- --- > -- > docs testAPI :: API --- > docsGreet :: API --- > docsGreet = docsWith [intro1, intro2] extra testApi --- > --- > main :: IO () --- > main = putStrLn $ markdown docsGreet +-- See example/greet.hs for an example. module Servant.Docs ( -- * 'HasDocs' class and key functions - HasDocs(..), docs, markdown + HasDocs(..), docs, pretty, markdown + -- ** Customising generated documentation + , markdownWith, RenderingOptions(..), defRenderingOptions + , requestExamples, responseExamples, ShowContentTypes(..), notesHeading -- * Generating docs with extra information - , ExtraInfo(..), docsWith, docsWithIntros, extraInfo + , docsWith, docsWithIntros, docsWithOptions + , ExtraInfo(..), extraInfo + , DocOptions(..) , defaultDocOptions, maxSamples , -- * Classes you need to implement for your types ToSample(..) + , toSample + , noSamples + , singleSample + , samples , sampleByteString , sampleByteStrings , ToParam(..) , ToCapture(..) , -- * ADTs to represent an 'API' - Method(..) - , Endpoint, path, method, defEndpoint + 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 +import Servant.Docs.Internal.Pretty diff --git a/src/Servant/Docs/Internal.hs b/src/Servant/Docs/Internal.hs --- a/src/Servant/Docs/Internal.hs +++ b/src/Servant/Docs/Internal.hs @@ -1,904 +1,1196 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif -module Servant.Docs.Internal where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Lens (makeLenses, over, traversed, (%~), - (&), (.~), (<>~), (^.), _1, _2, - _last, (|>)) -import Data.ByteString.Conversion (ToByteString, toByteString) -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.Maybe -import Data.Monoid -import Data.Ord (comparing) -import Data.Proxy (Proxy(Proxy)) -import Data.String.Conversions (cs) -import Data.Text (Text, pack, unpack) -import GHC.Exts (Constraint) -import GHC.Generics -import GHC.TypeLits -import Servant.API -import Servant.API.ContentTypes -import Servant.Utils.Links - -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import qualified Network.HTTP.Media as M -import qualified Network.HTTP.Types as HTTP - --- | Supported HTTP request methods -data Method = DocDELETE -- ^ the DELETE method - | DocGET -- ^ the GET method - | DocPOST -- ^ the POST method - | DocPUT -- ^ the PUT method - deriving (Eq, Ord, Generic) - -instance Show Method where - show DocGET = "GET" - show DocPOST = "POST" - show DocDELETE = "DELETE" - show DocPUT = "PUT" - -instance Hashable Method - --- | An 'Endpoint' type that holds the 'path' and the 'method'. --- --- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint' --- 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' '.~' 'DocPOST' --- POST /foo --- @ -data Endpoint = Endpoint - { _path :: [String] -- type collected - , _method :: Method -- type collected - } deriving (Eq, Ord, Generic) - -instance Show Endpoint where - show (Endpoint p m) = - show m ++ " " ++ showPath p - --- | --- Render a path as a '/'-delimited string --- -showPath :: [String] -> String -showPath [] = "/" -showPath ps = concatMap ('/' :) ps - --- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET' --- --- Here's how you can modify it: --- --- @ --- λ> 'defEndpoint' --- GET / --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] --- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' --- POST /foo --- @ -defEndpoint :: Endpoint -defEndpoint = Endpoint [] DocGET - -instance Hashable Endpoint - --- | Our API documentation type, a product of top-level information and a good --- old hashmap from 'Endpoint' to 'Action' -data API = API - { _apiIntros :: [DocIntro] - , _apiEndpoints :: HashMap Endpoint Action - } deriving (Eq, Show) - -instance Monoid API where - API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2) - mempty = API mempty mempty - --- | An empty 'API' -emptyAPI :: API -emptyAPI = mempty - --- | A type to represent captures. Holds the name of the capture --- and a description. --- --- Write a 'ToCapture' instance for your captured types. -data DocCapture = DocCapture - { _capSymbol :: String -- type supplied - , _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. --- --- Write a 'ToParam' instance for your GET parameter types -data DocQueryParam = DocQueryParam - { _paramName :: String -- type supplied - , _paramValues :: [String] -- user supplied - , _paramDesc :: String -- user supplied - , _paramKind :: ParamKind - } deriving (Eq, Ord, Show) - --- | An introductory paragraph for your documentation. You can pass these to --- 'docsWithIntros'. -data DocIntro = DocIntro - { _introTitle :: String -- ^ Appears above the intro blob - , _introBody :: [String] -- ^ Each String is a paragraph. - } deriving (Eq, Show) - -instance Ord DocIntro where - compare = comparing _introTitle - --- | A type to represent extra notes that may be attached to an 'Action'. --- --- This is intended to be used when writing your own HasDocs instances to --- add extra sections to your endpoint's documentation. -data DocNote = DocNote - { _noteTitle :: String - , _noteBody :: [String] - } deriving (Eq, Ord, Show) - --- | Type of extra information that a user may wish to "union" with their --- documentation. --- --- These are intended to be built using extraInfo. --- Multiple ExtraInfo may be combined with the monoid instance. -newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action) -instance Monoid (ExtraInfo a) where - mempty = ExtraInfo mempty - ExtraInfo a `mappend` ExtraInfo b = - ExtraInfo $ HM.unionWith combineAction a b - --- | Type of GET parameter: --- --- - Normal corresponds to @QueryParam@, i.e your usual GET parameter --- - List corresponds to @QueryParams@, i.e GET parameters with multiple values --- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter -data ParamKind = Normal | List | Flag - deriving (Eq, Ord, Show) - --- | A type to represent an HTTP response. Has an 'Int' status, a list of --- possible 'MediaType's, and a list of example 'ByteString' response bodies. --- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody' --- lenses if you want. --- --- If you want to respond with a non-empty response body, you'll most likely --- 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. --- --- > λ> 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\" }")]} -data Response = Response - { _respStatus :: Int - , _respTypes :: [M.MediaType] - , _respBody :: [(Text, M.MediaType, ByteString)] - , _respHeaders :: [HTTP.Header] - } deriving (Eq, Ord, Show) - --- | Default response: status code 200, no response body. --- --- Can be tweaked with two lenses. --- --- > λ> defResponse --- > Response {_respStatus = 200, _respBody = Nothing} --- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" --- > Response {_respStatus = 204, _respBody = Just "[]"} -defResponse :: Response -defResponse = Response - { _respStatus = 200 - , _respTypes = [] - , _respBody = [] - , _respHeaders = [] - } - --- | A datatype that represents everything that can happen --- at an endpoint, with its lenses: --- --- - List of captures ('captures') --- - List of GET parameters ('params') --- - What the request body should look like, if any is requested ('rqbody') --- - What the response should be if everything goes well ('response') --- --- You can tweak an 'Action' (like the default 'defAction') with these lenses --- to transform an action and add some information to it. -data Action = Action - { _captures :: [DocCapture] -- type collected + user supplied info - , _headers :: [Text] -- type collected - , _params :: [DocQueryParam] -- 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 - , _response :: Response -- user supplied - } deriving (Eq, Ord, Show) - --- | Combine two Actions, we can't make a monoid as merging Response breaks the --- 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 :: Action -> Action -> Action -Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ = - Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp - --- Default 'Action'. Has no 'captures', no GET '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 -defAction = - Action [] - [] - [] - [] - [] - [] - [] - defResponse - --- | Create an API that's comprised of a single endpoint. --- 'API' is a 'Monoid', so combine multiple endpoints with --- 'mappend' or '<>'. -single :: Endpoint -> Action -> API -single e a = API mempty (HM.singleton e a) - --- gimme some lenses -makeLenses ''API -makeLenses ''Endpoint -makeLenses ''DocCapture -makeLenses ''DocQueryParam -makeLenses ''DocIntro -makeLenses ''DocNote -makeLenses ''Response -makeLenses ''Action - --- | Generate the docs for a given API that implements 'HasDocs'. This is the --- default way to create documentation. -docs :: HasDocs layout => Proxy layout -> API -docs 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. --- --- The safety here is to ensure that you only add custom documentation to an --- endpoint that actually exists within your API. --- --- > extra :: ExtraInfo TestApi --- > extra = --- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $ --- > defAction & headers <>~ ["unicorns"] --- > & notes <>~ [ DocNote "Title" ["This is some text"] --- > , DocNote "Second secton" ["And some more"] --- > ] - -extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) - => Proxy endpoint -> Action -> ExtraInfo layout -extraInfo p action = - let api = docsFor p (defEndpoint, defAction) - -- Assume one endpoint, HasLink constraint means that we should only ever - -- point at one endpoint. - in ExtraInfo $ api ^. apiEndpoints & traversed .~ action - --- | Generate documentation given some extra introductions (in the form of --- 'DocInfo') and some extra endpoint documentation (in the form of --- 'ExtraInfo'. --- --- The extra introductions will be prepended to the top of the documentation, --- before the specific endpoint documentation. The extra endpoint documentation --- will be "unioned" with the automatically generated endpoint documentation. --- --- You are expected to build up the ExtraInfo with the Monoid instance and --- 'extraInfo'. --- --- If you only want to add an introduction, use 'docsWithIntros'. -docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API -docsWith intros (ExtraInfo endpoints) p = - docs p & apiIntros <>~ intros - & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints - - --- | Generate the docs for a given API that implements 'HasDocs' with with any --- number of introduction(s) -docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API -docsWithIntros intros = docsWith intros mempty - --- | The class that abstracts away the impact of API combinators --- on documentation generation. -class HasDocs layout where - docsFor :: Proxy layout -> (Endpoint, Action) -> API - --- | The class that lets us display a sample input or output in the supported --- content-types when generating documentation for endpoints that either: --- --- - expect a request body, or --- - return a non empty response body --- --- Example of an instance: --- --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Data.Aeson --- > import Data.Text --- > import GHC.Generics --- > --- > data Greet = Greet { _msg :: Text } --- > deriving (Generic, Show) --- > --- > instance FromJSON Greet --- > instance ToJSON Greet --- > --- > instance ToSample Greet Greet where --- > toSample _ = Just g --- > --- > where g = Greet "Hello, haskeller!" --- --- You can also instantiate this class using 'toSamples' instead of --- 'toSample': it lets you specify different responses along with --- some context (as 'Text') that explains when you're supposed to --- get the corresponding response. -class ToSample a b | a -> b where - {-# MINIMAL (toSample | toSamples) #-} - toSample :: Proxy a -> Maybe b - toSample _ = snd <$> listToMaybe samples - where samples = toSamples (Proxy :: Proxy a) - - toSamples :: Proxy a -> [(Text, b)] - toSamples _ = maybe [] (return . ("",)) s - where s = toSample (Proxy :: Proxy a) - -instance ToSample a b => ToSample (Headers ls a) b where - toSample _ = toSample (Proxy :: Proxy a) - toSamples _ = toSamples (Proxy :: Proxy a) - - -class AllHeaderSamples ls where - allHeaderToSample :: Proxy ls -> [HTTP.Header] - -instance AllHeaderSamples '[] where - allHeaderToSample _ = [] - -instance (ToByteString l, AllHeaderSamples ls, ToSample l 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 Nothing = (headerName, "") - --- | Synthesise a sample value of a type, encoded in the specified media types. -sampleByteString - :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b) - => Proxy ctypes - -> Proxy a - -> [(M.MediaType, ByteString)] -sampleByteString ctypes@Proxy Proxy = - maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a) - --- | Synthesise a list of sample values of a particular type, encoded in the --- specified media types. -sampleByteStrings - :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b) - => Proxy ctypes - -> Proxy a - -> [(Text, M.MediaType, ByteString)] -sampleByteStrings ctypes@Proxy Proxy = - let samples = toSamples (Proxy :: Proxy a) - enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s - in concatMap enc samples - --- | Generate a list of 'MediaType' values describing the content types --- accepted by an API component. -class SupportedTypes (list :: [*]) where - supportedTypes :: Proxy list -> [M.MediaType] - -instance SupportedTypes '[] where - supportedTypes Proxy = [] - -instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest) - where - supportedTypes Proxy = - contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest) - --- | The class that helps us automatically get documentation --- for GET parameters. --- --- Example of an instance: --- --- > instance ToParam (QueryParam "capital" Bool) where --- > toParam _ = --- > DocQueryParam "capital" --- > ["true", "false"] --- > "Get the greeting message in uppercase (true) or not (false). Default is false." -class ToParam t where - toParam :: Proxy t -> DocQueryParam - --- | The class that helps us automatically get documentation --- for URL captures. --- --- Example of an instance: --- --- > instance ToCapture (Capture "name" Text) where --- > toCapture _ = DocCapture "name" "name of the person to greet" -class ToCapture c where - toCapture :: Proxy c -> DocCapture - --- | Generate documentation in Markdown format for --- the given 'API'. -markdown :: API -> String -markdown api = unlines $ - introsStr (api ^. apiIntros) - ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints) - - where printEndpoint :: Endpoint -> Action -> [String] - printEndpoint endpoint action = - str : - "" : - notesStr (action ^. notes) ++ - capturesStr (action ^. captures) ++ - mxParamsStr (action ^. mxParams) ++ - headersStr (action ^. headers) ++ - paramsStr (action ^. params) ++ - rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++ - responseStr (action ^. response) ++ - [] - - where str = "## " ++ show (endpoint^.method) - ++ " " ++ showPath (endpoint^.path) - - introsStr :: [DocIntro] -> [String] - introsStr = concatMap introStr - - introStr :: DocIntro -> [String] - introStr i = - ("## " ++ i ^. introTitle) : - "" : - intersperse "" (i ^. introBody) ++ - "" : - [] - - notesStr :: [DocNote] -> [String] - notesStr = concatMap noteStr - - noteStr :: DocNote -> [String] - noteStr nt = - ("#### " ++ nt ^. noteTitle) : - "" : - intersperse "" (nt ^. noteBody) ++ - "" : - [] - - capturesStr :: [DocCapture] -> [String] - capturesStr [] = [] - capturesStr l = - "#### Captures:" : - "" : - map captureStr l ++ - "" : - [] - - captureStr cap = - "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) - - mxParamsStr :: [(String, [DocQueryParam])] -> [String] - mxParamsStr [] = [] - mxParamsStr l = - "#### Matrix Parameters:" : - "" : - map segmentStr l - segmentStr :: (String, [DocQueryParam]) -> String - segmentStr (segment, l) = unlines $ - ("**" ++ segment ++ "**:") : - "" : - map paramStr l ++ - "" : - [] - - headersStr :: [Text] -> [String] - headersStr [] = [] - headersStr l = [""] ++ 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:" : - "" : - map paramStr l ++ - "" : - [] - - paramStr 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 " - ++ param ^. paramName ++ "[] will forward their values in a list to the handler."] - else []) ++ - (if (param ^. paramKind == Flag) - then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."] - else []) ++ - [] - - where values = param ^. paramValues - - rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String] - rqbodyStr [] [] = [] - rqbodyStr types samples = - ["#### Request:", ""] - <> formatTypes types - <> concatMap formatBody samples - - formatTypes [] = [] - formatTypes ts = ["- Supported content types are:", ""] - <> map (\t -> " - `" <> show t <> "`") ts - <> [""] - - formatBody (m, b) = - "- Example: `" <> cs (show m) <> "`" : - contentStr m b - - markdownForType mime_type = - case (M.mainType mime_type, M.subType mime_type) of - ("text", "html") -> "html" - ("application", "xml") -> "xml" - ("application", "json") -> "javascript" - ("application", "javascript") -> "javascript" - ("text", "css") -> "css" - (_, _) -> "" - - contentStr mime_type body = - "" : - "```" <> markdownForType mime_type : - cs body : - "```" : - "" : - [] - - responseStr :: Response -> [String] - responseStr resp = - "#### Response:" : - "" : - ("- Status code " ++ show (resp ^. respStatus)) : - ("- Headers: " ++ show (resp ^. respHeaders)) : - "" : - formatTypes (resp ^. respTypes) ++ - bodies - - where bodies = case resp ^. respBody of - [] -> ["- 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 - --- * Instances - --- | The generated docs for @a ':<|>' b@ just appends the docs --- for @a@ with the docs for @b@. -instance (HasDocs layout1, HasDocs layout2) - => HasDocs (layout1 :<|> layout2) where - - docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) - - where p1 :: Proxy layout1 - p1 = Proxy - - p2 :: Proxy layout2 - p2 = Proxy - --- | @"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 - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action') - - where sublayoutP = Proxy :: Proxy sublayout - 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 -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) - => HasDocs (Delete cts a) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocDELETE - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Delete cts (Headers ls a)) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocDELETE - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) - => HasDocs (Get cts a) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Get cts (Headers ls a)) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance (KnownSymbol sym, HasDocs sublayout) - => HasDocs (Header sym a :> sublayout) where - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - action' = over headers (|> headername) action - headername = pack $ symbolVal (Proxy :: Proxy sym) - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) - => HasDocs (Post cts a) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - & response.respStatus .~ 201 - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Post cts (Headers ls a)) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - & response.respStatus .~ 201 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) - => HasDocs (Put cts a) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - & response.respStatus .~ 200 - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Put cts (Headers ls a)) where - docsFor Proxy (endpoint, action) = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - & response.respStatus .~ 200 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) - => HasDocs (QueryParam sym a :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - paramP = Proxy :: Proxy (QueryParam sym a) - action' = over params (|> toParam paramP) action - -instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout) - => HasDocs (QueryParams sym a :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - 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 - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - paramP = Proxy :: Proxy (QueryFlag sym) - action' = over params (|> toParam paramP) action - - -instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout) - => HasDocs (MatrixParam sym a :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action') - - where sublayoutP = Proxy :: Proxy sublayout - paramP = Proxy :: Proxy (MatrixParam sym a) - segment = endpoint ^. (path._last) - segment' = action ^. (mxParams._last._1) - endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=") endpoint - - action' = if segment' /= segment - -- This is the first matrix parameter for this segment, insert a new entry into the mxParams list - then over mxParams (|> (segment, [toParam paramP])) action - -- We've already inserted a matrix parameter for this segment, append to the existing list - else action & mxParams._last._2 <>~ [toParam paramP] - symP = Proxy :: Proxy sym - - -instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout) - => HasDocs (MatrixParams sym a :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action) - - where sublayoutP = Proxy :: Proxy sublayout - endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "="]) endpoint - symP = Proxy :: Proxy sym - - -instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout) - => HasDocs (MatrixFlag sym :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action) - - where sublayoutP = Proxy :: Proxy sublayout - - endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint - symP = Proxy :: Proxy sym - -instance HasDocs Raw where - docsFor _proxy (endpoint, action) = - single endpoint action - --- 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 b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout - , SupportedTypes cts) - => HasDocs (ReqBody cts a :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - action' = action & rqbody .~ sampleByteString t p - & rqtypes .~ supportedTypes t - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where - - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action) - - where sublayoutP = Proxy :: Proxy sublayout - endpoint' = endpoint & path <>~ [symbolVal pa] - pa = Proxy :: Proxy path - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Docs.Internal where + +import Prelude () +import Prelude.Compat + +import Control.Applicative +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.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 + (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.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 +import qualified Network.HTTP.Types as HTTP + +-- | An 'Endpoint' type that holds the 'path' and the 'method'. +-- +-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint' +-- 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 +-- +data Endpoint = Endpoint + { _path :: [String] -- type collected + , _method :: HTTP.Method -- type collected + } deriving (Eq, Ord, Generic) + +instance Show Endpoint where + show (Endpoint p m) = + show m ++ " " ++ showPath p + +-- | +-- Render a path as a '/'-delimited string +-- +showPath :: [String] -> String +showPath [] = "/" +showPath ps = concatMap ('/' :) ps + +-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@ +-- +-- Here's how you can modify it: +-- +-- >>> defEndpoint +-- "GET" / +-- +-- >>> defEndpoint & path <>~ ["foo"] +-- "GET" /foo +-- +-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost +-- "POST" /foo +-- +defEndpoint :: Endpoint +defEndpoint = Endpoint [] HTTP.methodGet + +instance Hashable Endpoint + +-- | Our API documentation type, a product of top-level information and a good +-- old hashmap from 'Endpoint' to 'Action' +data API = API + { _apiIntros :: [DocIntro] + , _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 `mappend` a2) + (HM.unionWith combineAction b1 b2) + mempty = API mempty mempty + +-- | An empty 'API' +emptyAPI :: API +emptyAPI = mempty + +-- | A type to represent captures. Holds the name of the capture +-- and a description. +-- +-- Write a 'ToCapture' instance for your captured types. +data DocCapture = DocCapture + { _capSymbol :: String -- type supplied + , _capDesc :: String -- user supplied + } deriving (Eq, Ord, Show) + +-- | 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 + { _paramName :: String -- type supplied + , _paramValues :: [String] -- user supplied + , _paramDesc :: String -- user supplied + , _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 + { _introTitle :: String -- ^ Appears above the intro blob + , _introBody :: [String] -- ^ Each String is a paragraph. + } deriving (Eq, Show) + +-- | A type to represent Authentication information about an endpoint. +data DocAuthentication = DocAuthentication + { _authIntro :: String + , _authDataRequired :: String + } deriving (Eq, Ord, Show) + +instance Ord DocIntro where + compare = comparing _introTitle + +-- | A type to represent extra notes that may be attached to an 'Action'. +-- +-- This is intended to be used when writing your own HasDocs instances to +-- add extra sections to your endpoint's documentation. +data DocNote = DocNote + { _noteTitle :: String + , _noteBody :: [String] + } deriving (Eq, Ord, Show) + +-- | Type of extra information that a user may wish to "union" with their +-- documentation. +-- +-- These are intended to be built using extraInfo. +-- Multiple ExtraInfo may be combined with the monoid instance. +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 = + ExtraInfo $ HM.unionWith combineAction a b + +-- | Documentation options. +data DocOptions = DocOptions + { _maxSamples :: Int -- ^ Maximum samples allowed. + } deriving (Show) + +-- | Default documentation options. +defaultDocOptions :: DocOptions +defaultDocOptions = DocOptions + { _maxSamples = 5 } + +-- | 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 +-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter +data ParamKind = Normal | List | Flag + deriving (Eq, Ord, Show) + +-- | A type to represent an HTTP response. Has an 'Int' status, a list of +-- possible 'MediaType's, and a list of example 'ByteString' response bodies. +-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody' +-- lenses if you want. +-- +-- If you want to respond with a non-empty response body, you'll most likely +-- want to write a 'ToSample' instance for the type that'll be represented +-- as encoded data in the response. +-- +-- Can be tweaked with four lenses. +-- +-- >>> 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] + , _respBody :: [(Text, M.MediaType, ByteString)] + , _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 four lenses. +-- +-- >>> defResponse +-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []} +-- +-- >>> defResponse & respStatus .~ 204 +-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []} +-- +defResponse :: Response +defResponse = Response + { _respStatus = 200 + , _respTypes = [] + , _respBody = [] + , _respHeaders = [] + } + +-- | A datatype that represents everything that can happen +-- at an endpoint, with its lenses: +-- +-- - List of captures ('captures') +-- - 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') +-- +-- You can tweak an 'Action' (like the default 'defAction') with these lenses +-- to transform an action and add some information to it. +data Action = Action + { _authInfo :: [DocAuthentication] -- user supplied info + , _captures :: [DocCapture] -- type collected + user supplied info + , _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 :: [(Text, M.MediaType, ByteString)] -- user supplied + , _response :: Response -- user supplied + } deriving (Eq, Ord, Show) + +-- | Combine two Actions, we can't make a monoid as merging Response breaks the +-- laws. +-- +-- As such, we invent a non-commutative, left associative operation +-- 'combineAction' to mush two together taking the response from the very left. +combineAction :: Action -> Action -> Action +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 query 'params', expects +-- no request body ('rqbody') and the typical response is 'defResponse'. +-- +-- Tweakable with lenses. +-- +-- >>> 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 + [] + [] + [] + [] + defResponse + +-- | Create an API that's comprised of a single endpoint. +-- 'API' is a 'Monoid', so combine multiple endpoints with +-- 'mappend' or '<>'. +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 +makeLenses ''API +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. +-- +-- > 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 api => Proxy api -> DocOptions -> API +docsWithOptions p = docsFor p (defEndpoint, defAction) + +-- | 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. +-- +-- > extra :: ExtraInfo TestApi +-- > extra = +-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $ +-- > defAction & headers <>~ [("X-Num-Unicorns", 1)] +-- > & notes <>~ [ DocNote "Title" ["This is some text"] +-- > , DocNote "Second section" ["And some more"] +-- > ] + +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 + -- point at one endpoint. + in ExtraInfo $ api ^. apiEndpoints & traversed .~ action + +-- | Generate documentation given some extra introductions (in the form of +-- 'DocInfo') and some extra endpoint documentation (in the form of +-- 'ExtraInfo'. +-- +-- The extra introductions will be prepended to the top of the documentation, +-- before the specific endpoint documentation. The extra endpoint documentation +-- will be "unioned" with the automatically generated endpoint documentation. +-- +-- You are expected to build up the ExtraInfo with the Monoid instance and +-- 'extraInfo'. +-- +-- If you only want to add an introduction, use 'docsWithIntros'. +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 any +-- number of introduction(s) +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 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: +-- +-- - expect a request body, or +-- - return a non empty response body +-- +-- Example of an instance: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.Aeson +-- > import Data.Text +-- > import GHC.Generics +-- > +-- > data Greet = Greet { _msg :: Text } +-- > deriving (Generic, Show) +-- > +-- > instance FromJSON Greet +-- > instance ToJSON Greet +-- > +-- > instance ToSample Greet where +-- > toSamples _ = singleSample g +-- > +-- > where g = Greet "Hello, haskeller!" +-- +-- You can also instantiate this class using 'toSamples' instead of +-- 'toSample': it lets you specify different responses along with +-- some context (as 'Text') that explains when you're supposed to +-- get the corresponding response. +class ToSample a where + toSamples :: Proxy a -> [(Text, a)] + default toSamples :: (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)] + toSamples = defaultSamples + +-- | Sample input or output (if there is at least one). +toSample :: forall a. ToSample a => Proxy a -> Maybe a +toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a)) + +-- | No samples. +noSamples :: [(Text, a)] +noSamples = empty + +-- | Single sample without description. +singleSample :: a -> [(Text, a)] +singleSample x = [("", x)] + +-- | Samples without documentation. +samples :: [a] -> [(Text, a)] +samples = map ("",) + +-- | Default sample Generic-based inputs/outputs. +defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)] +defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a)) + +-- | @'ToSample'@ for Generics. +-- +-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation. +class GToSample t where + gtoSamples :: proxy t -> [(Text, t x)] + +instance GToSample U1 where + gtoSamples _ = singleSample U1 + +instance GToSample V1 where + gtoSamples _ = empty + +instance (GToSample p, GToSample q) => GToSample (p :*: q) where + gtoSamples _ = U.cartesianProduct render ps qs + where + ps = gtoSamples (Proxy :: Proxy p) + qs = gtoSamples (Proxy :: Proxy q) + render (ta, a) (tb, b) + | T.null ta || T.null tb = (ta <> tb, a :*: b) + | otherwise = (ta <> ", " <> tb, a :*: b) + +instance (GToSample p, GToSample q) => GToSample (p :+: q) where + 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 <$> toSamples (Proxy :: Proxy a) + +instance (GToSample f) => GToSample (M1 i a f) where + gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f) + + +class AllHeaderSamples ls where + allHeaderToSample :: Proxy ls -> [HTTP.Header] + +instance AllHeaderSamples '[] where + allHeaderToSample _ = [] + +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 $ toHeader x) + mkHeader Nothing = (headerName, "") + +-- | Synthesise a sample value of a type, encoded in the specified media types. +sampleByteString + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) + -> Proxy a + -> [(M.MediaType, ByteString)] +sampleByteString ctypes@Proxy Proxy = + maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a) + +-- | Synthesise a list of sample values of a particular type, encoded in the +-- specified media types. +sampleByteStrings + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) + -> Proxy a + -> [(Text, M.MediaType, ByteString)] +sampleByteStrings ctypes@Proxy Proxy = + let samples' = toSamples (Proxy :: Proxy a) + enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s + in concatMap enc samples' + +-- | The class that helps us automatically get documentation for GET +-- (or other 'HTTP.Method') parameters. +-- +-- Example of an instance: +-- +-- > instance ToParam (QueryParam' mods "capital" Bool) where +-- > toParam _ = +-- > DocQueryParam "capital" +-- > ["true", "false"] +-- > "Get the greeting message in uppercase (true) or not (false). Default is false." +class ToParam t where + toParam :: Proxy t -> DocQueryParam + +-- | The class that helps us automatically get documentation +-- for URL captures. +-- +-- Example of an instance: +-- +-- > instance ToCapture (Capture "name" Text) where +-- > toCapture _ = DocCapture "name" "name of the person to greet" +class ToCapture c where + toCapture :: Proxy c -> DocCapture + +-- | The class that helps us get documentation for authenticated endpoints +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 = 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) + + where printEndpoint :: Endpoint -> Action -> [String] + printEndpoint endpoint action = + str : + "" : + notesStr (action ^. notes) ++ + authStr (action ^. authInfo) ++ + capturesStr (action ^. captures) ++ + 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 meth + ++ " " ++ showPath (endpoint^.path) + + meth = endpoint ^. method + + introsStr :: [DocIntro] -> [String] + introsStr = concatMap introStr + + introStr :: DocIntro -> [String] + introStr i = + ("## " ++ i ^. introTitle) : + "" : + intersperse "" (i ^. introBody) ++ + "" : + [] + + notesStr :: [DocNote] -> [String] + notesStr = addHeading + . concatMap noteStr + where + addHeading nts = maybe nts (\hd -> ("### " ++ hd) : "" : nts) _notesHeading + + noteStr :: DocNote -> [String] + noteStr nt = + (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": + "": + unlines authIntros : + "": + "Clients must supply the following data" : + unlines clientInfos : + "" : + [] + + capturesStr :: [DocCapture] -> [String] + capturesStr [] = [] + capturesStr l = + "### Captures:" : + "" : + map captureStr l ++ + "" : + [] + + captureStr cap = + "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) + + headersStr :: [Text] -> [String] + headersStr [] = [] + headersStr l = + "### Headers:" : + "" : + map headerStr l ++ + "" : + [] + + where headerStr hname = "- This endpoint is sensitive to the value of the **" + ++ unpack hname ++ "** HTTP header." + + paramsStr :: HTTP.Method -> [DocQueryParam] -> [String] + paramsStr _ [] = [] + paramsStr m l = + ("### " ++ cs m ++ " Parameters:") : + "" : + map (paramStr m) l ++ + "" : + [] + + 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 " ++ cs m ++ " parameters with the name " + ++ param ^. paramName ++ "[] will forward their values in a list to the handler."] + else []) ++ + (if (param ^. paramKind == Flag) + then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."] + else []) ++ + [] + + where values = param ^. paramValues + + 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:", ""] + <> formatTypes types + <> formatBodies _requestExamples s + + formatTypes [] = [] + formatTypes ts = ["- Supported content types are:", ""] + <> map (\t -> " - `" <> show t <> "`") ts + <> [""] + + -- 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" + ("text", "xml") -> "xml" + ("application", "json") -> "json" + ("application", "javascript") -> "javascript" + ("text", "css") -> "css" + (_, _) -> "" + + contentStr mime_type body = + "" : + "```" <> markdownForType mime_type : + cs body : + "```" : + "" : + [] + + responseStr :: Response -> [String] + responseStr resp = + "### Response:" : + "" : + ("- Status code " ++ show (resp ^. respStatus)) : + ("- Headers: " ++ show (resp ^. respHeaders)) : + "" : + formatTypes (resp ^. respTypes) ++ + bodies + + where bodies = case resp ^. respBody of + [] -> ["- No response body\n"] + [("", t, r)] -> "- Response body as below." : 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 a, HasDocs b) + => HasDocs (a :<|> b) where + + docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) + + where p1 :: Proxy a + p1 = Proxy + + 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 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 (CaptureAll sym a) + + action' = over captures (|> toCapture captureP) action + endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint + symP = Proxy :: Proxy sym + + +instance {-# OVERLAPPABLE #-} + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method) + => HasDocs (Verb method status (ct ': cts) a) where + docsFor Proxy (endpoint, action) DocOptions{..} = + single endpoint' action' + + where endpoint' = endpoint & method .~ method' + action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) + & response.respTypes .~ allMime t + & response.respStatus .~ status + t = Proxy :: Proxy (ct ': cts) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) + p = Proxy :: Proxy a + +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 + docsFor Proxy (endpoint, action) DocOptions{..} = + single endpoint' action' + + where endpoint' = endpoint & method .~ method' + action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) + & response.respTypes .~ allMime t + & response.respStatus .~ status + & response.respHeaders .~ hdrs + t = Proxy :: Proxy (ct ': cts) + hdrs = allHeaderToSample (Proxy :: Proxy ls) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) + p = Proxy :: Proxy a + +instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api) + => HasDocs (Header' mods sym a :> api) where + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + + 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 -> "" + +instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api) + => HasDocs (QueryParam' mods sym a :> api) where + + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + + 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 api) + => HasDocs (QueryParams sym a :> api) where + + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + + where subApiP = Proxy :: Proxy api + paramP = Proxy :: Proxy (QueryParams sym a) + action' = over params (|> toParam paramP) action + + +instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api) + => HasDocs (QueryFlag sym :> api) where + + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + + 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 api) + => HasDocs (ReqBody' mods (ct ': cts) a :> api) where + docsFor Proxy (endpoint, action) opts@DocOptions{..} = + docsFor subApiP (endpoint, action') opts + + 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 + +-- | 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 subApiP (endpoint', action) + + where subApiP = Proxy :: Proxy api + endpoint' = endpoint & path <>~ [symbolVal pa] + pa = Proxy :: Proxy path + +instance HasDocs api => HasDocs (RemoteHost :> api) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy api) ep + +instance HasDocs api => HasDocs (IsSecure :> api) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy api) ep + +instance HasDocs api => HasDocs (HttpVersion :> api) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy api) ep + +instance HasDocs api => HasDocs (Vault :> api) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy api) ep + +instance HasDocs api => HasDocs (WithNamedContext name context api) where + docsFor Proxy = docsFor (Proxy :: Proxy api) + +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 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 NoContent +instance ToSample Bool +instance ToSample Ordering + +-- polymorphic ToSample instances +instance (ToSample a, ToSample b) => ToSample (a, b) +instance (ToSample a, ToSample b, ToSample c) => ToSample (a, b, c) +instance (ToSample a, ToSample b, ToSample c, ToSample d) => ToSample (a, b, c, d) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e) => ToSample (a, b, c, d, e) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f) => ToSample (a, b, c, d, e, f) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f, ToSample g) => ToSample (a, b, c, d, e, f, g) + +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) +instance ToSample a => ToSample (ZipList a) + +-- ToSample instances for Data.Monoid newtypes +instance ToSample All +instance ToSample Any +instance ToSample a => ToSample (Sum a) +instance ToSample a => ToSample (Product a) +instance ToSample a => ToSample (First a) +instance ToSample a => ToSample (Last a) +instance ToSample a => ToSample (Dual a) + +-- $setup +-- >>> :set -XOverloadedStrings diff --git a/src/Servant/Docs/Internal/Pretty.hs b/src/Servant/Docs/Internal/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Docs/Internal/Pretty.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# 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 Servant.API.Verbs + +-- | PrettyJSON content type. +data PrettyJSON + +instance Accept PrettyJSON where + contentType _ = "application" // "json" + +instance ToJSON a => MimeRender PrettyJSON a where + mimeRender _ = encodePretty + +-- | Prettify generated JSON documentation. +-- +-- @ +-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) +-- @ +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 (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 + Pretty (Post cs r) = Post (Pretty cs) r + 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 + Pretty x = x diff --git a/test/Servant/DocsSpec.hs b/test/Servant/DocsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/DocsSpec.hs @@ -0,0 +1,220 @@ +{-# 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.List + (isInfixOf) +import Data.Proxy +import Data.String.Conversions + (cs) +import GHC.Generics +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.Docs.Internal +import Servant.Test.ComprehensiveAPI + +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +comprehensiveDocs :: API +comprehensiveDocs = docs comprehensiveAPI + +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 _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List +instance ToParam (QueryFlag "foo") where + toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag +instance ToCapture (Capture "foo" Int) where + 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 :: TestTree +spec = describe "Servant.Docs" $ do + golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs) + + describe "markdown" $ do + 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 + extra = extraInfo + (Proxy :: Proxy (Get '[JSON, PlainText] (Headers '[Header "Location" String] Int))) + (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]]) + <> + extraInfo + (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)) + tests1 md + it "contains the extra info provided" $ do + md `shouldContain` "Get an Integer" + md `shouldContain` "Post data" + md `shouldContain` "get an integer in Json or plain text" + md `shouldContain` "Posts some Json data" + + describe "tuple samples" $ do + it "looks like expected" $ do + (toSample (Proxy :: Proxy (TT, UT))) `shouldBe` Just (TT1,UT1) + (toSample (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1) + (toSamples (Proxy :: Proxy (TT, UT))) `shouldBe` + [ ("eins, yks",(TT1,UT1)), ("eins, kaks",(TT1,UT2)) + , ("zwei, yks",(TT2,UT1)), ("zwei, kaks",(TT2,UT2)) + ] + (toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe` + [ ("eins, yks, yks",(TT1,UT1,UT1)) + , ("eins, yks, kaks",(TT1,UT1,UT2)) + , ("zwei, yks, yks",(TT2,UT1,UT1)) + , ("eins, kaks, yks",(TT1,UT2,UT1)) + , ("zwei, yks, kaks",(TT2,UT1,UT2)) + , ("eins, kaks, kaks",(TT1,UT2,UT2)) + , ("zwei, kaks, yks",(TT2,UT2,UT1)) + , ("zwei, kaks, kaks",(TT2,UT2,UT2)) + ] + + + where + tests1 md = do + it "mentions supported content-types" $ do + md `shouldContain` "application/json" + md `shouldContain` "text/plain;charset=utf-8" + + it "mentions status codes" $ do + md `shouldContain` "Status code 200" + + it "has methods as section headers" $ do + md `shouldContain` "## POST" + md `shouldContain` "## GET" + + it "mentions headers" $ do + md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." + + 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 + , dt1field2 :: Int + } deriving (Eq, Show, Generic) + +instance ToJSON Datatype1 + +instance ToSample Datatype1 where + toSamples _ = singleSample $ Datatype1 "field 1" 13 + +instance ToSample Char where + toSamples _ = samples ['a'..'z'] + +instance ToSample Int where + toSamples _ = singleSample 17 + +instance MimeRender PlainText Int where + mimeRender _ = cs . show + +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) + +instance ToSample TT where + toSamples _ = [("eins", TT1), ("zwei", TT2)] + +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)) ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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