@@ -22,7 +22,7 @@ module Servant.Docs.Internal where
2222
2323import Control.Applicative
2424import Control.Arrow (second)
25−import Control.Lens (makeLenses, over, traversed, (%~),
25+import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
2626 (&), (.~), (<>~), (^.), (|>))
2727import qualified Control.Monad.Omega as Omega
2828import Data.ByteString.Conversion (ToByteString, toByteString)
@@ -140,6 +140,12 @@ data DocIntro = DocIntro
140140 , _introBody :: [String] -- ^ Each String is a paragraph.
141141 } deriving (Eq, Show)
142142
143+-- | A type to represent Authentication information about an endpoint.
144+data DocAuthentication = DocAuthentication
145+ { _authIntro :: String
146+ , _authDataRequired :: String
147+ } deriving (Eq, Ord, Show)
148+
143149instance Ord DocIntro where
144150 compare = comparing _introTitle
145151
@@ -230,7 +236,8 @@ defResponse = Response
230236-- You can tweak an 'Action' (like the default 'defAction') with these lenses
231237-- to transform an action and add some information to it.
232238data Action = Action
233− { _captures :: [DocCapture] -- type collected + user supplied info
239+ { _authInfo :: [DocAuthentication] -- user supplied info
240+ , _captures :: [DocCapture] -- type collected + user supplied info
234241 , _headers :: [Text] -- type collected
235242 , _params :: [DocQueryParam] -- type collected + user supplied info
236243 , _notes :: [DocNote] -- user supplied
@@ -247,8 +254,8 @@ data Action = Action
247254-- 'combineAction' to mush two together taking the response, body and content
248255-- types from the very left.
249256combineAction :: Action -> Action -> Action
250−Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
251− Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
257+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
258+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
252259
253260-- Default 'Action'. Has no 'captures', no GET 'params', expects
254261-- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -268,6 +275,7 @@ defAction =
268275 []
269276 []
270277 []
278+ []
271279 defResponse
272280
273281-- | Create an API that's comprised of a single endpoint.
@@ -277,6 +285,7 @@ single :: Endpoint -> Action -> API
277285single e a = API mempty (HM.singleton e a)
278286
279287-- gimme some lenses
288+makeLenses ''DocAuthentication
280289makeLenses ''DocOptions
281290makeLenses ''API
282291makeLenses ''Endpoint
@@ -454,7 +463,7 @@ instance AllHeaderSamples '[] where
454463
455464instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
456465 => AllHeaderSamples (Header h l ': ls) where
457− allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :
466+ allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
458467 allHeaderToSample (Proxy :: Proxy ls)
459468 where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
460469 mkHeader (Just x) = (headerName, cs $ toByteString x)
@@ -504,6 +513,10 @@ class ToParam t where
504513class ToCapture c where
505514 toCapture :: Proxy c -> DocCapture
506515
516+-- | The class that helps us get documentation for authenticated endpoints
517+class ToAuthInfo a where
518+ toAuthInfo :: Proxy a -> DocAuthentication
519+
507520-- | Generate documentation in Markdown format for
508521-- the given 'API'.
509522markdown :: API -> String
@@ -516,6 +529,7 @@ markdown api = unlines $
516529 str :
517530 "" :
518531 notesStr (action ^. notes) ++
532+ authStr (action ^. authInfo) ++
519533 capturesStr (action ^. captures) ++
520534 headersStr (action ^. headers) ++
521535 paramsStr (action ^. params) ++
@@ -548,6 +562,20 @@ markdown api = unlines $
548562 "" :
549563 []
550564
565+
566+ authStr :: [DocAuthentication] -> [String]
567+ authStr auths =
568+ let authIntros = mapped %~ view authIntro $ auths
569+ clientInfos = mapped %~ view authDataRequired $ auths
570+ in "#### Authentication":
571+ "":
572+ unlines authIntros :
573+ "":
574+ "Clients must supply the following data" :
575+ unlines clientInfos :
576+ "" :
577+ []
578+
551579 capturesStr :: [DocCapture] -> [String]
552580 capturesStr [] = []
553581 capturesStr l =
@@ -797,6 +825,13 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
797825instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
798826 docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
799827
828+instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where
829+ docsFor Proxy (endpoint, action) =
830+ docsFor (Proxy :: Proxy sublayout) (endpoint, action')
831+ where
832+ authProxy = Proxy :: Proxy (BasicAuth realm usr)
833+ action' = over authInfo (|> toAuthInfo authProxy) action
834+
800835-- ToSample instances for simple types
801836instance ToSample ()
802837instance ToSample Bool