diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +[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.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 ---- diff --git a/servant-docs.cabal b/servant-docs.cabal --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -1,10 +1,10 @@ name: servant-docs -version: 0.11 +version: 0.11.1 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. . - Runnable example . + Runnable example . . license: BSD3 @@ -12,10 +12,14 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Servant Web +category: Servant, Web build-type: Simple cabal-version: >=1.10 -tested-with: GHC >= 7.8 +tested-with: + GHC==7.8.4 + GHC==7.10.3 + GHC==8.0.2 + GHC==8.2.1 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: @@ -42,14 +46,14 @@ , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.11.* + , servant == 0.12.* , string-conversions , text , unordered-containers , 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 @@ -75,6 +79,8 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Servant.DocsSpec + build-tool-depends: + hspec-discover:hspec-discover hs-source-dirs: test ghc-options: -Wall build-depends: diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -24,6 +24,9 @@ module Servant.Docs ( -- * 'HasDocs' class and key functions HasDocs(..), docs, pretty, markdown + -- ** Customising generated documentation + , markdownWith, RenderingOptions(..), defRenderingOptions + , requestExamples, responseExamples, ShowContentTypes(..), notesHeading -- * Generating docs with extra information , docsWith, docsWithIntros, docsWithOptions , ExtraInfo(..), extraInfo @@ -43,12 +46,13 @@ , -- * ADTs to represent an 'API' Endpoint, path, method, defEndpoint , API, apiIntros, apiEndpoints, emptyAPI + , DocAuthentication(..), authIntro, authDataRequired , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind , DocNote(..), noteTitle, noteBody , DocIntro(..), introTitle, introBody , Response(..), respStatus, respTypes, respBody, defResponse - , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction + , Action, authInfo, captures, headers, notes, params, rqtypes, rqbody, response, defAction , single ) where 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 @@ -20,24 +20,31 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where -import Prelude () +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 @@ -125,9 +132,10 @@ , _capDesc :: String -- user supplied } deriving (Eq, Ord, Show) --- | A type to represent a /GET/ parameter from the Query String. Holds its name, --- the possible values (leave empty if there isn't a finite number of them), --- and a description of how it influences the output or behavior. +-- | A type to represent a /GET/ (or other possible 'HTTP.Method') +-- parameter from the Query String. Holds its name, the possible +-- values (leave empty if there isn't a finite number of them), and +-- a description of how it influences the output or behavior. -- -- Write a 'ToParam' instance for your GET parameter types data DocQueryParam = DocQueryParam @@ -185,7 +193,7 @@ defaultDocOptions = DocOptions { _maxSamples = 5 } --- | Type of GET parameter: +-- | Type of GET (or other 'HTTP.Method') parameter: -- -- - Normal corresponds to @QueryParam@, i.e your usual GET parameter -- - List corresponds to @QueryParams@, i.e GET parameters with multiple values @@ -235,7 +243,7 @@ -- at an endpoint, with its lenses: -- -- - List of captures ('captures') --- - List of GET parameters ('params') +-- - List of GET (or other 'HTTP.Method') parameters ('params') -- - What the request body should look like, if any is requested ('rqbody') -- - What the response should be if everything goes well ('response') -- @@ -263,7 +271,7 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp --- Default 'Action'. Has no 'captures', no GET 'params', expects +-- | Default 'Action'. Has no 'captures', no query 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. -- -- Tweakable with lenses. @@ -290,6 +298,39 @@ 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. + } 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 + } + -- gimme some lenses makeLenses ''DocAuthentication makeLenses ''DocOptions @@ -301,6 +342,7 @@ 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. @@ -487,8 +529,8 @@ enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s in concatMap enc samples' --- | The class that helps us automatically get documentation --- for GET parameters. +-- | The class that helps us automatically get documentation for GET +-- (or other 'HTTP.Method') parameters. -- -- Example of an instance: -- @@ -516,8 +558,34 @@ -- | 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) @@ -529,14 +597,16 @@ authStr (action ^. authInfo) ++ capturesStr (action ^. captures) ++ headersStr (action ^. headers) ++ - paramsStr (action ^. params) ++ + paramsStr meth (action ^. params) ++ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++ responseStr (action ^. response) ++ [] - where str = "## " ++ BSC.unpack (endpoint^.method) + where str = "## " ++ BSC.unpack meth ++ " " ++ showPath (endpoint^.path) + meth = endpoint ^. method + introsStr :: [DocIntro] -> [String] introsStr = concatMap introStr @@ -549,22 +619,28 @@ [] notesStr :: [DocNote] -> [String] - notesStr = concatMap noteStr + notesStr = addHeading + . concatMap noteStr + where + addHeading nts = maybe nts (\hd -> ("### " ++ hd) : "" : nts) _notesHeading noteStr :: DocNote -> [String] noteStr nt = - ("#### " ++ nt ^. noteTitle) : + (hdr ++ nt ^. noteTitle) : "" : intersperse "" (nt ^. noteBody) ++ "" : [] - + where + hdr | isJust _notesHeading = "#### " + | otherwise = "### " authStr :: [DocAuthentication] -> [String] + authStr [] = [] authStr auths = let authIntros = mapped %~ view authIntro $ auths clientInfos = mapped %~ view authDataRequired $ auths - in "#### Authentication": + in "### Authentication": "": unlines authIntros : "": @@ -576,7 +652,7 @@ capturesStr :: [DocCapture] -> [String] capturesStr [] = [] capturesStr l = - "#### Captures:" : + "### Captures:" : "" : map captureStr l ++ "" : @@ -587,28 +663,33 @@ headersStr :: [Text] -> [String] headersStr [] = [] - headersStr l = [""] ++ map headerStr l ++ [""] + headersStr l = + "### Headers:" : + "" : + map headerStr l ++ + "" : + [] where headerStr hname = "- This endpoint is sensitive to the value of the **" ++ unpack hname ++ "** HTTP header." - paramsStr :: [DocQueryParam] -> [String] - paramsStr [] = [] - paramsStr l = - "#### GET Parameters:" : + paramsStr :: HTTP.Method -> [DocQueryParam] -> [String] + paramsStr _ [] = [] + paramsStr m l = + ("### " ++ cs m ++ " Parameters:") : "" : - map paramStr l ++ + map (paramStr m) l ++ "" : [] - paramStr param = unlines $ + paramStr m param = unlines $ ("- " ++ param ^. paramName) : (if (not (null values) || param ^. paramKind /= Flag) then [" - **Values**: *" ++ intercalate ", " values ++ "*"] else []) ++ (" - **Description**: " ++ param ^. paramDesc) : (if (param ^. paramKind == List) - then [" - This parameter is a **list**. All GET parameters with the name " + then [" - This parameter is a **list**. All " ++ cs m ++ " parameters with the name " ++ param ^. paramName ++ "[] will forward their values in a list to the handler."] else []) ++ (if (param ^. paramKind == Flag) @@ -621,39 +702,63 @@ rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String] rqbodyStr [] [] = [] rqbodyStr types s = - ["#### Request:", ""] + ["### Request:", ""] <> formatTypes types - <> concatMap formatBody s + <> formatBodies _requestExamples s formatTypes [] = [] formatTypes ts = ["- Supported content types are:", ""] <> map (\t -> " - `" <> show t <> "`") ts <> [""] - formatBody (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 : - "```" : + " ```" : "" : [] responseStr :: Response -> [String] responseStr resp = - "#### Response:" : + "### Response:" : "" : ("- Status code " ++ show (resp ^. respStatus)) : ("- Headers: " ++ show (resp ^. respHeaders)) : @@ -665,7 +770,7 @@ [] -> ["- No response body\n"] [("", t, r)] -> "- Response body as below." : contentStr t r xs -> - concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs + formatBodies _responseExamples xs -- * Instances @@ -797,6 +902,27 @@ 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 diff --git a/test/Servant/DocsSpec.hs b/test/Servant/DocsSpec.hs --- a/test/Servant/DocsSpec.hs +++ b/test/Servant/DocsSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,6 +8,12 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif + module Servant.DocsSpec where import Control.Lens