Generate docs with samples encoded in all types

Request and response body documentation now includes sample values
encoded in all supported media types.
This commit is contained in:
Thomas Sutton 2015-02-19 12:55:00 +11:00
parent dba8689acd
commit 508b9f9791

View file

@ -1,13 +1,16 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-------------------------------------------------------------------------------
-- | This module lets you get API docs for free. It lets generate
@ -154,25 +157,27 @@ module Servant.Docs
, module Data.Monoid
) where
import Control.Applicative
import Control.Lens
import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Ord(comparing)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.List
import Data.Maybe (listToMaybe)
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Proxy
import Data.Text (Text, pack, unpack)
import Data.String.Conversions
import Data.Text (Text, pack, unpack)
import GHC.Generics
import GHC.TypeLits
import Servant.API
import Servant.API.ContentTypes
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Network.HTTP.Media as M
-- | Supported HTTP request methods
data Method = DocDELETE -- ^ the DELETE method
@ -315,7 +320,7 @@ data ParamKind = Normal | List | Flag
-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
data Response = Response
{ _respStatus :: Int
, _respBody :: [(Text, ByteString)]
, _respBody :: [(Text, M.MediaType, ByteString)]
} deriving (Eq, Show)
-- | Default response: status code 200, no response body.
@ -345,7 +350,7 @@ data Action = Action
, _params :: [DocQueryParam] -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
, _rqbody :: Maybe ByteString -- user supplied
, _rqbody :: Maybe [(M.MediaType, ByteString)] -- user supplied
, _response :: Response -- user supplied
} deriving (Eq, Show)
@ -432,20 +437,34 @@ class HasDocs layout where
class ToJSON a => ToSample a where
{-# MINIMAL (toSample | toSamples) #-}
toSample :: Maybe a
toSample = fmap snd $ listToMaybe samples
toSample = snd <$> listToMaybe samples
where samples = toSamples :: [(Text, a)]
toSamples :: [(Text, a)]
toSamples = maybe [] (return . ("",)) s
where s = toSample :: Maybe a
sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString
sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)
-- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
=> Proxy ctypes
-> Proxy a
-> Maybe [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy =
fmap (amr ctypes) (toSample :: Maybe a)
sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]
sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty
where samples = toSamples :: [(Text, a)]
-- | Synthesise a list of sample values of a particular type, encoded in the
-- specified media types.
sampleByteStrings
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
=> Proxy ctypes
-> Proxy a
-> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy =
let samples = toSamples :: [(Text, a)]
ext t (a,b) = (t,a,b)
enc (t, s) = ext t <$> amr ctypes s
in concatMap enc samples
-- | The class that helps us automatically get documentation
-- for GET parameters.
@ -574,16 +593,26 @@ markdown api = unlines $
where values = param ^. paramValues
rqbodyStr :: Maybe ByteString -> [String]
rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String]
rqbodyStr Nothing = []
rqbodyStr (Just b) =
"#### Request Body:" :
jsonStr b
rqbodyStr (Just b) = concatMap formatBody b
jsonStr b =
formatBody (m, b) =
"#### Request Body: `" <> show (M.mainType m <> "/" <> M.subType 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"
(_, _) -> ""
contentStr mime_type body =
"" :
"``` javascript" :
cs b :
"``` " <> markdownForType mime_type :
cs body :
"```" :
"" :
[]
@ -597,9 +626,9 @@ markdown api = unlines $
where bodies = case resp ^. respBody of
[] -> [" - No response body\n"]
[("", r)] -> " - Response body as below." : jsonStr r
[("", t, r)] -> " - Response body as below." : contentStr t r
xs ->
concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
concatMap (\(ctx, t, r) -> (" - " <> T.unpack ctx) : contentStr t r) xs
-- * Instances
@ -641,14 +670,16 @@ instance HasDocs Delete where
action' = action & response.respBody .~ []
& response.respStatus .~ 204
instance ToSample a => HasDocs (Get cts a) where
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ sampleByteStrings p
action' = action & response.respBody .~ sampleByteStrings t p
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout)
=> HasDocs (Header sym a :> sublayout) where
docsFor Proxy (endpoint, action) =
@ -658,29 +689,26 @@ instance (KnownSymbol sym, HasDocs sublayout)
action' = over headers (|> headername) action
headername = pack $ symbolVal (Proxy :: Proxy sym)
instance ToSample a => HasDocs (Post cts a) where
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings p
action' = action & response.respBody .~ sampleByteStrings t p
& response.respStatus .~ 201
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance ToSample a => HasDocs (Put cts a) where
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings p
action' = action & response.respBody .~ sampleByteStrings t p
& response.respStatus .~ 200
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where
@ -755,20 +783,23 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym
instance HasDocs Raw where
docsFor _proxy (endpoint, action) =
single endpoint action
instance (ToSample a, HasDocs sublayout)
-- 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, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
=> HasDocs (ReqBody cts a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString p
action' = action & rqbody .~ sampleByteString t p
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where