@@ -1,13 +1,16 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE TupleSections #-}
5−{-# LANGUAGE TypeOperators #-}
6−{-# LANGUAGE TemplateHaskell #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE FlexibleInstances #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
1114
1215-------------------------------------------------------------------------------
1316-- | This module lets you get API docs for free. It lets generate
@@ -102,11 +105,11 @@
102105-- > -- API specification
103106-- > type TestApi =
104107-- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON
105−-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
108+-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
106109-- >
107110-- > -- POST /greet with a Greet as JSON in the request body,
108111-- > -- returns a Greet as JSON
109−-- > :<|> "greet" :> ReqBody Greet :> Post Greet
112+-- > :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
110113-- >
111114-- > -- DELETE /greet/:greetid
112115-- > :<|> "greet" :> Capture "greetid" Text :> Delete
@@ -145,8 +148,8 @@ module Servant.Docs
145148 , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
146149 , DocNote(..), noteTitle, noteBody
147150 , DocIntro(..)
148− , Response, respStatus, respBody, defResponse
149− , Action, captures, headers, notes, params, rqbody, response, defAction
151+ , Response, respStatus, respTypes, respBody, defResponse
152+ , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
150153 , single
151154
152155 , -- * Useful modules when defining your doc printers
@@ -154,25 +157,27 @@ module Servant.Docs
154157 , module Data.Monoid
155158 ) where
156159
157−import Control.Lens hiding (Action)
160+import Control.Applicative
161+import Control.Lens
158162import Data.Aeson
159−import Data.Aeson.Encode.Pretty (encodePretty)
160−import Data.Ord(comparing)
161163import Data.ByteString.Lazy.Char8 (ByteString)
162164import Data.Hashable
163165import Data.HashMap.Strict (HashMap)
164166import Data.List
165−import Data.Maybe (listToMaybe)
167+import Data.Maybe
166168import Data.Monoid
169+import Data.Ord (comparing)
167170import Data.Proxy
168−import Data.Text (Text, pack, unpack)
169171import Data.String.Conversions
172+import Data.Text (Text, pack, unpack)
170173import GHC.Generics
171174import GHC.TypeLits
172175import Servant.API
176+import Servant.API.ContentTypes
173177
174178import qualified Data.HashMap.Strict as HM
175−import qualified Data.Text as T
179+import qualified Data.Text as T
180+import qualified Network.HTTP.Media as M
176181
177182-- | Supported HTTP request methods
178183data Method = DocDELETE -- ^ the DELETE method
@@ -299,23 +304,25 @@ data DocNote = DocNote
299304data ParamKind = Normal | List | Flag
300305 deriving (Eq, Show)
301306
302−-- | A type to represent an HTTP response. Has an 'Int' status and
303−-- a 'Maybe ByteString' response body. Tweak 'defResponse' using
304−-- the 'respStatus' and 'respBody' lenses if you want.
307+-- | A type to represent an HTTP response. Has an 'Int' status, a list of
308+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
309+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'
310+-- lenses if you want.
305311--
306312-- If you want to respond with a non-empty response body, you'll most likely
307313-- want to write a 'ToSample' instance for the type that'll be represented
308−-- as some JSON in the response.
314+-- as encoded data in the response.
309315--
310−-- Can be tweaked with two lenses.
316+-- Can be tweaked with three lenses.
311317--
312318-- > λ> defResponse
313−-- > Response {_respStatus = 200, _respBody = []}
319+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
314320-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
315−-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
321+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
316322data Response = Response
317323 { _respStatus :: Int
318− , _respBody :: [(Text, ByteString)]
324+ , _respTypes :: [M.MediaType]
325+ , _respBody :: [(Text, M.MediaType, ByteString)]
319326 } deriving (Eq, Show)
320327
321328-- | Default response: status code 200, no response body.
@@ -327,7 +334,7 @@ data Response = Response
327334-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
328335-- > Response {_respStatus = 204, _respBody = Just "[]"}
329336defResponse :: Response
330−defResponse = Response 200 []
337+defResponse = Response 200 [] []
331338
332339-- | A datatype that represents everything that can happen
333340-- at an endpoint, with its lenses:
@@ -340,13 +347,14 @@ defResponse = Response 200 []
340347-- You can tweak an 'Action' (like the default 'defAction') with these lenses
341348-- to transform an action and add some information to it.
342349data Action = Action
343− { _captures :: [DocCapture] -- type collected + user supplied info
344− , _headers :: [Text] -- type collected
345− , _params :: [DocQueryParam] -- type collected + user supplied info
346− , _notes :: [DocNote] -- user supplied
347− , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
348− , _rqbody :: Maybe ByteString -- user supplied
349− , _response :: Response -- user supplied
350+ { _captures :: [DocCapture] -- type collected + user supplied info
351+ , _headers :: [Text] -- type collected
352+ , _params :: [DocQueryParam] -- type collected + user supplied info
353+ , _notes :: [DocNote] -- user supplied
354+ , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
355+ , _rqtypes :: [M.MediaType] -- type collected
356+ , _rqbody :: [(M.MediaType, ByteString)] -- user supplied
357+ , _response :: Response -- user supplied
350358 } deriving (Eq, Show)
351359
352360-- Default 'Action'. Has no 'captures', no GET 'params', expects
@@ -365,7 +373,8 @@ defAction =
365373 []
366374 []
367375 []
368− Nothing
376+ []
377+ []
369378 defResponse
370379
371380-- | Create an API that's comprised of a single endpoint.
@@ -428,24 +437,50 @@ class HasDocs layout where
428437-- You can also instantiate this class using 'toSamples' instead of
429438-- 'toSample': it lets you specify different responses along with
430439-- some context (as 'Text') that explains when you're supposed to
431−-- get the corresponding response.
440+-- get the corresponding response.
432441class ToJSON a => ToSample a where
433442 {-# MINIMAL (toSample | toSamples) #-}
434443 toSample :: Maybe a
435− toSample = fmap snd $ listToMaybe samples
444+ toSample = snd <$> listToMaybe samples
436445 where samples = toSamples :: [(Text, a)]
437446
438447 toSamples :: [(Text, a)]
439448 toSamples = maybe [] (return . ("",)) s
440449 where s = toSample :: Maybe a
441450
442−sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString
443−sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)
444−
445−sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]
446−sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty
447−
448− where samples = toSamples :: [(Text, a)]
451+-- | Synthesise a sample value of a type, encoded in the specified media types.
452+sampleByteString
453+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
454+ => Proxy ctypes
455+ -> Proxy a
456+ -> [(M.MediaType, ByteString)]
457+sampleByteString ctypes@Proxy Proxy =
458+ maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
459+
460+-- | Synthesise a list of sample values of a particular type, encoded in the
461+-- specified media types.
462+sampleByteStrings
463+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
464+ => Proxy ctypes
465+ -> Proxy a
466+ -> [(Text, M.MediaType, ByteString)]
467+sampleByteStrings ctypes@Proxy Proxy =
468+ let samples = toSamples :: [(Text, a)]
469+ enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
470+ in concatMap enc samples
471+
472+-- | Generate a list of 'MediaType' values describing the content types
473+-- accepted by an API component.
474+class SupportedTypes (list :: [*]) where
475+ supportedTypes :: Proxy list -> [M.MediaType]
476+
477+instance SupportedTypes '[] where
478+ supportedTypes Proxy = []
479+
480+instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
481+ where
482+ supportedTypes Proxy =
483+ contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
449484
450485-- | The class that helps us automatically get documentation
451486-- for GET parameters.
@@ -486,7 +521,7 @@ markdown api = unlines $
486521 mxParamsStr (action ^. mxParams) ++
487522 headersStr (action ^. headers) ++
488523 paramsStr (action ^. params) ++
489− rqbodyStr (action ^. rqbody) ++
524+ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
490525 responseStr (action ^. response) ++
491526 []
492527
@@ -500,7 +535,7 @@ markdown api = unlines $
500535 introStr i =
501536 ("#### " ++ i ^. introTitle) :
502537 "" :
503− intersperse "" (i ^. introBody) ++
538+ intersperse "" (i ^. introBody) ++
504539 "" :
505540 []
506541
@@ -523,6 +558,7 @@ markdown api = unlines $
523558 map captureStr l ++
524559 "" :
525560 []
561+
526562 captureStr cap =
527563 "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
528564
@@ -534,6 +570,7 @@ markdown api = unlines $
534570 map segmentStr l ++
535571 "" :
536572 []
573+
537574 segmentStr :: (String, [DocQueryParam]) -> String
538575 segmentStr (segment, l) = unlines $
539576 ("**" ++ segment ++ "**:") :
@@ -557,8 +594,9 @@ markdown api = unlines $
557594 map paramStr l ++
558595 "" :
559596 []
597+
560598 paramStr param = unlines $
561− (" - " ++ param ^. paramName) :
599+ ("- " ++ param ^. paramName) :
562600 (if (not (null values) || param ^. paramKind /= Flag)
563601 then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
564602 else []) ++
@@ -574,16 +612,35 @@ markdown api = unlines $
574612
575613 where values = param ^. paramValues
576614
577− rqbodyStr :: Maybe ByteString -> [String]
578− rqbodyStr Nothing = []
579− rqbodyStr (Just b) =
580− "#### Request Body:" :
581− jsonStr b
582−
583− jsonStr b =
615+ rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
616+ rqbodyStr [] [] = []
617+ rqbodyStr types samples =
618+ ["#### Request:", ""]
619+ <> formatTypes types
620+ <> concatMap formatBody samples
621+
622+ formatTypes [] = []
623+ formatTypes ts = ["- Supported content types are: ", ""]
624+ <> map (\t -> " - `" <> show t <> "`") ts
625+ <> [""]
626+
627+ formatBody (m, b) =
628+ "- Example: `" <> cs (show m) <> "`" :
629+ contentStr m b
630+
631+ markdownForType mime_type =
632+ case (M.mainType mime_type, M.subType mime_type) of
633+ ("text", "html") -> "html"
634+ ("application", "xml") -> "xml"
635+ ("application", "json") -> "javascript"
636+ ("application", "javascript") -> "javascript"
637+ ("text", "css") -> "css"
638+ (_, _) -> ""
639+
640+ contentStr mime_type body =
584641 "" :
585− "``` javascript" :
586− cs b :
642+ "``` " <> markdownForType mime_type :
643+ cs body :
587644 "```" :
588645 "" :
589646 []
@@ -592,14 +649,16 @@ markdown api = unlines $
592649 responseStr resp =
593650 "#### Response:" :
594651 "" :
595− (" - Status code " ++ show (resp ^. respStatus)) :
652+ ("- Status code " ++ show (resp ^. respStatus)) :
653+ "" :
654+ formatTypes (resp ^. respTypes) ++
596655 bodies
597656
598657 where bodies = case resp ^. respBody of
599− [] -> [" - No response body\n"]
600− [("", r)] -> " - Response body as below." : jsonStr r
658+ [] -> ["- No response body\n"]
659+ [("", t, r)] -> "- Response body as below." : contentStr t r
601660 xs ->
602− concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
661+ concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
603662
604663-- * Instances
605664
@@ -641,12 +700,15 @@ instance HasDocs Delete where
641700 action' = action & response.respBody .~ []
642701 & response.respStatus .~ 204
643702
644−instance ToSample a => HasDocs (Get a) where
703+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
704+ => HasDocs (Get cts a) where
645705 docsFor Proxy (endpoint, action) =
646706 single endpoint' action'
647707
648708 where endpoint' = endpoint & method .~ DocGET
649− action' = action & response.respBody .~ sampleByteStrings p
709+ action' = action & response.respBody .~ sampleByteStrings t p
710+ & response.respTypes .~ supportedTypes t
711+ t = Proxy :: Proxy cts
650712 p = Proxy :: Proxy a
651713
652714instance (KnownSymbol sym, HasDocs sublayout)
@@ -658,29 +720,30 @@ instance (KnownSymbol sym, HasDocs sublayout)
658720 action' = over headers (|> headername) action
659721 headername = pack $ symbolVal (Proxy :: Proxy sym)
660722
661−instance ToSample a => HasDocs (Post a) where
723+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
724+ => HasDocs (Post cts a) where
662725 docsFor Proxy (endpoint, action) =
663726 single endpoint' action'
664727
665728 where endpoint' = endpoint & method .~ DocPOST
666−
667− action' = action & response.respBody .~ sampleByteStrings p
729+ action' = action & response.respBody .~ sampleByteStrings t p
730+ & response.respTypes .~ supportedTypes t
668731 & response.respStatus .~ 201
669−
732+ t = Proxy :: Proxy cts
670733 p = Proxy :: Proxy a
671734
672−instance ToSample a => HasDocs (Put a) where
735+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
736+ => HasDocs (Put cts a) where
673737 docsFor Proxy (endpoint, action) =
674738 single endpoint' action'
675739
676740 where endpoint' = endpoint & method .~ DocPUT
677−
678− action' = action & response.respBody .~ sampleByteStrings p
741+ action' = action & response.respBody .~ sampleByteStrings t p
742+ & response.respTypes .~ supportedTypes t
679743 & response.respStatus .~ 200
680−
744+ t = Proxy :: Proxy cts
681745 p = Proxy :: Proxy a
682746
683−
684747instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
685748 => HasDocs (QueryParam sym a :> sublayout) where
686749
@@ -755,20 +818,24 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
755818 endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
756819 symP = Proxy :: Proxy sym
757820
758−
759821instance HasDocs Raw where
760822 docsFor _proxy (endpoint, action) =
761823 single endpoint action
762824
763−instance (ToSample a, HasDocs sublayout)
764− => HasDocs (ReqBody a :> sublayout) where
825+-- TODO: We use 'AllMimeRender' here because we need to be able to show the
826+-- example data. However, there's no reason to believe that the instances of
827+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
828+-- both are even defined) for any particular type.
829+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
830+ => HasDocs (ReqBody cts a :> sublayout) where
765831
766832 docsFor Proxy (endpoint, action) =
767833 docsFor sublayoutP (endpoint, action')
768834
769835 where sublayoutP = Proxy :: Proxy sublayout
770−
771− action' = action & rqbody .~ sampleByteString p
836+ action' = action & rqbody .~ sampleByteString t p
837+ & rqtypes .~ supportedTypes t
838+ t = Proxy :: Proxy cts
772839 p = Proxy :: Proxy a
773840
774841instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where