Add automatic doc generation support, including instances for all our API combinators so far

This commit is contained in:
Alp Mestanogullari 2014-10-28 09:04:27 +01:00
parent d85231d093
commit 4ebc4944c2
11 changed files with 569 additions and 5 deletions

View File

@ -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,16 +20,31 @@ 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 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
@ -58,6 +75,9 @@ getGreet :<|> postGreet = clientApi
test :: Application
test = serve testApi server
docsGreet :: API
docsGreet = docs testApi
-- Run the server
runTestServer :: Port -> IO ()
runTestServer port = run port test
@ -72,3 +92,5 @@ main = do
let g = Greet "yo"
print =<< runEitherT (postGreet g uri)
killThread tid
putStrLn "\n---------\n"
printMarkdown docsGreet

51
example/greet.md Normal file
View File

@ -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

View File

@ -16,6 +16,7 @@ library
exposed-modules:
Servant
Servant.Client
Servant.Docs
Servant.Server
Servant.Text
Servant.API
@ -43,6 +44,9 @@ library
, warp
, transformers
, text
, lens
, unordered-containers
, hashable
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -O0 -Wall
@ -67,7 +71,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 +84,7 @@ test-suite spec
, http-client
, http-types
, network-uri >= 2.6
, servant
, string-conversions
, text
, transformers

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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
@ -49,3 +51,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

View File

@ -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

View File

@ -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

View File

@ -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

403
src/Servant/Docs.hs Normal file
View File

@ -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")
(\b -> putStrLn " - Response body as below." >> jsonStr b)