@@ -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
@@ -154,25 +157,27 @@ module Servant.Docs
154157 , module Data.Monoid
155158 ) where
156159
160+import Control.Applicative
157161import 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
@@ -315,7 +320,7 @@ data ParamKind = Normal | List | Flag
315320-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
316321data Response = Response
317322 { _respStatus :: Int
318− , _respBody :: [(Text, ByteString)]
323+ , _respBody :: [(Text, M.MediaType, ByteString)]
319324 } deriving (Eq, Show)
320325
321326-- | Default response: status code 200, no response body.
@@ -345,7 +350,7 @@ data Action = Action
345350 , _params :: [DocQueryParam] -- type collected + user supplied info
346351 , _notes :: [DocNote] -- user supplied
347352 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
348− , _rqbody :: Maybe ByteString -- user supplied
353+ , _rqbody :: Maybe [(M.MediaType, ByteString)] -- user supplied
349354 , _response :: Response -- user supplied
350355 } deriving (Eq, Show)
351356
@@ -428,24 +433,38 @@ class HasDocs layout where
428433-- You can also instantiate this class using 'toSamples' instead of
429434-- 'toSample': it lets you specify different responses along with
430435-- some context (as 'Text') that explains when you're supposed to
431−-- get the corresponding response.
436+-- get the corresponding response.
432437class ToJSON a => ToSample a where
433438 {-# MINIMAL (toSample | toSamples) #-}
434439 toSample :: Maybe a
435− toSample = fmap snd $ listToMaybe samples
440+ toSample = snd <$> listToMaybe samples
436441 where samples = toSamples :: [(Text, a)]
437442
438443 toSamples :: [(Text, a)]
439444 toSamples = maybe [] (return . ("",)) s
440445 where s = toSample :: Maybe a
441446
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)]
447+-- | Synthesise a sample value of a type, encoded in the specified media types.
448+sampleByteString
449+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
450+ => Proxy ctypes
451+ -> Proxy a
452+ -> Maybe [(M.MediaType, ByteString)]
453+sampleByteString ctypes@Proxy Proxy =
454+ fmap (amr ctypes) (toSample :: Maybe a)
455+
456+-- | Synthesise a list of sample values of a particular type, encoded in the
457+-- specified media types.
458+sampleByteStrings
459+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
460+ => Proxy ctypes
461+ -> Proxy a
462+ -> [(Text, M.MediaType, ByteString)]
463+sampleByteStrings ctypes@Proxy Proxy =
464+ let samples = toSamples :: [(Text, a)]
465+ ext t (a,b) = (t,a,b)
466+ enc (t, s) = ext t <$> amr ctypes s
467+ in concatMap enc samples
449468
450469-- | The class that helps us automatically get documentation
451470-- for GET parameters.
@@ -574,16 +593,26 @@ markdown api = unlines $
574593
575594 where values = param ^. paramValues
576595
577− rqbodyStr :: Maybe ByteString -> [String]
596+ rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String]
578597 rqbodyStr Nothing = []
579− rqbodyStr (Just b) =
580− "#### Request Body:" :
581− jsonStr b
598+ rqbodyStr (Just b) = concatMap formatBody b
582599
583− jsonStr b =
600+ formatBody (m, b) =
601+ "#### Request Body: `" <> show (M.mainType m <> "/" <> M.subType m) <> "`" :
602+ contentStr m b
603+
604+ markdownForType mime_type =
605+ case (M.mainType mime_type, M.subType mime_type) of
606+ ("text", "html") -> "html"
607+ ("application", "xml") -> "xml"
608+ ("application", "json") -> "javascript"
609+ ("application", "javascript") -> "javascript"
610+ (_, _) -> ""
611+
612+ contentStr mime_type body =
584613 "" :
585− "``` javascript" :
586− cs b :
614+ "``` " <> markdownForType mime_type :
615+ cs body :
587616 "```" :
588617 "" :
589618 []
@@ -597,9 +626,9 @@ markdown api = unlines $
597626
598627 where bodies = case resp ^. respBody of
599628 [] -> [" - No response body\n"]
600− [("", r)] -> " - Response body as below." : jsonStr r
629+ [("", t, r)] -> " - Response body as below." : contentStr t r
601630 xs ->
602− concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
631+ concatMap (\(ctx, t, r) -> (" - " <> T.unpack ctx) : contentStr t r) xs
603632
604633-- * Instances
605634
@@ -641,14 +670,16 @@ instance HasDocs Delete where
641670 action' = action & response.respBody .~ []
642671 & response.respStatus .~ 204
643672
644−instance ToSample a => HasDocs (Get cts a) where
673+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts a) where
645674 docsFor Proxy (endpoint, action) =
646675 single endpoint' action'
647676
648677 where endpoint' = endpoint & method .~ DocGET
649− action' = action & response.respBody .~ sampleByteStrings p
678+ action' = action & response.respBody .~ sampleByteStrings t p
679+ t = Proxy :: Proxy cts
650680 p = Proxy :: Proxy a
651681
682+
652683instance (KnownSymbol sym, HasDocs sublayout)
653684 => HasDocs (Header sym a :> sublayout) where
654685 docsFor Proxy (endpoint, action) =
@@ -658,29 +689,26 @@ instance (KnownSymbol sym, HasDocs sublayout)
658689 action' = over headers (|> headername) action
659690 headername = pack $ symbolVal (Proxy :: Proxy sym)
660691
661−instance ToSample a => HasDocs (Post cts a) where
692+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts a) where
662693 docsFor Proxy (endpoint, action) =
663694 single endpoint' action'
664695
665696 where endpoint' = endpoint & method .~ DocPOST
666−
667− action' = action & response.respBody .~ sampleByteStrings p
697+ action' = action & response.respBody .~ sampleByteStrings t p
668698 & response.respStatus .~ 201
669−
699+ t = Proxy :: Proxy cts
670700 p = Proxy :: Proxy a
671701
672−instance ToSample a => HasDocs (Put cts a) where
702+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts a) where
673703 docsFor Proxy (endpoint, action) =
674704 single endpoint' action'
675705
676706 where endpoint' = endpoint & method .~ DocPUT
677−
678− action' = action & response.respBody .~ sampleByteStrings p
707+ action' = action & response.respBody .~ sampleByteStrings t p
679708 & response.respStatus .~ 200
680−
709+ t = Proxy :: Proxy cts
681710 p = Proxy :: Proxy a
682711
683−
684712instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
685713 => HasDocs (QueryParam sym a :> sublayout) where
686714
@@ -755,20 +783,23 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
755783 endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
756784 symP = Proxy :: Proxy sym
757785
758−
759786instance HasDocs Raw where
760787 docsFor _proxy (endpoint, action) =
761788 single endpoint action
762789
763−instance (ToSample a, HasDocs sublayout)
790+-- TODO: We use 'AllMimeRender' here because we need to be able to show the
791+-- example data. However, there's no reason to believe that the instances of
792+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
793+-- both are even defined) for any particular type.
794+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
764795 => HasDocs (ReqBody cts a :> sublayout) where
765796
766797 docsFor Proxy (endpoint, action) =
767798 docsFor sublayoutP (endpoint, action')
768799
769800 where sublayoutP = Proxy :: Proxy sublayout
770−
771− action' = action & rqbody .~ sampleByteString p
801+ action' = action & rqbody .~ sampleByteString t p
802+ t = Proxy :: Proxy cts
772803 p = Proxy :: Proxy a
773804
774805instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where