eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source 
servant-docs: configurable rendering for multiple content types
This commit is contained in:
Alp Mestanogullari 2017-10-09 08:13:29 +02:00 committed by GitHub
commit f960d97256
7 changed files with 180 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

78
doc/tutorial/Docs.lhs
View file

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

1
doc/tutorial/tutorial.cabal
View file

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

2
servant-docs/CHANGELOG.md
View file

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

2
servant-docs/servant-docs.cabal
View file

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

3
servant-docs/src/Servant/Docs.hs
View file

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

115
servant-docs/src/Servant/Docs/Internal.hs
View file

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

2
stack-ghc-7.8.4.yaml
View file

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