508b9f9 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Generate docs with samples encoded in all types

508b9f9Thomas Sutton12 years ago

src/Servant/Docs.hs+81−50

compare with master

unifiedsplit

@@ -1,13 +1,16 @@

1−{-# LANGUAGE TypeFamilies #-}

1+{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE TupleSections #-}

5−{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE TemplateHaskell #-}

7−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

8−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TemplateHaskell #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

12-------------------------------------------------------------------------------

15-------------------------------------------------------------------------------

13-- | This module lets you get API docs for free. It lets generate

16-- | This module lets you get API docs for free. It lets generate

@@ -154,25 +157,27 @@ module Servant.Docs

154 , module Data.Monoid

157 , module Data.Monoid

155 ) where

158 ) where

156

159

160+import Control.Applicative

157import Control.Lens

161import Control.Lens

158import Data.Aeson

162import Data.Aeson

159−import Data.Aeson.Encode.Pretty (encodePretty)

160−import Data.Ord(comparing)

161import Data.ByteString.Lazy.Char8 (ByteString)

163import Data.ByteString.Lazy.Char8 (ByteString)

162import Data.Hashable

164import Data.Hashable

163import Data.HashMap.Strict (HashMap)

165import Data.HashMap.Strict (HashMap)

164import Data.List

166import Data.List

165−import Data.Maybe (listToMaybe)

167+import Data.Maybe

166import Data.Monoid

168import Data.Monoid

169+import Data.Ord (comparing)

167import Data.Proxy

170import Data.Proxy

168−import Data.Text (Text, pack, unpack)

169import Data.String.Conversions

171import Data.String.Conversions

172+import Data.Text (Text, pack, unpack)

170import GHC.Generics

173import GHC.Generics

171import GHC.TypeLits

174import GHC.TypeLits

172import Servant.API

175import Servant.API

176+import Servant.API.ContentTypes

173

177

174import qualified Data.HashMap.Strict as HM

178import 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

176

181

177-- | Supported HTTP request methods

182-- | Supported HTTP request methods

178data Method = DocDELETE -- ^ the DELETE method

183data Method = DocDELETE -- ^ the DELETE method

@@ -315,7 +320,7 @@ data ParamKind = Normal | List | Flag

315-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}

320-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}

316data Response = Response

321data Response = Response

317 { _respStatus :: Int

322 { _respStatus :: Int

318− , _respBody :: [(Text, ByteString)]

323+ , _respBody :: [(Text, M.MediaType, ByteString)]

319 } deriving (Eq, Show)

324 } deriving (Eq, Show)

320

325

321-- | Default response: status code 200, no response body.

326-- | Default response: status code 200, no response body.

@@ -345,7 +350,7 @@ data Action = Action

345 , _params :: [DocQueryParam] -- type collected + user supplied info

350 , _params :: [DocQueryParam] -- type collected + user supplied info

346 , _notes :: [DocNote] -- user supplied

351 , _notes :: [DocNote] -- user supplied

347 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

352 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

348− , _rqbody :: Maybe ByteString -- user supplied

353+ , _rqbody :: Maybe [(M.MediaType, ByteString)] -- user supplied

349 , _response :: Response -- user supplied

354 , _response :: Response -- user supplied

350 } deriving (Eq, Show)

355 } deriving (Eq, Show)

351

356

@@ -428,24 +433,38 @@ class HasDocs layout where

428-- You can also instantiate this class using 'toSamples' instead of

433-- You can also instantiate this class using 'toSamples' instead of

429-- 'toSample': it lets you specify different responses along with

434-- 'toSample': it lets you specify different responses along with

430-- some context (as 'Text') that explains when you're supposed to

435-- some context (as 'Text') that explains when you're supposed to

431−-- get the corresponding response.

436+-- get the corresponding response.

432class ToJSON a => ToSample a where

437class ToJSON a => ToSample a where

433 {-# MINIMAL (toSample | toSamples) #-}

438 {-# MINIMAL (toSample | toSamples) #-}

434 toSample :: Maybe a

439 toSample :: Maybe a

435− toSample = fmap snd $ listToMaybe samples

440+ toSample = snd <$> listToMaybe samples

436 where samples = toSamples :: [(Text, a)]

441 where samples = toSamples :: [(Text, a)]

437

442

438 toSamples :: [(Text, a)]

443 toSamples :: [(Text, a)]

439 toSamples = maybe [] (return . ("",)) s

444 toSamples = maybe [] (return . ("",)) s

440 where s = toSample :: Maybe a

445 where s = toSample :: Maybe a

441

446

442−sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString

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)]

443−sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)

453+sampleByteString ctypes@Proxy Proxy =

444−

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.

445−sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]

458+sampleByteStrings

459+ :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)

460+ => Proxy ctypes

461+ -> Proxy a

462+ -> [(Text, M.MediaType, ByteString)]

446−sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty

463+sampleByteStrings ctypes@Proxy Proxy =

447−

448− where samples = toSamples :: [(Text, a)]

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

449

468

450-- | The class that helps us automatically get documentation

469-- | The class that helps us automatically get documentation

451-- for GET parameters.

470-- for GET parameters.

@@ -574,16 +593,26 @@ markdown api = unlines $

574

593

575 where values = param ^. paramValues

594 where values = param ^. paramValues

576

595

577− rqbodyStr :: Maybe ByteString -> [String]

596+ rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String]

578 rqbodyStr Nothing = []

597 rqbodyStr Nothing = []

579− rqbodyStr (Just b) =

598+ rqbodyStr (Just b) = concatMap formatBody b

580− "#### Request Body:" :

581− jsonStr b

582

599

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 =

584 "" :

613 "" :

585− "``` javascript" :

614+ "``` " <> markdownForType mime_type :

586− cs b :

615+ cs body :

587 "```" :

616 "```" :

588 "" :

617 "" :

589 []

618 []

@@ -597,9 +626,9 @@ markdown api = unlines $

597

626

598 where bodies = case resp ^. respBody of

627 where bodies = case resp ^. respBody of

599 [] -> [" - No response body\n"]

628 [] -> [" - No response body\n"]

600− [("", r)] -> " - Response body as below." : jsonStr r

629+ [("", t, r)] -> " - Response body as below." : contentStr t r

601 xs ->

630 xs ->

602− concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs

631+ concatMap (\(ctx, t, r) -> (" - " <> T.unpack ctx) : contentStr t r) xs

603

632

604-- * Instances

633-- * Instances

605

634

@@ -641,14 +670,16 @@ instance HasDocs Delete where

641 action' = action & response.respBody .~ []

670 action' = action & response.respBody .~ []

642 & response.respStatus .~ 204

671 & response.respStatus .~ 204

643

672

644−instance ToSample a => HasDocs (Get cts a) where

673+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts a) where

645 docsFor Proxy (endpoint, action) =

674 docsFor Proxy (endpoint, action) =

646 single endpoint' action'

675 single endpoint' action'

647

676

648 where endpoint' = endpoint & method .~ DocGET

677 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

650 p = Proxy :: Proxy a

680 p = Proxy :: Proxy a

651

681

682+

652instance (KnownSymbol sym, HasDocs sublayout)

683instance (KnownSymbol sym, HasDocs sublayout)

653 => HasDocs (Header sym a :> sublayout) where

684 => HasDocs (Header sym a :> sublayout) where

654 docsFor Proxy (endpoint, action) =

685 docsFor Proxy (endpoint, action) =

@@ -658,29 +689,26 @@ instance (KnownSymbol sym, HasDocs sublayout)

658 action' = over headers (|> headername) action

689 action' = over headers (|> headername) action

659 headername = pack $ symbolVal (Proxy :: Proxy sym)

690 headername = pack $ symbolVal (Proxy :: Proxy sym)

660

691

661−instance ToSample a => HasDocs (Post cts a) where

692+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts a) where

662 docsFor Proxy (endpoint, action) =

693 docsFor Proxy (endpoint, action) =

663 single endpoint' action'

694 single endpoint' action'

664

695

665 where endpoint' = endpoint & method .~ DocPOST

696 where endpoint' = endpoint & method .~ DocPOST

666−

667− action' = action & response.respBody .~ sampleByteStrings p

697+ action' = action & response.respBody .~ sampleByteStrings t p

668 & response.respStatus .~ 201

698 & response.respStatus .~ 201

669−

699+ t = Proxy :: Proxy cts

670 p = Proxy :: Proxy a

700 p = Proxy :: Proxy a

671

701

672−instance ToSample a => HasDocs (Put cts a) where

702+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts a) where

673 docsFor Proxy (endpoint, action) =

703 docsFor Proxy (endpoint, action) =

674 single endpoint' action'

704 single endpoint' action'

675

705

676 where endpoint' = endpoint & method .~ DocPUT

706 where endpoint' = endpoint & method .~ DocPUT

677−

678− action' = action & response.respBody .~ sampleByteStrings p

707+ action' = action & response.respBody .~ sampleByteStrings t p

679 & response.respStatus .~ 200

708 & response.respStatus .~ 200

680−

709+ t = Proxy :: Proxy cts

681 p = Proxy :: Proxy a

710 p = Proxy :: Proxy a

682

711

683−

684instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)

712instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)

685 => HasDocs (QueryParam sym a :> sublayout) where

713 => HasDocs (QueryParam sym a :> sublayout) where

686

714

@@ -755,20 +783,23 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)

755 endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint

783 endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint

756 symP = Proxy :: Proxy sym

784 symP = Proxy :: Proxy sym

757

785

758−

759instance HasDocs Raw where

786instance HasDocs Raw where

760 docsFor _proxy (endpoint, action) =

787 docsFor _proxy (endpoint, action) =

761 single endpoint action

788 single endpoint action

762

789

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.

763−instance (ToSample a, HasDocs sublayout)

794+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)

764 => HasDocs (ReqBody cts a :> sublayout) where

795 => HasDocs (ReqBody cts a :> sublayout) where

765

796

766 docsFor Proxy (endpoint, action) =

797 docsFor Proxy (endpoint, action) =

767 docsFor sublayoutP (endpoint, action')

798 docsFor sublayoutP (endpoint, action')

768

799

769 where sublayoutP = Proxy :: Proxy sublayout

800 where sublayoutP = Proxy :: Proxy sublayout

770−

771− action' = action & rqbody .~ sampleByteString p

801+ action' = action & rqbody .~ sampleByteString t p

802+ t = Proxy :: Proxy cts

772 p = Proxy :: Proxy a

803 p = Proxy :: Proxy a

773

804

774instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where

805instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where