Alp Mestanogullari
commit
f90348c03a
8 changed files with 931 additions and 813 deletions
|
|
@ -3,6 +3,8 @@
|
||||||
* Allow for extra information to be added to the docs
|
* Allow for extra information to be added to the docs
|
||||||
* Support content-type aware combinators of *servant-0.3*
|
* Support content-type aware combinators of *servant-0.3*
|
||||||
* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
|
* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
|
||||||
|
* Remove ToJSON superclass from ToSample
|
||||||
|
* Split out Internal module
|
||||||
|
|
||||||
0.3
|
0.3
|
||||||
---
|
---
|
||||||
|
|
|
||||||
19
default.nix
Normal file
19
default.nix
Normal file
|
|
@ -0,0 +1,19 @@
|
||||||
|
{ mkDerivation, aeson, base, bytestring, hashable, hspec
|
||||||
|
, http-media, lens, servant, stdenv, string-conversions, text
|
||||||
|
, unordered-containers
|
||||||
|
}:
|
||||||
|
mkDerivation {
|
||||||
|
pname = "servant-docs";
|
||||||
|
version = "0.3";
|
||||||
|
src = ./.;
|
||||||
|
isLibrary = true;
|
||||||
|
isExecutable = true;
|
||||||
|
buildDepends = [
|
||||||
|
aeson base bytestring hashable http-media lens servant
|
||||||
|
string-conversions text unordered-containers
|
||||||
|
];
|
||||||
|
testDepends = [ aeson base hspec lens servant ];
|
||||||
|
homepage = "http://haskell-servant.github.io/";
|
||||||
|
description = "generate API docs for your servant webservice";
|
||||||
|
license = stdenv.lib.licenses.bsd3;
|
||||||
|
}
|
||||||
|
|
@ -26,9 +26,9 @@ source-repository head
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Servant.Docs
|
Servant.Docs
|
||||||
|
, Servant.Docs.Internal
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.7 && <5
|
||||||
, aeson
|
|
||||||
, bytestring
|
, bytestring
|
||||||
, hashable
|
, hashable
|
||||||
, http-media >= 0.6
|
, http-media >= 0.6
|
||||||
|
|
@ -45,5 +45,27 @@ executable greet-docs
|
||||||
main-is: greet.hs
|
main-is: greet.hs
|
||||||
hs-source-dirs: example
|
hs-source-dirs: example
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends: base, aeson, lens, servant, servant-docs, string-conversions, text
|
build-depends:
|
||||||
|
base
|
||||||
|
, aeson
|
||||||
|
, lens
|
||||||
|
, servant
|
||||||
|
, servant-docs
|
||||||
|
, string-conversions
|
||||||
|
, text
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite spec
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Spec.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
ghc-options: -Wall
|
||||||
|
build-depends:
|
||||||
|
base
|
||||||
|
, aeson
|
||||||
|
, hspec
|
||||||
|
, servant
|
||||||
|
, servant-docs
|
||||||
|
, string-conversions
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
|
||||||
9
shell.nix
Normal file
9
shell.nix
Normal file
|
|
@ -0,0 +1,9 @@
|
||||||
|
with (import <nixpkgs> {}).pkgs;
|
||||||
|
let modifiedHaskellPackages = haskellngPackages.override {
|
||||||
|
overrides = self: super: {
|
||||||
|
servant = self.callPackage ../servant {};
|
||||||
|
servant-server = self.callPackage ./servant-server {};
|
||||||
|
servant-docs = self.callPackage ./. {};
|
||||||
|
};
|
||||||
|
};
|
||||||
|
in modifiedHaskellPackages.servant-docs.env
|
||||||
|
|
@ -1,31 +1,17 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# LANGUAGE PolyKinds #-}
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- | This module lets you get API docs for free. It lets generate
|
-- | This module lets you get API docs for free. It lets you generate
|
||||||
-- an 'API' from the type that represents your API using 'docs':
|
-- an 'API' from the type that represents your API using 'docs':
|
||||||
--
|
--
|
||||||
-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
|
-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
|
||||||
--
|
--
|
||||||
-- Alternately, if you wish to add one or more introductions to your
|
-- Alternatively, if you wish to add one or more introductions to your
|
||||||
-- documentation, use 'docsWithIntros':
|
-- documentation, use 'docsWithIntros':
|
||||||
--
|
--
|
||||||
-- @docsWithIntros :: 'HasDocs' api => [DocIntro] -> 'Proxy' api -> 'API'@
|
-- @'docsWithIntros' :: 'HasDocs' api => [DocIntro] -> 'Proxy' api -> 'API'@
|
||||||
--
|
--
|
||||||
-- You can then call 'markdown' on the 'API' value:
|
-- You can then call 'markdown' on the 'API' value:
|
||||||
--
|
--
|
||||||
-- @markdown :: 'API' -> String@
|
-- @'markdown' :: 'API' -> String@
|
||||||
--
|
--
|
||||||
-- or define a custom pretty printer:
|
-- or define a custom pretty printer:
|
||||||
--
|
--
|
||||||
|
|
@ -34,8 +20,8 @@
|
||||||
-- The only thing you'll need to do will be to implement some classes
|
-- The only thing you'll need to do will be to implement some classes
|
||||||
-- for your captures, get parameters and request or response bodies.
|
-- for your captures, get parameters and request or response bodies.
|
||||||
--
|
--
|
||||||
-- Here's a little (but complete) example that you can run to see the
|
-- Here is a complete example that you can run to see the markdown pretty
|
||||||
-- markdown pretty printer in action:
|
-- printer in action:
|
||||||
--
|
--
|
||||||
-- > {-# LANGUAGE DataKinds #-}
|
-- > {-# LANGUAGE DataKinds #-}
|
||||||
-- > {-# LANGUAGE DeriveGeneric #-}
|
-- > {-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
@ -174,797 +160,9 @@ module Servant.Docs
|
||||||
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
|
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
|
||||||
, DocNote(..), noteTitle, noteBody
|
, DocNote(..), noteTitle, noteBody
|
||||||
, DocIntro(..)
|
, DocIntro(..)
|
||||||
, Response, respStatus, respTypes, respBody, defResponse
|
, Response(..), respStatus, respTypes, respBody, defResponse
|
||||||
, Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
|
, Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
|
||||||
, single
|
, single
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative
|
import Servant.Docs.Internal
|
||||||
import Control.Lens hiding (Action)
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.ByteString.Lazy.Char8 (ByteString)
|
|
||||||
import Data.Hashable
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Monoid
|
|
||||||
import Data.Ord (comparing)
|
|
||||||
import Data.Proxy
|
|
||||||
import Data.String.Conversions
|
|
||||||
import Data.Text (Text, pack, unpack)
|
|
||||||
import GHC.Generics
|
|
||||||
import GHC.TypeLits
|
|
||||||
import GHC.Exts(Constraint)
|
|
||||||
import Servant.API
|
|
||||||
import Servant.Utils.Links
|
|
||||||
import Servant.API.ContentTypes
|
|
||||||
|
|
||||||
import qualified Data.HashMap.Strict as HM
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Network.HTTP.Media as M
|
|
||||||
|
|
||||||
-- | Supported HTTP request methods
|
|
||||||
data Method = DocDELETE -- ^ the DELETE method
|
|
||||||
| DocGET -- ^ the GET method
|
|
||||||
| DocPOST -- ^ the POST method
|
|
||||||
| DocPUT -- ^ the PUT method
|
|
||||||
deriving (Eq, Ord, 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, Ord, Generic)
|
|
||||||
|
|
||||||
instance Show Endpoint where
|
|
||||||
show (Endpoint p m) =
|
|
||||||
show m ++ " " ++ showPath p
|
|
||||||
|
|
||||||
-- |
|
|
||||||
-- Render a path as a '/'-delimited string
|
|
||||||
--
|
|
||||||
showPath :: [String] -> String
|
|
||||||
showPath [] = "/"
|
|
||||||
showPath ps = concatMap ('/' :) ps
|
|
||||||
|
|
||||||
-- | 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 documentation type, a product of top-level information and a good
|
|
||||||
-- old hashmap from 'Endpoint' to 'Action'
|
|
||||||
data API = API
|
|
||||||
{ _apiIntros :: [DocIntro]
|
|
||||||
, _apiEndpoints :: HashMap Endpoint Action
|
|
||||||
} deriving (Eq, Show)
|
|
||||||
|
|
||||||
instance Monoid API where
|
|
||||||
API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)
|
|
||||||
mempty = API mempty mempty
|
|
||||||
|
|
||||||
-- | An empty 'API'
|
|
||||||
emptyAPI :: API
|
|
||||||
emptyAPI = mempty
|
|
||||||
|
|
||||||
-- | 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, Ord, Show)
|
|
||||||
|
|
||||||
-- | A type to represent a /GET/ parameter from the Query String. 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 DocQueryParam = DocQueryParam
|
|
||||||
{ _paramName :: String -- type supplied
|
|
||||||
, _paramValues :: [String] -- user supplied
|
|
||||||
, _paramDesc :: String -- user supplied
|
|
||||||
, _paramKind :: ParamKind
|
|
||||||
} deriving (Eq, Ord, Show)
|
|
||||||
|
|
||||||
-- | An introductory paragraph for your documentation. You can pass these to
|
|
||||||
-- 'docsWithIntros'.
|
|
||||||
data DocIntro = DocIntro
|
|
||||||
{ _introTitle :: String -- ^ Appears above the intro blob
|
|
||||||
, _introBody :: [String] -- ^ Each String is a paragraph.
|
|
||||||
} deriving (Eq, Show)
|
|
||||||
|
|
||||||
instance Ord DocIntro where
|
|
||||||
compare = comparing _introTitle
|
|
||||||
|
|
||||||
-- | A type to represent extra notes that may be attached to an 'Action'.
|
|
||||||
--
|
|
||||||
-- This is intended to be used when writing your own HasDocs instances to
|
|
||||||
-- add extra sections to your endpoint's documentation.
|
|
||||||
data DocNote = DocNote
|
|
||||||
{ _noteTitle :: String
|
|
||||||
, _noteBody :: [String]
|
|
||||||
} deriving (Eq, Ord, Show)
|
|
||||||
|
|
||||||
-- | Type of extra information that a user may wish to "union" with their
|
|
||||||
-- documentation.
|
|
||||||
--
|
|
||||||
-- These are intended to be built using extraInfo.
|
|
||||||
-- Multiple ExtraInfo may be combined with the monoid instance.
|
|
||||||
newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
|
|
||||||
instance Monoid (ExtraInfo a) where
|
|
||||||
mempty = ExtraInfo mempty
|
|
||||||
ExtraInfo a `mappend` ExtraInfo b =
|
|
||||||
ExtraInfo $ HM.unionWith combineAction a b
|
|
||||||
|
|
||||||
-- | Type of GET parameter:
|
|
||||||
--
|
|
||||||
-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
|
|
||||||
-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values
|
|
||||||
-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter
|
|
||||||
data ParamKind = Normal | List | Flag
|
|
||||||
deriving (Eq, Ord, Show)
|
|
||||||
|
|
||||||
-- | A type to represent an HTTP response. Has an 'Int' status, a list of
|
|
||||||
-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
|
|
||||||
-- Tweak 'defResponse' using the 'respStatus', 'respTypes' 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 encoded data in the response.
|
|
||||||
--
|
|
||||||
-- Can be tweaked with three lenses.
|
|
||||||
--
|
|
||||||
-- > λ> defResponse
|
|
||||||
-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
|
|
||||||
-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
|
|
||||||
-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
|
|
||||||
data Response = Response
|
|
||||||
{ _respStatus :: Int
|
|
||||||
, _respTypes :: [M.MediaType]
|
|
||||||
, _respBody :: [(Text, M.MediaType, ByteString)]
|
|
||||||
} deriving (Eq, Ord, 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 [] []
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
, _headers :: [Text] -- type collected
|
|
||||||
, _params :: [DocQueryParam] -- type collected + user supplied info
|
|
||||||
, _notes :: [DocNote] -- user supplied
|
|
||||||
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
|
|
||||||
, _rqtypes :: [M.MediaType] -- type collected
|
|
||||||
, _rqbody :: [(M.MediaType, ByteString)] -- user supplied
|
|
||||||
, _response :: Response -- user supplied
|
|
||||||
} deriving (Eq, Ord, Show)
|
|
||||||
|
|
||||||
-- | Combine two Actions, we can't make a monoid as merging Response breaks the
|
|
||||||
-- laws.
|
|
||||||
--
|
|
||||||
-- As such, we invent a non-commutative, left associative operation
|
|
||||||
-- 'combineAction' to mush two together taking the response, body and content
|
|
||||||
-- types from the very left.
|
|
||||||
combineAction :: Action -> Action -> Action
|
|
||||||
Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
|
|
||||||
Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
|
|
||||||
|
|
||||||
-- 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 = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
|
|
||||||
-- > λ> defAction & response.respStatus .~ 201
|
|
||||||
-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
|
|
||||||
defAction :: Action
|
|
||||||
defAction =
|
|
||||||
Action []
|
|
||||||
[]
|
|
||||||
[]
|
|
||||||
[]
|
|
||||||
[]
|
|
||||||
[]
|
|
||||||
[]
|
|
||||||
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 e a = API mempty (HM.singleton e a)
|
|
||||||
|
|
||||||
-- gimme some lenses
|
|
||||||
makeLenses ''API
|
|
||||||
makeLenses ''Endpoint
|
|
||||||
makeLenses ''DocCapture
|
|
||||||
makeLenses ''DocQueryParam
|
|
||||||
makeLenses ''DocIntro
|
|
||||||
makeLenses ''DocNote
|
|
||||||
makeLenses ''Response
|
|
||||||
makeLenses ''Action
|
|
||||||
|
|
||||||
-- | Generate the docs for a given API that implements 'HasDocs'. This is the
|
|
||||||
-- default way to create documentation.
|
|
||||||
docs :: HasDocs layout => Proxy layout -> API
|
|
||||||
docs p = docsFor p (defEndpoint, defAction)
|
|
||||||
|
|
||||||
-- | Closed type family, check if endpoint is exactly within API.
|
|
||||||
|
|
||||||
-- We aren't sure what affects how an Endpoint is built up, so we require an
|
|
||||||
-- exact match.
|
|
||||||
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
|
||||||
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
|
||||||
IsIn (e :> sa) (e :> sb) = IsIn sa sb
|
|
||||||
IsIn e e = ()
|
|
||||||
|
|
||||||
-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.
|
|
||||||
--
|
|
||||||
-- The safety here is to ensure that you only add custom documentation to an
|
|
||||||
-- endpoint that actually exists within your API.
|
|
||||||
--
|
|
||||||
-- > extra :: ExtraInfo TestApi
|
|
||||||
-- > extra =
|
|
||||||
-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
|
|
||||||
-- > defAction & headers <>~ ["unicorns"]
|
|
||||||
-- > & notes <>~ [ DocNote "Title" ["This is some text"]
|
|
||||||
-- > , DocNote "Second secton" ["And some more"]
|
|
||||||
-- > ]
|
|
||||||
|
|
||||||
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
|
|
||||||
=> Proxy endpoint -> Action -> ExtraInfo layout
|
|
||||||
extraInfo p action =
|
|
||||||
let api = docsFor p (defEndpoint, defAction)
|
|
||||||
-- Assume one endpoint, HasLink constraint means that we should only ever
|
|
||||||
-- point at one endpoint.
|
|
||||||
in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
|
|
||||||
|
|
||||||
-- | Generate documentation given some extra introductions (in the form of
|
|
||||||
-- 'DocInfo') and some extra endpoint documentation (in the form of
|
|
||||||
-- 'ExtraInfo'.
|
|
||||||
--
|
|
||||||
-- The extra introductions will be prepended to the top of the documentation,
|
|
||||||
-- before the specific endpoint documentation. The extra endpoint documentation
|
|
||||||
-- will be "unioned" with the automatically generated endpoint documentation.
|
|
||||||
--
|
|
||||||
-- You are expected to build up the ExtraInfo with the Monoid instance and
|
|
||||||
-- 'extraInfo'.
|
|
||||||
--
|
|
||||||
-- If you only want to add an introduction, use 'docsWithIntros'.
|
|
||||||
docsWith :: HasDocs layout
|
|
||||||
=> [DocIntro]
|
|
||||||
-> ExtraInfo layout
|
|
||||||
-> Proxy layout
|
|
||||||
-> API
|
|
||||||
docsWith intros (ExtraInfo endpoints) p =
|
|
||||||
docs p & apiIntros <>~ intros
|
|
||||||
& apiEndpoints %~ HM.unionWith combineAction endpoints
|
|
||||||
|
|
||||||
|
|
||||||
-- | Generate the docs for a given API that implements 'HasDocs' with with any
|
|
||||||
-- number of introduction(s)
|
|
||||||
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
|
|
||||||
docsWithIntros intros = docsWith intros mempty
|
|
||||||
|
|
||||||
-- | 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 = Just g
|
|
||||||
-- >
|
|
||||||
-- > where g = Greet "Hello, haskeller!"
|
|
||||||
--
|
|
||||||
-- You can also instantiate this class using 'toSamples' instead of
|
|
||||||
-- 'toSample': it lets you specify different responses along with
|
|
||||||
-- some context (as 'Text') that explains when you're supposed to
|
|
||||||
-- get the corresponding response.
|
|
||||||
class ToJSON a => ToSample a where
|
|
||||||
{-# MINIMAL (toSample | toSamples) #-}
|
|
||||||
toSample :: Maybe a
|
|
||||||
toSample = snd <$> listToMaybe samples
|
|
||||||
where samples = toSamples :: [(Text, a)]
|
|
||||||
|
|
||||||
toSamples :: [(Text, a)]
|
|
||||||
toSamples = maybe [] (return . ("",)) s
|
|
||||||
where s = toSample :: Maybe a
|
|
||||||
|
|
||||||
-- | Synthesise a sample value of a type, encoded in the specified media types.
|
|
||||||
sampleByteString
|
|
||||||
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
|
|
||||||
=> Proxy ctypes
|
|
||||||
-> Proxy a
|
|
||||||
-> [(M.MediaType, ByteString)]
|
|
||||||
sampleByteString ctypes@Proxy Proxy =
|
|
||||||
maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
|
|
||||||
|
|
||||||
-- | Synthesise a list of sample values of a particular type, encoded in the
|
|
||||||
-- specified media types.
|
|
||||||
sampleByteStrings
|
|
||||||
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
|
|
||||||
=> Proxy ctypes
|
|
||||||
-> Proxy a
|
|
||||||
-> [(Text, M.MediaType, ByteString)]
|
|
||||||
sampleByteStrings ctypes@Proxy Proxy =
|
|
||||||
let samples = toSamples :: [(Text, a)]
|
|
||||||
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
|
|
||||||
in concatMap enc samples
|
|
||||||
|
|
||||||
-- | Generate a list of 'MediaType' values describing the content types
|
|
||||||
-- accepted by an API component.
|
|
||||||
class SupportedTypes (list :: [*]) where
|
|
||||||
supportedTypes :: Proxy list -> [M.MediaType]
|
|
||||||
|
|
||||||
instance SupportedTypes '[] where
|
|
||||||
supportedTypes Proxy = []
|
|
||||||
|
|
||||||
instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
|
|
||||||
where
|
|
||||||
supportedTypes Proxy =
|
|
||||||
contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
|
|
||||||
|
|
||||||
-- | The class that helps us automatically get documentation
|
|
||||||
-- for GET parameters.
|
|
||||||
--
|
|
||||||
-- Example of an instance:
|
|
||||||
--
|
|
||||||
-- > instance ToParam (QueryParam "capital" Bool) where
|
|
||||||
-- > toParam _ =
|
|
||||||
-- > DocQueryParam "capital"
|
|
||||||
-- > ["true", "false"]
|
|
||||||
-- > "Get the greeting message in uppercase (true) or not (false). Default is false."
|
|
||||||
class ToParam t where
|
|
||||||
toParam :: Proxy t -> DocQueryParam
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
-- | Generate documentation in Markdown format for
|
|
||||||
-- the given 'API'.
|
|
||||||
markdown :: API -> String
|
|
||||||
markdown api = unlines $
|
|
||||||
introsStr (api ^. apiIntros)
|
|
||||||
++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
|
|
||||||
|
|
||||||
where printEndpoint :: Endpoint -> Action -> [String]
|
|
||||||
printEndpoint endpoint action =
|
|
||||||
str :
|
|
||||||
"" :
|
|
||||||
notesStr (action ^. notes) ++
|
|
||||||
capturesStr (action ^. captures) ++
|
|
||||||
mxParamsStr (action ^. mxParams) ++
|
|
||||||
headersStr (action ^. headers) ++
|
|
||||||
paramsStr (action ^. params) ++
|
|
||||||
rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
|
|
||||||
responseStr (action ^. response) ++
|
|
||||||
[]
|
|
||||||
|
|
||||||
where str = "## " ++ show (endpoint^.method)
|
|
||||||
++ " " ++ showPath (endpoint^.path)
|
|
||||||
|
|
||||||
introsStr :: [DocIntro] -> [String]
|
|
||||||
introsStr = concatMap introStr
|
|
||||||
|
|
||||||
introStr :: DocIntro -> [String]
|
|
||||||
introStr i =
|
|
||||||
("#### " ++ i ^. introTitle) :
|
|
||||||
"" :
|
|
||||||
intersperse "" (i ^. introBody) ++
|
|
||||||
"" :
|
|
||||||
[]
|
|
||||||
|
|
||||||
notesStr :: [DocNote] -> [String]
|
|
||||||
notesStr = concatMap noteStr
|
|
||||||
|
|
||||||
noteStr :: DocNote -> [String]
|
|
||||||
noteStr nt =
|
|
||||||
("#### " ++ nt ^. noteTitle) :
|
|
||||||
"" :
|
|
||||||
intersperse "" (nt ^. noteBody) ++
|
|
||||||
"" :
|
|
||||||
[]
|
|
||||||
|
|
||||||
capturesStr :: [DocCapture] -> [String]
|
|
||||||
capturesStr [] = []
|
|
||||||
capturesStr l =
|
|
||||||
"#### Captures:" :
|
|
||||||
"" :
|
|
||||||
map captureStr l ++
|
|
||||||
"" :
|
|
||||||
[]
|
|
||||||
|
|
||||||
captureStr cap =
|
|
||||||
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
|
|
||||||
|
|
||||||
mxParamsStr :: [(String, [DocQueryParam])] -> [String]
|
|
||||||
mxParamsStr [] = []
|
|
||||||
mxParamsStr l =
|
|
||||||
"#### Matrix Parameters:" :
|
|
||||||
"" :
|
|
||||||
map segmentStr l
|
|
||||||
segmentStr :: (String, [DocQueryParam]) -> String
|
|
||||||
segmentStr (segment, l) = unlines $
|
|
||||||
("**" ++ segment ++ "**:") :
|
|
||||||
"" :
|
|
||||||
map paramStr l ++
|
|
||||||
"" :
|
|
||||||
[]
|
|
||||||
|
|
||||||
headersStr :: [Text] -> [String]
|
|
||||||
headersStr [] = []
|
|
||||||
headersStr l = [""] ++ map headerStr l ++ [""]
|
|
||||||
|
|
||||||
where headerStr hname = "- This endpoint is sensitive to the value of the **"
|
|
||||||
++ unpack hname ++ "** HTTP header."
|
|
||||||
|
|
||||||
paramsStr :: [DocQueryParam] -> [String]
|
|
||||||
paramsStr [] = []
|
|
||||||
paramsStr l =
|
|
||||||
"#### GET Parameters:" :
|
|
||||||
"" :
|
|
||||||
map paramStr l ++
|
|
||||||
"" :
|
|
||||||
[]
|
|
||||||
|
|
||||||
paramStr param = unlines $
|
|
||||||
("- " ++ param ^. paramName) :
|
|
||||||
(if (not (null values) || param ^. paramKind /= Flag)
|
|
||||||
then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
|
|
||||||
else []) ++
|
|
||||||
(" - **Description**: " ++ param ^. paramDesc) :
|
|
||||||
(if (param ^. paramKind == List)
|
|
||||||
then [" - This parameter is a **list**. All GET parameters with the name "
|
|
||||||
++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
|
|
||||||
else []) ++
|
|
||||||
(if (param ^. paramKind == Flag)
|
|
||||||
then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
|
|
||||||
else []) ++
|
|
||||||
[]
|
|
||||||
|
|
||||||
where values = param ^. paramValues
|
|
||||||
|
|
||||||
rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
|
|
||||||
rqbodyStr [] [] = []
|
|
||||||
rqbodyStr types samples =
|
|
||||||
["#### Request:", ""]
|
|
||||||
<> formatTypes types
|
|
||||||
<> concatMap formatBody samples
|
|
||||||
|
|
||||||
formatTypes [] = []
|
|
||||||
formatTypes ts = ["- Supported content types are:", ""]
|
|
||||||
<> map (\t -> " - `" <> show t <> "`") ts
|
|
||||||
<> [""]
|
|
||||||
|
|
||||||
formatBody (m, b) =
|
|
||||||
"- Example: `" <> cs (show m) <> "`" :
|
|
||||||
contentStr m b
|
|
||||||
|
|
||||||
markdownForType mime_type =
|
|
||||||
case (M.mainType mime_type, M.subType mime_type) of
|
|
||||||
("text", "html") -> "html"
|
|
||||||
("application", "xml") -> "xml"
|
|
||||||
("application", "json") -> "javascript"
|
|
||||||
("application", "javascript") -> "javascript"
|
|
||||||
("text", "css") -> "css"
|
|
||||||
(_, _) -> ""
|
|
||||||
|
|
||||||
contentStr mime_type body =
|
|
||||||
"" :
|
|
||||||
"```" <> markdownForType mime_type :
|
|
||||||
cs body :
|
|
||||||
"```" :
|
|
||||||
"" :
|
|
||||||
[]
|
|
||||||
|
|
||||||
responseStr :: Response -> [String]
|
|
||||||
responseStr resp =
|
|
||||||
"#### Response:" :
|
|
||||||
"" :
|
|
||||||
("- Status code " ++ show (resp ^. respStatus)) :
|
|
||||||
"" :
|
|
||||||
formatTypes (resp ^. respTypes) ++
|
|
||||||
bodies
|
|
||||||
|
|
||||||
where bodies = case resp ^. respBody of
|
|
||||||
[] -> ["- No response body\n"]
|
|
||||||
[("", t, r)] -> "- Response body as below." : contentStr t r
|
|
||||||
xs ->
|
|
||||||
concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
|
|
||||||
|
|
||||||
-- * Instances
|
|
||||||
|
|
||||||
-- | The generated docs for @a ':<|>' b@ just appends the docs
|
|
||||||
-- for @a@ with the docs for @b@.
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | @"books" :> 'Capture' "isbn" Text@ will appear as
|
|
||||||
-- @/books/:isbn@ in the docs.
|
|
||||||
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
|
|
||||||
|
|
||||||
|
|
||||||
instance HasDocs Delete where
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
single endpoint' action'
|
|
||||||
|
|
||||||
where endpoint' = endpoint & method .~ DocDELETE
|
|
||||||
|
|
||||||
action' = action & response.respBody .~ []
|
|
||||||
& response.respStatus .~ 204
|
|
||||||
|
|
||||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
|
||||||
=> HasDocs (Get cts a) where
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
single endpoint' action'
|
|
||||||
|
|
||||||
where endpoint' = endpoint & method .~ DocGET
|
|
||||||
action' = action & response.respBody .~ sampleByteStrings t p
|
|
||||||
& response.respTypes .~ supportedTypes t
|
|
||||||
t = Proxy :: Proxy cts
|
|
||||||
p = Proxy :: Proxy a
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, HasDocs sublayout)
|
|
||||||
=> HasDocs (Header sym a :> sublayout) where
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint, action')
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
action' = over headers (|> headername) action
|
|
||||||
headername = pack $ symbolVal (Proxy :: Proxy sym)
|
|
||||||
|
|
||||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
|
||||||
=> HasDocs (Post cts a) where
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
single endpoint' action'
|
|
||||||
|
|
||||||
where endpoint' = endpoint & method .~ DocPOST
|
|
||||||
action' = action & response.respBody .~ sampleByteStrings t p
|
|
||||||
& response.respTypes .~ supportedTypes t
|
|
||||||
& response.respStatus .~ 201
|
|
||||||
t = Proxy :: Proxy cts
|
|
||||||
p = Proxy :: Proxy a
|
|
||||||
|
|
||||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
|
||||||
=> HasDocs (Put cts a) where
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
single endpoint' action'
|
|
||||||
|
|
||||||
where endpoint' = endpoint & method .~ DocPUT
|
|
||||||
action' = action & response.respBody .~ sampleByteStrings t p
|
|
||||||
& response.respTypes .~ supportedTypes t
|
|
||||||
& response.respStatus .~ 200
|
|
||||||
t = Proxy :: Proxy cts
|
|
||||||
p = Proxy :: Proxy a
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
|
|
||||||
=> HasDocs (QueryParam sym a :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint, action')
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
paramP = Proxy :: Proxy (QueryParam sym a)
|
|
||||||
action' = over params (|> toParam paramP) action
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
|
|
||||||
=> HasDocs (QueryParams sym a :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint, action')
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
paramP = Proxy :: Proxy (QueryParams sym a)
|
|
||||||
action' = over params (|> toParam paramP) action
|
|
||||||
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
|
|
||||||
=> HasDocs (QueryFlag sym :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint, action')
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
paramP = Proxy :: Proxy (QueryFlag sym)
|
|
||||||
action' = over params (|> toParam paramP) action
|
|
||||||
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)
|
|
||||||
=> HasDocs (MatrixParam sym a :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint', action')
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
paramP = Proxy :: Proxy (MatrixParam sym a)
|
|
||||||
segment = endpoint ^. (path._last)
|
|
||||||
segment' = action ^. (mxParams._last._1)
|
|
||||||
endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint
|
|
||||||
|
|
||||||
action' = if segment' /= segment
|
|
||||||
-- This is the first matrix parameter for this segment, insert a new entry into the mxParams list
|
|
||||||
then over mxParams (|> (segment, [toParam paramP])) action
|
|
||||||
-- We've already inserted a matrix parameter for this segment, append to the existing list
|
|
||||||
else action & mxParams._last._2 <>~ [toParam paramP]
|
|
||||||
symP = Proxy :: Proxy sym
|
|
||||||
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)
|
|
||||||
=> HasDocs (MatrixParams sym a :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint', action)
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint
|
|
||||||
symP = Proxy :: Proxy sym
|
|
||||||
|
|
||||||
|
|
||||||
instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
|
|
||||||
=> HasDocs (MatrixFlag sym :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint', action)
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
|
|
||||||
endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
|
|
||||||
symP = Proxy :: Proxy sym
|
|
||||||
|
|
||||||
instance HasDocs Raw where
|
|
||||||
docsFor _proxy (endpoint, action) =
|
|
||||||
single endpoint action
|
|
||||||
|
|
||||||
-- TODO: We use 'AllMimeRender' here because we need to be able to show the
|
|
||||||
-- example data. However, there's no reason to believe that the instances of
|
|
||||||
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
|
|
||||||
-- both are even defined) for any particular type.
|
|
||||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
|
|
||||||
=> HasDocs (ReqBody cts a :> sublayout) where
|
|
||||||
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
docsFor sublayoutP (endpoint, action')
|
|
||||||
|
|
||||||
where sublayoutP = Proxy :: Proxy sublayout
|
|
||||||
action' = action & rqbody .~ sampleByteString t p
|
|
||||||
& rqtypes .~ supportedTypes t
|
|
||||||
t = Proxy :: Proxy cts
|
|
||||||
p = Proxy :: Proxy a
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
|
|
||||||
--
|
|
||||||
-- > type MyApi = "users" :> Get [User]
|
|
||||||
-- > :<|> "docs :> Raw
|
|
||||||
-- >
|
|
||||||
-- > apiProxy :: Proxy MyApi
|
|
||||||
-- > apiProxy = Proxy
|
|
||||||
-- >
|
|
||||||
-- > server :: Server MyApi
|
|
||||||
-- > server = listUsers
|
|
||||||
-- > :<|> serveDocumentation apiProxy
|
|
||||||
serveDocumentation :: HasDocs api => Proxy api -> Server Raw
|
|
||||||
serveDocumentation proxy _request respond =
|
|
||||||
respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
|
|
||||||
|
|
||||||
toHtml :: String -> String
|
|
||||||
toHtml md =
|
|
||||||
"<html>" ++
|
|
||||||
"<body>" ++
|
|
||||||
"<pre>" ++
|
|
||||||
md ++
|
|
||||||
"</pre>" ++
|
|
||||||
"</body>" ++
|
|
||||||
"</html>"
|
|
||||||
-}
|
|
||||||
|
|
|
||||||
803
src/Servant/Docs/Internal.hs
Normal file
803
src/Servant/Docs/Internal.hs
Normal file
|
|
@ -0,0 +1,803 @@
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
module Servant.Docs.Internal where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Lens
|
||||||
|
import Data.ByteString.Lazy.Char8 (ByteString)
|
||||||
|
import Data.Hashable
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.List
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Monoid
|
||||||
|
import Data.Ord (comparing)
|
||||||
|
import Data.Proxy
|
||||||
|
import Data.String.Conversions
|
||||||
|
import Data.Text (Text, pack, unpack)
|
||||||
|
import GHC.Exts (Constraint)
|
||||||
|
import GHC.Generics
|
||||||
|
import GHC.TypeLits
|
||||||
|
import Servant.API
|
||||||
|
import Servant.API.ContentTypes
|
||||||
|
import Servant.Utils.Links
|
||||||
|
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Network.HTTP.Media as M
|
||||||
|
|
||||||
|
-- | Supported HTTP request methods
|
||||||
|
data Method = DocDELETE -- ^ the DELETE method
|
||||||
|
| DocGET -- ^ the GET method
|
||||||
|
| DocPOST -- ^ the POST method
|
||||||
|
| DocPUT -- ^ the PUT method
|
||||||
|
deriving (Eq, Ord, 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, Ord, Generic)
|
||||||
|
|
||||||
|
instance Show Endpoint where
|
||||||
|
show (Endpoint p m) =
|
||||||
|
show m ++ " " ++ showPath p
|
||||||
|
|
||||||
|
-- |
|
||||||
|
-- Render a path as a '/'-delimited string
|
||||||
|
--
|
||||||
|
showPath :: [String] -> String
|
||||||
|
showPath [] = "/"
|
||||||
|
showPath ps = concatMap ('/' :) ps
|
||||||
|
|
||||||
|
-- | 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 documentation type, a product of top-level information and a good
|
||||||
|
-- old hashmap from 'Endpoint' to 'Action'
|
||||||
|
data API = API
|
||||||
|
{ _apiIntros :: [DocIntro]
|
||||||
|
, _apiEndpoints :: HashMap Endpoint Action
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Monoid API where
|
||||||
|
API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)
|
||||||
|
mempty = API mempty mempty
|
||||||
|
|
||||||
|
-- | An empty 'API'
|
||||||
|
emptyAPI :: API
|
||||||
|
emptyAPI = mempty
|
||||||
|
|
||||||
|
-- | 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, Ord, Show)
|
||||||
|
|
||||||
|
-- | A type to represent a /GET/ parameter from the Query String. 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 DocQueryParam = DocQueryParam
|
||||||
|
{ _paramName :: String -- type supplied
|
||||||
|
, _paramValues :: [String] -- user supplied
|
||||||
|
, _paramDesc :: String -- user supplied
|
||||||
|
, _paramKind :: ParamKind
|
||||||
|
} deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
-- | An introductory paragraph for your documentation. You can pass these to
|
||||||
|
-- 'docsWithIntros'.
|
||||||
|
data DocIntro = DocIntro
|
||||||
|
{ _introTitle :: String -- ^ Appears above the intro blob
|
||||||
|
, _introBody :: [String] -- ^ Each String is a paragraph.
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Ord DocIntro where
|
||||||
|
compare = comparing _introTitle
|
||||||
|
|
||||||
|
-- | A type to represent extra notes that may be attached to an 'Action'.
|
||||||
|
--
|
||||||
|
-- This is intended to be used when writing your own HasDocs instances to
|
||||||
|
-- add extra sections to your endpoint's documentation.
|
||||||
|
data DocNote = DocNote
|
||||||
|
{ _noteTitle :: String
|
||||||
|
, _noteBody :: [String]
|
||||||
|
} deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
-- | Type of extra information that a user may wish to "union" with their
|
||||||
|
-- documentation.
|
||||||
|
--
|
||||||
|
-- These are intended to be built using extraInfo.
|
||||||
|
-- Multiple ExtraInfo may be combined with the monoid instance.
|
||||||
|
newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
|
||||||
|
instance Monoid (ExtraInfo a) where
|
||||||
|
mempty = ExtraInfo mempty
|
||||||
|
ExtraInfo a `mappend` ExtraInfo b =
|
||||||
|
ExtraInfo $ HM.unionWith combineAction a b
|
||||||
|
|
||||||
|
-- | Type of GET parameter:
|
||||||
|
--
|
||||||
|
-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
|
||||||
|
-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values
|
||||||
|
-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter
|
||||||
|
data ParamKind = Normal | List | Flag
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
-- | A type to represent an HTTP response. Has an 'Int' status, a list of
|
||||||
|
-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
|
||||||
|
-- Tweak 'defResponse' using the 'respStatus', 'respTypes' 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 encoded data in the response.
|
||||||
|
--
|
||||||
|
-- Can be tweaked with three lenses.
|
||||||
|
--
|
||||||
|
-- > λ> defResponse
|
||||||
|
-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
|
||||||
|
-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
|
||||||
|
-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
|
||||||
|
data Response = Response
|
||||||
|
{ _respStatus :: Int
|
||||||
|
, _respTypes :: [M.MediaType]
|
||||||
|
, _respBody :: [(Text, M.MediaType, ByteString)]
|
||||||
|
} deriving (Eq, Ord, 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 [] []
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
, _headers :: [Text] -- type collected
|
||||||
|
, _params :: [DocQueryParam] -- type collected + user supplied info
|
||||||
|
, _notes :: [DocNote] -- user supplied
|
||||||
|
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
|
||||||
|
, _rqtypes :: [M.MediaType] -- type collected
|
||||||
|
, _rqbody :: [(M.MediaType, ByteString)] -- user supplied
|
||||||
|
, _response :: Response -- user supplied
|
||||||
|
} deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
-- | Combine two Actions, we can't make a monoid as merging Response breaks the
|
||||||
|
-- laws.
|
||||||
|
--
|
||||||
|
-- As such, we invent a non-commutative, left associative operation
|
||||||
|
-- 'combineAction' to mush two together taking the response, body and content
|
||||||
|
-- types from the very left.
|
||||||
|
combineAction :: Action -> Action -> Action
|
||||||
|
Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
|
||||||
|
Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
|
||||||
|
|
||||||
|
-- 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 = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
|
||||||
|
-- > λ> defAction & response.respStatus .~ 201
|
||||||
|
-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
|
||||||
|
defAction :: Action
|
||||||
|
defAction =
|
||||||
|
Action []
|
||||||
|
[]
|
||||||
|
[]
|
||||||
|
[]
|
||||||
|
[]
|
||||||
|
[]
|
||||||
|
[]
|
||||||
|
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 e a = API mempty (HM.singleton e a)
|
||||||
|
|
||||||
|
-- gimme some lenses
|
||||||
|
makeLenses ''API
|
||||||
|
makeLenses ''Endpoint
|
||||||
|
makeLenses ''DocCapture
|
||||||
|
makeLenses ''DocQueryParam
|
||||||
|
makeLenses ''DocIntro
|
||||||
|
makeLenses ''DocNote
|
||||||
|
makeLenses ''Response
|
||||||
|
makeLenses ''Action
|
||||||
|
|
||||||
|
-- | Generate the docs for a given API that implements 'HasDocs'. This is the
|
||||||
|
-- default way to create documentation.
|
||||||
|
docs :: HasDocs layout => Proxy layout -> API
|
||||||
|
docs p = docsFor p (defEndpoint, defAction)
|
||||||
|
|
||||||
|
-- | Closed type family, check if endpoint is exactly within API.
|
||||||
|
|
||||||
|
-- We aren't sure what affects how an Endpoint is built up, so we require an
|
||||||
|
-- exact match.
|
||||||
|
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
||||||
|
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
||||||
|
IsIn (e :> sa) (e :> sb) = IsIn sa sb
|
||||||
|
IsIn e e = ()
|
||||||
|
|
||||||
|
-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.
|
||||||
|
--
|
||||||
|
-- The safety here is to ensure that you only add custom documentation to an
|
||||||
|
-- endpoint that actually exists within your API.
|
||||||
|
--
|
||||||
|
-- > extra :: ExtraInfo TestApi
|
||||||
|
-- > extra =
|
||||||
|
-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
|
||||||
|
-- > defAction & headers <>~ ["unicorns"]
|
||||||
|
-- > & notes <>~ [ DocNote "Title" ["This is some text"]
|
||||||
|
-- > , DocNote "Second secton" ["And some more"]
|
||||||
|
-- > ]
|
||||||
|
|
||||||
|
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
|
||||||
|
=> Proxy endpoint -> Action -> ExtraInfo layout
|
||||||
|
extraInfo p action =
|
||||||
|
let api = docsFor p (defEndpoint, defAction)
|
||||||
|
-- Assume one endpoint, HasLink constraint means that we should only ever
|
||||||
|
-- point at one endpoint.
|
||||||
|
in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
|
||||||
|
|
||||||
|
-- | Generate documentation given some extra introductions (in the form of
|
||||||
|
-- 'DocInfo') and some extra endpoint documentation (in the form of
|
||||||
|
-- 'ExtraInfo'.
|
||||||
|
--
|
||||||
|
-- The extra introductions will be prepended to the top of the documentation,
|
||||||
|
-- before the specific endpoint documentation. The extra endpoint documentation
|
||||||
|
-- will be "unioned" with the automatically generated endpoint documentation.
|
||||||
|
--
|
||||||
|
-- You are expected to build up the ExtraInfo with the Monoid instance and
|
||||||
|
-- 'extraInfo'.
|
||||||
|
--
|
||||||
|
-- If you only want to add an introduction, use 'docsWithIntros'.
|
||||||
|
docsWith :: HasDocs layout
|
||||||
|
=> [DocIntro]
|
||||||
|
-> ExtraInfo layout
|
||||||
|
-> Proxy layout
|
||||||
|
-> API
|
||||||
|
docsWith intros (ExtraInfo endpoints) p =
|
||||||
|
docs p & apiIntros <>~ intros
|
||||||
|
& apiEndpoints %~ HM.unionWith combineAction endpoints
|
||||||
|
|
||||||
|
|
||||||
|
-- | Generate the docs for a given API that implements 'HasDocs' with with any
|
||||||
|
-- number of introduction(s)
|
||||||
|
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
|
||||||
|
docsWithIntros intros = docsWith intros mempty
|
||||||
|
|
||||||
|
-- | 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 input or output in the supported
|
||||||
|
-- content-types 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 = Just g
|
||||||
|
-- >
|
||||||
|
-- > where g = Greet "Hello, haskeller!"
|
||||||
|
--
|
||||||
|
-- You can also instantiate this class using 'toSamples' instead of
|
||||||
|
-- 'toSample': it lets you specify different responses along with
|
||||||
|
-- some context (as 'Text') that explains when you're supposed to
|
||||||
|
-- get the corresponding response.
|
||||||
|
class ToSample a where
|
||||||
|
{-# MINIMAL (toSample | toSamples) #-}
|
||||||
|
toSample :: Maybe a
|
||||||
|
toSample = snd <$> listToMaybe samples
|
||||||
|
where samples = toSamples :: [(Text, a)]
|
||||||
|
|
||||||
|
toSamples :: [(Text, a)]
|
||||||
|
toSamples = maybe [] (return . ("",)) s
|
||||||
|
where s = toSample :: Maybe a
|
||||||
|
|
||||||
|
-- | Synthesise a sample value of a type, encoded in the specified media types.
|
||||||
|
sampleByteString
|
||||||
|
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
|
||||||
|
=> Proxy ctypes
|
||||||
|
-> Proxy a
|
||||||
|
-> [(M.MediaType, ByteString)]
|
||||||
|
sampleByteString ctypes@Proxy Proxy =
|
||||||
|
maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
|
||||||
|
|
||||||
|
-- | Synthesise a list of sample values of a particular type, encoded in the
|
||||||
|
-- specified media types.
|
||||||
|
sampleByteStrings
|
||||||
|
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
|
||||||
|
=> Proxy ctypes
|
||||||
|
-> Proxy a
|
||||||
|
-> [(Text, M.MediaType, ByteString)]
|
||||||
|
sampleByteStrings ctypes@Proxy Proxy =
|
||||||
|
let samples = toSamples :: [(Text, a)]
|
||||||
|
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
|
||||||
|
in concatMap enc samples
|
||||||
|
|
||||||
|
-- | Generate a list of 'MediaType' values describing the content types
|
||||||
|
-- accepted by an API component.
|
||||||
|
class SupportedTypes (list :: [*]) where
|
||||||
|
supportedTypes :: Proxy list -> [M.MediaType]
|
||||||
|
|
||||||
|
instance SupportedTypes '[] where
|
||||||
|
supportedTypes Proxy = []
|
||||||
|
|
||||||
|
instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
|
||||||
|
where
|
||||||
|
supportedTypes Proxy =
|
||||||
|
contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
|
||||||
|
|
||||||
|
-- | The class that helps us automatically get documentation
|
||||||
|
-- for GET parameters.
|
||||||
|
--
|
||||||
|
-- Example of an instance:
|
||||||
|
--
|
||||||
|
-- > instance ToParam (QueryParam "capital" Bool) where
|
||||||
|
-- > toParam _ =
|
||||||
|
-- > DocQueryParam "capital"
|
||||||
|
-- > ["true", "false"]
|
||||||
|
-- > "Get the greeting message in uppercase (true) or not (false). Default is false."
|
||||||
|
class ToParam t where
|
||||||
|
toParam :: Proxy t -> DocQueryParam
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
|
||||||
|
-- | Generate documentation in Markdown format for
|
||||||
|
-- the given 'API'.
|
||||||
|
markdown :: API -> String
|
||||||
|
markdown api = unlines $
|
||||||
|
introsStr (api ^. apiIntros)
|
||||||
|
++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
|
||||||
|
|
||||||
|
where printEndpoint :: Endpoint -> Action -> [String]
|
||||||
|
printEndpoint endpoint action =
|
||||||
|
str :
|
||||||
|
"" :
|
||||||
|
notesStr (action ^. notes) ++
|
||||||
|
capturesStr (action ^. captures) ++
|
||||||
|
mxParamsStr (action ^. mxParams) ++
|
||||||
|
headersStr (action ^. headers) ++
|
||||||
|
paramsStr (action ^. params) ++
|
||||||
|
rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
|
||||||
|
responseStr (action ^. response) ++
|
||||||
|
[]
|
||||||
|
|
||||||
|
where str = "## " ++ show (endpoint^.method)
|
||||||
|
++ " " ++ showPath (endpoint^.path)
|
||||||
|
|
||||||
|
introsStr :: [DocIntro] -> [String]
|
||||||
|
introsStr = concatMap introStr
|
||||||
|
|
||||||
|
introStr :: DocIntro -> [String]
|
||||||
|
introStr i =
|
||||||
|
("#### " ++ i ^. introTitle) :
|
||||||
|
"" :
|
||||||
|
intersperse "" (i ^. introBody) ++
|
||||||
|
"" :
|
||||||
|
[]
|
||||||
|
|
||||||
|
notesStr :: [DocNote] -> [String]
|
||||||
|
notesStr = concatMap noteStr
|
||||||
|
|
||||||
|
noteStr :: DocNote -> [String]
|
||||||
|
noteStr nt =
|
||||||
|
("#### " ++ nt ^. noteTitle) :
|
||||||
|
"" :
|
||||||
|
intersperse "" (nt ^. noteBody) ++
|
||||||
|
"" :
|
||||||
|
[]
|
||||||
|
|
||||||
|
capturesStr :: [DocCapture] -> [String]
|
||||||
|
capturesStr [] = []
|
||||||
|
capturesStr l =
|
||||||
|
"#### Captures:" :
|
||||||
|
"" :
|
||||||
|
map captureStr l ++
|
||||||
|
"" :
|
||||||
|
[]
|
||||||
|
|
||||||
|
captureStr cap =
|
||||||
|
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
|
||||||
|
|
||||||
|
mxParamsStr :: [(String, [DocQueryParam])] -> [String]
|
||||||
|
mxParamsStr [] = []
|
||||||
|
mxParamsStr l =
|
||||||
|
"#### Matrix Parameters:" :
|
||||||
|
"" :
|
||||||
|
map segmentStr l
|
||||||
|
segmentStr :: (String, [DocQueryParam]) -> String
|
||||||
|
segmentStr (segment, l) = unlines $
|
||||||
|
("**" ++ segment ++ "**:") :
|
||||||
|
"" :
|
||||||
|
map paramStr l ++
|
||||||
|
"" :
|
||||||
|
[]
|
||||||
|
|
||||||
|
headersStr :: [Text] -> [String]
|
||||||
|
headersStr [] = []
|
||||||
|
headersStr l = [""] ++ map headerStr l ++ [""]
|
||||||
|
|
||||||
|
where headerStr hname = "- This endpoint is sensitive to the value of the **"
|
||||||
|
++ unpack hname ++ "** HTTP header."
|
||||||
|
|
||||||
|
paramsStr :: [DocQueryParam] -> [String]
|
||||||
|
paramsStr [] = []
|
||||||
|
paramsStr l =
|
||||||
|
"#### GET Parameters:" :
|
||||||
|
"" :
|
||||||
|
map paramStr l ++
|
||||||
|
"" :
|
||||||
|
[]
|
||||||
|
|
||||||
|
paramStr param = unlines $
|
||||||
|
("- " ++ param ^. paramName) :
|
||||||
|
(if (not (null values) || param ^. paramKind /= Flag)
|
||||||
|
then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
|
||||||
|
else []) ++
|
||||||
|
(" - **Description**: " ++ param ^. paramDesc) :
|
||||||
|
(if (param ^. paramKind == List)
|
||||||
|
then [" - This parameter is a **list**. All GET parameters with the name "
|
||||||
|
++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
|
||||||
|
else []) ++
|
||||||
|
(if (param ^. paramKind == Flag)
|
||||||
|
then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
|
||||||
|
else []) ++
|
||||||
|
[]
|
||||||
|
|
||||||
|
where values = param ^. paramValues
|
||||||
|
|
||||||
|
rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
|
||||||
|
rqbodyStr [] [] = []
|
||||||
|
rqbodyStr types samples =
|
||||||
|
["#### Request:", ""]
|
||||||
|
<> formatTypes types
|
||||||
|
<> concatMap formatBody samples
|
||||||
|
|
||||||
|
formatTypes [] = []
|
||||||
|
formatTypes ts = ["- Supported content types are:", ""]
|
||||||
|
<> map (\t -> " - `" <> show t <> "`") ts
|
||||||
|
<> [""]
|
||||||
|
|
||||||
|
formatBody (m, b) =
|
||||||
|
"- Example: `" <> cs (show m) <> "`" :
|
||||||
|
contentStr m b
|
||||||
|
|
||||||
|
markdownForType mime_type =
|
||||||
|
case (M.mainType mime_type, M.subType mime_type) of
|
||||||
|
("text", "html") -> "html"
|
||||||
|
("application", "xml") -> "xml"
|
||||||
|
("application", "json") -> "javascript"
|
||||||
|
("application", "javascript") -> "javascript"
|
||||||
|
("text", "css") -> "css"
|
||||||
|
(_, _) -> ""
|
||||||
|
|
||||||
|
contentStr mime_type body =
|
||||||
|
"" :
|
||||||
|
"```" <> markdownForType mime_type :
|
||||||
|
cs body :
|
||||||
|
"```" :
|
||||||
|
"" :
|
||||||
|
[]
|
||||||
|
|
||||||
|
responseStr :: Response -> [String]
|
||||||
|
responseStr resp =
|
||||||
|
"#### Response:" :
|
||||||
|
"" :
|
||||||
|
("- Status code " ++ show (resp ^. respStatus)) :
|
||||||
|
"" :
|
||||||
|
formatTypes (resp ^. respTypes) ++
|
||||||
|
bodies
|
||||||
|
|
||||||
|
where bodies = case resp ^. respBody of
|
||||||
|
[] -> ["- No response body\n"]
|
||||||
|
[("", t, r)] -> "- Response body as below." : contentStr t r
|
||||||
|
xs ->
|
||||||
|
concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
|
||||||
|
|
||||||
|
-- * Instances
|
||||||
|
|
||||||
|
-- | The generated docs for @a ':<|>' b@ just appends the docs
|
||||||
|
-- for @a@ with the docs for @b@.
|
||||||
|
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
|
||||||
|
|
||||||
|
-- | @"books" :> 'Capture' "isbn" Text@ will appear as
|
||||||
|
-- @/books/:isbn@ in the docs.
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
instance HasDocs Delete where
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
single endpoint' action'
|
||||||
|
|
||||||
|
where endpoint' = endpoint & method .~ DocDELETE
|
||||||
|
|
||||||
|
action' = action & response.respBody .~ []
|
||||||
|
& response.respStatus .~ 204
|
||||||
|
|
||||||
|
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||||
|
=> HasDocs (Get cts a) where
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
single endpoint' action'
|
||||||
|
|
||||||
|
where endpoint' = endpoint & method .~ DocGET
|
||||||
|
action' = action & response.respBody .~ sampleByteStrings t p
|
||||||
|
& response.respTypes .~ supportedTypes t
|
||||||
|
t = Proxy :: Proxy cts
|
||||||
|
p = Proxy :: Proxy a
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasDocs sublayout)
|
||||||
|
=> HasDocs (Header sym a :> sublayout) where
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint, action')
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
action' = over headers (|> headername) action
|
||||||
|
headername = pack $ symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||||
|
=> HasDocs (Post cts a) where
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
single endpoint' action'
|
||||||
|
|
||||||
|
where endpoint' = endpoint & method .~ DocPOST
|
||||||
|
action' = action & response.respBody .~ sampleByteStrings t p
|
||||||
|
& response.respTypes .~ supportedTypes t
|
||||||
|
& response.respStatus .~ 201
|
||||||
|
t = Proxy :: Proxy cts
|
||||||
|
p = Proxy :: Proxy a
|
||||||
|
|
||||||
|
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||||
|
=> HasDocs (Put cts a) where
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
single endpoint' action'
|
||||||
|
|
||||||
|
where endpoint' = endpoint & method .~ DocPUT
|
||||||
|
action' = action & response.respBody .~ sampleByteStrings t p
|
||||||
|
& response.respTypes .~ supportedTypes t
|
||||||
|
& response.respStatus .~ 200
|
||||||
|
t = Proxy :: Proxy cts
|
||||||
|
p = Proxy :: Proxy a
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
|
||||||
|
=> HasDocs (QueryParam sym a :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint, action')
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
paramP = Proxy :: Proxy (QueryParam sym a)
|
||||||
|
action' = over params (|> toParam paramP) action
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
|
||||||
|
=> HasDocs (QueryParams sym a :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint, action')
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
paramP = Proxy :: Proxy (QueryParams sym a)
|
||||||
|
action' = over params (|> toParam paramP) action
|
||||||
|
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
|
||||||
|
=> HasDocs (QueryFlag sym :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint, action')
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
paramP = Proxy :: Proxy (QueryFlag sym)
|
||||||
|
action' = over params (|> toParam paramP) action
|
||||||
|
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)
|
||||||
|
=> HasDocs (MatrixParam sym a :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint', action')
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
paramP = Proxy :: Proxy (MatrixParam sym a)
|
||||||
|
segment = endpoint ^. (path._last)
|
||||||
|
segment' = action ^. (mxParams._last._1)
|
||||||
|
endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint
|
||||||
|
|
||||||
|
action' = if segment' /= segment
|
||||||
|
-- This is the first matrix parameter for this segment, insert a new entry into the mxParams list
|
||||||
|
then over mxParams (|> (segment, [toParam paramP])) action
|
||||||
|
-- We've already inserted a matrix parameter for this segment, append to the existing list
|
||||||
|
else action & mxParams._last._2 <>~ [toParam paramP]
|
||||||
|
symP = Proxy :: Proxy sym
|
||||||
|
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)
|
||||||
|
=> HasDocs (MatrixParams sym a :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint', action)
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint
|
||||||
|
symP = Proxy :: Proxy sym
|
||||||
|
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
|
||||||
|
=> HasDocs (MatrixFlag sym :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint', action)
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
|
||||||
|
endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
|
||||||
|
symP = Proxy :: Proxy sym
|
||||||
|
|
||||||
|
instance HasDocs Raw where
|
||||||
|
docsFor _proxy (endpoint, action) =
|
||||||
|
single endpoint action
|
||||||
|
|
||||||
|
-- TODO: We use 'AllMimeRender' here because we need to be able to show the
|
||||||
|
-- example data. However, there's no reason to believe that the instances of
|
||||||
|
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
|
||||||
|
-- both are even defined) for any particular type.
|
||||||
|
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
|
||||||
|
=> HasDocs (ReqBody cts a :> sublayout) where
|
||||||
|
|
||||||
|
docsFor Proxy (endpoint, action) =
|
||||||
|
docsFor sublayoutP (endpoint, action')
|
||||||
|
|
||||||
|
where sublayoutP = Proxy :: Proxy sublayout
|
||||||
|
action' = action & rqbody .~ sampleByteString t p
|
||||||
|
& rqtypes .~ supportedTypes t
|
||||||
|
t = Proxy :: Proxy cts
|
||||||
|
p = Proxy :: Proxy a
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
{-
|
||||||
|
|
||||||
|
-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
|
||||||
|
--
|
||||||
|
-- > type MyApi = "users" :> Get [User]
|
||||||
|
-- > :<|> "docs :> Raw
|
||||||
|
-- >
|
||||||
|
-- > apiProxy :: Proxy MyApi
|
||||||
|
-- > apiProxy = Proxy
|
||||||
|
-- >
|
||||||
|
-- > server :: Server MyApi
|
||||||
|
-- > server = listUsers
|
||||||
|
-- > :<|> serveDocumentation apiProxy
|
||||||
|
serveDocumentation :: HasDocs api => Proxy api -> Server Raw
|
||||||
|
serveDocumentation proxy _request respond =
|
||||||
|
respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
|
||||||
|
|
||||||
|
toHtml :: String -> String
|
||||||
|
toHtml md =
|
||||||
|
"<html>" ++
|
||||||
|
"<body>" ++
|
||||||
|
"<pre>" ++
|
||||||
|
md ++
|
||||||
|
"</pre>" ++
|
||||||
|
"</body>" ++
|
||||||
|
"</html>"
|
||||||
|
-}
|
||||||
64
test/Servant/DocsSpec.hs
Normal file
64
test/Servant/DocsSpec.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
module Servant.DocsSpec where
|
||||||
|
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Proxy
|
||||||
|
import Data.String.Conversions (cs)
|
||||||
|
import GHC.Generics
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
import Servant.Docs.Internal
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.Docs" $ do
|
||||||
|
|
||||||
|
describe "markdown" $ do
|
||||||
|
let md = markdown (docs (Proxy :: Proxy TestApi1))
|
||||||
|
|
||||||
|
it "mentions supported content-types" $ do
|
||||||
|
md `shouldContain` "application/json"
|
||||||
|
md `shouldContain` "text/plain;charset=utf-8"
|
||||||
|
|
||||||
|
it "mentions status codes" $ do
|
||||||
|
md `shouldContain` "Status code 200"
|
||||||
|
md `shouldContain` "Status code 201"
|
||||||
|
|
||||||
|
it "mentions methods" $ do
|
||||||
|
md `shouldContain` "POST"
|
||||||
|
md `shouldContain` "GET"
|
||||||
|
|
||||||
|
it "contains response samples" $ do
|
||||||
|
md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
|
||||||
|
it "contains request body samples" $ do
|
||||||
|
md `shouldContain` "17"
|
||||||
|
-- * APIs
|
||||||
|
|
||||||
|
data Datatype1 = Datatype1 { dt1field1 :: String
|
||||||
|
, dt1field2 :: Int
|
||||||
|
} deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
|
instance ToJSON Datatype1
|
||||||
|
|
||||||
|
instance ToSample Datatype1 where
|
||||||
|
toSample = Just $ Datatype1 "field 1" 13
|
||||||
|
|
||||||
|
instance ToSample String where
|
||||||
|
toSample = Just "a string"
|
||||||
|
|
||||||
|
instance ToSample Int where
|
||||||
|
toSample = Just 17
|
||||||
|
|
||||||
|
instance MimeRender PlainText Int where
|
||||||
|
toByteString _ = cs . show
|
||||||
|
|
||||||
|
|
||||||
|
type TestApi1 = Get '[JSON, PlainText] Int
|
||||||
|
:<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
|
||||||
|
|
||||||
1
test/Spec.hs
Normal file
1
test/Spec.hs
Normal file
|
|
@ -0,0 +1 @@
|
||||||
|
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||||
Loading…
Reference in a new issue