@@ -37,15 +37,17 @@
3737-- Here's a little (but complete) example that you can run to see the
3838-- markdown pretty printer in action:
3939--
40−-- > {-# LANGUAGE DataKinds #-}
41−-- > {-# LANGUAGE DeriveGeneric #-}
42−-- > {-# LANGUAGE TypeOperators #-}
43−-- > {-# LANGUAGE FlexibleInstances #-}
44−-- > {-# LANGUAGE OverloadedStrings #-}
40+-- > {-# LANGUAGE DataKinds #-}
41+-- > {-# LANGUAGE DeriveGeneric #-}
42+-- > {-# LANGUAGE FlexibleInstances #-}
43+-- > {-# LANGUAGE MultiParamTypeClasses #-}
44+-- > {-# LANGUAGE OverloadedStrings #-}
45+-- > {-# LANGUAGE TypeOperators #-}
4546-- > {-# OPTIONS_GHC -fno-warn-orphans #-}
4647-- > import Data.Aeson
4748-- > import Data.Proxy
48−-- > import Data.Text(Text)
49+-- > import Data.String.Conversions
50+-- > import Data.Text (Text)
4951-- > import GHC.Generics
5052-- > import Servant.API
5153-- > import Servant.Docs
@@ -56,9 +58,15 @@
5658-- > newtype Greet = Greet Text
5759-- > deriving (Generic, Show)
5860-- >
61+-- > -- | We can get JSON support automatically. This will be used to parse
62+-- > -- and encode a Greeting as 'JSON'.
5963-- > instance FromJSON Greet
6064-- > instance ToJSON Greet
6165-- >
66+-- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
67+-- > instance MimeRender PlainText Greet where
68+-- > toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
69+-- >
6270-- > -- We add some useful annotations to our captures,
6371-- > -- query parameters and request body to make the docs
6472-- > -- really helpful.
@@ -109,12 +117,12 @@
109117-- >
110118-- > -- API specification
111119-- > type TestApi =
112−-- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON
113−-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
120+-- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
121+-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
114122-- >
115123-- > -- POST /greet with a Greet as JSON in the request body,
116124-- > -- returns a Greet as JSON
117−-- > :<|> "greet" :> ReqBody Greet :> Post Greet
125+-- > :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
118126-- >
119127-- > -- DELETE /greet/:greetid
120128-- > :<|> "greet" :> Capture "greetid" Text :> Delete
@@ -166,8 +174,8 @@ module Servant.Docs
166174 , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
167175 , DocNote(..), noteTitle, noteBody
168176 , DocIntro(..)
169− , Response, respStatus, respBody, defResponse
170− , Action, captures, headers, notes, params, rqbody, response, defAction
177+ , Response, respStatus, respTypes, respBody, defResponse
178+ , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
171179 , single
172180
173181 , -- * Useful modules when defining your doc printers
@@ -175,27 +183,29 @@ module Servant.Docs
175183 , module Data.Monoid
176184 ) where
177185
186+import Control.Applicative
178187import Control.Lens hiding (Action)
179188import Data.Aeson
180−import Data.Aeson.Encode.Pretty (encodePretty)
181−import Data.Ord(comparing)
182189import Data.ByteString.Lazy.Char8 (ByteString)
183190import Data.Hashable
184191import Data.HashMap.Strict (HashMap)
185192import Data.List
186−import Data.Maybe (listToMaybe)
193+import Data.Maybe
187194import Data.Monoid
195+import Data.Ord (comparing)
188196import Data.Proxy
189−import Data.Text (Text, pack, unpack)
190197import Data.String.Conversions
198+import Data.Text (Text, pack, unpack)
191199import GHC.Generics
192200import GHC.TypeLits
193201import GHC.Exts(Constraint)
194202import Servant.API
195203import Servant.Utils.Links
204+import Servant.API.ContentTypes
196205
197206import qualified Data.HashMap.Strict as HM
198−import qualified Data.Text as T
207+import qualified Data.Text as T
208+import qualified Network.HTTP.Media as M
199209
200210-- | Supported HTTP request methods
201211data Method = DocDELETE -- ^ the DELETE method
@@ -333,23 +343,25 @@ instance Monoid (ExtraInfo a) where
333343data ParamKind = Normal | List | Flag
334344 deriving (Eq, Show)
335345
336−-- | A type to represent an HTTP response. Has an 'Int' status and
337−-- a 'Maybe ByteString' response body. Tweak 'defResponse' using
338−-- the 'respStatus' and 'respBody' lenses if you want.
346+-- | A type to represent an HTTP response. Has an 'Int' status, a list of
347+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
348+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'
349+-- lenses if you want.
339350--
340351-- If you want to respond with a non-empty response body, you'll most likely
341352-- want to write a 'ToSample' instance for the type that'll be represented
342−-- as some JSON in the response.
353+-- as encoded data in the response.
343354--
344−-- Can be tweaked with two lenses.
355+-- Can be tweaked with three lenses.
345356--
346357-- > λ> defResponse
347−-- > Response {_respStatus = 200, _respBody = []}
358+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
348359-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
349−-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
360+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
350361data Response = Response
351362 { _respStatus :: Int
352− , _respBody :: [(Text, ByteString)]
363+ , _respTypes :: [M.MediaType]
364+ , _respBody :: [(Text, M.MediaType, ByteString)]
353365 } deriving (Eq, Show)
354366
355367-- | Default response: status code 200, no response body.
@@ -361,7 +373,7 @@ data Response = Response
361373-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
362374-- > Response {_respStatus = 204, _respBody = Just "[]"}
363375defResponse :: Response
364−defResponse = Response 200 []
376+defResponse = Response 200 [] []
365377
366378-- | A datatype that represents everything that can happen
367379-- at an endpoint, with its lenses:
@@ -374,23 +386,25 @@ defResponse = Response 200 []
374386-- You can tweak an 'Action' (like the default 'defAction') with these lenses
375387-- to transform an action and add some information to it.
376388data Action = Action
377− { _captures :: [DocCapture] -- type collected + user supplied info
378− , _headers :: [Text] -- type collected
379− , _params :: [DocQueryParam] -- type collected + user supplied info
380− , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
381− , _notes :: [DocNote] -- user supplied
382− , _rqbody :: Maybe ByteString -- user supplied
383− , _response :: Response -- user supplied
389+ { _captures :: [DocCapture] -- type collected + user supplied info
390+ , _headers :: [Text] -- type collected
391+ , _params :: [DocQueryParam] -- type collected + user supplied info
392+ , _notes :: [DocNote] -- user supplied
393+ , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
394+ , _rqtypes :: [M.MediaType] -- type collected
395+ , _rqbody :: [(M.MediaType, ByteString)] -- user supplied
396+ , _response :: Response -- user supplied
384397 } deriving (Eq, Show)
385398
386399-- | Combine two Actions, we can't make a monoid as merging Response breaks the
387400-- laws.
388401--
389402-- As such, we invent a non-commutative, left associative operation
390−-- 'combineAction' to mush two together taking the response from the very left.
403+-- 'combineAction' to mush two together taking the response, body and content
404+-- types from the very left.
391405combineAction :: Action -> Action -> Action
392−Action c h p m n r resp `combineAction` Action c' h' p' m' n' r' _ =
393− Action (c <> c') (h <> h') (p <> p') (m <> m') (n <> n') (r <> r') resp
406+Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
407+ Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
394408
395409-- Default 'Action'. Has no 'captures', no GET 'params', expects
396410-- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -408,7 +422,8 @@ defAction =
408422 []
409423 []
410424 []
411− Nothing
425+ []
426+ []
412427 defResponse
413428
414429-- | Create an API that's comprised of a single endpoint.
@@ -455,7 +470,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
455470-- > ]
456471
457472extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
458− => Proxy endpoint -> Action -> ExtraInfo layout
473+ => Proxy endpoint -> Action -> ExtraInfo layout
459474extraInfo p action =
460475 let api = docsFor p (defEndpoint, defAction)
461476 -- Assume one endpoint, HasLink constraint means that we should only ever
@@ -527,20 +542,46 @@ class HasDocs layout where
527542class ToJSON a => ToSample a where
528543 {-# MINIMAL (toSample | toSamples) #-}
529544 toSample :: Maybe a
530− toSample = fmap snd $ listToMaybe samples
545+ toSample = snd <$> listToMaybe samples
531546 where samples = toSamples :: [(Text, a)]
532547
533548 toSamples :: [(Text, a)]
534549 toSamples = maybe [] (return . ("",)) s
535550 where s = toSample :: Maybe a
536551
537−sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString
538−sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)
539−
540−sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]
541−sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty
542−
543− where samples = toSamples :: [(Text, a)]
552+-- | Synthesise a sample value of a type, encoded in the specified media types.
553+sampleByteString
554+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
555+ => Proxy ctypes
556+ -> Proxy a
557+ -> [(M.MediaType, ByteString)]
558+sampleByteString ctypes@Proxy Proxy =
559+ maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
560+
561+-- | Synthesise a list of sample values of a particular type, encoded in the
562+-- specified media types.
563+sampleByteStrings
564+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
565+ => Proxy ctypes
566+ -> Proxy a
567+ -> [(Text, M.MediaType, ByteString)]
568+sampleByteStrings ctypes@Proxy Proxy =
569+ let samples = toSamples :: [(Text, a)]
570+ enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
571+ in concatMap enc samples
572+
573+-- | Generate a list of 'MediaType' values describing the content types
574+-- accepted by an API component.
575+class SupportedTypes (list :: [*]) where
576+ supportedTypes :: Proxy list -> [M.MediaType]
577+
578+instance SupportedTypes '[] where
579+ supportedTypes Proxy = []
580+
581+instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
582+ where
583+ supportedTypes Proxy =
584+ contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
544585
545586-- | The class that helps us automatically get documentation
546587-- for GET parameters.
@@ -581,7 +622,7 @@ markdown api = unlines $
581622 mxParamsStr (action ^. mxParams) ++
582623 headersStr (action ^. headers) ++
583624 paramsStr (action ^. params) ++
584− rqbodyStr (action ^. rqbody) ++
625+ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
585626 responseStr (action ^. response) ++
586627 []
587628
@@ -595,7 +636,7 @@ markdown api = unlines $
595636 introStr i =
596637 ("#### " ++ i ^. introTitle) :
597638 "" :
598− intersperse "" (i ^. introBody) ++
639+ intersperse "" (i ^. introBody) ++
599640 "" :
600641 []
601642
@@ -618,6 +659,7 @@ markdown api = unlines $
618659 map captureStr l ++
619660 "" :
620661 []
662+
621663 captureStr cap =
622664 "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
623665
@@ -650,8 +692,9 @@ markdown api = unlines $
650692 map paramStr l ++
651693 "" :
652694 []
695+
653696 paramStr param = unlines $
654− (" - " ++ param ^. paramName) :
697+ ("- " ++ param ^. paramName) :
655698 (if (not (null values) || param ^. paramKind /= Flag)
656699 then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
657700 else []) ++
@@ -667,16 +710,35 @@ markdown api = unlines $
667710
668711 where values = param ^. paramValues
669712
670− rqbodyStr :: Maybe ByteString -> [String]
671− rqbodyStr Nothing = []
672− rqbodyStr (Just b) =
673− "#### Request Body:" :
674− jsonStr b
675−
676− jsonStr b =
713+ rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
714+ rqbodyStr [] [] = []
715+ rqbodyStr types samples =
716+ ["#### Request:", ""]
717+ <> formatTypes types
718+ <> concatMap formatBody samples
719+
720+ formatTypes [] = []
721+ formatTypes ts = ["- Supported content types are:", ""]
722+ <> map (\t -> " - `" <> show t <> "`") ts
723+ <> [""]
724+
725+ formatBody (m, b) =
726+ "- Example: `" <> cs (show m) <> "`" :
727+ contentStr m b
728+
729+ markdownForType mime_type =
730+ case (M.mainType mime_type, M.subType mime_type) of
731+ ("text", "html") -> "html"
732+ ("application", "xml") -> "xml"
733+ ("application", "json") -> "javascript"
734+ ("application", "javascript") -> "javascript"
735+ ("text", "css") -> "css"
736+ (_, _) -> ""
737+
738+ contentStr mime_type body =
677739 "" :
678− "``` javascript" :
679− cs b :
740+ "```" <> markdownForType mime_type :
741+ cs body :
680742 "```" :
681743 "" :
682744 []
@@ -685,14 +747,16 @@ markdown api = unlines $
685747 responseStr resp =
686748 "#### Response:" :
687749 "" :
688− (" - Status code " ++ show (resp ^. respStatus)) :
750+ ("- Status code " ++ show (resp ^. respStatus)) :
751+ "" :
752+ formatTypes (resp ^. respTypes) ++
689753 bodies
690754
691755 where bodies = case resp ^. respBody of
692− [] -> [" - No response body\n"]
693− [("", r)] -> " - Response body as below." : jsonStr r
756+ [] -> ["- No response body\n"]
757+ [("", t, r)] -> "- Response body as below." : contentStr t r
694758 xs ->
695− concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
759+ concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
696760
697761-- * Instances
698762
@@ -734,12 +798,15 @@ instance HasDocs Delete where
734798 action' = action & response.respBody .~ []
735799 & response.respStatus .~ 204
736800
737−instance ToSample a => HasDocs (Get a) where
801+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
802+ => HasDocs (Get cts a) where
738803 docsFor Proxy (endpoint, action) =
739804 single endpoint' action'
740805
741806 where endpoint' = endpoint & method .~ DocGET
742− action' = action & response.respBody .~ sampleByteStrings p
807+ action' = action & response.respBody .~ sampleByteStrings t p
808+ & response.respTypes .~ supportedTypes t
809+ t = Proxy :: Proxy cts
743810 p = Proxy :: Proxy a
744811
745812instance (KnownSymbol sym, HasDocs sublayout)
@@ -751,29 +818,30 @@ instance (KnownSymbol sym, HasDocs sublayout)
751818 action' = over headers (|> headername) action
752819 headername = pack $ symbolVal (Proxy :: Proxy sym)
753820
754−instance ToSample a => HasDocs (Post a) where
821+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
822+ => HasDocs (Post cts a) where
755823 docsFor Proxy (endpoint, action) =
756824 single endpoint' action'
757825
758826 where endpoint' = endpoint & method .~ DocPOST
759−
760− action' = action & response.respBody .~ sampleByteStrings p
827+ action' = action & response.respBody .~ sampleByteStrings t p
828+ & response.respTypes .~ supportedTypes t
761829 & response.respStatus .~ 201
762−
830+ t = Proxy :: Proxy cts
763831 p = Proxy :: Proxy a
764832
765−instance ToSample a => HasDocs (Put a) where
833+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
834+ => HasDocs (Put cts a) where
766835 docsFor Proxy (endpoint, action) =
767836 single endpoint' action'
768837
769838 where endpoint' = endpoint & method .~ DocPUT
770−
771− action' = action & response.respBody .~ sampleByteStrings p
839+ action' = action & response.respBody .~ sampleByteStrings t p
840+ & response.respTypes .~ supportedTypes t
772841 & response.respStatus .~ 200
773−
842+ t = Proxy :: Proxy cts
774843 p = Proxy :: Proxy a
775844
776−
777845instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
778846 => HasDocs (QueryParam sym a :> sublayout) where
779847
@@ -848,20 +916,24 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
848916 endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
849917 symP = Proxy :: Proxy sym
850918
851−
852919instance HasDocs Raw where
853920 docsFor _proxy (endpoint, action) =
854921 single endpoint action
855922
856−instance (ToSample a, HasDocs sublayout)
857− => HasDocs (ReqBody a :> sublayout) where
923+-- TODO: We use 'AllMimeRender' here because we need to be able to show the
924+-- example data. However, there's no reason to believe that the instances of
925+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
926+-- both are even defined) for any particular type.
927+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
928+ => HasDocs (ReqBody cts a :> sublayout) where
858929
859930 docsFor Proxy (endpoint, action) =
860931 docsFor sublayoutP (endpoint, action')
861932
862933 where sublayoutP = Proxy :: Proxy sublayout
863−
864− action' = action & rqbody .~ sampleByteString p
934+ action' = action & rqbody .~ sampleByteString t p
935+ & rqtypes .~ supportedTypes t
936+ t = Proxy :: Proxy cts
865937 p = Proxy :: Proxy a
866938
867939instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where