@@ -0,0 +1,588 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TemplateHaskell #-}
8+
9+-------------------------------------------------------------------------------
10+-- | This module lets you get API docs for free. It lets generate
11+-- an 'API' from the type that represents your API using 'docs':
12+--
13+-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
14+--
15+-- You can then call 'markdown' on it:
16+--
17+-- @markdown :: 'API' -> String@
18+--
19+-- or define a custom pretty printer:
20+--
21+-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@
22+--
23+-- The only thing you'll need to do will be to implement some classes
24+-- for your captures, get parameters and request or response bodies.
25+--
26+-- Here's a little (but complete) example that you can run to see the
27+-- markdown pretty printer in action:
28+--
29+-- > {-# LANGUAGE DataKinds #-}
30+-- > {-# LANGUAGE PolyKinds #-}
31+-- > {-# LANGUAGE TypeFamilies #-}
32+-- > {-# LANGUAGE DeriveGeneric #-}
33+-- > {-# LANGUAGE TypeOperators #-}
34+-- > {-# LANGUAGE FlexibleInstances #-}
35+-- > {-# LANGUAGE OverloadedStrings #-}
36+-- >
37+-- > import Data.Proxy
38+-- > import Data.Text
39+-- > import Servant
40+-- >
41+-- > -- our type for a Greeting message
42+-- > data Greet = Greet { _msg :: Text }
43+-- > deriving (Generic, Show)
44+-- >
45+-- > -- we get our JSON serialization for free
46+-- > instance FromJSON Greet
47+-- > instance ToJSON Greet
48+-- >
49+-- > -- we provide a sample value for the 'Greet' type
50+-- > instance ToSample Greet where
51+-- > toSample = Just g
52+-- >
53+-- > where g = Greet "Hello, haskeller!"
54+-- >
55+-- > instance ToParam (QueryParam "capital" Bool) where
56+-- > toParam _ =
57+-- > DocQueryParam "capital"
58+-- > ["true", "false"]
59+-- > "Get the greeting message in uppercase (true) or not (false). Default is false."
60+-- >
61+-- > instance ToCapture (Capture "name" Text) where
62+-- > toCapture _ = DocCapture "name" "name of the person to greet"
63+-- >
64+-- > instance ToCapture (Capture "greetid" Text) where
65+-- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
66+-- >
67+-- > -- API specification
68+-- > type TestApi =
69+-- > "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
70+-- > :<|> "greet" :> RQBody Greet :> Post Greet
71+-- > :<|> "delete" :> Capture "greetid" Text :> Delete
72+-- >
73+-- > testApi :: Proxy TestApi
74+-- > testApi = Proxy
75+-- >
76+-- > -- Generate the Documentation's ADT
77+-- > greetDocs :: API
78+-- > greetDocs = docs testApi
79+-- >
80+-- > main :: IO ()
81+-- > main = putStrLn $ markdown greetDocs
82+module Servant.Docs
83+ ( -- * 'HasDocs' class and key functions
84+ HasDocs(..), docs, markdown
85+
86+ {- , -- * Serving the documentation
87+ serveDocumentation -}
88+
89+ , -- * Classes you need to implement for your types
90+ ToSample(..)
91+ , sampleByteString
92+ , ToParam(..)
93+ , ToCapture(..)
94+
95+ , -- * ADTs to represent an 'API'
96+ Method(..)
97+ , Endpoint, path, method, defEndpoint
98+ , API, emptyAPI
99+ , DocCapture(..), capSymbol, capDesc
100+ , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
101+ , Response, respStatus, respBody, defResponse
102+ , Action, captures, params, rqbody, response, defAction
103+ , single
104+
105+ , -- * Useful modules when defining your doc printers
106+ module Control.Lens
107+ , module Data.Monoid
108+ ) where
109+
110+import Control.Lens hiding (Action)
111+import Data.Aeson
112+import Data.ByteString.Lazy.Char8 (ByteString)
113+import Data.Hashable
114+import Data.HashMap.Strict (HashMap)
115+import Data.List
116+import Data.Monoid
117+import Data.Proxy
118+import Data.String.Conversions
119+import GHC.Generics
120+import GHC.TypeLits
121+import Servant
122+
123+import qualified Data.HashMap.Strict as HM
124+
125+-- | Supported HTTP request methods
126+data Method = DocDELETE -- ^ the DELETE method
127+ | DocGET -- ^ the GET method
128+ | DocPOST -- ^ the POST method
129+ | DocPUT -- ^ the PUT method
130+ deriving (Eq, Generic)
131+
132+instance Show Method where
133+ show DocGET = "GET"
134+ show DocPOST = "POST"
135+ show DocDELETE = "DELETE"
136+ show DocPUT = "PUT"
137+
138+instance Hashable Method
139+
140+-- | An 'Endpoint' type that holds the 'path' and the 'method'.
141+--
142+-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'
143+-- or any 'Endpoint' value you want using the 'path' and 'method'
144+-- lenses to tweak.
145+--
146+-- @
147+-- λ> 'defEndpoint'
148+-- GET /
149+-- λ> 'defEndpoint' & 'path' '<>~' "foo"
150+-- GET /foo
151+-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST'
152+-- POST /foo
153+-- @
154+data Endpoint = Endpoint
155+ { _path :: String -- type collected
156+ , _method :: Method -- type collected
157+ } deriving (Eq, Generic)
158+
159+instance Show Endpoint where
160+ show (Endpoint p m) =
161+ show m ++ " " ++ p
162+
163+-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
164+--
165+-- Here's how you can modify it:
166+--
167+-- @
168+-- λ> 'defEndpoint'
169+-- GET /
170+-- λ> 'defEndpoint' & 'path' '<>~' "foo"
171+-- GET /foo
172+-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST'
173+-- POST /foo
174+-- @
175+defEndpoint :: Endpoint
176+defEndpoint = Endpoint "/" DocGET
177+
178+instance Hashable Endpoint
179+
180+-- | Our API type, a good old hashmap from 'Endpoint' to 'Action'
181+type API = HashMap Endpoint Action
182+
183+-- | An empty 'API'
184+emptyAPI :: API
185+emptyAPI = HM.empty
186+
187+-- | A type to represent captures. Holds the name of the capture
188+-- and a description.
189+--
190+-- Write a 'ToCapture' instance for your captured types.
191+data DocCapture = DocCapture
192+ { _capSymbol :: String -- type supplied
193+ , _capDesc :: String -- user supplied
194+ } deriving (Eq, Show)
195+
196+-- | A type to represent a /GET/ parameter from the Query String. Holds its name,
197+-- the possible values (leave empty if there isn't a finite number of them),
198+-- and a description of how it influences the output or behavior.
199+--
200+-- Write a 'ToParam' instance for your GET parameter types
201+data DocQueryParam = DocQueryParam
202+ { _paramName :: String -- type supplied
203+ , _paramValues :: [String] -- user supplied
204+ , _paramDesc :: String -- user supplied
205+ , _paramKind :: ParamKind
206+ } deriving (Eq, Show)
207+
208+-- | Type of GET parameter:
209+--
210+-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
211+-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values
212+-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter
213+data ParamKind = Normal | List | Flag
214+ deriving (Eq, Show)
215+
216+-- | A type to represent an HTTP response. Has an 'Int' status and
217+-- a 'Maybe ByteString' response body. Tweak 'defResponse' using
218+-- the 'respStatus' and 'respBody' lenses if you want.
219+--
220+-- If you want to respond with a non-empty response body, you'll most likely
221+-- want to write a 'ToSample' instance for the type that'll be represented
222+-- as some JSON in the response.
223+--
224+-- Can be tweaked with two lenses.
225+--
226+-- > λ> defResponse
227+-- > Response {_respStatus = 200, _respBody = Nothing}
228+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
229+-- > Response {_respStatus = 204, _respBody = Just "[]"}
230+data Response = Response
231+ { _respStatus :: Int
232+ , _respBody :: Maybe ByteString
233+ } deriving (Eq, Show)
234+
235+-- | Default response: status code 200, no response body.
236+--
237+-- Can be tweaked with two lenses.
238+--
239+-- > λ> defResponse
240+-- > Response {_respStatus = 200, _respBody = Nothing}
241+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
242+-- > Response {_respStatus = 204, _respBody = Just "[]"}
243+defResponse :: Response
244+defResponse = Response 200 Nothing
245+
246+-- | A datatype that represents everything that can happen
247+-- at an endpoint, with its lenses:
248+--
249+-- - List of captures ('captures')
250+-- - List of GET parameters ('params')
251+-- - What the request body should look like, if any is requested ('rqbody')
252+-- - What the response should be if everything goes well ('response')
253+--
254+-- You can tweak an 'Action' (like the default 'defAction') with these lenses
255+-- to transform an action and add some information to it.
256+data Action = Action
257+ { _captures :: [DocCapture] -- type collected + user supplied info
258+ , _params :: [DocQueryParam] -- type collected + user supplied info
259+ , _rqbody :: Maybe ByteString -- user supplied
260+ , _response :: Response -- user supplied
261+ } deriving (Eq, Show)
262+
263+-- Default 'Action'. Has no 'captures', no GET 'params', expects
264+-- no request body ('rqbody') and the typical response is 'defResponse'.
265+--
266+-- Tweakable with lenses.
267+--
268+-- > λ> defAction
269+-- > Action {_captures = [], _params = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
270+-- > λ> defAction & response.respStatus .~ 201
271+-- > Action {_captures = [], _params = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
272+defAction :: Action
273+defAction =
274+ Action []
275+ []
276+ Nothing
277+ defResponse
278+
279+-- | Create an API that's comprised of a single endpoint.
280+-- 'API' is a 'Monoid', so combine multiple endpoints with
281+-- 'mappend' or '<>'.
282+single :: Endpoint -> Action -> API
283+single = HM.singleton
284+
285+-- gimme some lenses
286+makeLenses ''Endpoint
287+makeLenses ''DocCapture
288+makeLenses ''DocQueryParam
289+makeLenses ''Response
290+makeLenses ''Action
291+
292+-- | Generate the docs for a given API that implements 'HasDocs'.
293+docs :: HasDocs layout => Proxy layout -> API
294+docs p = docsFor p (defEndpoint, defAction)
295+
296+-- | The class that abstracts away the impact of API combinators
297+-- on documentation generation.
298+class HasDocs layout where
299+ docsFor :: Proxy layout -> (Endpoint, Action) -> API
300+
301+-- | The class that lets us display a sample JSON input or output
302+-- when generating documentation for endpoints that either:
303+--
304+-- - expect a request body, or
305+-- - return a non empty response body
306+--
307+-- Example of an instance:
308+--
309+-- > {-# LANGUAGE DeriveGeneric #-}
310+-- > {-# LANGUAGE OverloadedStrings #-}
311+-- >
312+-- > import Data.Aeson
313+-- > import Data.Text
314+-- > import GHC.Generics
315+-- >
316+-- > data Greet = Greet { _msg :: Text }
317+-- > deriving (Generic, Show)
318+-- >
319+-- > instance FromJSON Greet
320+-- > instance ToJSON Greet
321+-- >
322+-- > instance ToSample Greet where
323+-- > toSample = Just g
324+-- >
325+-- > where g = Greet "Hello, haskeller!"
326+class ToJSON a => ToSample a where
327+ toSample :: Maybe a
328+
329+instance ToSample () where
330+ toSample = Just ()
331+
332+sampleByteString :: forall a . ToSample a => Proxy a -> Maybe ByteString
333+sampleByteString Proxy = fmap encode (toSample :: Maybe a)
334+
335+-- | The class that helps us automatically get documentation
336+-- for GET parameters.
337+--
338+-- Example of an instance:
339+--
340+-- > instance ToParam (QueryParam "capital" Bool) where
341+-- > toParam _ =
342+-- > DocQueryParam "capital"
343+-- > ["true", "false"]
344+-- > "Get the greeting message in uppercase (true) or not (false). Default is false."
345+class ToParam t where
346+ toParam :: Proxy t -> DocQueryParam
347+
348+-- | The class that helps us automatically get documentation
349+-- for URL captures.
350+--
351+-- Example of an instance:
352+--
353+-- > instance ToCapture (Capture "name" Text) where
354+-- > toCapture _ = DocCapture "name" "name of the person to greet"
355+class ToCapture c where
356+ toCapture :: Proxy c -> DocCapture
357+
358+-- | Generate documentation in Markdown format for
359+-- the given 'API'.
360+markdown :: API -> String
361+markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
362+
363+ where printEndpoint :: Endpoint -> Action -> [String]
364+ printEndpoint endpoint action =
365+ str :
366+ replicate len '-' :
367+ "" :
368+ capturesStr (action ^. captures) ++
369+ paramsStr (action ^. params) ++
370+ rqbodyStr (action ^. rqbody) ++
371+ responseStr (action ^. response) ++
372+ []
373+
374+ where str = show (endpoint^.method) ++ " " ++ endpoint^.path
375+ len = length str
376+
377+ capturesStr :: [DocCapture] -> [String]
378+ capturesStr [] = []
379+ capturesStr l =
380+ "**Captures**: " :
381+ "" :
382+ map captureStr l ++
383+ "" :
384+ []
385+ captureStr cap =
386+ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
387+
388+ paramsStr :: [DocQueryParam] -> [String]
389+ paramsStr [] = []
390+ paramsStr l =
391+ "**GET Parameters**: " :
392+ "" :
393+ map paramStr l ++
394+ "" :
395+ []
396+ paramStr param = unlines $
397+ (" - " ++ param ^. paramName) :
398+ (if (not (null values) || param ^. paramKind /= Flag)
399+ then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
400+ else []) ++
401+ (" - **Description**: " ++ param ^. paramDesc) :
402+ (if (param ^. paramKind == List)
403+ then [" - This parameter is a **list**. All GET parameters with the name "
404+ ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
405+ else []) ++
406+ (if (param ^. paramKind == Flag)
407+ then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
408+ else []) ++
409+ []
410+
411+ where values = param ^. paramValues
412+
413+ rqbodyStr :: Maybe ByteString -> [String]
414+ rqbodyStr Nothing = []
415+ rqbodyStr (Just b) =
416+ "**Request Body**: " :
417+ jsonStr b
418+
419+ jsonStr b =
420+ "" :
421+ "``` javascript" :
422+ cs b :
423+ "```" :
424+ "" :
425+ []
426+
427+ responseStr :: Response -> [String]
428+ responseStr resp =
429+ "**Response**: " :
430+ "" :
431+ (" - Status code " ++ show (resp ^. respStatus)) :
432+ (resp ^. respBody &
433+ maybe [" - No response body\n"]
434+ (\b -> " - Response body as below." : jsonStr b))
435+
436+-- * Instances
437+
438+-- | The generated docs for @a ':<|>' b@ just appends the docs
439+-- for @a@ with the docs for @b@.
440+instance (HasDocs layout1, HasDocs layout2)
441+ => HasDocs (layout1 :<|> layout2) where
442+
443+ docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
444+
445+ where p1 :: Proxy layout1
446+ p1 = Proxy
447+
448+ p2 :: Proxy layout2
449+ p2 = Proxy
450+
451+-- | @"books" :> 'Capture' "isbn" Text@ will appear as
452+-- @/books/:isbn@ in the docs.
453+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
454+ => HasDocs (Capture sym a :> sublayout) where
455+
456+ docsFor Proxy (endpoint, action) =
457+ docsFor sublayoutP (endpoint', action')
458+
459+ where sublayoutP = Proxy :: Proxy sublayout
460+ captureP = Proxy :: Proxy (Capture sym a)
461+
462+ action' = over captures (|> toCapture captureP) action
463+ endpoint' = over path (\p -> p++"/:"++symbolVal symP) endpoint
464+ symP = Proxy :: Proxy sym
465+
466+
467+instance HasDocs Delete where
468+ docsFor Proxy (endpoint, action) =
469+ single endpoint' action'
470+
471+ where endpoint' = endpoint & method .~ DocDELETE
472+
473+ action' = action & response.respBody .~ Nothing
474+ & response.respStatus .~ 204
475+
476+instance ToSample a => HasDocs (Get a) where
477+ docsFor Proxy (endpoint, action) =
478+ single endpoint' action'
479+
480+ where endpoint' = endpoint & method .~ DocGET
481+ action' = action & response.respBody .~ sampleByteString p
482+ p = Proxy :: Proxy a
483+
484+instance ToSample a => HasDocs (Post a) where
485+ docsFor Proxy (endpoint, action) =
486+ single endpoint' action'
487+
488+ where endpoint' = endpoint & method .~ DocPOST
489+
490+ action' = action & response.respBody .~ sampleByteString p
491+ & response.respStatus .~ 201
492+
493+ p = Proxy :: Proxy a
494+
495+instance ToSample a => HasDocs (Put a) where
496+ docsFor Proxy (endpoint, action) =
497+ single endpoint' action'
498+
499+ where endpoint' = endpoint & method .~ DocPUT
500+
501+ action' = action & response.respBody .~ sampleByteString p
502+ & response.respStatus .~ 200
503+
504+ p = Proxy :: Proxy a
505+
506+
507+instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
508+ => HasDocs (QueryParam sym a :> sublayout) where
509+
510+ docsFor Proxy (endpoint, action) =
511+ docsFor sublayoutP (endpoint, action')
512+
513+ where sublayoutP = Proxy :: Proxy sublayout
514+ paramP = Proxy :: Proxy (QueryParam sym a)
515+ action' = over params (|> toParam paramP) action
516+
517+instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
518+ => HasDocs (QueryParams sym a :> sublayout) where
519+
520+ docsFor Proxy (endpoint, action) =
521+ docsFor sublayoutP (endpoint, action')
522+
523+ where sublayoutP = Proxy :: Proxy sublayout
524+ paramP = Proxy :: Proxy (QueryParams sym a)
525+ action' = over params (|> toParam paramP) action
526+
527+
528+instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
529+ => HasDocs (QueryFlag sym :> sublayout) where
530+
531+ docsFor Proxy (endpoint, action) =
532+ docsFor sublayoutP (endpoint, action')
533+
534+ where sublayoutP = Proxy :: Proxy sublayout
535+ paramP = Proxy :: Proxy (QueryFlag sym)
536+ action' = over params (|> toParam paramP) action
537+
538+instance HasDocs Raw where
539+ docsFor _proxy (endpoint, action) =
540+ single endpoint action
541+
542+instance (ToSample a, HasDocs sublayout)
543+ => HasDocs (ReqBody a :> sublayout) where
544+
545+ docsFor Proxy (endpoint, action) =
546+ docsFor sublayoutP (endpoint, action')
547+
548+ where sublayoutP = Proxy :: Proxy sublayout
549+
550+ action' = action & rqbody .~ sampleByteString p
551+ p = Proxy :: Proxy a
552+
553+instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
554+
555+ docsFor Proxy (endpoint, action) =
556+ docsFor sublayoutP (endpoint', action)
557+
558+ where sublayoutP = Proxy :: Proxy sublayout
559+ endpoint' = endpoint & path <>~ symbolVal pa
560+ pa = Proxy :: Proxy path
561+
562+{-
563+
564+-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
565+--
566+-- > type MyApi = "users" :> Get [User]
567+-- > :<|> "docs :> Raw
568+-- >
569+-- > apiProxy :: Proxy MyApi
570+-- > apiProxy = Proxy
571+-- >
572+-- > server :: Server MyApi
573+-- > server = listUsers
574+-- > :<|> serveDocumentation apiProxy
575+serveDocumentation :: HasDocs api => Proxy api -> Server Raw
576+serveDocumentation proxy _request respond =
577+ respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
578+
579+toHtml :: String -> String
580+toHtml md =
581+ "<html>" ++
582+ "<body>" ++
583+ "<pre>" ++
584+ md ++
585+ "</pre>" ++
586+ "</body>" ++
587+ "</html>"
588+-}