Docs.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Auth.Docs
  (
  -- | The purpose of this package is provide the instance for 'servant-auth'
  -- combinators needed for 'servant-docs' documentation generation.
  --
  -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int
  -- >>> putStr $ markdown $ docs (Proxy :: Proxy API)
  -- ## GET /
  -- ...
  -- ... Authentication
  -- ...
  -- This part of the API is protected by the following authentication mechanisms:
  -- ...
  --  * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))
  --  * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)
  --  * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)
  -- ...
  -- Clients must supply the following data
  -- ...
  -- One of the following:
  -- ...
  --  * A JWT Token signed with this server's key
  --  * Cookies automatically set by browsers, plus a header
  --  * Cookies automatically set by browsers, plus a header
  -- ...

  -- * Re-export
    JWT
  , BasicAuth
  , Cookie
  , Auth
  ) where

import Control.Lens          ((%~), (&), (|>))
import Data.Kind             (Type)
import Data.List             (intercalate)
import Data.Monoid
import Data.Proxy            (Proxy (Proxy))
import Servant.API           hiding (BasicAuth)
import Servant.Auth
import Servant.Docs          hiding (pretty)
import Servant.Docs.Internal (DocAuthentication (..), authInfo)

instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where
  docsFor _ (endpoint, action) =
    docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info))
    where
      (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths)
      info = DocAuthentication intro reqData


pretty :: [(String, String)] -> (String, String)
pretty [] = error "shouldn't happen"
pretty [(i, d)] =
  ( "This part of the API is protected by " <> i
  , d
  )
pretty rs =
  ( "This part of the API is protected by the following authentication mechanisms:\n\n"
  ++  " * " <> intercalate "\n * " (fst <$> rs)
  , "\nOne of the following:\n\n"
  ++  " * " <> intercalate "\n * " (snd <$> rs)
  )


class AllDocs (x :: [Type]) where
  allDocs :: proxy x
              -- intro, req
          -> [(String, String)]

instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where
  allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)

instance AllDocs '[] where
  allDocs _ = []

class OneDoc a where
  oneDoc :: proxy a -> (String, String)

instance OneDoc JWT where
  oneDoc _ =
    ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))"
     , "A JWT Token signed with this server's key")

instance OneDoc Cookie where
  oneDoc _ =
    ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)"
    , "Cookies automatically set by browsers, plus a header")

instance OneDoc BasicAuth where
  oneDoc _ =
    ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)"
    , "Cookies automatically set by browsers, plus a header")

-- $setup
-- >>> instance ToSample Int where toSamples _ = singleSample 1729