servant/servant-docs/src/Servant/Docs/Internal.hs

891 lines
31 KiB
Haskell
Raw Normal View History

2015-05-02 03:21:03 +02:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
2015-05-02 03:21:03 +02:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
2015-05-02 03:21:03 +02:00
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
2015-05-02 03:21:03 +02:00
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
2015-12-27 17:54:29 +01:00
#include "overlapping-compat.h"
2015-04-08 16:27:38 +02:00
module Servant.Docs.Internal where
2017-01-19 18:05:01 +01:00
import Prelude ()
import Prelude.Compat
2015-04-08 16:27:38 +02:00
import Control.Applicative
import Control.Arrow (second)
import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
(&), (.~), (<>~), (^.), (|>))
import qualified Control.Monad.Omega as Omega
2015-04-08 16:27:38 +02:00
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BSC
2015-05-02 03:21:03 +02:00
import qualified Data.CaseInsensitive as CI
2015-09-23 18:26:05 +02:00
import Data.Hashable (Hashable)
2015-04-08 16:27:38 +02:00
import Data.HashMap.Strict (HashMap)
2017-01-19 18:05:01 +01:00
import Data.List.Compat (intercalate, intersperse, sort)
2015-04-08 16:27:38 +02:00
import Data.Maybe
2017-01-19 18:05:01 +01:00
import Data.Monoid (All (..), Any (..), Sum (..), Product (..), First (..), Last (..), Dual (..))
import Data.Semigroup (Semigroup (..))
2015-04-08 16:27:38 +02:00
import Data.Ord (comparing)
2015-09-23 18:26:05 +02:00
import Data.Proxy (Proxy(Proxy))
import Data.String.Conversions (cs)
2016-01-06 17:31:40 +01:00
import Data.Text (Text, unpack)
2015-04-08 16:27:38 +02:00
import GHC.Generics
import GHC.TypeLits
import Servant.API
import Servant.API.ContentTypes
2016-01-20 15:56:52 +01:00
import Servant.API.TypeLevel
2015-04-08 16:27:38 +02:00
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Network.HTTP.Media as M
2015-05-02 03:21:03 +02:00
import qualified Network.HTTP.Types as HTTP
2015-04-08 16:27:38 +02:00
-- | 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
2016-01-06 17:31:40 +01:00
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
2015-04-08 16:27:38 +02:00
-- POST /foo
-- @
data Endpoint = Endpoint
2016-01-06 17:31:40 +01:00
{ _path :: [String] -- type collected
, _method :: HTTP.Method -- type collected
2015-04-08 16:27:38 +02:00
} 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
2016-01-06 17:31:40 +01:00
-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@
2015-04-08 16:27:38 +02:00
--
-- Here's how you can modify it:
--
-- @
-- λ> 'defEndpoint'
-- GET /
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
-- GET /foo
2016-01-06 17:31:40 +01:00
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
2015-04-08 16:27:38 +02:00
-- POST /foo
-- @
defEndpoint :: Endpoint
2016-01-06 17:31:40 +01:00
defEndpoint = Endpoint [] HTTP.methodGet
2015-04-08 16:27:38 +02:00
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)
2017-01-19 18:05:01 +01:00
instance Semigroup API where
(<>) = mappend
2015-04-08 16:27:38 +02:00
instance Monoid API where
2017-01-19 18:05:01 +01:00
API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
2015-04-08 16:27:38 +02:00
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/ (or other possible 'HTTP.Method')
-- 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.
2015-04-08 16:27:38 +02:00
--
-- 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)
-- | A type to represent Authentication information about an endpoint.
data DocAuthentication = DocAuthentication
{ _authIntro :: String
, _authDataRequired :: String
} deriving (Eq, Ord, Show)
2015-04-08 16:27:38 +02:00
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 api = ExtraInfo (HashMap Endpoint Action)
2017-01-19 18:05:01 +01:00
instance Semigroup (ExtraInfo a) where
(<>) = mappend
2015-04-08 16:27:38 +02:00
instance Monoid (ExtraInfo a) where
mempty = ExtraInfo mempty
ExtraInfo a `mappend` ExtraInfo b =
ExtraInfo $ HM.unionWith combineAction a b
-- | Documentation options.
data DocOptions = DocOptions
{ _maxSamples :: Int -- ^ Maximum samples allowed.
} deriving (Show)
-- | Default documentation options.
defaultDocOptions :: DocOptions
defaultDocOptions = DocOptions
{ _maxSamples = 5 }
-- | Type of GET (or other 'HTTP.Method') parameter:
2015-04-08 16:27:38 +02:00
--
-- - 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
2015-05-02 03:21:03 +02:00
{ _respStatus :: Int
, _respTypes :: [M.MediaType]
, _respBody :: [(Text, M.MediaType, ByteString)]
, _respHeaders :: [HTTP.Header]
2015-04-08 16:27:38 +02:00
} 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
2015-05-02 03:21:03 +02:00
defResponse = Response
{ _respStatus = 200
, _respTypes = []
, _respBody = []
, _respHeaders = []
}
2015-04-08 16:27:38 +02:00
-- | A datatype that represents everything that can happen
-- at an endpoint, with its lenses:
--
-- - List of captures ('captures')
-- - List of GET (or other 'HTTP.Method') parameters ('params')
2015-04-08 16:27:38 +02:00
-- - 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
{ _authInfo :: [DocAuthentication] -- user supplied info
, _captures :: [DocCapture] -- type collected + user supplied info
2015-04-08 16:27:38 +02:00
, _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 :: [(Text, M.MediaType, ByteString)] -- user supplied
2015-04-08 16:27:38 +02:00
, _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 a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
2015-04-08 16:27:38 +02:00
-- | Default 'Action'. Has no 'captures', no query 'params', expects
2015-04-08 16:27:38 +02:00
-- 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 []
[]
[]
[]
[]
[]
[]
[]
2015-04-08 16:27:38 +02:00
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 ''DocAuthentication
makeLenses ''DocOptions
2015-04-08 16:27:38 +02:00
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.
--
-- prop> docs == docsWithOptions defaultDocOptions
docs :: HasDocs api => Proxy api -> API
docs p = docsWithOptions p defaultDocOptions
-- | Generate the docs for a given API that implements 'HasDocs'.
docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API
docsWithOptions p = docsFor p (defEndpoint, defAction)
2015-04-08 16:27:38 +02:00
-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout.
2015-04-08 16:27:38 +02:00
--
-- 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 api, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo api
2015-04-08 16:27:38 +02:00
extraInfo p action =
let api = docsFor p (defEndpoint, defAction) defaultDocOptions
2015-04-08 16:27:38 +02:00
-- 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 api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API
docsWith opts intros (ExtraInfo endpoints) p =
docsWithOptions p opts
& apiIntros <>~ intros
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
2015-04-08 16:27:38 +02:00
-- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s)
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty
2015-04-08 16:27:38 +02:00
-- | The class that abstracts away the impact of API combinators
-- on documentation generation.
class HasDocs api where
docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API
2015-04-08 16:27:38 +02:00
-- | 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
-- >
2015-09-24 14:25:58 +02:00
-- > instance ToSample Greet where
-- > toSamples _ = singleSample g
2015-04-08 16:27:38 +02:00
-- >
-- > 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
toSamples :: Proxy a -> [(Text, a)]
default toSamples :: (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
toSamples = defaultSamples
-- | Sample input or output (if there is at least one).
toSample :: forall a. ToSample a => Proxy a -> Maybe a
toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a))
-- | No samples.
noSamples :: [(Text, a)]
noSamples = empty
-- | Single sample without description.
singleSample :: a -> [(Text, a)]
singleSample x = [("", x)]
-- | Samples without documentation.
samples :: [a] -> [(Text, a)]
samples = map ("",)
-- | Default sample Generic-based inputs/outputs.
defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
-- | @'ToSample'@ for Generics.
--
-- The use of @'Omega'@ allows for more productive sample generation.
class GToSample t where
gtoSamples :: proxy t -> Omega.Omega (Text, t x)
instance GToSample U1 where
gtoSamples _ = Omega.each (singleSample U1)
instance GToSample V1 where
gtoSamples _ = empty
instance (GToSample p, GToSample q) => GToSample (p :*: q) where
gtoSamples _ = render <$> ps <*> qs
where
ps = gtoSamples (Proxy :: Proxy p)
qs = gtoSamples (Proxy :: Proxy q)
render (ta, a) (tb, b)
| T.null ta || T.null tb = (ta <> tb, a :*: b)
| otherwise = (ta <> ", " <> tb, a :*: b)
instance (GToSample p, GToSample q) => GToSample (p :+: q) where
gtoSamples _ = lefts <|> rights
where
lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
instance ToSample a => GToSample (K1 i a) where
gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
instance (GToSample f) => GToSample (M1 i a f) where
gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
2015-05-02 03:21:03 +02:00
2015-04-08 16:27:38 +02:00
2015-05-02 03:21:03 +02:00
class AllHeaderSamples ls where
allHeaderToSample :: Proxy ls -> [HTTP.Header]
instance AllHeaderSamples '[] where
allHeaderToSample _ = []
instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
2015-05-02 03:21:03 +02:00
=> AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
2015-05-02 03:21:03 +02:00
allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
mkHeader (Just x) = (headerName, cs $ toHeader x)
2015-05-02 03:21:03 +02:00
mkHeader Nothing = (headerName, "<no header sample provided>")
2015-04-08 16:27:38 +02:00
-- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy (ct ': cts)
2015-04-08 16:27:38 +02:00
-> Proxy a
-> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy =
2015-05-02 03:21:03 +02:00
maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)
2015-04-08 16:27:38 +02:00
-- | Synthesise a list of sample values of a particular type, encoded in the
-- specified media types.
sampleByteStrings
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy (ct ': cts)
2015-04-08 16:27:38 +02:00
-> Proxy a
-> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy =
2015-09-23 18:26:05 +02:00
let samples' = toSamples (Proxy :: Proxy a)
2015-04-08 16:27:38 +02:00
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
2015-09-23 18:26:05 +02:00
in concatMap enc samples'
2015-04-08 16:27:38 +02:00
-- | The class that helps us automatically get documentation for GET
-- (or other 'HTTP.Method') parameters.
2015-04-08 16:27:38 +02:00
--
-- 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
-- | The class that helps us get documentation for authenticated endpoints
class ToAuthInfo a where
toAuthInfo :: Proxy a -> DocAuthentication
2015-04-08 16:27:38 +02:00
-- | 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) ++
authStr (action ^. authInfo) ++
2015-04-08 16:27:38 +02:00
capturesStr (action ^. captures) ++
headersStr (action ^. headers) ++
paramsStr meth (action ^. params) ++
2015-04-08 16:27:38 +02:00
rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
responseStr (action ^. response) ++
[]
where str = "## " ++ BSC.unpack meth
2015-04-08 16:27:38 +02:00
++ " " ++ showPath (endpoint^.path)
meth = endpoint ^. method
2015-04-08 16:27:38 +02:00
introsStr :: [DocIntro] -> [String]
introsStr = concatMap introStr
introStr :: DocIntro -> [String]
introStr i =
("## " ++ i ^. introTitle) :
2015-04-08 16:27:38 +02:00
"" :
intersperse "" (i ^. introBody) ++
"" :
[]
notesStr :: [DocNote] -> [String]
notesStr = concatMap noteStr
noteStr :: DocNote -> [String]
noteStr nt =
("#### " ++ nt ^. noteTitle) :
"" :
intersperse "" (nt ^. noteBody) ++
"" :
[]
authStr :: [DocAuthentication] -> [String]
2017-06-29 12:01:46 +02:00
authStr [] = []
authStr auths =
let authIntros = mapped %~ view authIntro $ auths
clientInfos = mapped %~ view authDataRequired $ auths
in "#### Authentication":
"":
unlines authIntros :
"":
"Clients must supply the following data" :
unlines clientInfos :
"" :
[]
2015-04-08 16:27:38 +02:00
capturesStr :: [DocCapture] -> [String]
capturesStr [] = []
capturesStr l =
"#### Captures:" :
"" :
map captureStr l ++
"" :
[]
captureStr cap =
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
headersStr :: [Text] -> [String]
headersStr [] = []
headersStr l =
"#### Headers:" :
"" :
map headerStr l ++
"" :
[]
2015-04-08 16:27:38 +02:00
where headerStr hname = "- This endpoint is sensitive to the value of the **"
++ unpack hname ++ "** HTTP header."
paramsStr :: HTTP.Method -> [DocQueryParam] -> [String]
paramsStr _ [] = []
paramsStr m l =
("#### " ++ cs m ++ " Parameters:") :
2015-04-08 16:27:38 +02:00
"" :
map (paramStr m) l ++
2015-04-08 16:27:38 +02:00
"" :
[]
paramStr m param = unlines $
2015-04-08 16:27:38 +02:00
("- " ++ 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 " ++ cs m ++ " parameters with the name "
2015-04-08 16:27:38 +02:00
++ 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] -> [(Text, M.MediaType, ByteString)]-> [String]
2015-04-08 16:27:38 +02:00
rqbodyStr [] [] = []
2015-09-23 18:26:05 +02:00
rqbodyStr types s =
2015-04-08 16:27:38 +02:00
["#### Request:", ""]
<> formatTypes types
2015-09-23 18:26:05 +02:00
<> concatMap formatBody s
2015-04-08 16:27:38 +02:00
formatTypes [] = []
formatTypes ts = ["- Supported content types are:", ""]
<> map (\t -> " - `" <> show t <> "`") ts
<> [""]
formatBody (t, m, b) =
"- Example (" <> cs t <> "): `" <> cs (show m) <> "`" :
2015-04-08 16:27:38 +02:00
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)) :
2015-05-02 03:21:03 +02:00
("- Headers: " ++ show (resp ^. respHeaders)) :
2015-04-08 16:27:38 +02:00
"" :
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@.
2015-12-27 17:54:29 +01:00
instance OVERLAPPABLE_
(HasDocs a, HasDocs b)
=> HasDocs (a :<|> b) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
where p1 :: Proxy a
2015-04-08 16:27:38 +02:00
p1 = Proxy
p2 :: Proxy b
2015-04-08 16:27:38 +02:00
p2 = Proxy
2017-05-16 11:52:55 +02:00
-- | The generated docs for @'EmptyAPI'@ are empty.
instance HasDocs EmptyAPI where
docsFor Proxy _ _ = emptyAPI
2015-04-08 16:27:38 +02:00
-- | @"books" :> 'Capture' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
=> HasDocs (Capture sym a :> api) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint', action')
2015-04-08 16:27:38 +02:00
where subApiP = Proxy :: Proxy api
2015-04-08 16:27:38 +02:00
captureP = Proxy :: Proxy (Capture sym a)
action' = over captures (|> toCapture captureP) action
endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym
2016-05-26 22:22:11 +02:00
-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
=> HasDocs (CaptureAll sym a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action')
where sublayoutP = Proxy :: Proxy sublayout
captureP = Proxy :: Proxy (CaptureAll sym a)
action' = over captures (|> toCapture captureP) action
endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym
2015-12-27 17:54:29 +01:00
instance OVERLAPPABLE_
2016-01-06 17:31:40 +01:00
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method)
=> HasDocs (Verb method status (ct ': cts) a) where
docsFor Proxy (endpoint, action) DocOptions{..} =
2015-04-08 16:27:38 +02:00
single endpoint' action'
2016-01-06 17:31:40 +01:00
where endpoint' = endpoint & method .~ method'
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
2016-01-06 17:31:40 +01:00
& response.respStatus .~ status
t = Proxy :: Proxy (ct ': cts)
2016-01-06 17:31:40 +01:00
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
2015-04-08 16:27:38 +02:00
p = Proxy :: Proxy a
2015-12-27 17:54:29 +01:00
instance OVERLAPPING_
2016-01-06 17:31:40 +01:00
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
=> HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} =
2015-05-02 03:21:03 +02:00
single endpoint' action'
2016-01-06 17:31:40 +01:00
where endpoint' = endpoint & method .~ method'
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
2016-01-06 17:31:40 +01:00
& response.respStatus .~ status
2015-05-02 03:21:03 +02:00
& response.respHeaders .~ hdrs
t = Proxy :: Proxy (ct ': cts)
2016-01-06 17:31:40 +01:00
hdrs = allHeaderToSample (Proxy :: Proxy ls)
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
2015-05-02 03:21:03 +02:00
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs api)
=> HasDocs (Header sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
where subApiP = Proxy :: Proxy api
action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
=> HasDocs (QueryParam sym a :> api) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
2015-04-08 16:27:38 +02:00
where subApiP = Proxy :: Proxy api
2015-04-08 16:27:38 +02:00
paramP = Proxy :: Proxy (QueryParam sym a)
action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
=> HasDocs (QueryParams sym a :> api) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
2015-04-08 16:27:38 +02:00
where subApiP = Proxy :: Proxy api
2015-04-08 16:27:38 +02:00
paramP = Proxy :: Proxy (QueryParams sym a)
action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
=> HasDocs (QueryFlag sym :> api) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
2015-04-08 16:27:38 +02:00
where subApiP = Proxy :: Proxy api
2015-04-08 16:27:38 +02:00
paramP = Proxy :: Proxy (QueryFlag sym)
action' = over params (|> toParam paramP) action
instance HasDocs Raw where
docsFor _proxy (endpoint, action) _ =
2015-04-08 16:27:38 +02:00
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, AllMimeRender (ct ': cts) a, HasDocs api)
=> HasDocs (ReqBody (ct ': cts) a :> api) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (endpoint, action) opts@DocOptions{..} =
docsFor subApiP (endpoint, action') opts
2015-04-08 16:27:38 +02:00
where subApiP = Proxy :: Proxy api
action' :: Action
action' = action & rqbody .~ take _maxSamples (sampleByteStrings t p)
& rqtypes .~ allMime t
t = Proxy :: Proxy (ct ': cts)
2015-04-08 16:27:38 +02:00
p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
2015-04-08 16:27:38 +02:00
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint', action)
2015-04-08 16:27:38 +02:00
where subApiP = Proxy :: Proxy api
2015-04-08 16:27:38 +02:00
endpoint' = endpoint & path <>~ [symbolVal pa]
pa = Proxy :: Proxy path
instance HasDocs api => HasDocs (RemoteHost :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy api) ep
instance HasDocs api => HasDocs (IsSecure :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy api) ep
instance HasDocs api => HasDocs (HttpVersion :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy api) ep
instance HasDocs api => HasDocs (Vault :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy api) ep
2015-09-16 11:35:15 +02:00
instance HasDocs api => HasDocs (WithNamedContext name context api) where
docsFor Proxy = docsFor (Proxy :: Proxy api)
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
docsFor Proxy (endpoint, action) =
docsFor (Proxy :: Proxy api) (endpoint, action')
where
authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action
-- ToSample instances for simple types
instance ToSample NoContent
instance ToSample Bool
instance ToSample Ordering
2015-09-16 11:35:15 +02:00
-- polymorphic ToSample instances
instance (ToSample a, ToSample b) => ToSample (a, b)
instance (ToSample a, ToSample b, ToSample c) => ToSample (a, b, c)
instance (ToSample a, ToSample b, ToSample c, ToSample d) => ToSample (a, b, c, d)
instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e) => ToSample (a, b, c, d, e)
instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f) => ToSample (a, b, c, d, e, f)
instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f, ToSample g) => ToSample (a, b, c, d, e, f, g)
instance ToSample a => ToSample (Maybe a)
instance (ToSample a, ToSample b) => ToSample (Either a b)
instance ToSample a => ToSample [a]
2015-09-21 11:02:44 +02:00
-- ToSample instances for Control.Applicative types
instance ToSample a => ToSample (Const a b)
instance ToSample a => ToSample (ZipList a)
2015-09-21 11:02:44 +02:00
-- ToSample instances for Data.Monoid newtypes
instance ToSample All
instance ToSample Any
instance ToSample a => ToSample (Sum a)
instance ToSample a => ToSample (Product a)
instance ToSample a => ToSample (First a)
instance ToSample a => ToSample (Last a)
instance ToSample a => ToSample (Dual a)