-- 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/>.

module Wire.AuthenticationSubsystem.Interpreter
  ( interpretAuthenticationSubsystem,
    passwordResetCodeTtl,
    module Wire.AuthenticationSubsystem.Error,
  )
where

import Data.ByteString.Conversion
import Data.HavePendingInvitations
import Data.Id
import Data.Misc
import Data.Qualified
import Data.Time
import Imports hiding (local, lookup)
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog (TinyLog)
import Polysemy.TinyLog qualified as Log
import System.Logger
import Wire.API.Allowlists (AllowlistEmailDomains)
import Wire.API.Allowlists qualified as AllowLists
import Wire.API.Password (Password, PasswordStatus (..))
import Wire.API.Password qualified as Password
import Wire.API.Password qualified as Pasword
import Wire.API.User
import Wire.API.User.Password
import Wire.AuthenticationSubsystem
import Wire.AuthenticationSubsystem.Error
import Wire.EmailSubsystem
import Wire.HashPassword
import Wire.PasswordResetCodeStore
import Wire.PasswordStore (PasswordStore, upsertHashedPassword)
import Wire.PasswordStore qualified as PasswordStore
import Wire.Sem.Now
import Wire.Sem.Now qualified as Now
import Wire.SessionStore
import Wire.UserKeyStore
import Wire.UserStore
import Wire.UserSubsystem (UserSubsystem, getLocalAccountBy)
import Wire.UserSubsystem qualified as User

interpretAuthenticationSubsystem ::
  forall r.
  ( Member PasswordResetCodeStore r,
    Member Now r,
    Member (Error AuthenticationSubsystemError) r,
    Member TinyLog r,
    Member HashPassword r,
    Member SessionStore r,
    Member (Input (Local ())) r,
    Member (Input (Maybe AllowlistEmailDomains)) r,
    Member PasswordStore r,
    Member EmailSubsystem r,
    Member UserStore r
  ) =>
  InterpreterFor UserSubsystem r ->
  InterpreterFor AuthenticationSubsystem r
interpretAuthenticationSubsystem :: forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Error AuthenticationSubsystemError) r, Member TinyLog r,
 Member HashPassword r, Member SessionStore r,
 Member (Input (Local ())) r,
 Member (Input (Maybe AllowlistEmailDomains)) r,
 Member PasswordStore r, Member EmailSubsystem r,
 Member UserStore r) =>
InterpreterFor UserSubsystem r
-> InterpreterFor AuthenticationSubsystem r
interpretAuthenticationSubsystem InterpreterFor UserSubsystem r
userSubsystemInterpreter =
  (forall (rInitial :: EffectRow) x.
 AuthenticationSubsystem (Sem rInitial) x -> Sem r x)
-> Sem (AuthenticationSubsystem : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  AuthenticationSubsystem (Sem rInitial) x -> Sem r x)
 -> Sem (AuthenticationSubsystem : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    AuthenticationSubsystem (Sem rInitial) x -> Sem r x)
-> Sem (AuthenticationSubsystem : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$
    Sem (UserSubsystem : r) x -> Sem r x
InterpreterFor UserSubsystem r
userSubsystemInterpreter (Sem (UserSubsystem : r) x -> Sem r x)
-> (AuthenticationSubsystem (Sem rInitial) x
    -> Sem (UserSubsystem : r) x)
-> AuthenticationSubsystem (Sem rInitial) x
-> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      AuthenticateEither UserId
uid PlainTextPassword6
pwd -> UserId
-> PlainTextPassword6
-> Sem (UserSubsystem : r) (Either AuthError ())
forall (r :: EffectRow).
(Member UserStore r, Member HashPassword r,
 Member PasswordStore r) =>
UserId -> PlainTextPassword6 -> Sem r (Either AuthError ())
authenticateEitherImpl UserId
uid PlainTextPassword6
pwd
      ReauthenticateEither UserId
uid Maybe PlainTextPassword6
pwd -> UserId
-> Maybe PlainTextPassword6
-> Sem (UserSubsystem : r) (Either ReAuthError ())
forall (r :: EffectRow) (t :: Nat).
(Member UserStore r, Member UserSubsystem r,
 Member (Input (Local ())) r) =>
UserId
-> Maybe (PlainTextPassword' t) -> Sem r (Either ReAuthError ())
reauthenticateEitherImpl UserId
uid Maybe PlainTextPassword6
pwd
      CreatePasswordResetCode EmailKey
userKey -> EmailKey -> Sem (UserSubsystem : r) ()
forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Input (Local ())) r,
 Member (Input (Maybe AllowlistEmailDomains)) r, Member TinyLog r,
 Member UserSubsystem r, Member EmailSubsystem r) =>
EmailKey -> Sem r ()
createPasswordResetCodeImpl EmailKey
userKey
      ResetPassword PasswordResetIdentity
ident PasswordResetCode
resetCode PlainTextPassword8
newPassword -> PasswordResetIdentity
-> PasswordResetCode
-> PlainTextPassword8
-> Sem (UserSubsystem : r) ()
forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Input (Local ())) r,
 Member (Error AuthenticationSubsystemError) r, Member TinyLog r,
 Member UserSubsystem r, Member HashPassword r,
 Member SessionStore r, Member PasswordStore r) =>
PasswordResetIdentity
-> PasswordResetCode -> PlainTextPassword8 -> Sem r ()
resetPasswordImpl PasswordResetIdentity
ident PasswordResetCode
resetCode PlainTextPassword8
newPassword
      VerifyPassword PlainTextPassword6
plaintext Password
pwd -> PlainTextPassword6
-> Password -> Sem (UserSubsystem : r) (Bool, PasswordStatus)
forall (r :: EffectRow).
PlainTextPassword6 -> Password -> Sem r (Bool, PasswordStatus)
verifyPasswordImpl PlainTextPassword6
plaintext Password
pwd
      VerifyUserPassword UserId
uid PlainTextPassword6
plaintext -> UserId
-> PlainTextPassword6
-> Sem (UserSubsystem : r) (Bool, PasswordStatus)
forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
UserId -> PlainTextPassword6 -> Sem r (Bool, PasswordStatus)
verifyUserPasswordImpl UserId
uid PlainTextPassword6
plaintext
      VerifyUserPasswordError Local UserId
luid PlainTextPassword6
plaintext -> Local UserId -> PlainTextPassword6 -> Sem (UserSubsystem : r) ()
forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
Local UserId -> PlainTextPassword6 -> Sem r ()
verifyUserPasswordErrorImpl Local UserId
luid PlainTextPassword6
plaintext
      VerifyProviderPassword ProviderId
pid PlainTextPassword6
plaintext -> ProviderId
-> PlainTextPassword6
-> Sem (UserSubsystem : r) (Bool, PasswordStatus)
forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
ProviderId -> PlainTextPassword6 -> Sem r (Bool, PasswordStatus)
verifyProviderPasswordImpl ProviderId
pid PlainTextPassword6
plaintext
      -- Testing
      InternalLookupPasswordResetCode EmailKey
userKey -> EmailKey -> Sem (UserSubsystem : r) (Maybe PasswordResetPair)
forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Input (Local ())) r, Member UserSubsystem r) =>
EmailKey -> Sem r (Maybe PasswordResetPair)
internalLookupPasswordResetCodeImpl EmailKey
userKey

maxAttempts :: Int32
maxAttempts :: Int32
maxAttempts = Int32
3

passwordResetCodeTtl :: NominalDiffTime
passwordResetCodeTtl :: NominalDiffTime
passwordResetCodeTtl = NominalDiffTime
3600 -- 60 minutes

-- This type is not exported and used for internal control flow only
data PasswordResetError
  = AllowListError
  | InvalidResetKey
  | InProgress
  deriving (Int -> PasswordResetError -> ShowS
[PasswordResetError] -> ShowS
PasswordResetError -> String
(Int -> PasswordResetError -> ShowS)
-> (PasswordResetError -> String)
-> ([PasswordResetError] -> ShowS)
-> Show PasswordResetError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PasswordResetError -> ShowS
showsPrec :: Int -> PasswordResetError -> ShowS
$cshow :: PasswordResetError -> String
show :: PasswordResetError -> String
$cshowList :: [PasswordResetError] -> ShowS
showList :: [PasswordResetError] -> ShowS
Show)

instance Exception PasswordResetError where
  displayException :: PasswordResetError -> String
displayException PasswordResetError
AllowListError = String
"email domain is not allowed for password reset"
  displayException PasswordResetError
InvalidResetKey = String
"invalid reset key for password reset"
  displayException PasswordResetError
InProgress = String
"password reset already in progress"

authenticateEitherImpl ::
  ( Member UserStore r,
    Member HashPassword r,
    Member PasswordStore r
  ) =>
  UserId ->
  PlainTextPassword6 ->
  Sem r (Either AuthError ())
authenticateEitherImpl :: forall (r :: EffectRow).
(Member UserStore r, Member HashPassword r,
 Member PasswordStore r) =>
UserId -> PlainTextPassword6 -> Sem r (Either AuthError ())
authenticateEitherImpl UserId
uid PlainTextPassword6
plaintext = do
  Sem (Error AuthError : r) () -> Sem r (Either AuthError ())
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError (Sem (Error AuthError : r) () -> Sem r (Either AuthError ()))
-> Sem (Error AuthError : r) () -> Sem r (Either AuthError ())
forall a b. (a -> b) -> a -> b
$
    UserId
-> Sem
     (Error AuthError : r) (Maybe (Maybe Password, AccountStatus))
forall (r :: EffectRow).
Member UserStore r =>
UserId -> Sem r (Maybe (Maybe Password, AccountStatus))
getUserAuthenticationInfo UserId
uid Sem (Error AuthError : r) (Maybe (Maybe Password, AccountStatus))
-> (Maybe (Maybe Password, AccountStatus)
    -> Sem (Error AuthError : r) ())
-> Sem (Error AuthError : r) ()
forall a b.
Sem (Error AuthError : r) a
-> (a -> Sem (Error AuthError : r) b)
-> Sem (Error AuthError : r) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Maybe Password, AccountStatus)
Nothing -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthInvalidUser
      Just (Maybe Password
_, AccountStatus
Deleted) -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthInvalidUser
      Just (Maybe Password
_, AccountStatus
Suspended) -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthSuspended
      Just (Maybe Password
_, AccountStatus
Ephemeral) -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthEphemeral
      Just (Maybe Password
_, AccountStatus
PendingInvitation) -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthPendingInvitation
      Just (Maybe Password
Nothing, AccountStatus
_) -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthInvalidCredentials
      Just (Just Password
password, AccountStatus
Active) -> do
        case PlainTextPassword6 -> Password -> (Bool, PasswordStatus)
forall (t :: Nat).
PlainTextPassword' t -> Password -> (Bool, PasswordStatus)
Pasword.verifyPasswordWithStatus PlainTextPassword6
plaintext Password
password of
          (Bool
False, PasswordStatus
_) -> AuthError -> Sem (Error AuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthError
AuthInvalidCredentials
          (Bool
True, PasswordStatus
PasswordStatusNeedsUpdate) -> do
            (UserId -> PlainTextPassword6 -> Sem (Error AuthError : r) ()
forall {r :: EffectRow}.
(Member HashPassword r, Member PasswordStore r) =>
UserId -> PlainTextPassword6 -> Sem r ()
hashAndUpdatePwd UserId
uid PlainTextPassword6
plaintext)
          (Bool
True, PasswordStatus
_) -> () -> Sem (Error AuthError : r) ()
forall a. a -> Sem (Error AuthError : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    hashAndUpdatePwd :: UserId -> PlainTextPassword6 -> Sem r ()
hashAndUpdatePwd UserId
u PlainTextPassword6
pwd = do
      Password
hashed <- PlainTextPassword6 -> Sem r Password
forall (r :: EffectRow).
Member HashPassword r =>
PlainTextPassword6 -> Sem r Password
hashPassword6 PlainTextPassword6
pwd
      UserId -> Password -> Sem r ()
forall (r :: EffectRow).
Member PasswordStore r =>
UserId -> Password -> Sem r ()
upsertHashedPassword UserId
u Password
hashed

-- | Password reauthentication. If the account has a password, reauthentication
-- is mandatory. If
-- * User has no password, re-auth is a no-op
-- * User is an SSO user and no password is given, re-auth is a no-op.
reauthenticateEitherImpl ::
  ( Member UserStore r,
    Member UserSubsystem r,
    Member (Input (Local ())) r
  ) =>
  UserId ->
  Maybe (PlainTextPassword' t) ->
  Sem r (Either ReAuthError ())
reauthenticateEitherImpl :: forall (r :: EffectRow) (t :: Nat).
(Member UserStore r, Member UserSubsystem r,
 Member (Input (Local ())) r) =>
UserId
-> Maybe (PlainTextPassword' t) -> Sem r (Either ReAuthError ())
reauthenticateEitherImpl UserId
user Maybe (PlainTextPassword' t)
plaintextMaybe =
  UserId -> Sem r (Maybe (Maybe Password, AccountStatus))
forall (r :: EffectRow).
Member UserStore r =>
UserId -> Sem r (Maybe (Maybe Password, AccountStatus))
getUserAuthenticationInfo UserId
user
    Sem r (Maybe (Maybe Password, AccountStatus))
-> (Maybe (Maybe Password, AccountStatus)
    -> Sem r (Either ReAuthError ()))
-> Sem r (Either ReAuthError ())
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem (Error ReAuthError : r) () -> Sem r (Either ReAuthError ())
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
      (Sem (Error ReAuthError : r) () -> Sem r (Either ReAuthError ()))
-> (Maybe (Maybe Password, AccountStatus)
    -> Sem (Error ReAuthError : r) ())
-> Maybe (Maybe Password, AccountStatus)
-> Sem r (Either ReAuthError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        Maybe (Maybe Password, AccountStatus)
Nothing -> ReAuthError -> Sem (Error ReAuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (AuthError -> ReAuthError
ReAuthError AuthError
AuthInvalidUser)
        Just (Maybe Password
_, AccountStatus
Deleted) -> ReAuthError -> Sem (Error ReAuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (AuthError -> ReAuthError
ReAuthError AuthError
AuthInvalidUser)
        Just (Maybe Password
_, AccountStatus
Suspended) -> ReAuthError -> Sem (Error ReAuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (AuthError -> ReAuthError
ReAuthError AuthError
AuthSuspended)
        Just (Maybe Password
_, AccountStatus
PendingInvitation) -> ReAuthError -> Sem (Error ReAuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (AuthError -> ReAuthError
ReAuthError AuthError
AuthPendingInvitation)
        Just (Maybe Password
Nothing, AccountStatus
_) -> Maybe (PlainTextPassword' t)
-> (PlainTextPassword' t -> Sem (Error ReAuthError : r) Any)
-> Sem (Error ReAuthError : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (PlainTextPassword' t)
plaintextMaybe ((PlainTextPassword' t -> Sem (Error ReAuthError : r) Any)
 -> Sem (Error ReAuthError : r) ())
-> (PlainTextPassword' t -> Sem (Error ReAuthError : r) Any)
-> Sem (Error ReAuthError : r) ()
forall a b. (a -> b) -> a -> b
$ Sem (Error ReAuthError : r) Any
-> PlainTextPassword' t -> Sem (Error ReAuthError : r) Any
forall a b. a -> b -> a
const (ReAuthError -> Sem (Error ReAuthError : r) Any
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (ReAuthError -> Sem (Error ReAuthError : r) Any)
-> ReAuthError -> Sem (Error ReAuthError : r) Any
forall a b. (a -> b) -> a -> b
$ AuthError -> ReAuthError
ReAuthError AuthError
AuthInvalidCredentials)
        Just (Just Password
pw', AccountStatus
Active) -> Password -> Sem (Error ReAuthError : r) ()
maybeReAuth Password
pw'
        Just (Just Password
pw', AccountStatus
Ephemeral) -> Password -> Sem (Error ReAuthError : r) ()
maybeReAuth Password
pw'
  where
    maybeReAuth :: Password -> Sem (Error ReAuthError : r) ()
maybeReAuth Password
pw' = case Maybe (PlainTextPassword' t)
plaintextMaybe of
      Maybe (PlainTextPassword' t)
Nothing -> do
        Local ()
local <- Sem (Error ReAuthError : r) (Local ())
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
        Maybe User
musr <- HavePendingInvitations
-> Local UserId -> Sem (Error ReAuthError : r) (Maybe User)
forall (r :: EffectRow).
Member UserSubsystem r =>
HavePendingInvitations -> Local UserId -> Sem r (Maybe User)
getLocalAccountBy HavePendingInvitations
NoPendingInvitations (Local () -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ()
local UserId
user)
        let isSaml :: Bool
isSaml = Bool -> (User -> Bool) -> Maybe User -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False User -> Bool
isSamlUser Maybe User
musr
        -- If this is a SAML user, re-auth should be no-op so no error is thrown.
        Bool
-> Sem (Error ReAuthError : r) () -> Sem (Error ReAuthError : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isSaml (Sem (Error ReAuthError : r) () -> Sem (Error ReAuthError : r) ())
-> Sem (Error ReAuthError : r) () -> Sem (Error ReAuthError : r) ()
forall a b. (a -> b) -> a -> b
$
          ReAuthError -> Sem (Error ReAuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw ReAuthError
ReAuthMissingPassword
      Just PlainTextPassword' t
p ->
        Bool
-> Sem (Error ReAuthError : r) () -> Sem (Error ReAuthError : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PlainTextPassword' t -> Password -> Bool
forall (t :: Nat). PlainTextPassword' t -> Password -> Bool
Password.verifyPassword PlainTextPassword' t
p Password
pw') do
          ReAuthError -> Sem (Error ReAuthError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (AuthError -> ReAuthError
ReAuthError AuthError
AuthInvalidCredentials)

createPasswordResetCodeImpl ::
  forall r.
  ( Member PasswordResetCodeStore r,
    Member Now r,
    Member (Input (Local ())) r,
    Member (Input (Maybe AllowlistEmailDomains)) r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member EmailSubsystem r
  ) =>
  EmailKey ->
  Sem r ()
createPasswordResetCodeImpl :: forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Input (Local ())) r,
 Member (Input (Maybe AllowlistEmailDomains)) r, Member TinyLog r,
 Member UserSubsystem r, Member EmailSubsystem r) =>
EmailKey -> Sem r ()
createPasswordResetCodeImpl EmailKey
target =
  Either PasswordResetError () -> Sem r ()
logPasswordResetError (Either PasswordResetError () -> Sem r ())
-> Sem r (Either PasswordResetError ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem (Error PasswordResetError : r) ()
-> Sem r (Either PasswordResetError ())
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError do
    Bool
allowListOk <- (\Maybe AllowlistEmailDomains
e -> Maybe AllowlistEmailDomains -> EmailAddress -> Bool
AllowLists.verify Maybe AllowlistEmailDomains
e (EmailKey -> EmailAddress
emailKeyOrig EmailKey
target)) (Maybe AllowlistEmailDomains -> Bool)
-> Sem (Error PasswordResetError : r) (Maybe AllowlistEmailDomains)
-> Sem (Error PasswordResetError : r) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem (Error PasswordResetError : r) (Maybe AllowlistEmailDomains)
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
    Bool
-> Sem (Error PasswordResetError : r) ()
-> Sem (Error PasswordResetError : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowListOk (Sem (Error PasswordResetError : r) ()
 -> Sem (Error PasswordResetError : r) ())
-> Sem (Error PasswordResetError : r) ()
-> Sem (Error PasswordResetError : r) ()
forall a b. (a -> b) -> a -> b
$ PasswordResetError -> Sem (Error PasswordResetError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw PasswordResetError
AllowListError
    User
user <- EmailKey -> Sem (Error PasswordResetError : r) (Maybe User)
forall (r :: EffectRow).
(Member UserSubsystem r, Member (Input (Local ())) r) =>
EmailKey -> Sem r (Maybe User)
lookupActiveUserByUserKey EmailKey
target Sem (Error PasswordResetError : r) (Maybe User)
-> (Maybe User -> Sem (Error PasswordResetError : r) User)
-> Sem (Error PasswordResetError : r) User
forall a b.
Sem (Error PasswordResetError : r) a
-> (a -> Sem (Error PasswordResetError : r) b)
-> Sem (Error PasswordResetError : r) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem (Error PasswordResetError : r) User
-> (User -> Sem (Error PasswordResetError : r) User)
-> Maybe User
-> Sem (Error PasswordResetError : r) User
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PasswordResetError -> Sem (Error PasswordResetError : r) User
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw PasswordResetError
InvalidResetKey) User -> Sem (Error PasswordResetError : r) User
forall a. a -> Sem (Error PasswordResetError : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    let uid :: UserId
uid = User -> UserId
userId User
user
    (Msg -> Msg) -> Sem (Error PasswordResetError : r) ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.debug ((Msg -> Msg) -> Sem (Error PasswordResetError : r) ())
-> (Msg -> Msg) -> Sem (Error PasswordResetError : r) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"user" (UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString UserId
uid) (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"action" (ByteString -> Builder
val ByteString
"User.beginPasswordReset")

    Maybe PasswordResetCode
mExistingCode <- UserId
-> Sem (Error PasswordResetError : r) (Maybe PasswordResetCode)
forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r) =>
UserId -> Sem r (Maybe PasswordResetCode)
lookupPasswordResetCode UserId
uid
    Bool
-> Sem (Error PasswordResetError : r) ()
-> Sem (Error PasswordResetError : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe PasswordResetCode -> Bool
forall a. Maybe a -> Bool
isJust Maybe PasswordResetCode
mExistingCode) (Sem (Error PasswordResetError : r) ()
 -> Sem (Error PasswordResetError : r) ())
-> Sem (Error PasswordResetError : r) ()
-> Sem (Error PasswordResetError : r) ()
forall a b. (a -> b) -> a -> b
$
      PasswordResetError -> Sem (Error PasswordResetError : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw PasswordResetError
InProgress

    let key :: PasswordResetKey
key = UserId -> PasswordResetKey
mkPasswordResetKey UserId
uid
    UTCTime
now <- Sem (Error PasswordResetError : r) UTCTime
forall (r :: EffectRow). Member Now r => Sem r UTCTime
Now.get
    PasswordResetCode
code <- Sem (Error PasswordResetError : r) PasswordResetCode
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
Sem r PasswordResetCode
generateEmailCode
    PasswordResetKey
-> PRQueryData Identity
-> Int32
-> Sem (Error PasswordResetError : r) ()
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
PasswordResetKey -> PRQueryData Identity -> Int32 -> Sem r ()
codeInsert
      PasswordResetKey
key
      (PasswordResetCode
-> UserId
-> Identity Int32
-> Identity UTCTime
-> PRQueryData Identity
forall (f :: * -> *).
PasswordResetCode
-> UserId -> f Int32 -> f UTCTime -> PRQueryData f
PRQueryData PasswordResetCode
code UserId
uid (Int32 -> Identity Int32
forall a. a -> Identity a
Identity Int32
maxAttempts) (UTCTime -> Identity UTCTime
forall a. a -> Identity a
Identity (NominalDiffTime
passwordResetCodeTtl NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now)))
      (NominalDiffTime -> Int32
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
passwordResetCodeTtl)
    EmailAddress
-> PasswordResetPair
-> Maybe Locale
-> Sem (Error PasswordResetError : r) ()
forall (r :: EffectRow).
Member EmailSubsystem r =>
EmailAddress -> PasswordResetPair -> Maybe Locale -> Sem r ()
sendPasswordResetMail (EmailKey -> EmailAddress
emailKeyOrig EmailKey
target) (PasswordResetKey
key, PasswordResetCode
code) (Locale -> Maybe Locale
forall a. a -> Maybe a
Just User
user.userLocale)
    () -> Sem (Error PasswordResetError : r) ()
forall a. a -> Sem (Error PasswordResetError : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    -- `PasswordResetError` are errors that we don't want to leak to the caller.
    -- Therefore we handle them here and only log without propagating them.
    logPasswordResetError :: Either PasswordResetError () -> Sem r ()
    logPasswordResetError :: Either PasswordResetError () -> Sem r ()
logPasswordResetError = \case
      Left PasswordResetError
e ->
        (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.err ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
          ByteString -> Builder -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"action" (ByteString -> Builder
val ByteString
"User.beginPasswordReset")
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"error" (PasswordResetError -> String
forall e. Exception e => e -> String
displayException PasswordResetError
e)
      Right ()
v -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
v

lookupActiveUserIdByUserKey ::
  ( Member UserSubsystem r,
    Member (Input (Local ())) r
  ) =>
  EmailKey ->
  Sem r (Maybe UserId)
lookupActiveUserIdByUserKey :: forall (r :: EffectRow).
(Member UserSubsystem r, Member (Input (Local ())) r) =>
EmailKey -> Sem r (Maybe UserId)
lookupActiveUserIdByUserKey EmailKey
target =
  User -> UserId
userId (User -> UserId) -> Sem r (Maybe User) -> Sem r (Maybe UserId)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> EmailKey -> Sem r (Maybe User)
forall (r :: EffectRow).
(Member UserSubsystem r, Member (Input (Local ())) r) =>
EmailKey -> Sem r (Maybe User)
lookupActiveUserByUserKey EmailKey
target

lookupActiveUserByUserKey ::
  ( Member UserSubsystem r,
    Member (Input (Local ())) r
  ) =>
  EmailKey ->
  Sem r (Maybe User)
lookupActiveUserByUserKey :: forall (r :: EffectRow).
(Member UserSubsystem r, Member (Input (Local ())) r) =>
EmailKey -> Sem r (Maybe User)
lookupActiveUserByUserKey EmailKey
target = do
  Local ()
localUnit <- Sem r (Local ())
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  let ltarget :: QualifiedWithTag 'QLocal [EmailAddress]
ltarget = Local ()
-> [EmailAddress] -> QualifiedWithTag 'QLocal [EmailAddress]
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ()
localUnit [EmailKey -> EmailAddress
emailKeyOrig EmailKey
target]
  [User]
mUser <- QualifiedWithTag 'QLocal [EmailAddress] -> Sem r [User]
forall (r :: EffectRow).
Member UserSubsystem r =>
QualifiedWithTag 'QLocal [EmailAddress] -> Sem r [User]
User.getAccountsByEmailNoFilter QualifiedWithTag 'QLocal [EmailAddress]
ltarget
  case [User]
mUser of
    [User
user] -> do
      Maybe User -> Sem r (Maybe User)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe User -> Sem r (Maybe User))
-> Maybe User -> Sem r (Maybe User)
forall a b. (a -> b) -> a -> b
$
        if User
user.userStatus AccountStatus -> AccountStatus -> Bool
forall a. Eq a => a -> a -> Bool
== AccountStatus
Active
          then User -> Maybe User
forall a. a -> Maybe a
Just User
user
          else Maybe User
forall a. Maybe a
Nothing
    [User]
_ -> Maybe User -> Sem r (Maybe User)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe User
forall a. Maybe a
Nothing

internalLookupPasswordResetCodeImpl ::
  ( Member PasswordResetCodeStore r,
    Member Now r,
    Member (Input (Local ())) r,
    Member UserSubsystem r
  ) =>
  EmailKey ->
  Sem r (Maybe PasswordResetPair)
internalLookupPasswordResetCodeImpl :: forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Input (Local ())) r, Member UserSubsystem r) =>
EmailKey -> Sem r (Maybe PasswordResetPair)
internalLookupPasswordResetCodeImpl EmailKey
key = do
  Maybe UserId
mUser <- EmailKey -> Sem r (Maybe UserId)
forall (r :: EffectRow).
(Member UserSubsystem r, Member (Input (Local ())) r) =>
EmailKey -> Sem r (Maybe UserId)
lookupActiveUserIdByUserKey EmailKey
key
  case Maybe UserId
mUser of
    Just UserId
user -> do
      Maybe PasswordResetCode
mCode <- UserId -> Sem r (Maybe PasswordResetCode)
forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r) =>
UserId -> Sem r (Maybe PasswordResetCode)
lookupPasswordResetCode UserId
user
      let k :: PasswordResetKey
k = UserId -> PasswordResetKey
mkPasswordResetKey UserId
user
      Maybe PasswordResetPair -> Sem r (Maybe PasswordResetPair)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PasswordResetPair -> Sem r (Maybe PasswordResetPair))
-> Maybe PasswordResetPair -> Sem r (Maybe PasswordResetPair)
forall a b. (a -> b) -> a -> b
$ (PasswordResetKey
k,) (PasswordResetCode -> PasswordResetPair)
-> Maybe PasswordResetCode -> Maybe PasswordResetPair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PasswordResetCode
mCode
    Maybe UserId
Nothing -> Maybe PasswordResetPair -> Sem r (Maybe PasswordResetPair)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PasswordResetPair
forall a. Maybe a
Nothing

lookupPasswordResetCode ::
  ( Member PasswordResetCodeStore r,
    Member Now r
  ) =>
  UserId ->
  Sem r (Maybe PasswordResetCode)
lookupPasswordResetCode :: forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r) =>
UserId -> Sem r (Maybe PasswordResetCode)
lookupPasswordResetCode UserId
u = do
  let key :: PasswordResetKey
key = UserId -> PasswordResetKey
mkPasswordResetKey UserId
u
  UTCTime
now <- Sem r UTCTime
forall (r :: EffectRow). Member Now r => Sem r UTCTime
Now.get
  UTCTime
-> Maybe (PRQueryData Maybe) -> Sem r (Maybe PasswordResetCode)
forall {f :: * -> *}.
Applicative f =>
UTCTime -> Maybe (PRQueryData Maybe) -> f (Maybe PasswordResetCode)
validate UTCTime
now (Maybe (PRQueryData Maybe) -> Sem r (Maybe PasswordResetCode))
-> Sem r (Maybe (PRQueryData Maybe))
-> Sem r (Maybe PasswordResetCode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PasswordResetKey -> Sem r (Maybe (PRQueryData Maybe))
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
PasswordResetKey -> Sem r (Maybe (PRQueryData Maybe))
codeSelect PasswordResetKey
key
  where
    validate :: UTCTime -> Maybe (PRQueryData Maybe) -> f (Maybe PasswordResetCode)
validate UTCTime
now (Just (PRQueryData PasswordResetCode
c UserId
_ Maybe Int32
_ (Just UTCTime
t))) | UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now = Maybe PasswordResetCode -> f (Maybe PasswordResetCode)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PasswordResetCode -> f (Maybe PasswordResetCode))
-> Maybe PasswordResetCode -> f (Maybe PasswordResetCode)
forall a b. (a -> b) -> a -> b
$ PasswordResetCode -> Maybe PasswordResetCode
forall a. a -> Maybe a
Just PasswordResetCode
c
    validate UTCTime
_ Maybe (PRQueryData Maybe)
_ = Maybe PasswordResetCode -> f (Maybe PasswordResetCode)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PasswordResetCode
forall a. Maybe a
Nothing

resetPasswordImpl ::
  forall r.
  ( Member PasswordResetCodeStore r,
    Member Now r,
    Member (Input (Local ())) r,
    Member (Error AuthenticationSubsystemError) r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member HashPassword r,
    Member SessionStore r,
    Member PasswordStore r
  ) =>
  PasswordResetIdentity ->
  PasswordResetCode ->
  PlainTextPassword8 ->
  Sem r ()
resetPasswordImpl :: forall (r :: EffectRow).
(Member PasswordResetCodeStore r, Member Now r,
 Member (Input (Local ())) r,
 Member (Error AuthenticationSubsystemError) r, Member TinyLog r,
 Member UserSubsystem r, Member HashPassword r,
 Member SessionStore r, Member PasswordStore r) =>
PasswordResetIdentity
-> PasswordResetCode -> PlainTextPassword8 -> Sem r ()
resetPasswordImpl PasswordResetIdentity
ident PasswordResetCode
code PlainTextPassword8
pw = do
  PasswordResetKey
key <- Sem r PasswordResetKey
passwordResetKeyFromIdentity

  Maybe UserId
muid :: Maybe UserId <- PasswordResetPair -> Sem r (Maybe UserId)
verify (PasswordResetKey
key, PasswordResetCode
code)
  case Maybe UserId
muid of
    Maybe UserId
Nothing -> AuthenticationSubsystemError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemInvalidPasswordResetCode
    Just UserId
uid -> do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.debug ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"user" (UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString UserId
uid) (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"action" (ByteString -> Builder
val ByteString
"User.completePasswordReset")
      UserId -> PlainTextPassword8 -> Sem r ()
forall (t :: Nat). UserId -> PlainTextPassword' t -> Sem r ()
checkNewIsDifferent UserId
uid PlainTextPassword8
pw
      Password
hashedPw <- PlainTextPassword8 -> Sem r Password
forall (r :: EffectRow).
Member HashPassword r =>
PlainTextPassword8 -> Sem r Password
hashPassword8 PlainTextPassword8
pw
      UserId -> Password -> Sem r ()
forall (r :: EffectRow).
Member PasswordStore r =>
UserId -> Password -> Sem r ()
PasswordStore.upsertHashedPassword UserId
uid Password
hashedPw
      PasswordResetKey -> Sem r ()
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
PasswordResetKey -> Sem r ()
codeDelete PasswordResetKey
key
      UserId -> Sem r ()
forall (r :: EffectRow).
Member SessionStore r =>
UserId -> Sem r ()
deleteAllCookies UserId
uid
  where
    passwordResetKeyFromIdentity :: Sem r PasswordResetKey
    passwordResetKeyFromIdentity :: Sem r PasswordResetKey
passwordResetKeyFromIdentity = case PasswordResetIdentity
ident of
      PasswordResetIdentityKey PasswordResetKey
k -> PasswordResetKey -> Sem r PasswordResetKey
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PasswordResetKey
k
      PasswordResetEmailIdentity EmailAddress
e -> do
        Maybe UserId
mUserId <- EmailKey -> Sem r (Maybe UserId)
forall (r :: EffectRow).
(Member UserSubsystem r, Member (Input (Local ())) r) =>
EmailKey -> Sem r (Maybe UserId)
lookupActiveUserIdByUserKey (EmailAddress -> EmailKey
mkEmailKey EmailAddress
e)
        let mResetKey :: Maybe PasswordResetKey
mResetKey = UserId -> PasswordResetKey
mkPasswordResetKey (UserId -> PasswordResetKey)
-> Maybe UserId -> Maybe PasswordResetKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserId
mUserId
        Sem r PasswordResetKey
-> (PasswordResetKey -> Sem r PasswordResetKey)
-> Maybe PasswordResetKey
-> Sem r PasswordResetKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthenticationSubsystemError -> Sem r PasswordResetKey
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemInvalidPasswordResetKey) PasswordResetKey -> Sem r PasswordResetKey
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PasswordResetKey
mResetKey
      PasswordResetPhoneIdentity Phone
_ -> do
        AuthenticationSubsystemError -> Sem r PasswordResetKey
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemInvalidPhone

    checkNewIsDifferent :: UserId -> PlainTextPassword' t -> Sem r ()
    checkNewIsDifferent :: forall (t :: Nat). UserId -> PlainTextPassword' t -> Sem r ()
checkNewIsDifferent UserId
uid PlainTextPassword' t
newPassword = do
      Maybe Password
mCurrentPassword <- UserId -> Sem r (Maybe Password)
forall (r :: EffectRow).
Member PasswordStore r =>
UserId -> Sem r (Maybe Password)
PasswordStore.lookupHashedPassword UserId
uid
      case Maybe Password
mCurrentPassword of
        Just Password
currentPassword
          | (PlainTextPassword' t -> Password -> Bool
forall (t :: Nat). PlainTextPassword' t -> Password -> Bool
Password.verifyPassword PlainTextPassword' t
newPassword Password
currentPassword) -> AuthenticationSubsystemError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemResetPasswordMustDiffer
        Maybe Password
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    verify :: PasswordResetPair -> Sem r (Maybe UserId)
    verify :: PasswordResetPair -> Sem r (Maybe UserId)
verify (PasswordResetKey
k, PasswordResetCode
c) = do
      UTCTime
now <- Sem r UTCTime
forall (r :: EffectRow). Member Now r => Sem r UTCTime
Now.get
      Maybe (PRQueryData Maybe)
passwordResetData <- PasswordResetKey -> Sem r (Maybe (PRQueryData Maybe))
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
PasswordResetKey -> Sem r (Maybe (PRQueryData Maybe))
codeSelect PasswordResetKey
k
      case Maybe (PRQueryData Maybe)
passwordResetData of
        Just (PRQueryData PasswordResetCode
codeInDB UserId
u Maybe Int32
_ (Just UTCTime
t)) | PasswordResetCode
c PasswordResetCode -> PasswordResetCode -> Bool
forall a. Eq a => a -> a -> Bool
== PasswordResetCode
codeInDB Bool -> Bool -> Bool
&& UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
now -> Maybe UserId -> Sem r (Maybe UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
u)
        Just (PRQueryData PasswordResetCode
codeInDB UserId
u (Just Int32
n) (Just UTCTime
t)) | Int32
n Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
1 Bool -> Bool -> Bool
&& UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now -> do
          -- If we only update retries, there is a chance that this races with
          -- the PasswordResetCodeTtl and we have a situation where only retries is non-null for
          -- a given key. To avoid this, we insert the whole row again.
          PasswordResetKey -> PRQueryData Identity -> Int32 -> Sem r ()
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
PasswordResetKey -> PRQueryData Identity -> Int32 -> Sem r ()
codeInsert PasswordResetKey
k (PasswordResetCode
-> UserId
-> Identity Int32
-> Identity UTCTime
-> PRQueryData Identity
forall (f :: * -> *).
PasswordResetCode
-> UserId -> f Int32 -> f UTCTime -> PRQueryData f
PRQueryData PasswordResetCode
codeInDB UserId
u (Int32 -> Identity Int32
forall a. a -> Identity a
Identity (Int32
n Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1)) (UTCTime -> Identity UTCTime
forall a. a -> Identity a
Identity UTCTime
t)) (NominalDiffTime -> Int32
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
passwordResetCodeTtl)
          Maybe UserId -> Sem r (Maybe UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UserId
forall a. Maybe a
Nothing
        Just PRQueryData {} -> PasswordResetKey -> Sem r ()
forall (r :: EffectRow).
Member PasswordResetCodeStore r =>
PasswordResetKey -> Sem r ()
codeDelete PasswordResetKey
k Sem r () -> Maybe UserId -> Sem r (Maybe UserId)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe UserId
forall a. Maybe a
Nothing
        Maybe (PRQueryData Maybe)
Nothing -> Maybe UserId -> Sem r (Maybe UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UserId
forall a. Maybe a
Nothing

verifyPasswordImpl ::
  PlainTextPassword6 ->
  Password ->
  Sem r (Bool, PasswordStatus)
verifyPasswordImpl :: forall (r :: EffectRow).
PlainTextPassword6 -> Password -> Sem r (Bool, PasswordStatus)
verifyPasswordImpl PlainTextPassword6
plaintext Password
password = do
  (Bool, PasswordStatus) -> Sem r (Bool, PasswordStatus)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, PasswordStatus) -> Sem r (Bool, PasswordStatus))
-> (Bool, PasswordStatus) -> Sem r (Bool, PasswordStatus)
forall a b. (a -> b) -> a -> b
$ PlainTextPassword6 -> Password -> (Bool, PasswordStatus)
forall (t :: Nat).
PlainTextPassword' t -> Password -> (Bool, PasswordStatus)
Password.verifyPasswordWithStatus PlainTextPassword6
plaintext Password
password

verifyProviderPasswordImpl ::
  ( Member PasswordStore r,
    Member (Error AuthenticationSubsystemError) r
  ) =>
  ProviderId ->
  PlainTextPassword6 ->
  Sem r (Bool, PasswordStatus)
verifyProviderPasswordImpl :: forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
ProviderId -> PlainTextPassword6 -> Sem r (Bool, PasswordStatus)
verifyProviderPasswordImpl ProviderId
pid PlainTextPassword6
plaintext = do
  -- We type-erase uid here
  Password
password <-
    ProviderId -> Sem r (Maybe Password)
forall (r :: EffectRow).
Member PasswordStore r =>
ProviderId -> Sem r (Maybe Password)
PasswordStore.lookupHashedProviderPassword ProviderId
pid
      Sem r (Maybe Password)
-> (Maybe Password -> Sem r Password) -> Sem r Password
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r Password
-> (Password -> Sem r Password) -> Maybe Password -> Sem r Password
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthenticationSubsystemError -> Sem r Password
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemBadCredentials) Password -> Sem r Password
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  PlainTextPassword6 -> Password -> Sem r (Bool, PasswordStatus)
forall (r :: EffectRow).
PlainTextPassword6 -> Password -> Sem r (Bool, PasswordStatus)
verifyPasswordImpl PlainTextPassword6
plaintext Password
password

verifyUserPasswordImpl ::
  ( Member PasswordStore r,
    Member (Error AuthenticationSubsystemError) r
  ) =>
  UserId ->
  PlainTextPassword6 ->
  Sem r (Bool, PasswordStatus)
verifyUserPasswordImpl :: forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
UserId -> PlainTextPassword6 -> Sem r (Bool, PasswordStatus)
verifyUserPasswordImpl UserId
uid PlainTextPassword6
plaintext = do
  Password
password <-
    UserId -> Sem r (Maybe Password)
forall (r :: EffectRow).
Member PasswordStore r =>
UserId -> Sem r (Maybe Password)
PasswordStore.lookupHashedPassword UserId
uid
      Sem r (Maybe Password)
-> (Maybe Password -> Sem r Password) -> Sem r Password
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r Password
-> (Password -> Sem r Password) -> Maybe Password -> Sem r Password
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthenticationSubsystemError -> Sem r Password
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemBadCredentials) Password -> Sem r Password
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  PlainTextPassword6 -> Password -> Sem r (Bool, PasswordStatus)
forall (r :: EffectRow).
PlainTextPassword6 -> Password -> Sem r (Bool, PasswordStatus)
verifyPasswordImpl PlainTextPassword6
plaintext Password
password

verifyUserPasswordErrorImpl ::
  ( Member PasswordStore r,
    Member (Error AuthenticationSubsystemError) r
  ) =>
  Local UserId ->
  PlainTextPassword6 ->
  Sem r ()
verifyUserPasswordErrorImpl :: forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
Local UserId -> PlainTextPassword6 -> Sem r ()
verifyUserPasswordErrorImpl (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified -> UserId
uid) PlainTextPassword6
password = do
  Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((Bool, PasswordStatus) -> Bool
forall a b. (a, b) -> a
fst ((Bool, PasswordStatus) -> Bool)
-> Sem r (Bool, PasswordStatus) -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserId -> PlainTextPassword6 -> Sem r (Bool, PasswordStatus)
forall (r :: EffectRow).
(Member PasswordStore r,
 Member (Error AuthenticationSubsystemError) r) =>
UserId -> PlainTextPassword6 -> Sem r (Bool, PasswordStatus)
verifyUserPasswordImpl UserId
uid PlainTextPassword6
password) do
    AuthenticationSubsystemError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw AuthenticationSubsystemError
AuthenticationSubsystemBadCredentials