@@ -1,4 +1,3 @@
2{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DefaultSignatures #-}
@@ -17,34 +16,55 @@
17{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
17{-# LANGUAGE UndecidableInstances #-}
20−#include "overlapping-compat.h"
21module Servant.Docs.Internal where
19module Servant.Docs.Internal where
23import Prelude ()
21import Prelude ()
24import Prelude.Compat
22import Prelude.Compat
25import Control.Applicative
24import Control.Applicative
26−import Control.Arrow (second)
25+import Control.Arrow
27−import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
28+ (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
28− (&), (.~), (<>~), (^.), (|>))
29+ _1, (%~), (&), (.~), (<>~), (^.), (|>))
29−import qualified Control.Monad.Omega as Omega
30−import Data.ByteString.Lazy.Char8 (ByteString)
31import qualified Data.ByteString.Char8 as BSC
30import qualified Data.ByteString.Char8 as BSC
31+import Data.ByteString.Lazy.Char8
32import qualified Data.CaseInsensitive as CI
33import qualified Data.CaseInsensitive as CI
33−import Data.Hashable (Hashable)
37+ (Hashable)
34−import Data.HashMap.Strict (HashMap)
38+import Data.HashMap.Strict
40+import Data.List.Compat
35−import Data.List.Compat (intercalate, intersperse, sort)
41+ (intercalate, intersperse, sort)
42+import Data.List.NonEmpty
43+ (NonEmpty ((:|)), groupWith)
44+import qualified Data.List.NonEmpty as NE
36import Data.Maybe
45import Data.Maybe
37−import Data.Monoid (All (..), Any (..), Sum (..), Product (..), First (..), Last (..), Dual (..))
46+import Data.Monoid
38−import Data.Semigroup (Semigroup (..))
47+ (All (..), Any (..), Dual (..), First (..), Last (..),
48+ Product (..), Sum (..))
39−import Data.Ord (comparing)
49+import Data.Ord
40−import Data.Proxy (Proxy(Proxy))
51+import Data.Proxy
41−import Data.String.Conversions (cs)
53+import Data.String.Conversions
42−import Data.Text (Text, unpack)
55+import Data.Text
43import GHC.Generics
57import GHC.Generics
58+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59+ (:*:)((:*:)), (:+:)(L1, R1))
60+import qualified GHC.Generics as G
44import GHC.TypeLits
61import GHC.TypeLits
45import Servant.API
62import Servant.API
46import Servant.API.ContentTypes
63import Servant.API.ContentTypes
47import Servant.API.TypeLevel
64import Servant.API.TypeLevel
65+import Servant.API.Generic
67+import qualified Data.Universe.Helpers as U
49import qualified Data.HashMap.Strict as HM
69import qualified Data.HashMap.Strict as HM
50import qualified Data.Text as T
70import qualified Data.Text as T
@@ -57,14 +77,15 @@ import qualified Network.HTTP.Types as HTTP
57-- or any 'Endpoint' value you want using the 'path' and 'method'
77-- or any 'Endpoint' value you want using the 'path' and 'method'
58-- lenses to tweak.
78-- lenses to tweak.
61−-- λ> 'defEndpoint'
80+-- >>> defEndpoint
63−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
83+-- >>> defEndpoint & path <>~ ["foo"]
64−-- GET /foo
84+-- "GET" /foo
65−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
86+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
66−-- POST /foo
87+-- "POST" /foo
68data Endpoint = Endpoint
89data Endpoint = Endpoint
69 { _path :: [String] -- type collected
90 { _path :: [String] -- type collected
70 , _method :: HTTP.Method -- type collected
91 , _method :: HTTP.Method -- type collected
@@ -85,14 +106,15 @@ showPath ps = concatMap ('/' :) ps
86-- Here's how you can modify it:
107-- Here's how you can modify it:
89−-- λ> 'defEndpoint'
109+-- >>> defEndpoint
90−-- GET /
110+-- "GET" /
91−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
112+-- >>> defEndpoint & path <>~ ["foo"]
92−-- GET /foo
113+-- "GET" /foo
93−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
115+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
94−-- POST /foo
116+-- "POST" /foo
96defEndpoint :: Endpoint
118defEndpoint :: Endpoint
97defEndpoint = Endpoint [] HTTP.methodGet
119defEndpoint = Endpoint [] HTTP.methodGet
@@ -109,7 +131,8 @@ instance Semigroup API where
109 (<>) = mappend
131 (<>) = mappend
111instance Monoid API where
133instance Monoid API where
112− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
134+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
135+ (HM.unionWith combineAction b1 b2)
113 mempty = API mempty mempty
136 mempty = API mempty mempty
115-- | An empty 'API'
138-- | An empty 'API'
@@ -138,6 +161,20 @@ data DocQueryParam = DocQueryParam
138 , _paramKind :: ParamKind
161 , _paramKind :: ParamKind
139 } deriving (Eq, Ord, Show)
162 } deriving (Eq, Ord, Show)
164+-- | A type to represent fragment. Holds the name of the fragment and its description.
166+-- Write a 'ToFragment' instance for your fragment types.
167+data DocFragment = DocFragment
168+ { _fragSymbol :: String -- type supplied
169+ , _fragDesc :: String -- user supplied
170+ } deriving (Eq, Ord, Show)
172+-- | There should be at most one 'Fragment' per API endpoint.
173+-- So here we are keeping the first occurrence.
174+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment
175+Nothing `combineFragment` mdocFragment = mdocFragment
176+Just docFragment `combineFragment` _ = Just docFragment
141-- | An introductory paragraph for your documentation. You can pass these to
178-- | An introductory paragraph for your documentation. You can pass these to
142-- 'docsWithIntros'.
179-- 'docsWithIntros'.
143data DocIntro = DocIntro
180data DocIntro = DocIntro
@@ -203,12 +240,14 @@ data ParamKind = Normal | List | Flag
203-- want to write a 'ToSample' instance for the type that'll be represented
240-- want to write a 'ToSample' instance for the type that'll be represented
204-- as encoded data in the response.
241-- as encoded data in the response.
206−-- Can be tweaked with three lenses.
243+-- Can be tweaked with four lenses.
246+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
248+-- >>> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "application/json", "{ \"status\": \"ok\" }")]
249+-- Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well",application/json,"{ \"status\": \"ok\" }")], _respHeaders = []}
209−-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
210−-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
211−-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
212data Response = Response
251data Response = Response
213 { _respStatus :: Int
252 { _respStatus :: Int
214 , _respTypes :: [M.MediaType]
253 , _respTypes :: [M.MediaType]
@@ -216,14 +255,25 @@ data Response = Response
216 , _respHeaders :: [HTTP.Header]
255 , _respHeaders :: [HTTP.Header]
217 } deriving (Eq, Ord, Show)
256 } deriving (Eq, Ord, Show)
258+-- | Combine two Responses, we can't make a monoid because merging Status breaks
261+-- As such, we invent a non-commutative, left associative operation
262+-- 'combineResponse' to mush two together taking the status from the very left.
263+combineResponse :: Response -> Response -> Response
264+Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
265+ = Response s (ts <> ts') (bs <> bs') (hs <> hs')
219-- | Default response: status code 200, no response body.
267-- | Default response: status code 200, no response body.
221−-- Can be tweaked with two lenses.
269+-- Can be tweaked with four lenses.
272+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
274+-- >>> defResponse & respStatus .~ 204
275+-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []}
224−-- > Response {_respStatus = 200, _respBody = Nothing}
225−-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
226−-- > Response {_respStatus = 204, _respBody = Just "[]"}
227defResponse :: Response
277defResponse :: Response
228defResponse = Response
278defResponse = Response
229 { _respStatus = 200
279 { _respStatus = 200
@@ -245,8 +295,9 @@ defResponse = Response
245data Action = Action
295data Action = Action
246 { _authInfo :: [DocAuthentication] -- user supplied info
296 { _authInfo :: [DocAuthentication] -- user supplied info
247 , _captures :: [DocCapture] -- type collected + user supplied info
297 , _captures :: [DocCapture] -- type collected + user supplied info
248− , _headers :: [Text] -- type collected
298+ , _headers :: [HTTP.Header] -- type collected
249 , _params :: [DocQueryParam] -- type collected + user supplied info
299 , _params :: [DocQueryParam] -- type collected + user supplied info
300+ , _fragment :: Maybe DocFragment -- type collected + user supplied info
250 , _notes :: [DocNote] -- user supplied
301 , _notes :: [DocNote] -- user supplied
251 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
252 , _rqtypes :: [M.MediaType] -- type collected
303 , _rqtypes :: [M.MediaType] -- type collected
@@ -258,27 +309,30 @@ data Action = Action
260-- As such, we invent a non-commutative, left associative operation
311-- As such, we invent a non-commutative, left associative operation
261−-- 'combineAction' to mush two together taking the response, body and content
312+-- 'combineAction' to mush two together taking the response from the very left.
262−-- types from the very left.
263combineAction :: Action -> Action -> Action
313combineAction :: Action -> Action -> Action
264−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
314+Action a c h p f n m ts body resp
315+ `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =
265− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
316+ Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
267-- | Default 'Action'. Has no 'captures', no query 'params', expects
318-- | Default 'Action'. Has no 'captures', no query 'params', expects
268-- no request body ('rqbody') and the typical response is 'defResponse'.
319-- no request body ('rqbody') and the typical response is 'defResponse'.
270-- Tweakable with lenses.
321-- Tweakable with lenses.
272−-- > λ> defAction
323+-- >>> defAction
273−-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
324+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
274−-- > λ> defAction & response.respStatus .~ 201
326+-- >>> defAction & response.respStatus .~ 201
275−-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
327+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
276defAction :: Action
329defAction :: Action
277defAction =
330defAction =
278 Action []
331 Action []
@@ -291,6 +345,42 @@ defAction =
291single :: Endpoint -> Action -> API
345single :: Endpoint -> Action -> API
292single e a = API mempty (HM.singleton e a)
346single e a = API mempty (HM.singleton e a)
348+-- | How many content-types for each example should be shown?
351+data ShowContentTypes = AllContentTypes -- ^ For each example, show each content type.
352+ | FirstContentType -- ^ For each example, show only one content type.
353+ deriving (Eq, Ord, Show, Read, Bounded, Enum)
355+-- | Customise how an 'API' is converted into documentation.
358+data RenderingOptions = RenderingOptions
359+ { _requestExamples :: !ShowContentTypes
360+ -- ^ How many content types to display for request body examples?
361+ , _responseExamples :: !ShowContentTypes
362+ -- ^ How many content types to display for response body examples?
363+ , _notesHeading :: !(Maybe String)
364+ -- ^ Optionally group all 'notes' together under a common heading.
365+ , _renderCurlBasePath :: !(Maybe String)
366+ -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`).
369+-- | Default API generation options.
371+-- All content types are shown for both 'requestExamples' and
372+-- 'responseExamples'; 'notesHeading' is set to 'Nothing'
373+-- (i.e. un-grouped).
376+defRenderingOptions :: RenderingOptions
377+defRenderingOptions = RenderingOptions
378+ { _requestExamples = AllContentTypes
379+ , _responseExamples = AllContentTypes
380+ , _notesHeading = Nothing
381+ , _renderCurlBasePath = Nothing
294-- gimme some lenses
384-- gimme some lenses
295makeLenses ''DocAuthentication
385makeLenses ''DocAuthentication
296makeLenses ''DocOptions
386makeLenses ''DocOptions
@@ -298,15 +388,18 @@ makeLenses ''API
298makeLenses ''Endpoint
388makeLenses ''Endpoint
299makeLenses ''DocCapture
389makeLenses ''DocCapture
300makeLenses ''DocQueryParam
390makeLenses ''DocQueryParam
391+makeLenses ''DocFragment
301makeLenses ''DocIntro
392makeLenses ''DocIntro
302makeLenses ''DocNote
393makeLenses ''DocNote
303makeLenses ''Response
394makeLenses ''Response
304makeLenses ''Action
395makeLenses ''Action
396+makeLenses ''RenderingOptions
306-- | Generate the docs for a given API that implements 'HasDocs'. This is the
398-- | Generate the docs for a given API that implements 'HasDocs'. This is the
307-- default way to create documentation.
399-- default way to create documentation.
309−-- prop> docs == docsWithOptions defaultDocOptions
401+-- > docs == docsWithOptions defaultDocOptions
310docs :: HasDocs api => Proxy api -> API
403docs :: HasDocs api => Proxy api -> API
311docs p = docsWithOptions p defaultDocOptions
404docs p = docsWithOptions p defaultDocOptions
@@ -322,9 +415,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
322-- > extra :: ExtraInfo TestApi
415-- > extra :: ExtraInfo TestApi
323-- > extra =
416-- > extra =
324-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
325−-- > defAction & headers <>~ ["unicorns"]
418+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
326-- > & notes <>~ [ DocNote "Title" ["This is some text"]
419-- > & notes <>~ [ DocNote "Title" ["This is some text"]
327−-- > , DocNote "Second secton" ["And some more"]
420+-- > , DocNote "Second section" ["And some more"]
330extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
423extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
@@ -417,22 +510,22 @@ samples = map ("",)
418-- | Default sample Generic-based inputs/outputs.
511-- | Default sample Generic-based inputs/outputs.
419defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
420−defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
513+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
422-- | @'ToSample'@ for Generics.
515-- | @'ToSample'@ for Generics.
424−-- The use of @'Omega'@ allows for more productive sample generation.
517+-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.
425class GToSample t where
518class GToSample t where
426− gtoSamples :: proxy t -> Omega.Omega (Text, t x)
519+ gtoSamples :: proxy t -> [(Text, t x)]
428instance GToSample U1 where
521instance GToSample U1 where
429− gtoSamples _ = Omega.each (singleSample U1)
522+ gtoSamples _ = singleSample U1
431instance GToSample V1 where
524instance GToSample V1 where
432 gtoSamples _ = empty
525 gtoSamples _ = empty
434instance (GToSample p, GToSample q) => GToSample (p :*: q) where
527instance (GToSample p, GToSample q) => GToSample (p :*: q) where
435− gtoSamples _ = render <$> ps <*> qs
528+ gtoSamples _ = U.cartesianProduct render ps qs
437 ps = gtoSamples (Proxy :: Proxy p)
530 ps = gtoSamples (Proxy :: Proxy p)
438 qs = gtoSamples (Proxy :: Proxy q)
531 qs = gtoSamples (Proxy :: Proxy q)
@@ -441,13 +534,13 @@ instance (GToSample p, GToSample q) => GToSample (p :*: q) where
441 | otherwise = (ta <> ", " <> tb, a :*: b)
534 | otherwise = (ta <> ", " <> tb, a :*: b)
443instance (GToSample p, GToSample q) => GToSample (p :+: q) where
536instance (GToSample p, GToSample q) => GToSample (p :+: q) where
444− gtoSamples _ = lefts <|> rights
537+ gtoSamples _ = lefts U.+++ rights
446 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
539 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
447 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
540 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
449instance ToSample a => GToSample (K1 i a) where
542instance ToSample a => GToSample (K1 i a) where
450− gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
543+ gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)
452instance (GToSample f) => GToSample (M1 i a f) where
545instance (GToSample f) => GToSample (M1 i a f) where
453 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
546 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
@@ -493,7 +586,7 @@ sampleByteStrings ctypes@Proxy Proxy =
494-- Example of an instance:
587-- Example of an instance:
496−-- > instance ToParam (QueryParam "capital" Bool) where
589+-- > instance ToParam (QueryParam' mods "capital" Bool) where
497-- > toParam _ =
590-- > toParam _ =
498-- > DocQueryParam "capital"
591-- > DocQueryParam "capital"
499-- > ["true", "false"]
592-- > ["true", "false"]
@@ -515,10 +608,45 @@ class ToCapture c where
515class ToAuthInfo a where
608class ToAuthInfo a where
516 toAuthInfo :: Proxy a -> DocAuthentication
609 toAuthInfo :: Proxy a -> DocAuthentication
611+-- | The class that helps us get documentation for URL fragments.
613+-- Example of an instance:
615+-- > instance ToFragment (Fragment a) where
616+-- > toFragment _ = DocFragment "fragment" "fragment description"
617+class ToFragment t where
618+ toFragment :: Proxy t -> DocFragment
518-- | Generate documentation in Markdown format for
620-- | Generate documentation in Markdown format for
519-- the given 'API'.
621-- the given 'API'.
623+-- This is equivalent to @'markdownWith' 'defRenderingOptions'@.
520markdown :: API -> String
624markdown :: API -> String
521−markdown api = unlines $
625+markdown = markdownWith defRenderingOptions
627+-- | Generate documentation in Markdown format for
628+-- the given 'API' using the specified options.
630+-- These options allow you to customise aspects such as:
632+-- * Choose how many content-types for each request body example are
633+-- shown with 'requestExamples'.
635+-- * Choose how many content-types for each response body example
636+-- are shown with 'responseExamples'.
638+-- For example, to only show the first content-type of each example:
641+-- markdownWith ('defRenderingOptions'
642+-- & 'requestExamples' '.~' 'FirstContentType'
643+-- & 'responseExamples' '.~' 'FirstContentType' )
648+markdownWith :: RenderingOptions -> API -> String
649+markdownWith RenderingOptions{..} api = unlines $
522 introsStr (api ^. apiIntros)
650 introsStr (api ^. apiIntros)
523 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
@@ -529,10 +657,12 @@ markdown api = unlines $
529 notesStr (action ^. notes) ++
657 notesStr (action ^. notes) ++
530 authStr (action ^. authInfo) ++
658 authStr (action ^. authInfo) ++
531 capturesStr (action ^. captures) ++
659 capturesStr (action ^. captures) ++
532− headersStr (action ^. headers) ++
660+ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
533 paramsStr meth (action ^. params) ++
661 paramsStr meth (action ^. params) ++
662+ fragmentStr (action ^. fragment) ++
534 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
535 responseStr (action ^. response) ++
664 responseStr (action ^. response) ++
665+ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
538 where str = "## " ++ BSC.unpack meth
668 where str = "## " ++ BSC.unpack meth
@@ -552,23 +682,28 @@ markdown api = unlines $
554 notesStr :: [DocNote] -> [String]
684 notesStr :: [DocNote] -> [String]
685+ notesStr = addHeading
555− notesStr = concatMap noteStr
686+ . concatMap noteStr
688+ addHeading nts = maybe nts (\hd -> ("### " ++ hd) : "" : nts) _notesHeading
557 noteStr :: DocNote -> [String]
690 noteStr :: DocNote -> [String]
558 noteStr nt =
691 noteStr nt =
559− ("#### " ++ nt ^. noteTitle) :
692+ (hdr ++ nt ^. noteTitle) :
561 intersperse "" (nt ^. noteBody) ++
694 intersperse "" (nt ^. noteBody) ++
698+ hdr | isJust _notesHeading = "#### "
699+ | otherwise = "### "
566 authStr :: [DocAuthentication] -> [String]
701 authStr :: [DocAuthentication] -> [String]
567 authStr [] = []
702 authStr [] = []
568 authStr auths =
703 authStr auths =
569 let authIntros = mapped %~ view authIntro $ auths
704 let authIntros = mapped %~ view authIntro $ auths
570 clientInfos = mapped %~ view authDataRequired $ auths
705 clientInfos = mapped %~ view authDataRequired $ auths
571− in "#### Authentication":
706+ in "### Authentication":
573 unlines authIntros :
708 unlines authIntros :
@@ -580,7 +715,7 @@ markdown api = unlines $
580 capturesStr :: [DocCapture] -> [String]
715 capturesStr :: [DocCapture] -> [String]
581 capturesStr [] = []
716 capturesStr [] = []
582 capturesStr l =
717 capturesStr l =
583− "#### Captures:" :
718+ "### Captures:" :
585 map captureStr l ++
720 map captureStr l ++
@@ -592,7 +727,7 @@ markdown api = unlines $
592 headersStr :: [Text] -> [String]
727 headersStr :: [Text] -> [String]
593 headersStr [] = []
728 headersStr [] = []
594 headersStr l =
729 headersStr l =
595− "#### Headers:" :
730+ "### Headers:" :
597 map headerStr l ++
732 map headerStr l ++
@@ -604,7 +739,7 @@ markdown api = unlines $
604 paramsStr :: HTTP.Method -> [DocQueryParam] -> [String]
739 paramsStr :: HTTP.Method -> [DocQueryParam] -> [String]
605 paramsStr _ [] = []
740 paramsStr _ [] = []
606 paramsStr m l =
741 paramsStr m l =
607− ("#### " ++ cs m ++ " Parameters:") :
742+ ("### " ++ cs m ++ " Parameters:") :
609 map (paramStr m) l ++
744 map (paramStr m) l ++
@@ -627,26 +762,57 @@ markdown api = unlines $
628 where values = param ^. paramValues
763 where values = param ^. paramValues
765+ fragmentStr :: Maybe DocFragment -> [String]
766+ fragmentStr Nothing = []
767+ fragmentStr (Just frag) =
768+ [ "### Fragment:", ""
769+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
630 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
773 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
631 rqbodyStr [] [] = []
774 rqbodyStr [] [] = []
632 rqbodyStr types s =
775 rqbodyStr types s =
633− ["#### Request:", ""]
776+ ["### Request:", ""]
634 <> formatTypes types
777 <> formatTypes types
635− <> concatMap formatBody s
778+ <> formatBodies _requestExamples s
637 formatTypes [] = []
780 formatTypes [] = []
638 formatTypes ts = ["- Supported content types are:", ""]
781 formatTypes ts = ["- Supported content types are:", ""]
639 <> map (\t -> " - `" <> show t <> "`") ts
782 <> map (\t -> " - `" <> show t <> "`") ts
642− formatBody (t, m, b) =
785+ -- This assumes that when the bodies are created, identical
786+ -- labels and representations are located next to each other.
787+ formatBodies :: ShowContentTypes -> [(Text, M.MediaType, ByteString)] -> [String]
788+ formatBodies ex bds = concatMap formatBody (select bodyGroups)
790+ bodyGroups :: [(Text, NonEmpty M.MediaType, ByteString)]
792+ map (\grps -> let (t,_,b) = NE.head grps in (t, fmap (\(_,m,_) -> m) grps, b))
793+ . groupWith (\(t,_,b) -> (t,b))
797+ AllContentTypes -> id
798+ FirstContentType -> map (\(t,ms,b) -> (t, NE.head ms :| [], b))
800+ formatBody :: (Text, NonEmpty M.MediaType, ByteString) -> [String]
801+ formatBody (t, ms, b) =
802+ "- " <> title <> " (" <> mediaList ms <> "):" :
803+ contentStr (NE.head ms) b
805+ mediaList = fold . NE.intersperse ", " . fmap (\m -> "`" ++ show m ++ "`")
643− "- Example (" <> cs t <> "): `" <> cs (show m) <> "`" :
808+ | T.null t = "Example"
644− contentStr m b
809+ | otherwise = cs t
646 markdownForType mime_type =
811 markdownForType mime_type =
647 case (M.mainType mime_type, M.subType mime_type) of
812 case (M.mainType mime_type, M.subType mime_type) of
648 ("text", "html") -> "html"
813 ("text", "html") -> "html"
649 ("application", "xml") -> "xml"
814 ("application", "xml") -> "xml"
815+ ("text", "xml") -> "xml"
650 ("application", "json") -> "javascript"
816 ("application", "json") -> "javascript"
651 ("application", "javascript") -> "javascript"
817 ("application", "javascript") -> "javascript"
652 ("text", "css") -> "css"
818 ("text", "css") -> "css"
@@ -662,7 +828,7 @@ markdown api = unlines $
663 responseStr :: Response -> [String]
829 responseStr :: Response -> [String]
664 responseStr resp =
830 responseStr resp =
665− "#### Response:" :
831+ "### Response:" :
667 ("- Status code " ++ show (resp ^. respStatus)) :
833 ("- Status code " ++ show (resp ^. respStatus)) :
668 ("- Headers: " ++ show (resp ^. respHeaders)) :
834 ("- Headers: " ++ show (resp ^. respHeaders)) :
@@ -674,13 +840,43 @@ markdown api = unlines $
674 [] -> ["- No response body\n"]
840 [] -> ["- No response body\n"]
675 [("", t, r)] -> "- Response body as below." : contentStr t r
841 [("", t, r)] -> "- Response body as below." : contentStr t r
677− concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
843+ formatBodies _responseExamples xs
845+ curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]
846+ curlStr endpoint hdrs reqBodies basePath =
847+ [ "### Sample Request:"
850+ , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"
852+ maybe [] pure mbMediaTypeStr <>
854+ maybe [] pure mbReqBodyStr <>
855+ [ " " ++ basePath ++ showPath (endpoint ^. path)
860+ where escapeQuotes :: String -> String
861+ escapeQuotes = concatMap $ \c -> case c of
864+ mbReqBody = listToMaybe reqBodies
865+ mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody
866+ headersStrs = mkHeaderStr <$> hdrs
867+ mbReqBodyStr = mkReqBodyStr <$> mbReqBody
868+ mkMediaTypeStr (_, media_type, _) =
869+ " -H \"Content-Type: " ++ show media_type ++ "\" \\"
870+ mkHeaderStr (hdrName, hdrVal) =
871+ " -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " ++
872+ escapeQuotes (cs hdrVal) ++ "\" \\"
873+ mkReqBodyStr (_, _, body) = " -d \"" ++ escapeQuotes (cs body) ++ "\" \\"
679-- * Instances
875-- * Instances
681-- | The generated docs for @a ':<|>' b@ just appends the docs
877-- | The generated docs for @a ':<|>' b@ just appends the docs
682-- for @a@ with the docs for @b@.
878-- for @a@ with the docs for @b@.
683−instance OVERLAPPABLE_
879+instance {-# OVERLAPPABLE #-}
684 (HasDocs a, HasDocs b)
880 (HasDocs a, HasDocs b)
685 => HasDocs (a :<|> b) where
881 => HasDocs (a :<|> b) where
@@ -699,7 +895,7 @@ instance HasDocs EmptyAPI where
699-- | @"books" :> 'Capture' "isbn" Text@ will appear as
895-- | @"books" :> 'Capture' "isbn" Text@ will appear as
700-- @/books/:isbn@ in the docs.
896-- @/books/:isbn@ in the docs.
701instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
702− => HasDocs (Capture sym a :> api) where
898+ => HasDocs (Capture' '[] sym a :> api) where
704 docsFor Proxy (endpoint, action) =
900 docsFor Proxy (endpoint, action) =
705 docsFor subApiP (endpoint', action')
901 docsFor subApiP (endpoint', action')
@@ -711,6 +907,28 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
711 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
712 symP = Proxy :: Proxy sym
908 symP = Proxy :: Proxy sym
910+instance (KnownSymbol descr, KnownSymbol sym, HasDocs api)
911+ => HasDocs (Capture' (Description descr ': mods) sym a :> api) where
913+ docsFor Proxy (endpoint, action) =
914+ docsFor subApiP (endpoint', action')
916+ where subApiP = Proxy :: Proxy api
918+ docCapture = DocCapture (symbolVal symP) (symbolVal descrP)
919+ action' = over captures (|> docCapture) action
920+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
921+ descrP = Proxy :: Proxy descr
922+ symP = Proxy :: Proxy sym
924+instance {-# OVERLAPPABLE #-} HasDocs (Capture' mods sym a :> api)
925+ => HasDocs (Capture' (mod ': mods) sym a :> api) where
930+ where apiP = Proxy :: Proxy (Capture' mods sym a :> api)
715-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
716-- @/books/:isbn@ in the docs.
934-- @/books/:isbn@ in the docs.
@@ -728,7 +946,7 @@ instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
728 symP = Proxy :: Proxy sym
946 symP = Proxy :: Proxy sym
731−instance OVERLAPPABLE_
949+instance {-# OVERLAPPABLE #-}
732 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
950 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
733 , ReflectMethod method)
951 , ReflectMethod method)
734 => HasDocs (Verb method status (ct ': cts) a) where
952 => HasDocs (Verb method status (ct ': cts) a) where
@@ -744,7 +962,37 @@ instance OVERLAPPABLE_
744 status = fromInteger $ natVal (Proxy :: Proxy status)
962 status = fromInteger $ natVal (Proxy :: Proxy status)
745 p = Proxy :: Proxy a
963 p = Proxy :: Proxy a
747−instance OVERLAPPING_
965+instance (ReflectMethod method) =>
966+ HasDocs (NoContentVerb method) where
967+ docsFor Proxy (endpoint, action) DocOptions{..} =
968+ single endpoint' action'
970+ where endpoint' = endpoint & method .~ method'
971+ action' = action & response.respStatus .~ 204
972+ & response.respTypes .~ []
973+ & response.respBody .~ []
974+ & response.respHeaders .~ []
975+ method' = reflectMethod (Proxy :: Proxy method)
977+-- | TODO: mention the endpoint is streaming, its framing strategy
979+-- Also there are no samples.
981+-- TODO: AcceptFraming for content-type
982+instance {-# OVERLAPPABLE #-}
983+ (Accept ct, KnownNat status, ReflectMethod method)
984+ => HasDocs (Stream method status framing ct a) where
985+ docsFor Proxy (endpoint, action) DocOptions{..} =
986+ single endpoint' action'
988+ where endpoint' = endpoint & method .~ method'
989+ action' = action & response.respTypes .~ allMime t
990+ & response.respStatus .~ status
991+ t = Proxy :: Proxy '[ct]
992+ method' = reflectMethod (Proxy :: Proxy method)
993+ status = fromInteger $ natVal (Proxy :: Proxy status)
995+instance {-# OVERLAPPING #-}
748 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
996 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
749 , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
997 , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
750 => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
998 => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
@@ -762,23 +1010,26 @@ instance OVERLAPPING_
762 status = fromInteger $ natVal (Proxy :: Proxy status)
1010 status = fromInteger $ natVal (Proxy :: Proxy status)
763 p = Proxy :: Proxy a
1011 p = Proxy :: Proxy a
765−instance (KnownSymbol sym, HasDocs api)
1013+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
766− => HasDocs (Header sym a :> api) where
1014+ => HasDocs (Header' mods sym a :> api) where
767 docsFor Proxy (endpoint, action) =
1015 docsFor Proxy (endpoint, action) =
768 docsFor subApiP (endpoint, action')
1016 docsFor subApiP (endpoint, action')
770 where subApiP = Proxy :: Proxy api
1018 where subApiP = Proxy :: Proxy api
771− action' = over headers (|> headername) action
1019+ action' = over headers (|> (headerName, headerVal)) action
772− headername = T.pack $ symbolVal (Proxy :: Proxy sym)
1020+ headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)
1021+ headerVal = case toSample (Proxy :: Proxy a) of
1022+ Just x -> cs $ toHeader x
1023+ Nothing -> "<no header sample provided>"
774−instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
1025+instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
775− => HasDocs (QueryParam sym a :> api) where
1026+ => HasDocs (QueryParam' mods sym a :> api) where
777 docsFor Proxy (endpoint, action) =
1028 docsFor Proxy (endpoint, action) =
778 docsFor subApiP (endpoint, action')
1029 docsFor subApiP (endpoint, action')
780 where subApiP = Proxy :: Proxy api
1031 where subApiP = Proxy :: Proxy api
781− paramP = Proxy :: Proxy (QueryParam sym a)
1032+ paramP = Proxy :: Proxy (QueryParam' mods sym a)
782 action' = over params (|> toParam paramP) action
1033 action' = over params (|> toParam paramP) action
784instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
1035instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
@@ -802,6 +1053,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
802 paramP = Proxy :: Proxy (QueryFlag sym)
1053 paramP = Proxy :: Proxy (QueryFlag sym)
803 action' = over params (|> toParam paramP) action
1054 action' = over params (|> toParam paramP) action
1056+instance (ToFragment (Fragment a), HasDocs api)
1057+ => HasDocs (Fragment a :> api) where
1059+ docsFor Proxy (endpoint, action) =
1060+ docsFor subApiP (endpoint, action')
1062+ where subApiP = Proxy :: Proxy api
1063+ fragmentP = Proxy :: Proxy (Fragment a)
1064+ action' = set fragment (Just (toFragment fragmentP)) action
806instance HasDocs Raw where
1066instance HasDocs Raw where
807 docsFor _proxy (endpoint, action) _ =
1067 docsFor _proxy (endpoint, action) _ =
@@ -833,8 +1093,7 @@ instance (KnownSymbol desc, HasDocs api)
833-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
1093-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
834-- both are even defined) for any particular type.
1094-- both are even defined) for any particular type.
835instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
1095instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
836− => HasDocs (ReqBody (ct ': cts) a :> api) where
1096+ => HasDocs (ReqBody' mods (ct ': cts) a :> api) where
838 docsFor Proxy (endpoint, action) opts@DocOptions{..} =
1097 docsFor Proxy (endpoint, action) opts@DocOptions{..} =
839 docsFor subApiP (endpoint, action') opts
1098 docsFor subApiP (endpoint, action') opts
@@ -845,6 +1104,18 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
845 t = Proxy :: Proxy (ct ': cts)
1104 t = Proxy :: Proxy (ct ': cts)
846 p = Proxy :: Proxy a
1105 p = Proxy :: Proxy a
1107+-- | TODO: this instance is incomplete.
1108+instance (HasDocs api, Accept ctype) => HasDocs (StreamBody' mods framing ctype a :> api) where
1109+ docsFor Proxy (endpoint, action) opts =
1110+ docsFor subApiP (endpoint, action') opts
1112+ subApiP = Proxy :: Proxy api
1115+ action' = action & rqtypes .~ toList (contentTypes t)
1117+ t = Proxy :: Proxy ctype
848instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
1119instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
850 docsFor Proxy (endpoint, action) =
1121 docsFor Proxy (endpoint, action) =
@@ -880,6 +1151,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
880 authProxy = Proxy :: Proxy (BasicAuth realm usr)
1151 authProxy = Proxy :: Proxy (BasicAuth realm usr)
881 action' = over authInfo (|> toAuthInfo authProxy) action
1152 action' = over authInfo (|> toAuthInfo authProxy) action
1154+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1155+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
883-- ToSample instances for simple types
1157-- ToSample instances for simple types
884instance ToSample NoContent
1158instance ToSample NoContent
885instance ToSample Bool
1159instance ToSample Bool
@@ -896,6 +1170,7 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f
896instance ToSample a => ToSample (Maybe a)
1170instance ToSample a => ToSample (Maybe a)
897instance (ToSample a, ToSample b) => ToSample (Either a b)
1171instance (ToSample a, ToSample b) => ToSample (Either a b)
898instance ToSample a => ToSample [a]
1172instance ToSample a => ToSample [a]
1173+instance ToSample a => ToSample (NonEmpty a)
900-- ToSample instances for Control.Applicative types
1175-- ToSample instances for Control.Applicative types
901instance ToSample a => ToSample (Const a b)
1176instance ToSample a => ToSample (Const a b)
@@ -909,3 +1184,6 @@ instance ToSample a => ToSample (Product a)
909instance ToSample a => ToSample (First a)
1184instance ToSample a => ToSample (First a)
910instance ToSample a => ToSample (Last a)
1185instance ToSample a => ToSample (Last a)
911instance ToSample a => ToSample (Dual a)
1186instance ToSample a => ToSample (Dual a)
1189+-- >>> :set -XOverloadedStrings