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