Add automatic doc generation support, including instances for all our API combinators so far
This commit is contained in:
parent
d85231d093
commit
4ebc4944c2
11 changed files with 569 additions and 5 deletions
|
@ -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
51
example/greet.md
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
403
src/Servant/Docs.hs
Normal 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)
|
||||
|
Loading…
Reference in a new issue