module Servant.Docs
(
HasDocs(..), docs, markdown
,
ToSample(..)
, sampleByteString
, sampleByteStrings
, ToParam(..)
, ToCapture(..)
,
Method(..)
, Endpoint, path, method, defEndpoint
, API, emptyAPI
, DocCapture(..), capSymbol, capDesc
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
, Response, respStatus, respBody, defResponse
, Action, captures, headers, params, rqbody, response, defAction
, single
,
module Control.Lens
, module Data.Monoid
) where
import Control.Lens hiding (Action)
import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.List
import Data.Maybe (listToMaybe)
import Data.Monoid
import Data.Proxy
import Data.Text (Text, pack, unpack)
import Data.String.Conversions
import GHC.Generics
import GHC.TypeLits
import Servant.API
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
data Method = DocDELETE
| DocGET
| DocPOST
| DocPUT
deriving (Eq, Generic)
instance Show Method where
show DocGET = "GET"
show DocPOST = "POST"
show DocDELETE = "DELETE"
show DocPUT = "PUT"
instance Hashable Method
data Endpoint = Endpoint
{ _path :: [String]
, _method :: Method
} deriving (Eq, Generic)
instance Show Endpoint where
show (Endpoint p m) =
show m ++ " " ++ showPath p
showPath :: [String] -> String
showPath [] = "/"
showPath ps = concatMap ('/' :) ps
defEndpoint :: Endpoint
defEndpoint = Endpoint [] DocGET
instance Hashable Endpoint
type API = HashMap Endpoint Action
emptyAPI :: API
emptyAPI = HM.empty
data DocCapture = DocCapture
{ _capSymbol :: String
, _capDesc :: String
} deriving (Eq, Show)
data DocQueryParam = DocQueryParam
{ _paramName :: String
, _paramValues :: [String]
, _paramDesc :: String
, _paramKind :: ParamKind
} deriving (Eq, Show)
data ParamKind = Normal | List | Flag
deriving (Eq, Show)
data Response = Response
{ _respStatus :: Int
, _respBody :: [(Text, ByteString)]
} deriving (Eq, Show)
defResponse :: Response
defResponse = Response 200 []
data Action = Action
{ _captures :: [DocCapture]
, _headers :: [Text]
, _params :: [DocQueryParam]
, _mxParams :: [(String, [DocQueryParam])]
, _rqbody :: Maybe ByteString
, _response :: Response
} deriving (Eq, Show)
defAction :: Action
defAction =
Action []
[]
[]
[]
Nothing
defResponse
single :: Endpoint -> Action -> API
single = HM.singleton
makeLenses ''Endpoint
makeLenses ''DocCapture
makeLenses ''DocQueryParam
makeLenses ''Response
makeLenses ''Action
docs :: HasDocs layout => Proxy layout -> API
docs p = docsFor p (defEndpoint, defAction)
class HasDocs layout where
docsFor :: Proxy layout -> (Endpoint, Action) -> API
class ToJSON a => ToSample a where
toSample :: Maybe a
toSample = fmap snd $ listToMaybe samples
where samples = toSamples :: [(Text, a)]
toSamples :: [(Text, a)]
toSamples = maybe [] (return . ("",)) s
where s = toSample :: Maybe a
sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString
sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)
sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]
sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty
where samples = toSamples :: [(Text, a)]
class ToParam t where
toParam :: Proxy t -> DocQueryParam
class ToCapture c where
toCapture :: Proxy c -> DocCapture
markdown :: API -> String
markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
where printEndpoint :: Endpoint -> Action -> [String]
printEndpoint endpoint action =
str :
replicate len '-' :
"" :
capturesStr (action ^. captures) ++
mxParamsStr (action ^. mxParams) ++
headersStr (action ^. headers) ++
paramsStr (action ^. params) ++
rqbodyStr (action ^. rqbody) ++
responseStr (action ^. response) ++
[]
where str = show (endpoint^.method) ++ " " ++ showPath (endpoint^.path)
len = length str
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 :: Maybe ByteString -> [String]
rqbodyStr Nothing = []
rqbodyStr (Just b) =
"**Request Body**: " :
jsonStr b
jsonStr b =
"" :
"``` javascript" :
cs b :
"```" :
"" :
[]
responseStr :: Response -> [String]
responseStr resp =
"**Response**: " :
"" :
(" - Status code " ++ show (resp ^. respStatus)) :
bodies
where bodies = case resp ^. respBody of
[] -> [" - No response body\n"]
[("", r)] -> " - Response body as below." : jsonStr r
xs ->
concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
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
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 => HasDocs (Get a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ sampleByteStrings p
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 => HasDocs (Post a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings p
& response.respStatus .~ 201
p = Proxy :: Proxy a
instance ToSample a => HasDocs (Put a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings p
& response.respStatus .~ 200
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
then over mxParams (|> (segment, [toParam paramP])) action
else action & mxParams._last._2 <>~ [toParam paramP]
symP = Proxy :: Proxy sym
instance (KnownSymbol sym, 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, 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
instance (ToSample a, HasDocs sublayout)
=> HasDocs (ReqBody a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString p
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