-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Foundation.Servant.Types
  ( CaptureBearerRestriction, CaptureBearerRestriction'
  , CaptureBearerToken, CaptureBearerToken'
  , CaptureCryptoID', CaptureCryptoID, CaptureCryptoUUID, CaptureCryptoFileName
  , ApiVersion, apiVersionToSemVer, matchesApiVersion
  , BearerAuth, SessionAuth
  ) where

import ClassyPrelude hiding (fromList)
import Data.Proxy

import Servant.API
import Servant.API.Modifiers (FoldRequired)
import Servant.API.Description
import Servant.Swagger
import Servant.Docs
import Servant.Server
import Servant.Server.Internal.Router
import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.ErrorFormatter
-- import Servant.Server.Internal.DelayedIO

import Servant.Client.Core.RunClient (RunClient)
import Servant.Client.Core.HasClient
import qualified Servant.Client.Core.Request as Servant (Request)
import qualified Servant.Client.Core.Request as Request

import Jose.Jwt (Jwt(..))

import Network.Wai (mapResponseHeaders, requestHeaders)

import Control.Lens hiding (Context)

import Data.UUID (UUID)
import Data.CaseInsensitive (CI)
import Data.CryptoID.Class.ImplicitNamespace
import Data.CryptoID.Instances ()

import GHC.TypeLits
import GHC.Exts (IsList(..))

import Data.Swagger hiding (version)

import Data.Kind (Type)

import qualified Data.SemVer as SemVer
import qualified Data.SemVer.Constraint as SemVer (Constraint)
import qualified Data.SemVer.Constraint as SemVer.Constraint

import Data.SemVer.Instances ()


type CaptureBearerRestriction = CaptureBearerRestriction' '[Required]
data CaptureBearerRestriction' (mods :: [Type]) (restr :: Type)
  
type CaptureBearerToken = CaptureBearerToken' '[Required]
data CaptureBearerToken' (mods :: [Type])

data CaptureCryptoID' (mods :: [Type]) (ciphertext :: Type) (sym :: Symbol) (plaintext :: Type)
type CaptureCryptoID = CaptureCryptoID' '[]
type CaptureCryptoUUID = CaptureCryptoID UUID
type CaptureCryptoFileName = CaptureCryptoID (CI FilePath)

data ApiVersion (major :: Nat) (minor :: Nat) (patch :: Nat)

apiVersionToSemVer :: forall major minor patch p.
                      ( KnownNat major, KnownNat minor, KnownNat patch )
                   => p (ApiVersion major minor patch)
                   -> SemVer.Version
apiVersionToSemVer _ = SemVer.version
  (fromIntegral . natVal $ Proxy @major)
  (fromIntegral . natVal $ Proxy @minor)
  (fromIntegral . natVal $ Proxy @patch)
  []
  []

matchesApiVersion :: forall major minor patch p.
                     ( KnownNat major, KnownNat minor, KnownNat patch )
                  => p (ApiVersion major minor patch)
                  -> SemVer.Constraint
                  -> Bool
matchesApiVersion _ = SemVer.Constraint.satisfies . apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)


instance HasLink sub => HasLink (CaptureBearerRestriction' mods restr :> sub) where
  type MkLink (CaptureBearerRestriction' mods restr :> sub) r = MkLink sub r
  toLink toA _ = toLink toA $ Proxy @sub

instance HasLink sub => HasLink (CaptureBearerToken' mods :> sub) where
  type MkLink (CaptureBearerToken' mods :> sub) r = MkLink sub r
  toLink toA _ = toLink toA $ Proxy @sub

instance (HasLink sub, ToHttpApiData ciphertext) => HasLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
  type MkLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) r = MkLink (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) r
  toLink toA _ = toLink toA $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)

instance HasLink sub => HasLink (ApiVersion major minor patch :> sub) where
  type MkLink (ApiVersion major minor patch :> sub) r = MkLink sub r
  toLink toA _ = toLink toA $ Proxy @sub

instance HasSwagger sub => HasSwagger (CaptureBearerRestriction' mods restr :> sub) where
  toSwagger _ = toSwagger $ Proxy @sub

instance HasSwagger sub => HasSwagger (CaptureBearerToken' mods :> sub) where
  toSwagger _ = toSwagger $ Proxy @sub

instance (HasSwagger sub, ToParamSchema ciphertext, KnownSymbol sym, KnownSymbol (FoldDescription mods)) => HasSwagger (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
  toSwagger _ = toSwagger $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)

instance HasSwagger sub => HasSwagger (ApiVersion major minor patch :> sub) where
  toSwagger _ = toSwagger $ Proxy @sub

instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) where
  docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
    where action' = action & notes <>~ [DocNote "Bearer restrictions" ["The behaviour of this route dependes on the restrictions stored for it in the bearer token used for authorization"]]

instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where
  docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
    where action' = action & notes <>~ [DocNote "Bearer token" ["The behaviour of this route dependes on the exact bearer token used for authorization"]]

instance (ToCapture (Capture sym ciphertext), KnownSymbol sym, HasDocs sub) => HasDocs (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
  docsFor _ = docsFor $ Proxy @(Capture' mods sym ciphertext :> sub)

instance (RunClient m, HasClient m (Capture' mods sym (CryptoID ciphertext plaintext) :> sub)) => HasClient m (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
  type Client m (CaptureCryptoID' mods ciphertext sym plaintext :> sub) = Client m (Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
  clientWithRoute pm _ = clientWithRoute pm $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)


type family ApiVersionSub major minor patch sup sub where
  ApiVersionSub major minor patch (ApiVersion major' minor' patch') sub = ApiVersion major' minor' patch' :> sub
  ApiVersionSub major minor patch sup sub = sup :> (ApiVersion major minor patch :> sub)

instance HasServer (ApiVersionSub major minor patch sup sub) context => HasServer (ApiVersion major minor patch :> ((sup :: Type) :> sub)) context where
  type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (ApiVersionSub major minor patch sup sub) m
  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(ApiVersionSub major minor patch sup sub)
  route _ = route $ Proxy @(ApiVersionSub major minor patch sup sub)
  
instance HasServer (sup :> (ApiVersion major minor patch :> sub)) context => HasServer (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) context where
  type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (sup :> (ApiVersion major minor patch :> sub)) m
  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
  route _ = route $ Proxy @(sup :> (ApiVersion major minor patch :> sub))

instance ( HasServer (ApiVersion major minor patch :> a) context
         , HasServer (ApiVersion major minor patch :> b) context
         , SBoolI (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))
         ) => HasServer (ApiVersion major minor patch :> (a :<|> b)) context where
  type ServerT (ApiVersion major minor patch :> (a :<|> b)) m = ServerT (ApiVersion major minor patch :> a) m :<|> ServerT (ApiVersion major minor patch :> b) m
  hoistServerWithContext _ = hoistServerWithContext $ Proxy @((ApiVersion major minor patch :> a) :<|> (ApiVersion major minor patch :> b))
  route Proxy context server = choice'
    (route (Proxy @(ApiVersion major minor patch :> a)) context $ (\(a :<|> _) -> a) <$> server)
    (route (Proxy @(ApiVersion major minor patch :> b)) context $ (\(_ :<|> b) -> b) <$> server)
    where
      choice' :: forall env' a'. Router' env' a' -> Router' env' a' -> Router' env' a'
      choice' = case (sbool :: SBool (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))) of
        STrue  -> flip choice
        SFalse -> choice

instance (RunClient m, HasClient m (ApiVersionSub major minor patch sup sub)) => HasClient m (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where
  type Client m (ApiVersion major minor patch :> (sup :> sub)) = Client m (ApiVersionSub major minor patch sup sub)
  clientWithRoute pm _ = clientWithRoute pm $ Proxy @(ApiVersionSub major minor patch sup sub)
  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(ApiVersionSub major minor patch sup sub)

instance (RunClient m, HasClient m (sup :> (ApiVersion major minor patch :> sub))) => HasClient m (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where
  type Client m (ApiVersion major minor patch :> (sup :> sub)) = Client m (sup :> (ApiVersion major minor patch :> sub))
  clientWithRoute pm _ = clientWithRoute pm $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(sup :> (ApiVersion major minor patch :> sub))

instance ( HasClient m (ApiVersion major minor patch :> a)
         , HasClient m (ApiVersion major minor patch :> b)
         ) => HasClient m (ApiVersion major minor patch :> (a :<|> b)) where
  type Client m (ApiVersion major minor patch :> (a :<|> b)) = Client m (ApiVersion major minor patch :> a) :<|> Client m (ApiVersion major minor patch :> b)
  clientWithRoute pm _ req = clientWithRoute pm (Proxy @(ApiVersion major minor patch :> a)) req
                        :<|> clientWithRoute pm (Proxy @(ApiVersion major minor patch :> b)) req
  hoistClientMonad pm _ f (ca :<|> cb) = hoistClientMonad pm (Proxy @(ApiVersion major minor patch :> a)) f ca
                                    :<|> hoistClientMonad pm (Proxy @(ApiVersion major minor patch :> b)) f cb
         
  
versionRequestHeaderName :: CI ByteString
versionRequestHeaderName = "Accept-API-Version"
  
routeWithApiVersion :: forall api context env major minor patch.
                       ( HasServer api context
                       , KnownNat major, KnownNat minor, KnownNat patch
                       , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
                       )
                    => Proxy (ApiVersion major minor patch)
                    -> Proxy api -> Context context -> Delayed env (Server api) -> Router env
routeWithApiVersion _ _ context subserver = RawRouter $ \env req ((. addVersion) -> cont) -> case maybe (pure SemVer.Constraint.CAny) parseHeader . lookup versionRequestHeaderName $ requestHeaders req of
  Left parseErr -> cont $ FailFatal err400 { errBody = encodeUtf8 . fromStrict $ "Could not parse version constraint: " <> parseErr }
  Right vHdr -> if
    | version `SemVer.Constraint.satisfies` vHdr -> runRouterEnv notFound (route (Proxy @api) context subserver) env req cont
    | otherwise -> cont $ Fail err400 { errBody = encodeUtf8 "Requested version could not be satisfied" }
  where addVersion (Fail sError) = Fail sError { errHeaders = addVersionHeader $ errHeaders sError}
        addVersion (FailFatal sError) = FailFatal sError { errHeaders = addVersionHeader $ errHeaders sError }
        addVersion (Route resp) = Route $ mapResponseHeaders addVersionHeader resp

        addVersionHeader hdrs
          | has (folded . _1 . only versionHeaderName) hdrs = hdrs
          | otherwise = hdrs <> pure (versionHeaderName, versionHeader)

        version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)

        versionHeaderName = "API-Version"
        versionHeader = encodeUtf8 $ SemVer.toText version

        notFound = notFoundErrorFormatter . getContextEntry $ mkContextWithErrorFormatter context
  
instance ( HasServer (Verb method statusCode contentTypes a) context
         , KnownNat major, KnownNat minor, KnownNat patch
         , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
         ) => HasServer (ApiVersion major minor patch :> Verb method statusCode contentTypes a) context where
  type ServerT (ApiVersion major minor patch :> Verb method statusCode contentTypes a) m = ServerT (Verb method statusCode contentTypes a) m

  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(Verb method statusCode contentTypes a)

  route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(Verb method statusCode contentTypes a))

instance ( HasServer (NoContentVerb method) context
         , KnownNat major, KnownNat minor, KnownNat patch
         , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
         ) => HasServer (ApiVersion major minor patch :> NoContentVerb method) context where
  type ServerT (ApiVersion major minor patch :> NoContentVerb method) m = ServerT (NoContentVerb method) m

  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(NoContentVerb method)

  route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(NoContentVerb method))


semVerCompatibleTo :: SemVer.Version -> SemVer.Constraint
semVerCompatibleTo v = SemVer.Constraint.CAnd (SemVer.Constraint.CGtEq v) (SemVer.Constraint.CLt $ SemVer.incrementMajor v)
  
instance ( HasClient m (Verb method statusCode contentTypes a)
         , KnownNat major, KnownNat minor, KnownNat patch
         ) => HasClient m (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where
  type Client m (ApiVersion major minor patch :> Verb method statusCode contentTypes a) = Client m (Verb method statusCode contentTypes a)
  clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method statusCode contentTypes a)) . Request.addHeader versionRequestHeaderName (semVerCompatibleTo version)
    where version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(Verb method statusCode contentTypes a)

instance ( HasClient m (NoContentVerb method)
         , KnownNat major, KnownNat minor, KnownNat patch
         ) => HasClient m (ApiVersion major minor patch :> NoContentVerb method) where
  type Client m (ApiVersion major minor patch :> NoContentVerb method) = Client m (NoContentVerb method)
  clientWithRoute pm _ = clientWithRoute pm (Proxy @(NoContentVerb method)) . Request.addHeader versionRequestHeaderName (semVerCompatibleTo version)
    where version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(NoContentVerb method)


instance ( HasDocs (ApiVersionSub major minor patch sup sub)
         ) => HasDocs (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where
  docsFor _ = docsFor $ Proxy @(ApiVersionSub major minor patch sup sub)

instance ( HasDocs (sup :> (ApiVersion major minor patch :> sub))
         ) => HasDocs (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where
  docsFor _ = docsFor $ Proxy @(sup :> (ApiVersion major minor patch :> sub))

instance ( HasDocs (ApiVersion major minor patch :> a)
         , HasDocs (ApiVersion major minor patch :> b)
         ) => HasDocs (ApiVersion major minor patch :> (a :<|> b)) where
  docsFor _ = docsFor $ Proxy @(ApiVersion major minor patch :> a :<|> ApiVersion major minor patch :> b)

  
apiVersionDocNote :: forall major minor patch.
                     ( KnownNat major, KnownNat minor, KnownNat patch )
                  => Proxy (ApiVersion major minor patch)
                  -> DocNote
apiVersionDocNote p = DocNote "Versioning" ["This route is provided in version " <> SemVer.toString (apiVersionToSemVer p)]
  
instance ( HasDocs (Verb method statusCode contentTypes a)
         , KnownNat major, KnownNat minor, KnownNat patch
         ) => HasDocs (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where
  docsFor _ (endpoint, action) = docsFor (Proxy @(Verb method statusCode contentTypes a)) (endpoint, action')
    where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)]

instance ( HasDocs (NoContentVerb method)
         , KnownNat major, KnownNat minor, KnownNat patch
         ) => HasDocs (ApiVersion major minor patch :> NoContentVerb method) where
  docsFor _ (endpoint, action) = docsFor (Proxy @(NoContentVerb method)) (endpoint, action')
    where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)]

  
type family FinalApiVersion api where
  FinalApiVersion (ApiVersion major minor patch :> sub) = AlternativeMaybe (FinalApiVersion sub) ('Just (ApiVersion major minor patch))
  FinalApiVersion (sup :> sub) = FinalApiVersion sub
  FinalApiVersion (a :<|> b) = MaxMaybe (CmpVersion (FinalApiVersion a) (FinalApiVersion b)) (FinalApiVersion a) (FinalApiVersion b)
  FinalApiVersion (Verb method statusCode contentTypes a) = 'Nothing
  FinalApiVersion (NoContentVerb method) = 'Nothing

type family MaxMaybe ord a b where
  MaxMaybe _ a 'Nothing = a
  MaxMaybe _ 'Nothing b = b
  MaxMaybe 'LT _ b = b
  MaxMaybe _   a _ = a

type family MappendOrdering a b where
  MappendOrdering 'EQ b = b
  MappendOrdering a _ = a

type family AlternativeMaybe a b where
  AlternativeMaybe ('Just a) _ = 'Just a
  AlternativeMaybe _ ('Just b) = 'Just b
  AlternativeMaybe _ _ = 'Nothing

type family CmpVersion x y where
  CmpVersion 'Nothing 'Nothing = 'EQ
  CmpVersion 'Nothing _ = 'GT
  CmpVersion _ 'Nothing = 'LT
  CmpVersion ('Just (ApiVersion major minor patch)) ('Just (ApiVersion major' minor' patch')) = MappendOrdering (CmpNat major major') (MappendOrdering (CmpNat minor minor') (CmpNat patch patch'))

type family IsLT x where
  IsLT 'LT = 'True
  IsLT _ = 'False
 

type instance IsElem' sa (CaptureCryptoID' mods ciphertext sym plaintext :> sb) = IsElem sa (Capture' mods sym (CryptoID ciphertext plaintext) :> sb)

type instance IsElem' sa (ApiVersion major minor patch :> sb) = IsElem sa sb


type family StripBearer api where
  StripBearer (CaptureBearerRestriction' mods restr :> sub) = sub
  StripBearer (CaptureBearerToken' mods :> sub) = sub
  StripBearer (BearerAuth :> sub) = sub
  StripBearer (sup :> sub) = sup :> StripBearer sub
  StripBearer (a :<|> b) = StripBearer a :<|> StripBearer b
  StripBearer (Verb method statusCode contentTypes a) = Verb method statusCode contentTypes a
  StripBearer (NoContentVerb method) = NoContentVerb method

type family BearerRequired api where
  BearerRequired (CaptureBearerRestriction' mods restr :> sub) = OrBool (FoldRequired mods) (BearerRequired sub)
  BearerRequired (CaptureBearerToken' mods :> sub) = OrBool (FoldRequired mods) (BearerRequired sub)
  BearerRequired (BearerAuth :> sub) = 'True
  BearerRequired (sup :> sub) = BearerRequired sub
  BearerRequired (a :<|> b) = OrBool (BearerRequired a) (BearerRequired b)
  BearerRequired (Verb method statusCode contentTypes a) = 'False
  BearerRequired (NoContentVerb method) = 'False

type family OrBool a b where
  OrBool 'False 'False = 'False 
  OrBool a b = 'True

maybeWithJwt :: forall (a :: Bool). SBoolI a => Proxy a -> If a Jwt (Maybe Jwt) -> Servant.Request -> Servant.Request
maybeWithJwt _ mparam = case (sbool :: SBool a, mparam) of
    (STrue, jwt) -> add jwt
    (SFalse, mJwt) -> maybe id add mJwt
  where add (Jwt jwt) = Request.addHeader "Authorization" . decodeUtf8 $ "Bearer " <> jwt

instance ( HasClient m (StripBearer sub)
         , RunClient m
         , SBoolI (BearerRequired (CaptureBearerRestriction' mods restr :> sub))
         ) => HasClient m (CaptureBearerRestriction' mods restr :> sub) where
  type Client m (CaptureBearerRestriction' mods restr :> sub) = If (BearerRequired (CaptureBearerRestriction' mods restr :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub)
  clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (CaptureBearerRestriction' mods restr :> sub))) mparam req
  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl

instance ( HasClient m (StripBearer sub)
         , RunClient m
         , SBoolI (BearerRequired (CaptureBearerToken' mods :> sub))
         ) => HasClient m (CaptureBearerToken' mods :> sub) where
  type Client m (CaptureBearerToken' mods :> sub) = If (BearerRequired (CaptureBearerToken' mods :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub)
  clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (CaptureBearerToken' mods :> sub))) mparam req
  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl

instance ( HasClient m (StripBearer sub)
         , RunClient m
         , SBoolI (BearerRequired (BearerAuth :> sub))
         ) => HasClient m (BearerAuth :> sub) where
  type Client m (BearerAuth :> sub) = If (BearerRequired (BearerAuth :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub)
  clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (BearerAuth :> sub))) mparam req
  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl


data BearerAuth
data SessionAuth

instance HasSwagger sub => HasSwagger (BearerAuth :> sub) where
  toSwagger _ = toSwagger (Proxy @sub)
    & securityDefinitions <>~ SecurityDefinitions (fromList [(defnKey, defn)])
    & allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]]
    where defnKey :: Text
          defnKey = "bearer"
          defn = SecurityScheme
            { _securitySchemeType
                 = SecuritySchemeApiKey ApiKeyParams
                     { _apiKeyName = "Authorization"
                     , _apiKeyIn = ApiKeyHeader
                     }
            , _securitySchemeDescription = Just
                "JSON Web Token-based API key"
            }

instance HasSwagger sub => HasSwagger (SessionAuth :> sub) where
  toSwagger _ = toSwagger (Proxy @sub)
    & allOperations . security <>~ [SecurityRequirement mempty]
    -- We do not expect API clients to be able/willing to conform with
    -- our CSRF mitigation, so we mark routes that require it as
    -- having unfullfillable security requirements

instance HasLink sub => HasLink (BearerAuth :> sub) where
  type MkLink (BearerAuth :> sub) a = MkLink sub a
  toLink  toA _ = toLink toA (Proxy @sub)

instance HasLink sub => HasLink (SessionAuth :> sub) where
  type MkLink (SessionAuth :> sub) a = MkLink sub a
  toLink toA _ = toLink toA (Proxy @sub)

instance HasDocs sub => HasDocs (BearerAuth :> sub) where
  docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
    where action' = action & authInfo %~ (|> authInfo')
          authInfo' = DocAuthentication
            ""
            "A JSON Web Token-based API key"
  
instance HasDocs sub => HasDocs (SessionAuth :> sub) where
  docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
    where action' = action & authInfo %~ (|> authInfo')
          authInfo' = DocAuthentication
            "When a web session is used for authorization, CSRF-mitigation measures must be observed."
            "An active web session identifying the user as one with sufficient authorization"
