#include "overlapping-compat.h"
module Servant.Docs.Internal where
import Control.Applicative
import Control.Arrow (second)
import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
(&), (.~), (<>~), (^.), (|>))
import qualified Control.Monad.Omega as Omega
import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.CaseInsensitive as CI
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Proxy (Proxy(Proxy))
import Data.String.Conversions (cs)
import Data.Text (Text, 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
import qualified Network.HTTP.Types as HTTP
data Endpoint = Endpoint
{ _path :: [String]
, _method :: HTTP.Method
} deriving (Eq, Ord, 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 [] HTTP.methodGet
instance Hashable Endpoint
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
emptyAPI :: API
emptyAPI = mempty
data DocCapture = DocCapture
{ _capSymbol :: String
, _capDesc :: String
} deriving (Eq, Ord, Show)
data DocQueryParam = DocQueryParam
{ _paramName :: String
, _paramValues :: [String]
, _paramDesc :: String
, _paramKind :: ParamKind
} deriving (Eq, Ord, Show)
data DocIntro = DocIntro
{ _introTitle :: String
, _introBody :: [String]
} deriving (Eq, Show)
data DocAuthentication = DocAuthentication
{ _authIntro :: String
, _authDataRequired :: String
} deriving (Eq, Ord, Show)
instance Ord DocIntro where
compare = comparing _introTitle
data DocNote = DocNote
{ _noteTitle :: String
, _noteBody :: [String]
} deriving (Eq, Ord, Show)
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
data DocOptions = DocOptions
{ _maxSamples :: Int
} deriving (Show)
defaultDocOptions :: DocOptions
defaultDocOptions = DocOptions
{ _maxSamples = 5 }
data ParamKind = Normal | List | Flag
deriving (Eq, Ord, Show)
data Response = Response
{ _respStatus :: Int
, _respTypes :: [M.MediaType]
, _respBody :: [(Text, M.MediaType, ByteString)]
, _respHeaders :: [HTTP.Header]
} deriving (Eq, Ord, Show)
defResponse :: Response
defResponse = Response
{ _respStatus = 200
, _respTypes = []
, _respBody = []
, _respHeaders = []
}
data Action = Action
{ _authInfo :: [DocAuthentication]
, _captures :: [DocCapture]
, _headers :: [Text]
, _params :: [DocQueryParam]
, _notes :: [DocNote]
, _mxParams :: [(String, [DocQueryParam])]
, _rqtypes :: [M.MediaType]
, _rqbody :: [(M.MediaType, ByteString)]
, _response :: Response
} deriving (Eq, Ord, Show)
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
defAction :: Action
defAction =
Action []
[]
[]
[]
[]
[]
[]
[]
defResponse
single :: Endpoint -> Action -> API
single e a = API mempty (HM.singleton e a)
makeLenses ''DocAuthentication
makeLenses ''DocOptions
makeLenses ''API
makeLenses ''Endpoint
makeLenses ''DocCapture
makeLenses ''DocQueryParam
makeLenses ''DocIntro
makeLenses ''DocNote
makeLenses ''Response
makeLenses ''Action
docs :: HasDocs layout => Proxy layout -> API
docs p = docsWithOptions p defaultDocOptions
docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API
docsWithOptions p = docsFor p (defEndpoint, defAction)
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 = ()
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout
extraInfo p action =
let api = docsFor p (defEndpoint, defAction) defaultDocOptions
in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
docsWith opts intros (ExtraInfo endpoints) p =
docsWithOptions p opts
& apiIntros <>~ intros
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty
class HasDocs layout where
docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API
class ToSample a where
toSamples :: Proxy a -> [(Text, a)]
default toSamples :: (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
toSamples = defaultSamples
toSample :: forall a. ToSample a => Proxy a -> Maybe a
toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a))
noSamples :: [(Text, a)]
noSamples = empty
singleSample :: a -> [(Text, a)]
singleSample x = [("", x)]
samples :: [a] -> [(Text, a)]
samples = map ("",)
defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
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)
class AllHeaderSamples ls where
allHeaderToSample :: Proxy ls -> [HTTP.Header]
instance AllHeaderSamples '[] where
allHeaderToSample _ = []
instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
=> AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
mkHeader (Just x) = (headerName, cs $ toByteString x)
mkHeader Nothing = (headerName, "<no header sample provided>")
sampleByteString
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy (ct ': cts)
-> Proxy a
-> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy =
maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)
sampleByteStrings
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy (ct ': cts)
-> Proxy a
-> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy =
let samples' = toSamples (Proxy :: Proxy a)
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
in concatMap enc samples'
class ToParam t where
toParam :: Proxy t -> DocQueryParam
class ToCapture c where
toCapture :: Proxy c -> DocCapture
class ToAuthInfo a where
toAuthInfo :: Proxy a -> DocAuthentication
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) ++
capturesStr (action ^. captures) ++
headersStr (action ^. headers) ++
paramsStr (action ^. params) ++
rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
responseStr (action ^. response) ++
[]
where str = "## " ++ BSC.unpack (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) ++
"" :
[]
authStr :: [DocAuthentication] -> [String]
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 :
"" :
[]
capturesStr :: [DocCapture] -> [String]
capturesStr [] = []
capturesStr l =
"#### Captures:" :
"" :
map captureStr l ++
"" :
[]
captureStr cap =
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
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 s =
["#### Request:", ""]
<> formatTypes types
<> concatMap formatBody s
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)) :
("- Headers: " ++ show (resp ^. respHeaders)) :
"" :
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
instance OVERLAPPABLE_
(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 OVERLAPPABLE_
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method)
=> HasDocs (Verb method status (ct ': cts) a) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ method'
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ status
t = Proxy :: Proxy (ct ': cts)
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance OVERLAPPING_
(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{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ method'
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ status
& response.respHeaders .~ hdrs
t = Proxy :: Proxy (ct ': cts)
hdrs = allHeaderToSample (Proxy :: Proxy ls)
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
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 = T.pack $ symbolVal (Proxy :: Proxy sym)
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 HasDocs Raw where
docsFor _proxy (endpoint, action) _ =
single endpoint action
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ allMime t
t = Proxy :: Proxy (ct ': 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
instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor (Proxy :: Proxy sublayout) (endpoint, action')
where
authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action
instance ToSample ()
instance ToSample Bool
instance ToSample Ordering
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]
instance ToSample a => ToSample (Const a b)
instance ToSample a => ToSample (ZipList a)
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)