Merge remote-tracking branch 'origin/new-impl' into misc

Conflicts:
	servant/src/Servant.hs
	servant/src/Servant/API.hs

example/greet.hs

@@ -3,7 +3,9 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 import Control.Concurrent (forkIO, killThread)
 import Control.Monad.Trans.Either
@@ -18,27 +20,46 @@ import Network.Wai.Handler.Warp
 
 import Servant.API
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 
 -- * Example
 
-data Greet = Greet { msg :: Text }
+data Greet = Greet { _msg :: Text }
   deriving (Generic, Show)
 
 instance FromJSON Greet
 instance ToJSON Greet
 
+instance ToCapture (Capture "name" Text) where
+  toCapture _ = DocCapture "name" "name of the person to greet"
+
+instance ToCapture (Capture "greetid" Text) where
+  toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
+
+instance ToParam (GetParam "capital" Bool) where
+  toParam _ =
+    DocGetParam "capital"
+                ["true", "false"]
+                "Get the greeting message in uppercase (true) or not (false). Default is false."
+
+instance ToSample Greet where
+  toSample Proxy = Just (encode g)
+
+    where g = Greet "Hello, haskeller!"
+
 -- API specification
 type TestApi = 
        "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
   :<|> "greet" :> RQBody Greet :> Post Greet
+  :<|> "delete" :> Capture "greetid" Text :> Delete
 
 testApi :: Proxy TestApi
 testApi = Proxy
 
 -- Server-side handlers
 server :: Server TestApi
-server = hello :<|> greet
+server = hello :<|> greet :<|> delete
 
   where hello name Nothing = hello name (Just False)
         hello name (Just False) = return . Greet $ "Hello, " <> name
@@ -46,18 +67,25 @@ server = hello :<|> greet
 
         greet = return
 
+        delete _ = return ()
+
 -- Client-side query functions
 clientApi :: Client TestApi
 clientApi = client testApi
 
 getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
 postGreet :: Greet -> URI -> EitherT String IO Greet
-getGreet :<|> postGreet = clientApi
+deleteGreet :: Text -> URI -> EitherT String IO ()
+getGreet :<|> postGreet :<|> deleteGreet = clientApi
 
 -- Turn the server into a WAI app
 test :: Application
 test = serve testApi server
 
+-- Documentation
+docsGreet :: API
+docsGreet = docs testApi
+
 -- Run the server
 runTestServer :: Port -> IO ()
 runTestServer port = run port test
@@ -71,4 +99,7 @@ main = do
   print =<< runEitherT (getGreet "alp" (Just False) uri)
   let g = Greet "yo"
   print =<< runEitherT (postGreet g uri)
+  print =<< runEitherT (deleteGreet "blah" uri)
   killThread tid
+  putStrLn "\n---------\n"
+  printMarkdown docsGreet

example/greet.md

@@ -0,0 +1,51 @@
+POST /greet
+-----------
+
+**Request Body**: 
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+**Response**: 
+
+ - Status code 201
+ - Response body as below.
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+GET /hello/:name
+----------------
+
+**Captures**: 
+
+- *name*: name of the person to greet
+
+**GET Parameters**: 
+
+ - capital
+     - **Values**: *true, false*
+     - **Description**: Get the greeting message in uppercase (true) or not (false). Default is false.
+
+**Response**: 
+
+ - Status code 200
+ - Response body as below.
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+DELETE /delete/:greetid
+-----------------------
+
+**Captures**: 
+
+- *greetid*: identifier of the greet msg to remove
+
+**Response**: 
+
+ - Status code 204
+ - No response body

servant.cabal

@@ -16,13 +16,16 @@ library
   exposed-modules:
     Servant
     Servant.Client
+    Servant.Docs
     Servant.Server
     Servant.Text
     Servant.API
     Servant.API.Capture
+    Servant.API.Delete
     Servant.API.Get
     Servant.API.GetParam
     Servant.API.Post
+    Servant.API.Put
     Servant.API.Raw
     Servant.API.RQBody
     Servant.API.Sub
@@ -30,7 +33,7 @@ library
   -- other-modules:       
   -- other-extensions:    
   build-depends:
-      base >=4 && <5
+      base >=4.7 && <5
     , either
     , aeson
     , bytestring
@@ -43,6 +46,9 @@ library
     , warp
     , transformers
     , text
+    , lens
+    , unordered-containers
+    , hashable
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -O0 -Wall
@@ -67,7 +73,7 @@ test-suite spec
   ghc-options:
     -Wall -Werror -fno-warn-name-shadowing -fno-warn-missing-signatures
   default-language: Haskell2010
-  hs-source-dirs: src, test
+  hs-source-dirs: test
   main-is: Spec.hs
   build-depends:
       base == 4.*
@@ -80,6 +86,7 @@ test-suite spec
     , http-client
     , http-types
     , network-uri >= 2.6
+    , servant
     , string-conversions
     , text
     , transformers

src/Servant.hs

@@ -7,11 +7,14 @@ module Servant (
   module Servant.Server,
   -- | For accessing servant APIs as API clients.
   module Servant.Client,
+  -- | For generating documentation for servant APIs.
+  module Servant.Docs,
   -- | Helper module
   module Servant.Text,
   ) where
 
 import Servant.API
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 import Servant.Text

src/Servant/API.hs

@@ -19,12 +19,18 @@ module Servant.API (
   module Servant.API.Get,
   -- | POST requests
   module Servant.API.Post,
+  -- | DELETE requests
+  module Servant.API.Delete,
+  -- | PUT requests
+  module Servant.API.Put,
   ) where
 
 import Servant.API.Capture
+import Servant.API.Delete
 import Servant.API.Get
 import Servant.API.GetParam
 import Servant.API.Post
+import Servant.API.Put
 import Servant.API.RQBody
 import Servant.API.Sub
 import Servant.API.Union

src/Servant/API/Capture.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Servant.API.Capture where
@@ -11,6 +12,7 @@ import GHC.TypeLits
 import Network.Wai
 import Servant.API.Sub
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 import Servant.Text
 
@@ -48,3 +50,16 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
       appendToPath p req
 
     where p = unpack (toText val)
+
+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
+      => HasDocs (Capture sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          captureP = Proxy :: Proxy (Capture sym a)
+
+          action' = over captures (|> toCapture captureP) action
+          endpoint' = over path (\p -> p++"/:"++symbolVal symP) endpoint
+          symP = Proxy :: Proxy sym

src/Servant/API/Delete.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Servant.API.Delete where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+import Data.Proxy
+import Data.String.Conversions
+import Network.HTTP.Types
+import Network.URI
+import Network.Wai
+import Servant.Client
+import Servant.Docs
+import Servant.Server
+
+import qualified Network.HTTP.Client as Client
+
+-- | Endpoint for DELETE requests.
+data Delete
+
+instance HasServer Delete where
+  type Server Delete = EitherT (Int, String) IO ()
+
+  route Proxy action _globalPathInfo request respond
+    | null (pathInfo request) && requestMethod request == methodDelete = do
+        e <- runEitherT action
+        respond $ Just $ case e of
+          Right () ->
+            responseLBS status204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | otherwise = respond Nothing
+
+instance HasClient Delete where
+  type Client Delete = URI -> EitherT String IO ()
+
+  clientWithRoute Proxy req uri = do
+    partialRequest <- liftIO $ reqToRequest req uri
+
+    let request = partialRequest { Client.method = methodDelete
+                                 }
+
+    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
+      Client.httpLbs request manager
+
+    when (Client.responseStatus innerResponse /= status204) $
+      left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse))
+
+instance HasDocs Delete where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocDELETE
+
+          action' = action & response.respBody .~ Nothing
+                           & response.respStatus .~ 204

src/Servant/API/Get.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Servant.API.Get where
 
 import Control.Monad
@@ -12,6 +13,7 @@ import Network.HTTP.Types
 import Network.URI
 import Network.Wai
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 
 import qualified Network.HTTP.Client as Client
@@ -43,3 +45,11 @@ instance FromJSON result => HasClient (Get result) where
       left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse))
     maybe (left "HTTP GET request returned invalid json") return $
       decode' (Client.responseBody innerResponse)
+
+instance ToSample a => HasDocs (Get a) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocGET
+          action' = action & response.respBody .~ toSample p
+          p = Proxy :: Proxy a

src/Servant/API/GetParam.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Servant.API.GetParam where
@@ -13,6 +14,7 @@ import Network.HTTP.Types
 import Network.Wai
 import Servant.API.Sub
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 import Servant.Text
 
@@ -28,7 +30,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   route Proxy subserver globalPathInfo request respond = do
     let querytext = parseQueryText $ rawQueryString request
         param =
-          case lookup paramName querytext of
+          case lookup paramname querytext of
             Nothing       -> Nothing -- param absent from the query string
             Just Nothing  -> Nothing -- param present with no value -> Nothing
             Just (Just v) -> fromText v -- if present, we try to convert to
@@ -36,7 +38,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 
     route (Proxy :: Proxy sublayout) (subserver param) globalPathInfo request respond
 
-    where paramName = cs $ symbolVal (Proxy :: Proxy sym)
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
       => HasClient (GetParam sym a :> sublayout) where
@@ -52,3 +54,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
     where pname  = pack pname'
           pname' = symbolVal (Proxy :: Proxy sym)
           mparamText = fmap toText mparam
+
+instance (KnownSymbol sym, ToParam (GetParam sym a), HasDocs sublayout)
+      => HasDocs (GetParam sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          paramP = Proxy :: Proxy (GetParam sym a)
+          action' = over params (|> toParam paramP) action

src/Servant/API/Post.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Servant.API.Post where
 
 import Control.Monad
@@ -12,6 +13,7 @@ import Network.HTTP.Types
 import Network.URI
 import Network.Wai
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 
 import qualified Network.HTTP.Client as Client
@@ -51,3 +53,14 @@ instance FromJSON a => HasClient (Post a) where
 
     maybe (left "HTTP POST request returned invalid json") return $
       decode' (Client.responseBody innerResponse)
+
+instance ToSample a => HasDocs (Post a) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocPOST
+
+          action' = action & response.respBody .~ toSample p
+                           & response.respStatus .~ 201
+
+          p = Proxy :: Proxy a

src/Servant/API/Put.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Servant.API.Put where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+import Data.Aeson
+import Data.Proxy
+import Data.String.Conversions
+import Network.HTTP.Types
+import Network.URI
+import Network.Wai
+import Servant.Client
+import Servant.Docs
+import Servant.Server
+
+import qualified Network.HTTP.Client as Client
+
+-- | Endpoint for PUT requests.
+data Put a
+
+instance ToJSON a => HasServer (Put a) where
+  type Server (Put a) = EitherT (Int, String) IO a
+
+  route Proxy action _globalPathInfo request respond
+    | null (pathInfo request) && requestMethod request == methodPut = do
+        e <- runEitherT action
+        respond $ Just $ case e of
+          Right out ->
+            responseLBS ok200 [("Content-Type", "application/json")] (encode out)
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | otherwise = respond Nothing
+
+instance FromJSON a => HasClient (Put a) where
+  type Client (Put a) = URI -> EitherT String IO a
+
+  clientWithRoute Proxy req uri = do
+    partialRequest <- liftIO $ reqToRequest req uri
+
+    let request = partialRequest { Client.method = methodPut
+                                 }
+
+    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
+      Client.httpLbs request manager
+
+    when (Client.responseStatus innerResponse /= ok200) $
+      left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
+
+    maybe (left "HTTP PUT request returned invalid json") return $
+      decode' (Client.responseBody innerResponse)
+
+instance ToSample a => HasDocs (Put a) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocPUT
+
+          action' = action & response.respBody .~ toSample p
+                           & response.respStatus .~ 200
+
+          p = Proxy :: Proxy a

src/Servant/API/RQBody.hs

@@ -11,6 +11,7 @@ import Data.Proxy
 import Network.Wai
 import Servant.API.Sub
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 
 -- * Request Body support
@@ -37,3 +38,14 @@ instance (ToJSON a, HasClient sublayout)
   clientWithRoute Proxy req body =
     clientWithRoute (Proxy :: Proxy sublayout) $
       setRQBody (encode body) req
+
+instance (ToSample a, HasDocs sublayout)
+      => HasDocs (RQBody a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+
+          action' = action & rqbody .~ toSample p
+          p = Proxy :: Proxy a

src/Servant/API/Sub.hs

@@ -9,6 +9,7 @@ import Data.String.Conversions
 import GHC.TypeLits
 import Network.Wai
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 
 -- | The contained API (second argument) can be found under @("/" ++ path)@
@@ -37,3 +38,11 @@ instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout
 
     where p = symbolVal (Proxy :: Proxy path)
 
+instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action)
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          endpoint' = endpoint & path <>~ symbolVal pa
+          pa = Proxy :: Proxy path

src/Servant/API/Union.hs

@@ -5,6 +5,7 @@ module Servant.API.Union where
 
 import Data.Proxy
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 
 -- | Union of two APIs, first takes precedence in case of overlap.
@@ -17,10 +18,21 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
     route (Proxy :: Proxy a) a globalPathInfo request $ \ mResponse ->
       case mResponse of
         Nothing -> route (Proxy :: Proxy b) b globalPathInfo request respond
-        Just response -> respond $ Just response
+        Just resp -> respond $ Just resp
 
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
   type Client (a :<|> b) = Client a :<|> Client b
   clientWithRoute Proxy req =
     clientWithRoute (Proxy :: Proxy a) req :<|>
     clientWithRoute (Proxy :: Proxy b) req
+
+instance (HasDocs layout1, HasDocs layout2)
+      => HasDocs (layout1 :<|> layout2) where
+
+  docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
+
+    where p1 :: Proxy layout1
+          p1 = Proxy
+
+          p2 :: Proxy layout2
+          p2 = Proxy

src/Servant/Docs.hs

@@ -0,0 +1,403 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-------------------------------------------------------------------------------
+-- |
+-- Module      : Servant.Docs
+-- License     : BSD-style
+-- Maintainer  : alpmestan@gmail.com
+-- Stability   : provisional
+-- Portability : TH, TypeFamilies, DeriveGeneric
+--
+-- This module lets you get API docs for free. It lets generate
+-- an 'API' from the type that represents your API using 'docs':
+--
+-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
+--
+-- You can then call 'printMarkdown' on it:
+--
+-- @printMarkdown :: 'API' -> IO ()@
+--
+-- or define a custom pretty printer:
+--
+-- @yourPrettyDocs :: 'API' -> IO () -- or blaze-html's HTML, or ...@
+--
+-- The only thing you'll need to do will be to implement some classes
+-- for your captures, get parameters and request or response bodies.
+--
+-- Here's a little (but complete) example that you can run to see the
+-- markdown pretty printer in action:
+--
+-- > {-# LANGUAGE DataKinds #-}
+-- > {-# LANGUAGE PolyKinds #-}
+-- > {-# LANGUAGE TypeFamilies #-}
+-- > {-# LANGUAGE DeriveGeneric #-}
+-- > {-# LANGUAGE TypeOperators #-}
+-- > {-# LANGUAGE FlexibleInstances #-}
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > import Data.Proxy
+-- > import Data.Text
+-- > import Servant
+-- > import Servant.Docs
+-- >
+-- > -- our type for a Greeting message
+-- > data Greet = Greet { _msg :: Text }
+-- >   deriving (Generic, Show)
+-- >
+-- > -- we get our JSON serialization for free
+-- > instance FromJSON Greet
+-- > instance ToJSON Greet
+-- >
+-- > -- we provide a sample value for the 'Greet' type
+-- > instance ToSample Greet where
+-- >   toSample Proxy = Just (encode g)
+-- >
+-- >     where g = Greet "Hello, haskeller!"
+-- >
+-- > instance ToParam (GetParam "capital" Bool) where
+-- >   toParam _ =
+-- >     DocGetParam "capital"
+-- >                 ["true", "false"]
+-- >                 "Get the greeting message in uppercase (true) or not (false). Default is false."
+-- >
+-- > instance ToCapture (Capture "name" Text) where
+-- >   toCapture _ = DocCapture "name" "name of the person to greet"
+-- >
+-- > instance ToCapture (Capture "greetid" Text) where
+-- >   toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
+-- >
+-- > -- API specification
+-- > type TestApi = 
+-- >        "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
+-- >   :<|> "greet" :> RQBody Greet :> Post Greet
+-- >   :<|> "delete" :> Capture "greetid" Text :> Delete
+-- >
+-- > testApi :: Proxy TestApi
+-- > testApi = Proxy
+-- >
+-- > -- Generate the Documentation's ADT
+-- > greetDocs :: API
+-- > greetDocs = docs testApi
+-- >
+-- > main :: IO ()
+-- > main = printMarkdown greetDocs
+module Servant.Docs
+  ( -- * 'HasDocs' class and key functions
+    HasDocs(..), docs, printMarkdown
+
+  , -- * Classes you need to implement for your types
+    ToSample(..), ToParam(..), ToCapture(..)
+
+  , -- * ADTs to represent an 'API'
+    Method(..)
+  , Endpoint, path, method, defEndpoint
+  , API, emptyAPI
+  , DocCapture(..), capSymbol, capDesc
+  , DocGetParam(..), paramName, paramValues, paramDesc
+  , Response, respStatus, respBody, defResponse
+  , Action, captures, params, rqbody, response, defAction
+  , single
+
+  , -- * Useful modules when defining your own instances
+    module Control.Lens
+  , module Data.Monoid
+  ) where
+
+import Control.Lens hiding (Action)
+import Control.Monad (when)
+import Data.Aeson
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import Data.List
+import Data.Monoid
+import Data.Proxy
+import GHC.Generics
+
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.HashMap.Strict as HM
+
+-- | Supported HTTP request methods
+data Method = DocDELETE -- ^ the DELETE method
+            | DocGET    -- ^ the GET method
+            | DocPOST   -- ^ the POST method
+            | DocPUT    -- ^ the PUT method
+  deriving (Eq, Generic)
+
+instance Show Method where
+  show DocGET = "GET"
+  show DocPOST = "POST"
+  show DocDELETE = "DELETE"
+  show DocPUT = "PUT"
+
+instance Hashable Method
+
+-- | An 'Endpoint' type that holds the 'path' and the 'method'.
+--
+-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'
+-- or any 'Endpoint' value you want using the 'path' and 'method'
+-- lenses to tweak.
+--
+-- @
+-- λ> 'defEndpoint'
+-- GET /
+-- λ> 'defEndpoint' & 'path' '<>~' "foo"
+-- GET /foo
+-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST'
+-- POST /foo
+-- @
+data Endpoint = Endpoint
+  { _path   :: String -- type collected
+  , _method :: Method -- type collected
+  } deriving (Eq, Generic)
+
+instance Show Endpoint where
+  show (Endpoint p m) =
+    show m ++ " " ++ p
+
+-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
+--
+-- Here's how you can modify it:
+--
+-- @
+-- λ> 'defEndpoint'
+-- GET /
+-- λ> 'defEndpoint' & 'path' '<>~' "foo"
+-- GET /foo
+-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST'
+-- POST /foo
+-- @
+defEndpoint :: Endpoint
+defEndpoint = Endpoint "/" DocGET
+
+instance Hashable Endpoint
+
+-- | Our API type, a good old hashmap from 'Endpoint' to 'Action'
+type API = HashMap Endpoint Action
+
+-- | An empty 'API'
+emptyAPI :: API
+emptyAPI = HM.empty
+
+-- | A type to represent captures. Holds the name of the capture
+--   and a description.
+--
+-- Write a 'ToCapture' instance for your captured types.
+data DocCapture = DocCapture
+  { _capSymbol :: String -- type supplied
+  , _capDesc   :: String -- user supplied
+  } deriving (Eq, Show)
+
+-- | A type to represent /GET/ parameters. Holds its name,
+--   the possible values (leave empty if there isn't a finite number of them),
+--   and a description of how it influences the output or behavior.
+--
+-- Write a 'ToParam' instance for your GET parameter types
+data DocGetParam = DocGetParam
+  { _paramName   :: String   -- type supplied
+  , _paramValues :: [String] -- user supplied
+  , _paramDesc   :: String   -- user supplied
+  } deriving (Eq, Show)
+
+-- | A type to represent an HTTP response. Has an 'Int' status and
+-- a 'Maybe ByteString' response body. Tweak 'defResponse' using
+-- the 'respStatus' and 'respBody' lenses if you want.
+--
+-- If you want to respond with a non-empty response body, you'll most likely
+-- want to write a 'ToSample' instance for the type that'll be represented
+-- as some JSON in the response.
+--
+-- Can be tweaked with two lenses.
+--
+-- > λ> defResponse
+-- > Response {_respStatus = 200, _respBody = Nothing}
+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
+-- > Response {_respStatus = 204, _respBody = Just "[]"}
+data Response = Response
+  { _respStatus :: Int
+  , _respBody   :: Maybe ByteString
+  } deriving (Eq, Show)
+
+-- | Default response: status code 200, no response body.
+--
+-- Can be tweaked with two lenses.
+--
+-- > λ> defResponse
+-- > Response {_respStatus = 200, _respBody = Nothing}
+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
+-- > Response {_respStatus = 204, _respBody = Just "[]"}
+defResponse :: Response
+defResponse = Response 200 Nothing
+
+-- | A datatype that represents everything that can happen
+-- at an endpoint, with its lenses:
+--
+-- - List of captures ('captures')
+-- - List of GET parameters ('params')
+-- - What the request body should look like, if any is requested ('rqbody')
+-- - What the response should be if everything goes well ('response')
+--
+-- You can tweak an 'Action' (like the default 'defAction') with these lenses
+-- to transform an action and add some information to it.
+data Action = Action
+  { _captures :: [DocCapture]        -- type collected + user supplied info
+  , _params   :: [DocGetParam]       -- type collected + user supplied info
+  , _rqbody   :: Maybe ByteString    -- user supplied
+  , _response :: Response            -- user supplied
+  } deriving (Eq, Show)
+
+-- Default 'Action'. Has no 'captures', no GET 'params', expects
+-- no request body ('rqbody') and the typical response is 'defResponse'.
+--
+-- Tweakable with lenses.
+--
+-- > λ> defAction
+-- > Action {_captures = [], _params = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
+-- > λ> defAction & response.respStatus .~ 201
+-- > Action {_captures = [], _params = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
+defAction :: Action
+defAction =
+  Action []
+         []
+         Nothing
+         defResponse
+
+-- | Create an API that's comprised of a single endpoint.
+--   'API' is a 'Monoid', so combine multiple endpoints with
+--   'mappend' or '<>'.
+single :: Endpoint -> Action -> API
+single = HM.singleton
+
+-- gimme some lenses
+makeLenses ''Endpoint
+makeLenses ''DocCapture
+makeLenses ''DocGetParam
+makeLenses ''Response
+makeLenses ''Action
+
+-- | Generate the docs for a given API that implements 'HasDocs'.
+docs :: HasDocs layout => Proxy layout -> API
+docs p = docsFor p (defEndpoint, defAction)
+
+-- | The class that abstracts away the impact of API combinators
+--   on documentation generation.
+class HasDocs layout where
+  docsFor :: Proxy layout -> (Endpoint, Action) -> API
+
+-- | The class that lets us display a sample JSON input or output
+--   when generating documentation for endpoints that either:
+--
+-- - expect a request body, or
+-- - return a non empty response body
+--
+-- Example of an instance:
+--
+-- > {-# LANGUAGE DeriveGeneric #-}
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > import Data.Aeson
+-- > import Data.Text
+-- > import GHC.Generics
+-- >
+-- > data Greet = Greet { _msg :: Text }
+-- >   deriving (Generic, Show)
+-- >
+-- > instance FromJSON Greet
+-- > instance ToJSON Greet
+-- >
+-- > instance ToSample Greet where
+-- >   toSample Proxy = Just (encode g)
+-- >
+-- >     where g = Greet "Hello, haskeller!"
+class ToJSON a => ToSample a where
+  toSample :: Proxy a -> Maybe ByteString
+
+-- | The class that helps us automatically get documentation
+--   for GET parameters.
+--
+-- Example of an instance:
+--
+-- > instance ToParam (GetParam "capital" Bool) where
+-- >   toParam _ =
+-- >     DocGetParam "capital"
+-- >                 ["true", "false"]
+-- >                 "Get the greeting message in uppercase (true) or not (false). Default is false."
+class ToParam t where
+  toParam :: Proxy t -> DocGetParam
+
+-- | The class that helps us automatically get documentation
+--   for URL captures.
+--
+-- Example of an instance:
+--
+-- > instance ToCapture (Capture "name" Text) where
+-- >   toCapture _ = DocCapture "name" "name of the person to greet"
+class ToCapture c where
+  toCapture :: Proxy c -> DocCapture
+
+-- | Print documentation in Markdown format for
+--   the given 'API', on standard output.
+printMarkdown :: API -> IO ()
+printMarkdown = imapM_ printEndpoint
+
+  where printEndpoint endpoint action = do
+          putStrLn $ str
+          putStrLn $ replicate len '-'
+          putStrLn ""
+          capturesStr (action ^. captures)
+          paramsStr (action ^. params)
+          rqbodyStr (action ^. rqbody)
+          responseStr (action ^. response) 
+
+          where str = show (endpoint^.method) ++ " " ++ endpoint^.path
+                len = length str
+
+        capturesStr :: [DocCapture] -> IO ()
+        capturesStr [] = return ()
+        capturesStr l = do
+          putStrLn "**Captures**: "
+          putStrLn ""
+          mapM_ captureStr l
+          putStrLn ""
+        captureStr cap =
+          putStrLn $ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
+
+        paramsStr :: [DocGetParam] -> IO ()
+        paramsStr [] = return ()
+        paramsStr l = do
+          putStrLn "**GET Parameters**: "
+          putStrLn ""
+          mapM_ paramStr l
+          putStrLn ""
+        paramStr param = do
+          putStrLn $ " - " ++ param ^. paramName
+          when (not $ null values) $
+            putStrLn $ "     - **Values**: *" ++ intercalate ", " values ++ "*"
+          putStrLn $   "     - **Description**: " ++ param ^. paramDesc
+
+          where values = param ^. paramValues
+
+        rqbodyStr :: Maybe ByteString -> IO ()
+        rqbodyStr Nothing = return ()
+        rqbodyStr (Just b) = do
+          putStrLn "**Request Body**: "
+          jsonStr b
+
+        jsonStr b = do
+          putStrLn ""
+          putStrLn "``` javascript"
+          LB.putStrLn b
+          putStrLn "```"
+          putStrLn ""
+
+        responseStr :: Response -> IO ()
+        responseStr resp = do
+          putStrLn $ "**Response**: "
+          putStrLn $ ""
+          putStrLn $ " - Status code " ++ show (resp ^. respStatus)
+          resp ^. respBody &
+            maybe (putStrLn " - No response body\n")
+                  (\b -> putStrLn " - Response body as below." >> jsonStr b)
+