module Servant.Docs.Pandoc (pandoc, makeFilter) where
import Control.Lens ((^.))
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B (unpack)
import Data.CaseInsensitive (foldedCase)
import Data.Foldable (foldMap)
import qualified Data.HashMap.Strict as HM
import Data.List (intercalate, sort)
import Data.Monoid (mconcat, mempty, (<>))
import Data.String.Conversions (convertString)
import Data.Text (Text, unpack)
import Network.HTTP.Media (MediaType)
import qualified Network.HTTP.Media as M
import Servant.Docs
import Text.Pandoc.Builder (Blocks, Inlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Definition (Pandoc)
import Text.Pandoc.JSON (toJSONFilter)
makeFilter :: API -> IO ()
makeFilter api = toJSONFilter inject
where
inject :: Pandoc -> Pandoc
inject p = p <> pandoc api
pandoc :: API -> Pandoc
pandoc api = B.doc $ intros <> mconcat endpoints
where printEndpoint :: Endpoint -> Action -> Blocks
printEndpoint endpoint action =
B.header 1 str <>
capturesStr (action ^. captures) <>
headersStr (action ^. headers) <>
paramsStr (action ^. params) <>
rqbodyStrs (action ^. rqtypes) (action ^. rqbody) <>
responseStr (action ^. response)
where str :: Inlines
str = B.str (show (endpoint^.method)) <> B.space <> B.code ("/" ++ intercalate "/" (endpoint ^. path))
intros = if null (api ^. apiIntros) then mempty else intros'
intros' = foldMap printIntro (api ^. apiIntros)
printIntro i =
B.header 1 (B.str $ i ^. introTitle) <>
foldMap (B.para . B.str) (i ^. introBody)
endpoints = map (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints
capturesStr :: [DocCapture] -> Blocks
capturesStr [] = mempty
capturesStr l =
B.header 2 "Captures" <>
B.bulletList (map captureStr l)
captureStr cap =
B.plain $ B.emph (B.str $ cap ^. capSymbol) <> ":" <> B.space <> B.str (cap ^. capDesc)
headersStr :: [Text] -> Blocks
headersStr [] = mempty
headersStr l = B.bulletList (map (B.para . headerStr) l)
where headerStr hname = "This endpoint is sensitive to the value of the" <> B.space <>
(B.strong . B.str $ unpack hname) <> B.space <> "HTTP header."
paramsStr :: [DocQueryParam] -> Blocks
paramsStr [] = mempty
paramsStr l =
B.header 2 "GET Parameters" <>
B.bulletList (map paramStr l)
paramStr param =
B.plain (B.str (param ^. paramName)) <>
B.definitionList (
[(B.strong "Values",
[B.plain (B.emph
(foldr1 (\a b -> a <> B.str "," <> B.space <> b) (map B.str values)))])
| not (null values) || param ^. paramKind /= Flag]
++
[(B.strong "Description",
[B.plain $ B.str (param ^. paramDesc)])])
<>
B.bulletList (
[B.plain $ "This parameter is a" <>
B.space <>
B.strong "list" <>
". All GET parameters with the name" <>
B.space <>
B.str (param ^. paramName) <>
B.space <>
B.code "[]" <> B.space <>
"will forward their values in a list to the handler."
| param ^. paramKind == List]
++
[B.plain $ "This parameter is a" <>
B.space <>
B.strong "flag." <>
B.space <>
"This means no value is expected to be associated to this parameter."
| param ^. paramKind == Flag]
)
where values = param ^. paramValues
rqbodyStrs :: [MediaType] -> [(Text, MediaType, ByteString)] -> Blocks
rqbodyStrs [] [] = mempty
rqbodyStrs types bs =
B.header 2 "Request Body" <>
formatTypes types <>
B.bulletList (map bodyStr bs)
formatTypes [] = mempty
formatTypes ts = B.bulletList
[ B.plain "Supported content types are:"
, B.bulletList (map (B.plain . B.code . show) ts)
]
bodyStr :: (Text, MediaType, ByteString) -> Blocks
bodyStr (t, media, bs) = mconcat
[ B.plain . mconcat $
[ "Example ("
, B.text (convertString t)
, "): "
, B.code (show media)
]
, codeStr media bs
]
codeStr :: MediaType -> ByteString -> Blocks
codeStr media b =
B.codeBlockWith ("",[markdownForType media],[]) (B.unpack b)
responseStr :: Response -> Blocks
responseStr resp =
B.header 2 "Response" <>
B.bulletList (
(B.plain $ "Status code" <> B.space <> (B.str . show) (resp ^. respStatus)) :
formatTypes (resp ^. respTypes) :
case resp ^. respBody of
[] -> [B.plain "No response body"]
[("", t, r)] -> [B.plain "Response body as below.", codeStr t r]
xs -> concatMap renderResponse xs)
where
renderResponse :: (Text, MediaType, ByteString) -> [Blocks]
renderResponse (ctx, t, r) = [B.plain (B.str (convertString ctx)), codeStr t r]
markdownForType :: MediaType -> String
markdownForType = convertString . foldedCase . M.subType