@@ -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 #-}
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':
13+-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
15+-- You can then call 'markdown' on it:
17+-- @markdown :: 'API' -> String@
19+-- or define a custom pretty printer:
21+-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@
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.
26+-- Here's a little (but complete) example that you can run to see the
27+-- markdown pretty printer in action:
29+-- > {-# LANGUAGE DataKinds #-}
30+-- > {-# LANGUAGE PolyKinds #-}
31+-- > {-# LANGUAGE TypeFamilies #-}
32+-- > {-# LANGUAGE DeriveGeneric #-}
33+-- > {-# LANGUAGE TypeOperators #-}
34+-- > {-# LANGUAGE FlexibleInstances #-}
35+-- > {-# LANGUAGE OverloadedStrings #-}
37+-- > import Data.Proxy
41+-- > -- our type for a Greeting message
42+-- > data Greet = Greet { _msg :: Text }
43+-- > deriving (Generic, Show)
45+-- > -- we get our JSON serialization for free
46+-- > instance FromJSON Greet
47+-- > instance ToJSON Greet
49+-- > -- we provide a sample value for the 'Greet' type
50+-- > instance ToSample Greet where
51+-- > toSample = Just g
53+-- > where g = Greet "Hello, haskeller!"
55+-- > instance ToParam (QueryParam "capital" Bool) where
57+-- > DocQueryParam "capital"
58+-- > ["true", "false"]
59+-- > "Get the greeting message in uppercase (true) or not (false). Default is false."
61+-- > instance ToCapture (Capture "name" Text) where
62+-- > toCapture _ = DocCapture "name" "name of the person to greet"
64+-- > instance ToCapture (Capture "greetid" Text) where
65+-- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
67+-- > -- API specification
69+-- > "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
70+-- > :<|> "greet" :> RQBody Greet :> Post Greet
71+-- > :<|> "delete" :> Capture "greetid" Text :> Delete
73+-- > testApi :: Proxy TestApi
76+-- > -- Generate the Documentation's ADT
78+-- > greetDocs = docs testApi
81+-- > main = putStrLn $ markdown greetDocs
83+ ( -- * 'HasDocs' class and key functions
84+ HasDocs(..), docs, markdown
86+ {- , -- * Serving the documentation
87+ serveDocumentation -}
89+ , -- * Classes you need to implement for your types
95+ , -- * ADTs to represent an 'API'
97+ , Endpoint, path, method, defEndpoint
99+ , DocCapture(..), capSymbol, capDesc
100+ , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
101+ , Response, respStatus, respBody, defResponse
102+ , Action, captures, params, rqbody, response, defAction
105+ , -- * Useful modules when defining your doc printers
107+ , module Data.Monoid
110+import Control.Lens hiding (Action)
112+import Data.ByteString.Lazy.Char8 (ByteString)
114+import Data.HashMap.Strict (HashMap)
118+import Data.String.Conversions
123+import qualified Data.HashMap.Strict as HM
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)
132+instance Show Method where
134+ show DocPOST = "POST"
135+ show DocDELETE = "DELETE"
138+instance Hashable Method
140+-- | An 'Endpoint' type that holds the 'path' and the 'method'.
142+-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'
143+-- or any 'Endpoint' value you want using the 'path' and 'method'
149+-- λ> 'defEndpoint' & 'path' '<>~' "foo"
151+-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST'
154+data Endpoint = Endpoint
155+ { _path :: String -- type collected
156+ , _method :: Method -- type collected
157+ } deriving (Eq, Generic)
159+instance Show Endpoint where
160+ show (Endpoint p m) =
163+-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
165+-- Here's how you can modify it:
170+-- λ> 'defEndpoint' & 'path' '<>~' "foo"
172+-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST'
175+defEndpoint :: Endpoint
176+defEndpoint = Endpoint "/" DocGET
178+instance Hashable Endpoint
180+-- | Our API type, a good old hashmap from 'Endpoint' to 'Action'
181+type API = HashMap Endpoint Action
187+-- | A type to represent captures. Holds the name of the capture
188+-- and a description.
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)
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.
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)
208+-- | Type of GET parameter:
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
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.
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.
224+-- Can be tweaked with two lenses.
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)
235+-- | Default response: status code 200, no response body.
237+-- Can be tweaked with two lenses.
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
246+-- | A datatype that represents everything that can happen
247+-- at an endpoint, with its lenses:
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')
254+-- You can tweak an 'Action' (like the default 'defAction') with these lenses
255+-- to transform an action and add some information to it.
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)
263+-- Default 'Action'. Has no 'captures', no GET 'params', expects
264+-- no request body ('rqbody') and the typical response is 'defResponse'.
266+-- Tweakable with lenses.
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}}
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
286+makeLenses ''Endpoint
287+makeLenses ''DocCapture
288+makeLenses ''DocQueryParam
289+makeLenses ''Response
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)
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
301+-- | The class that lets us display a sample JSON input or output
302+-- when generating documentation for endpoints that either:
304+-- - expect a request body, or
305+-- - return a non empty response body
307+-- Example of an instance:
309+-- > {-# LANGUAGE DeriveGeneric #-}
310+-- > {-# LANGUAGE OverloadedStrings #-}
312+-- > import Data.Aeson
313+-- > import Data.Text
314+-- > import GHC.Generics
316+-- > data Greet = Greet { _msg :: Text }
317+-- > deriving (Generic, Show)
319+-- > instance FromJSON Greet
320+-- > instance ToJSON Greet
322+-- > instance ToSample Greet where
323+-- > toSample = Just g
325+-- > where g = Greet "Hello, haskeller!"
326+class ToJSON a => ToSample a where
329+instance ToSample () where
332+sampleByteString :: forall a . ToSample a => Proxy a -> Maybe ByteString
333+sampleByteString Proxy = fmap encode (toSample :: Maybe a)
335+-- | The class that helps us automatically get documentation
336+-- for GET parameters.
338+-- Example of an instance:
340+-- > instance ToParam (QueryParam "capital" Bool) where
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
348+-- | The class that helps us automatically get documentation
351+-- Example of an instance:
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
358+-- | Generate documentation in Markdown format for
360+markdown :: API -> String
361+markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
363+ where printEndpoint :: Endpoint -> Action -> [String]
364+ printEndpoint endpoint action =
368+ capturesStr (action ^. captures) ++
369+ paramsStr (action ^. params) ++
370+ rqbodyStr (action ^. rqbody) ++
371+ responseStr (action ^. response) ++
374+ where str = show (endpoint^.method) ++ " " ++ endpoint^.path
377+ capturesStr :: [DocCapture] -> [String]
386+ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
388+ paramsStr :: [DocQueryParam] -> [String]
391+ "**GET Parameters**: " :
396+ paramStr param = unlines $
397+ (" - " ++ param ^. paramName) :
398+ (if (not (null values) || param ^. paramKind /= Flag)
399+ then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
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."]
406+ (if (param ^. paramKind == Flag)
407+ then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
411+ where values = param ^. paramValues
413+ rqbodyStr :: Maybe ByteString -> [String]
414+ rqbodyStr Nothing = []
415+ rqbodyStr (Just b) =
416+ "**Request Body**: " :
427+ responseStr :: Response -> [String]
431+ (" - Status code " ++ show (resp ^. respStatus)) :
433+ maybe [" - No response body\n"]
434+ (\b -> " - Response body as below." : jsonStr b))
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
443+ docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
445+ where p1 :: Proxy layout1
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
456+ docsFor Proxy (endpoint, action) =
457+ docsFor sublayoutP (endpoint', action')
459+ where sublayoutP = Proxy :: Proxy sublayout
460+ captureP = Proxy :: Proxy (Capture sym a)
462+ action' = over captures (|> toCapture captureP) action
463+ endpoint' = over path (\p -> p++"/:"++symbolVal symP) endpoint
464+ symP = Proxy :: Proxy sym
467+instance HasDocs Delete where
468+ docsFor Proxy (endpoint, action) =
469+ single endpoint' action'
471+ where endpoint' = endpoint & method .~ DocDELETE
473+ action' = action & response.respBody .~ Nothing
474+ & response.respStatus .~ 204
476+instance ToSample a => HasDocs (Get a) where
477+ docsFor Proxy (endpoint, action) =
478+ single endpoint' action'
480+ where endpoint' = endpoint & method .~ DocGET
481+ action' = action & response.respBody .~ sampleByteString p
482+ p = Proxy :: Proxy a
484+instance ToSample a => HasDocs (Post a) where
485+ docsFor Proxy (endpoint, action) =
486+ single endpoint' action'
488+ where endpoint' = endpoint & method .~ DocPOST
490+ action' = action & response.respBody .~ sampleByteString p
491+ & response.respStatus .~ 201
493+ p = Proxy :: Proxy a
495+instance ToSample a => HasDocs (Put a) where
496+ docsFor Proxy (endpoint, action) =
497+ single endpoint' action'
499+ where endpoint' = endpoint & method .~ DocPUT
501+ action' = action & response.respBody .~ sampleByteString p
502+ & response.respStatus .~ 200
504+ p = Proxy :: Proxy a
507+instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
508+ => HasDocs (QueryParam sym a :> sublayout) where
510+ docsFor Proxy (endpoint, action) =
511+ docsFor sublayoutP (endpoint, action')
513+ where sublayoutP = Proxy :: Proxy sublayout
514+ paramP = Proxy :: Proxy (QueryParam sym a)
515+ action' = over params (|> toParam paramP) action
517+instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
518+ => HasDocs (QueryParams sym a :> sublayout) where
520+ docsFor Proxy (endpoint, action) =
521+ docsFor sublayoutP (endpoint, action')
523+ where sublayoutP = Proxy :: Proxy sublayout
524+ paramP = Proxy :: Proxy (QueryParams sym a)
525+ action' = over params (|> toParam paramP) action
528+instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
529+ => HasDocs (QueryFlag sym :> sublayout) where
531+ docsFor Proxy (endpoint, action) =
532+ docsFor sublayoutP (endpoint, action')
534+ where sublayoutP = Proxy :: Proxy sublayout
535+ paramP = Proxy :: Proxy (QueryFlag sym)
536+ action' = over params (|> toParam paramP) action
538+instance HasDocs Raw where
539+ docsFor _proxy (endpoint, action) =
540+ single endpoint action
542+instance (ToSample a, HasDocs sublayout)
543+ => HasDocs (ReqBody a :> sublayout) where
545+ docsFor Proxy (endpoint, action) =
546+ docsFor sublayoutP (endpoint, action')
548+ where sublayoutP = Proxy :: Proxy sublayout
550+ action' = action & rqbody .~ sampleByteString p
551+ p = Proxy :: Proxy a
553+instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
555+ docsFor Proxy (endpoint, action) =
556+ docsFor sublayoutP (endpoint', action)
558+ where sublayoutP = Proxy :: Proxy sublayout
559+ endpoint' = endpoint & path <>~ symbolVal pa
560+ pa = Proxy :: Proxy path
564+-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
566+-- > type MyApi = "users" :> Get [User]
567+-- > :<|> "docs :> Raw
569+-- > apiProxy :: Proxy MyApi
570+-- > apiProxy = Proxy
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
579+toHtml :: String -> String