-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- | High-level user authentication and access control.
module Brig.User.Auth
  ( Access,
    login,
    logout,
    renewAccess,
    validateTokens,
    revokeAccess,

    -- * Internal
    ssoLogin,
    legalHoldLogin,

    -- * Re-exports
    listCookies,
  )
where

import Brig.API.Types
import Brig.API.User (changeSingleAccountStatus)
import Brig.App
import Brig.Options qualified as Opt
import Brig.User.Auth.Cookie
import Control.Error hiding (bool)
import Data.ByteString.Conversion (toByteString)
import Data.Code qualified as Code
import Data.Handle (Handle)
import Data.Id
import Data.List.NonEmpty qualified as NE
import Data.Misc (PlainTextPassword6)
import Data.Qualified
import Data.ZAuth.CryptoSign (CryptoSign)
import Data.ZAuth.Token qualified as ZAuth
import Data.ZAuth.Validation qualified as ZAuth
import Imports
import Network.Wai.Utilities.Error ((!>>))
import Polysemy
import Polysemy.Input
import Polysemy.TinyLog (TinyLog)
import Polysemy.TinyLog qualified as Log
import System.Logger (field, msg, val, (~~))
import Util.Timeout
import Wire.API.Team.Feature
import Wire.API.User
import Wire.API.User.Auth
import Wire.API.User.Auth.LegalHold
import Wire.API.User.Auth.Sso
import Wire.ActivationCodeStore (ActivationCodeStore)
import Wire.ActivationCodeStore qualified as ActivationCode
import Wire.AuthenticationSubsystem
import Wire.AuthenticationSubsystem qualified as Authentication
import Wire.AuthenticationSubsystem.Config
import Wire.AuthenticationSubsystem.Error (VerificationCodeError (..))
import Wire.AuthenticationSubsystem.ZAuth qualified as ZAuth
import Wire.BudgetStore
import Wire.ClientStore (ClientStore)
import Wire.ClientStore qualified as ClientStore
import Wire.Events (Events)
import Wire.GalleyAPIAccess (GalleyAPIAccess)
import Wire.GalleyAPIAccess qualified as GalleyAPIAccess
import Wire.Sem.Concurrency
import Wire.Sem.Metrics (Metrics)
import Wire.Sem.Now (Now)
import Wire.Sem.Random (Random)
import Wire.SessionStore (SessionStore)
import Wire.UserKeyStore
import Wire.UserStore
import Wire.UserSubsystem (UserSubsystem)
import Wire.UserSubsystem qualified as User

login ::
  forall r.
  ( Member (Input (Local ())) r,
    Member BudgetStore r,
    Member ActivationCodeStore r,
    Member Events r,
    Member TinyLog r,
    Member UserKeyStore r,
    Member UserStore r,
    Member UserSubsystem r,
    Member AuthenticationSubsystem r,
    Member (Input AuthenticationSubsystemConfig) r,
    Member (Concurrency Unsafe) r,
    Member Now r,
    Member CryptoSign r,
    Member Random r
  ) =>
  Login ->
  CookieType ->
  ExceptT LoginError (AppT r) (Access ZAuth.U)
login (MkLogin li pw label code) typ = do
  uid <- resolveLoginId li
  lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.login")
  checkRetryLimit uid

  (lift . liftSem $ Authentication.authenticateEither uid pw) >>= \case
    Right a -> pure a
    Left e -> case e of
      AuthInvalidUser -> lift (decrRetryLimit uid) >> throwE LoginFailed
      AuthInvalidCredentials -> lift (decrRetryLimit uid) >> throwE LoginFailed
      AuthSuspended -> throwE LoginSuspended
      AuthEphemeral -> throwE LoginEphemeral
      AuthPendingInvitation -> throwE LoginPendingActivation
  verifyLoginCode code uid
  newAccess @ZAuth.U @ZAuth.A uid Nothing typ label
  where
    verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError (AppT r) ()
    verifyLoginCode mbCode uid = do
      luid <- lift $ qualifyLocal uid
      lift (liftSem $ enforceVerificationCodeEither luid mbCode Login)
        >>= \case
          Left VerificationCodeNoPendingCode -> lift (decrRetryLimit uid) >> throwE LoginCodeInvalid
          Left VerificationCodeRequired -> lift (decrRetryLimit uid) >> throwE LoginCodeRequired
          Left VerificationCodeNoEmail -> lift (decrRetryLimit uid) >> throwE LoginFailed
          Right () -> pure ()

decrRetryLimit :: forall r. (Member BudgetStore r) => UserId -> (AppT r) ()
decrRetryLimit = withRetryLimit (\k b -> liftSem $ withBudget k b $ pure ())

checkRetryLimit ::
  (Member BudgetStore r) =>
  UserId ->
  ExceptT LoginError (AppT r) ()
checkRetryLimit uid =
  flip withRetryLimit uid $ \budgetKey budget ->
    lift (liftSem (checkBudget budgetKey budget)) >>= \case
      BudgetExhausted ttl -> throwE . LoginBlocked . RetryAfter . floor $ ttl
      BudgetedValue () remaining -> pure $ BudgetedValue () remaining

withRetryLimit ::
  (MonadReader Env m) =>
  (BudgetKey -> Budget -> m (Budgeted ())) ->
  UserId ->
  m ()
withRetryLimit action uid = do
  mLimitFailedLogins <- asks (.settings.limitFailedLogins)
  forM_ mLimitFailedLogins $ \opts -> do
    let bkey = BudgetKey ("login#" <> idToText uid)
        budget =
          Budget
            (timeoutDiff $ Opt.timeout opts)
            (fromIntegral $ Opt.retryLimit opts)
    action bkey budget

logout ::
  ( ZAuth.UserTokenLike u,
    ZAuth.AccessTokenLike a,
    Member (Input AuthenticationSubsystemConfig) r,
    Member AuthenticationSubsystem r,
    Member CryptoSign r,
    Member Now r
  ) =>
  NE.NonEmpty (ZAuth.Token u) ->
  ZAuth.Token a ->
  ExceptT ZAuth.Failure (AppT r) ()
logout uts at = do
  (u, ck) <- validateTokens uts (Just at)
  lift . liftSem $ revokeCookies u [cookieId ck] []

renewAccess ::
  forall r u a.
  ( Member TinyLog r,
    Member UserSubsystem r,
    Member Events r,
    ZAuth.UserTokenLike u,
    ZAuth.AccessTokenLike a,
    ZAuth.AccessTokenType u ~ a,
    Member (Input AuthenticationSubsystemConfig) r,
    Member (Embed IO) r,
    Member Metrics r,
    Member SessionStore r,
    Member (Concurrency Unsafe) r,
    Member CryptoSign r,
    Member Now r,
    Member AuthenticationSubsystem r,
    Member Random r,
    Member UserStore r,
    Member ClientStore r
  ) =>
  NE.NonEmpty (ZAuth.Token u) ->
  Maybe (ZAuth.Token a) ->
  Maybe ClientId ->
  ExceptT ZAuth.Failure (AppT r) (Access u)
renewAccess uts at mcid = do
  (uid, ck) <- validateTokens uts at
  traverse_ (checkClientId uid) mcid
  lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.renewAccess")
  catchSuspendInactiveUser uid ZAuth.Expired
  mapExceptT liftSem $ do
    ck' <- nextCookie ck mcid
    at' <- lift $ newAccessToken (fromMaybe ck ck') at
    pure $ Access at' ck'

revokeAccess ::
  ( Member TinyLog r,
    Member UserSubsystem r,
    Member AuthenticationSubsystem r
  ) =>
  Local UserId ->
  PlainTextPassword6 ->
  [CookieId] ->
  [CookieLabel] ->
  ExceptT AuthError (AppT r) ()
revokeAccess luid@(tUnqualified -> u) pw cc ll = do
  lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess")
  isSaml <- lift . liftSem $ do
    account <- User.getAccountNoFilter luid
    pure $ maybe False isSamlUser account
  unless isSaml do
    (lift . liftSem $ Authentication.authenticateEither u pw)
      >>= either throwE pure
  lift $ liftSem $ revokeCookies u cc ll

--------------------------------------------------------------------------------
-- Internal

catchSuspendInactiveUser ::
  ( Member TinyLog r,
    Member UserSubsystem r,
    Member Events r,
    Member (Concurrency 'Unsafe) r,
    Member AuthenticationSubsystem r,
    Member UserStore r
  ) =>
  UserId ->
  e ->
  ExceptT e (AppT r) ()
catchSuspendInactiveUser uid errval = do
  mustsuspend <- lift $ wrapHttpClient $ mustSuspendInactiveUser uid
  when mustsuspend $ do
    lift . liftSem . Log.warn $
      msg (val "Suspending user due to inactivity")
        ~~ field "user" (toByteString uid)
        ~~ field "action" ("user.suspend" :: String)
    lift $ runExceptT (changeSingleAccountStatus uid Suspended) >>= explicitlyIgnoreErrors
    throwE errval
  where
    explicitlyIgnoreErrors :: (Monad m) => Either AccountStatusError () -> m ()
    explicitlyIgnoreErrors = \case
      Left InvalidAccountStatus -> pure ()
      Left AccountNotFound -> pure ()
      Right () -> pure ()

newAccess ::
  forall u a r.
  ( Member TinyLog r,
    Member UserSubsystem r,
    Member Events r,
    ZAuth.UserTokenLike u,
    ZAuth.AccessTokenLike a,
    ZAuth.AccessTokenType u ~ a,
    Member (Concurrency Unsafe) r,
    Member (Input AuthenticationSubsystemConfig) r,
    Member Now r,
    Member AuthenticationSubsystem r,
    Member CryptoSign r,
    Member Random r,
    Member UserStore r
  ) =>
  UserId ->
  Maybe ClientId ->
  CookieType ->
  Maybe CookieLabel ->
  ExceptT LoginError (AppT r) (Access u)
newAccess uid cid ct cl = do
  catchSuspendInactiveUser uid LoginSuspended
  r <- lift $ liftSem $ newCookieLimited uid cid ct cl RevokeSameLabel
  case r of
    Left delay -> throwE $ LoginThrottled delay
    Right ck -> do
      t <- lift . liftSem $ newAccessToken @u @a ck Nothing
      pure $ Access t (Just ck)

resolveLoginId ::
  ( Member UserKeyStore r,
    Member UserStore r,
    Member UserSubsystem r,
    Member ActivationCodeStore r,
    Member (Input (Local ())) r
  ) =>
  LoginId ->
  ExceptT LoginError (AppT r) UserId
resolveLoginId li = do
  usr <- lift . liftSem . either lookupKey lookupHandle $ validateLoginId li
  case usr of
    Nothing -> do
      pending <- lift $ isPendingActivation li
      throwE $
        if pending
          then LoginPendingActivation
          else LoginFailed
    Just uid -> pure uid

validateLoginId :: LoginId -> Either EmailKey Handle
validateLoginId (LoginByEmail email) = (Left . mkEmailKey) email
validateLoginId (LoginByHandle h) = Right h

-- Has a user been activated so they can login?  (This does not apply
-- to apps, because they do not login, they already have their
-- cookie.)
isPendingActivation ::
  forall r.
  ( Member UserSubsystem r,
    Member ActivationCodeStore r,
    Member (Input (Local ())) r
  ) =>
  LoginId ->
  AppT r Bool
isPendingActivation ident = case ident of
  (LoginByHandle _) -> pure False
  (LoginByEmail e) -> checkKey (mkEmailKey e)
  where
    checkKey :: EmailKey -> AppT r Bool
    checkKey k = do
      musr <- (>>= fst) <$> liftSem (ActivationCode.lookupActivationCode k)
      case musr of
        Nothing -> pure False
        Just usr -> liftSem do
          lusr <- qualifyLocal' usr
          maybe False (checkAccount k) <$> User.getAccountNoFilter lusr

    checkAccount :: EmailKey -> User -> Bool
    checkAccount k a =
      let i = userIdentity a
          statusAdmitsPending = case userStatus a of
            Active -> True
            Suspended -> False
            Deleted -> False
            Ephemeral -> False
            PendingInvitation -> True
       in statusAdmitsPending && case i of
            Just (EmailIdentity e) -> mkEmailKey e /= k
            Just SSOIdentity {} -> False -- sso-created users are activated immediately.
            Nothing -> True

-- | Validate a list of (User/LH) tokens potentially with an associated access token.
--   If there are multiple valid cookies, we try all of them. When an access token is
--   given, we perform the usual checks.
--   If multiple cookies are given and several are valid, we return the first valid one.
validateTokens ::
  (ZAuth.UserTokenLike u, ZAuth.AccessTokenLike a, Member (Input AuthenticationSubsystemConfig) r, Member CryptoSign r, Member Now r) =>
  NE.NonEmpty (ZAuth.Token u) ->
  Maybe (ZAuth.Token a) ->
  ExceptT ZAuth.Failure (AppT r) (UserId, Cookie (ZAuth.Token u))
validateTokens uts at = do
  tokens <- forM uts $ \ut -> lift $ runExceptT (validateToken ut at)
  getFirstSuccessOrFirstFail tokens
  where
    -- FUTUREWORK: There is surely a better way to do this
    getFirstSuccessOrFirstFail ::
      (Monad m) =>
      NE.NonEmpty (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) ->
      ExceptT ZAuth.Failure m (UserId, Cookie (ZAuth.Token u))
    getFirstSuccessOrFirstFail tks = case (lefts $ NE.toList tks, rights $ NE.toList tks) of
      (_, suc : _) -> pure suc
      (e : _, _) -> throwE e
      _ -> throwE ZAuth.Invalid -- Impossible

validateToken ::
  (ZAuth.UserTokenLike u, ZAuth.AccessTokenLike a, Member (Input AuthenticationSubsystemConfig) r, Member CryptoSign r, Member Now r) =>
  ZAuth.Token u ->
  Maybe (ZAuth.Token a) ->
  ExceptT ZAuth.Failure (AppT r) (UserId, Cookie (ZAuth.Token u))
validateToken ut at = do
  unless (maybe True ((ut.body.user ==) . (.body.userId)) at) $
    throwE ZAuth.Invalid
  ExceptT . liftSem $ ZAuth.validateToken ut
  forM_ at $ \token ->
    ExceptT (liftSem $ ZAuth.validateToken token)
      `catchE` \e ->
        unless (e == ZAuth.Expired) (throwE e)
  ck <- lift (wrapClient $ lookupCookie ut) >>= maybe (throwE ZAuth.Invalid) pure
  pure (Id ut.body.user, ck)

-- | Allow to login as any user without having the credentials.
ssoLogin ::
  ( Member TinyLog r,
    Member UserSubsystem r,
    Member Events r,
    Member AuthenticationSubsystem r,
    Member (Input AuthenticationSubsystemConfig) r,
    Member (Concurrency Unsafe) r,
    Member Now r,
    Member CryptoSign r,
    Member Random r,
    Member UserStore r
  ) =>
  SsoLogin ->
  CookieType ->
  ExceptT LoginError (AppT r) (Access ZAuth.U)
ssoLogin (SsoLogin uid label) typ = do
  lift
    (liftSem $ Authentication.reauthenticateEither uid Nothing)
    >>= \case
      Right a -> pure a
      Left loginErr -> case loginErr of
        -- Important: We throw on Missing Password here because this can only be thrown
        -- for non-SSO users, so if we got this error, someone tried to authenticate
        -- a regular user as if they were an SSO user, bypassing pwd requirements.
        -- This would be a serious security issue if this weren't an internal endpoint.
        ReAuthMissingPassword -> throwE LoginFailed
        ReAuthCodeVerificationRequired -> pure ()
        ReAuthCodeVerificationNoPendingCode -> pure ()
        ReAuthCodeVerificationNoEmail -> pure ()
        ReAuthError e -> case e of
          AuthInvalidUser -> throwE LoginFailed
          AuthInvalidCredentials -> pure ()
          AuthSuspended -> throwE LoginSuspended
          AuthEphemeral -> throwE LoginEphemeral
          AuthPendingInvitation -> throwE LoginPendingActivation
  newAccess @ZAuth.U @ZAuth.A uid Nothing typ label

-- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens.
legalHoldLogin ::
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member AuthenticationSubsystem r,
    Member Events r,
    Member (Input AuthenticationSubsystemConfig) r,
    Member (Concurrency Unsafe) r,
    Member Now r,
    Member CryptoSign r,
    Member Random r,
    Member UserStore r
  ) =>
  LegalHoldLogin ->
  CookieType ->
  ExceptT LegalHoldLoginError (AppT r) (Access ZAuth.LU)
legalHoldLogin (LegalHoldLogin uid pw label) typ = do
  (lift . liftSem $ Authentication.reauthenticateEither uid pw)
    >>= either (throwE . LegalHoldReAuthError) (const $ pure ())
  -- legalhold login is only possible if
  -- the user is a team user
  -- and the team has legalhold enabled
  mteam <- lift $ liftSem $ GalleyAPIAccess.getTeamId uid
  case mteam of
    Nothing -> throwE LegalHoldLoginNoBindingTeam
    Just tid -> assertLegalHoldEnabled tid
  -- create access token and cookie
  newAccess @ZAuth.LU @ZAuth.LA uid Nothing typ label
    !>> LegalHoldLoginError

assertLegalHoldEnabled ::
  (Member GalleyAPIAccess r) =>
  TeamId ->
  ExceptT LegalHoldLoginError (AppT r) ()
assertLegalHoldEnabled tid = do
  feat <- lift $ liftSem $ GalleyAPIAccess.getTeamLegalHoldStatus tid
  case feat.status of
    FeatureStatusDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled
    FeatureStatusEnabled -> pure ()

checkClientId :: (Member ClientStore r) => UserId -> ClientId -> ExceptT ZAuth.Failure (AppT r) ()
checkClientId uid cid =
  lift (liftSem (ClientStore.lookupClient uid cid)) >>= maybe (throwE ZAuth.Invalid) (const (pure ()))
