From 0b284ff787e1c7d0bda4be3eb9ceea97aa0e0cca Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 3 Mar 2026 14:59:49 +0100 Subject: [PATCH 1/5] wire-subsystems: Make mock for UserSubsystem depend on UserStore This way while testing other subsystems which may be writing to/reading from UserStore will remain consistent. This is only useful for AuthenticationSubsystem as of now. --- .../InterpreterSpec.hs | 225 +++++++++--------- .../InterpreterSpec.hs | 2 +- .../Wire/MockInterpreters/UserKeyStore.hs | 13 + .../unit/Wire/MockInterpreters/UserStore.hs | 6 + .../Wire/MockInterpreters/UserSubsystem.hs | 53 +++-- .../SAMLEmailSubsystem/InterpreterSpec.hs | 7 +- .../Wire/ScimSubsystem/InterpreterSpec.hs | 26 +- .../InterpreterSpec.hs | 72 ++++-- .../UserGroupSubsystem/InterpreterSpec.hs | 77 +++--- 9 files changed, 276 insertions(+), 205 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index df6c4ae3e7a..6c6d891d53d 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -23,6 +23,7 @@ import Data.Domain import Data.Id import Data.Misc import Data.Qualified +import Data.Range (rcast) import Data.Set qualified as Set import Data.Text.Encoding (decodeUtf8) import Data.Time @@ -38,9 +39,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.Allowlists (AllowlistEmailDomains (AllowlistEmailDomains)) -import Wire.API.Password as Password import Wire.API.User -import Wire.API.User qualified as User import Wire.API.User.Auth import Wire.API.User.Password import Wire.API.UserEvent @@ -57,6 +56,7 @@ import Wire.MockInterpreters import Wire.MockInterpreters.Events as Event import Wire.PasswordResetCodeStore import Wire.PasswordStore +import Wire.PasswordStore qualified as PasswordStore import Wire.RateLimit import Wire.Sem.Logger.TinyLog import Wire.Sem.Now (Now) @@ -65,9 +65,11 @@ import Wire.SessionStore import Wire.StoredUser import Wire.UserKeyStore import Wire.UserStore +import Wire.UserSubsystem (UserSubsystem) type AllEffects = [ AuthenticationSubsystem, + UserSubsystem, Events, Error AuthenticationSubsystemError, Error RateLimitExceeded, @@ -86,16 +88,16 @@ type AllEffects = TinyLog, EmailSubsystem, UserStore, + UserKeyStore, State [MiniEvent], - State [StoredUser], State (Map EmailAddress [SentMail]), State [StoredApp] ] -runAllEffects :: Domain -> [User] -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a +runAllEffects :: Domain -> [StoredUser] -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a runAllEffects domain users emailDomains action = snd $ runAllEffectsWithEventState domain users emailDomains action -runAllEffectsWithEventState :: Domain -> [User] -> Maybe [Text] -> Sem AllEffects a -> ([MiniEvent], Either AuthenticationSubsystemError a) +runAllEffectsWithEventState :: Domain -> [StoredUser] -> Maybe [Text] -> Sem AllEffects a -> ([MiniEvent], Either AuthenticationSubsystemError a) runAllEffectsWithEventState localDomain preexistingUsers mAllowedEmailDomains = let cfg = defaultAuthenticationSubsystemConfig @@ -103,11 +105,11 @@ runAllEffectsWithEventState localDomain preexistingUsers mAllowedEmailDomains = local = toLocalUnsafe localDomain () } in run - . evalState mempty . evalState mempty . evalState mempty . runState mempty - . inMemoryUserStoreInterpreter + . runInMemoryUserKeyStoreIntepreterWithStoredUsers preexistingUsers + . runInMemoryUserStoreInterpreter preexistingUsers . inMemoryEmailSubsystemInterpreter . discardTinyLogs . evalState mempty @@ -125,14 +127,12 @@ runAllEffectsWithEventState localDomain preexistingUsers mAllowedEmailDomains = . runErrorUnsafe . runError . miniEventInterpreter - . interpretAuthenticationSubsystem (userSubsystemTestInterpreter preexistingUsers) + . inMemoryUserSubsystemInterpreter + . interpretAuthenticationSubsystem inMemoryUserSubsystemInterpreter -verifyPasswordPure :: PlainTextPassword' t -> Password -> Bool -verifyPasswordPure plain hashed = - run - . noRateLimit - . staticHashPasswordInterpreter - $ verifyPassword (RateLimitIp (IpAddr "0.0.0.0")) plain hashed +toInputPassword :: PlainTextPassword8 -> PlainTextPassword6 +toInputPassword pw8 = + PlainTextPassword' . rcast $ fromPlainTextPassword' pw8 spec :: Spec spec = describe "AuthenticationSubsystem.Interpreter" do @@ -141,48 +141,51 @@ spec = describe "AuthenticationSubsystem.Interpreter" do \email userNoEmail (cookiesWithTTL :: [(Cookie (), Maybe TTL)]) mPreviousPassword newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (newPasswordHash, cookiesAfterReset) = - runAllEffects localDomain [user] Nothing $ do - forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) + uid = user.id + eithRes = + runAllEffects testDomain [user] Nothing $ do + forM_ mPreviousPassword (hashPassword >=> PasswordStore.upsertHashedPassword uid) mapM_ (uncurry (insertCookie uid)) cookiesWithTTL createPasswordResetCode (mkEmailKey email) (_, resetCode) <- expect1ResetPasswordEmail email resetPassword (PasswordResetEmailIdentity email) resetCode newPassword - - (,) <$> lookupHashedPassword uid <*> listCookies uid - in mPreviousPassword /= Just newPassword ==> - (fmap (verifyPasswordPure newPassword) newPasswordHash === Just True) - .&&. (cookiesAfterReset === []) + (,,) + <$> forM mPreviousPassword (verifyUserPassword uid . toInputPassword) + <*> verifyUserPassword uid (toInputPassword newPassword) + <*> listCookies uid + in case eithRes of + Left e -> counterexample ("Unexpected Error: " <> show e) False + Right (mOldPasswordVerification, newPasswordVerification, cookiesAfterReset) -> + (maybe (property True) (\(verification, _) -> verification === False) mOldPasswordVerification) + .&&. fst newPasswordVerification === True + .&&. (cookiesAfterReset === []) prop "password reset should work with the returned password reset key" $ \email userNoEmail (cookiesWithTTL :: [(Cookie (), Maybe TTL)]) mPreviousPassword newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (newPasswordHash, cookiesAfterReset) = - runAllEffects localDomain [user] Nothing $ do - forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) + uid = user.id + Right (newPasswordVerification, cookiesAfterReset) = + runAllEffects testDomain [user] Nothing $ do + forM_ mPreviousPassword (hashPassword >=> PasswordStore.upsertHashedPassword uid) mapM_ (uncurry (insertCookie uid)) cookiesWithTTL createPasswordResetCode (mkEmailKey email) (passwordResetKey, resetCode) <- expect1ResetPasswordEmail email resetPassword (PasswordResetIdentityKey passwordResetKey) resetCode newPassword - (,) <$> lookupHashedPassword uid <*> listCookies uid + (,) <$> verifyUserPassword uid (toInputPassword newPassword) <*> listCookies uid in mPreviousPassword /= Just newPassword ==> - (fmap (verifyPasswordPure newPassword) newPasswordHash === Just True) + (fst newPasswordVerification === True) .&&. (cookiesAfterReset === []) prop "reset code is not generated when email is not in allow list" $ @@ -198,13 +201,12 @@ spec = describe "AuthenticationSubsystem.Interpreter" do \email userNoEmail -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - localDomain = userNoEmail.userQualifiedId.qDomain createPasswordResetCodeResult = - runAllEffects localDomain [user] (Just [decodeUtf8 $ domainPart email]) $ + runAllEffects testDomain [user] (Just [decodeUtf8 $ domainPart email]) $ createPasswordResetCode (mkEmailKey email) in counterexample ("expected Right, got: " <> show createPasswordResetCodeResult) $ isRight createPasswordResetCodeResult @@ -213,15 +215,14 @@ spec = describe "AuthenticationSubsystem.Interpreter" do \email userNoEmail -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing + { email = Just email, + emailUnvalidated = Nothing } - localDomain = userNoEmail.userQualifiedId.qDomain createPasswordResetCodeResult = - runAllEffects localDomain [user] Nothing $ + runAllEffects testDomain [user] Nothing $ createPasswordResetCode (mkEmailKey email) <* expectNoEmailSent - in userStatus user /= Active ==> + in (user.status /= Just Active && user.status /= Nothing) ==> createPasswordResetCodeResult === Right () prop "reset code is not generated for when there is no user for the email" $ @@ -236,14 +237,13 @@ spec = describe "AuthenticationSubsystem.Interpreter" do \email userNoEmail newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (newPasswordHash, mCaughtException) = - runAllEffects localDomain [user] Nothing $ do + uid = user.id + Right (newPasswordVerification, mCaughtException) = + runAllEffects testDomain [user] Nothing $ do createPasswordResetCode (mkEmailKey email) (_, resetCode) <- expect1ResetPasswordEmail email @@ -252,83 +252,88 @@ spec = describe "AuthenticationSubsystem.Interpreter" do -- Reset password still works with previously generated reset code resetPassword (PasswordResetEmailIdentity email) resetCode newPassword - (,mCaughtExc) <$> lookupHashedPassword uid - in (fmap (verifyPasswordPure newPassword) newPasswordHash === Just True) + (,mCaughtExc) <$> verifyUserPassword uid (toInputPassword newPassword) + in (fst newPasswordVerification === True) .&&. (mCaughtException === Nothing) prop "reset code is not accepted after expiry" $ \email userNoEmail oldPassword newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (passwordInDB, resetPasswordResult) = - runAllEffects localDomain [user] Nothing $ do - upsertHashedPassword uid =<< hashPassword oldPassword + uid = user.id + Right (oldPasswordVerification, newPasswordVerification, resetPasswordResult) = + runAllEffects testDomain [user] Nothing $ do + PasswordStore.upsertHashedPassword uid =<< hashPassword oldPassword createPasswordResetCode (mkEmailKey email) (_, resetCode) <- expect1ResetPasswordEmail email passTime (passwordResetCodeTtl + 1) mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + (,,mCaughtExc) + <$> verifyUserPassword uid (toInputPassword oldPassword) + <*> verifyUserPassword uid (toInputPassword newPassword) in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode - .&&. verifyPasswordProp oldPassword passwordInDB + .&&. fst oldPasswordVerification === True + .&&. fst newPasswordVerification === False prop "password reset is not allowed with arbitrary codes when no other codes exist" $ \email userNoEmail resetCode oldPassword newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (passwordInDB, resetPasswordResult) = - runAllEffects localDomain [user] Nothing $ do - upsertHashedPassword uid =<< hashPassword oldPassword + uid = user.id + Right (oldPasswordVerification, newPasswordVerification, resetPasswordResult) = + runAllEffects testDomain [user] Nothing $ do + PasswordStore.upsertHashedPassword uid =<< hashPassword oldPassword mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + (,,mCaughtExc) + <$> verifyUserPassword uid (toInputPassword oldPassword) + <*> verifyUserPassword uid (toInputPassword newPassword) in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode - .&&. verifyPasswordProp oldPassword passwordInDB + .&&. fst oldPasswordVerification === True + .&&. fst newPasswordVerification === False prop "password reset doesn't work if email is wrong" $ \email wrongEmail userNoEmail resetCode oldPassword newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (passwordInDB, resetPasswordResult) = - runAllEffects localDomain [user] Nothing $ do + uid = user.id + Right (oldPasswordVerification, newPasswordVerification, resetPasswordResult) = + runAllEffects testDomain [user] Nothing $ do hashAndUpsertPassword uid oldPassword mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity wrongEmail) resetCode newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + (,,mCaughtExc) + <$> verifyUserPassword uid (toInputPassword oldPassword) + <*> verifyUserPassword uid (toInputPassword newPassword) in email /= wrongEmail ==> resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetKey - .&&. verifyPasswordProp oldPassword passwordInDB + .&&. fst oldPasswordVerification === True + .&&. fst newPasswordVerification === False prop "only 3 wrong password reset attempts are allowed" $ \email userNoEmail arbitraryResetCode oldPassword newPassword (Upto4 wrongResetAttempts) -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right (passwordHashInDB, correctResetCode, wrongResetErrors, resetPassworedWithCorectCodeResult) = - runAllEffects localDomain [user] Nothing $ do - upsertHashedPassword uid =<< hashPassword oldPassword + uid = user.id + Right (oldPasswordVerification, newPasswordVerification, correctResetCode, wrongResetErrors, resetPassworedWithCorectCodeResult) = + runAllEffects testDomain [user] Nothing $ do + PasswordStore.upsertHashedPassword uid =<< hashPassword oldPassword createPasswordResetCode (mkEmailKey email) (_, generatedResetCode) <- expect1ResetPasswordEmail email @@ -338,38 +343,39 @@ spec = describe "AuthenticationSubsystem.Interpreter" do resetPassword (PasswordResetEmailIdentity email) arbitraryResetCode newPassword mFinalResetErr <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) generatedResetCode newPassword - (,generatedResetCode,wrongResetErrs,mFinalResetErr) <$> lookupHashedPassword uid + (,,generatedResetCode,wrongResetErrs,mFinalResetErr) + <$> verifyUserPassword uid (toInputPassword oldPassword) + <*> verifyUserPassword uid (toInputPassword newPassword) expectedFinalResetResult = if wrongResetAttempts >= 3 then Just AuthenticationSubsystemInvalidPasswordResetCode else Nothing - expectedFinalPassword = + assertPasswordVerification = if wrongResetAttempts >= 3 - then oldPassword - else newPassword + then fst oldPasswordVerification === True .&&. fst newPasswordVerification === False + else fst oldPasswordVerification === False .&&. fst newPasswordVerification === True in correctResetCode /= arbitraryResetCode ==> wrongResetErrors == replicate wrongResetAttempts (Just AuthenticationSubsystemInvalidPasswordResetCode) .&&. resetPassworedWithCorectCodeResult === expectedFinalResetResult - .&&. verifyPasswordProp expectedFinalPassword passwordHashInDB + .&&. assertPasswordVerification describe "internalLookupPasswordResetCode" do prop "should find password reset code by email" $ \email userNoEmail newPassword -> let user = userNoEmail - { userIdentity = Just $ EmailIdentity email, - userEmailUnvalidated = Nothing, - userStatus = Active + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active } - uid = User.userId user - localDomain = userNoEmail.userQualifiedId.qDomain - Right passwordHashInDB = - runAllEffects localDomain [user] Nothing $ do + uid = user.id + Right newPasswordVerification = + runAllEffects testDomain [user] Nothing $ do void $ createPasswordResetCode (mkEmailKey email) mLookupRes <- internalLookupPasswordResetCode (mkEmailKey email) for_ mLookupRes $ \(_, resetCode) -> resetPassword (PasswordResetEmailIdentity email) resetCode newPassword - lookupHashedPassword uid - in verifyPasswordProp newPassword passwordHashInDB + verifyUserPassword uid (toInputPassword newPassword) + in fst newPasswordVerification === True describe "newCookie" $ do prop "trivial attributes: plain user cookie" $ \localDomain uid cid typ mLabel -> @@ -477,11 +483,6 @@ newtype Upto4 = Upto4 Int instance Arbitrary Upto4 where arbitrary = Upto4 <$> elements [0 .. 4] -verifyPasswordProp :: PlainTextPassword8 -> Maybe Password -> Property -verifyPasswordProp plainTextPassword passwordHash = - counterexample ("Password doesn't match, plainText=" <> show plainTextPassword <> ", passwordHash=" <> show passwordHash) $ - fmap (verifyPasswordPure plainTextPassword) passwordHash == Just True - hashAndUpsertPassword :: (Member PasswordStore r) => UserId -> PlainTextPassword8 -> Sem r () hashAndUpsertPassword uid password = upsertHashedPassword uid =<< hashPassword password diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index 359372c7ef7..cbc6c4d563e 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -68,7 +68,7 @@ runDependencies :: Either EnterpriseLoginSubsystemError a runDependencies = run - . userSubsystemTestInterpreter [] + . runInMemoryUserSubsytemInterpreter mempty . (evalState mempty . inMemoryUserKeyStoreInterpreter . raiseUnder) . fakeRpc . runRandomPure diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs index eef306b861b..10f25b16367 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs @@ -19,11 +19,24 @@ module Wire.MockInterpreters.UserKeyStore where import Data.Id import Data.Map qualified as M +import Data.Map qualified as Map import Imports import Polysemy import Polysemy.State +import Wire.StoredUser import Wire.UserKeyStore +runInMemoryUserKeyStoreIntepreterWithStoredUsers :: [StoredUser] -> InterpreterFor UserKeyStore r +runInMemoryUserKeyStoreIntepreterWithStoredUsers initialUsers = + let emailKeys = Map.fromList $ mapMaybe (\u -> (,u.id) . mkEmailKey <$> u.email) initialUsers + in runInMemoryUserKeyStoreIntepreter emailKeys + +runInMemoryUserKeyStoreIntepreter :: Map EmailKey UserId -> InterpreterFor UserKeyStore r +runInMemoryUserKeyStoreIntepreter keys = + evalState keys + . inMemoryUserKeyStoreInterpreter + . raiseUnder + inMemoryUserKeyStoreInterpreter :: (Member (State (Map EmailKey UserId)) r) => InterpreterFor UserKeyStore r diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index ae743e865be..e82a6afc355 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -34,6 +34,12 @@ import Wire.StoredUser import Wire.UserStore import Wire.UserStore.IndexUser +runInMemoryUserStoreInterpreter :: [StoredUser] -> InterpreterFor UserStore r +runInMemoryUserStoreInterpreter initialUsers = + evalState initialUsers + . inMemoryUserStoreInterpreter + . raiseUnder + inMemoryUserStoreInterpreter :: forall r. (Member (State [StoredUser]) r) => diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index d2d1855cc3c..9b7abed4f16 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -17,35 +17,56 @@ module Wire.MockInterpreters.UserSubsystem where +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Domain +import Data.LanguageCodes import Data.LegalHold import Data.Qualified import Imports import Polysemy import Wire.API.User +import Wire.MockInterpreters.UserKeyStore +import Wire.MockInterpreters.UserStore +import Wire.StoredUser +import Wire.UserKeyStore (UserKeyStore) +import Wire.UserKeyStore qualified as UserKeyStore +import Wire.UserStore (UserStore) +import Wire.UserStore qualified as UserStore import Wire.UserSubsystem -userSubsystemTestInterpreter :: [User] -> InterpreterFor UserSubsystem r -userSubsystemTestInterpreter initialUsers = +runInMemoryUserSubsytemInterpreter :: [StoredUser] -> InterpreterFor UserSubsystem r +runInMemoryUserSubsytemInterpreter initialUsers = + runInMemoryUserStoreInterpreter initialUsers + . runInMemoryUserKeyStoreIntepreterWithStoredUsers initialUsers + . inMemoryUserSubsystemInterpreter + . raiseUnder + . raiseUnder + +testDomain :: Domain +testDomain = Domain "test.example" + +testLocale :: Locale +testLocale = Locale (Language EN) Nothing + +inMemoryUserSubsystemInterpreter :: (Member UserStore r, Member UserKeyStore r) => InterpreterFor UserSubsystem r +inMemoryUserSubsystemInterpreter = interpret \case - GetAccountsByEmailNoFilter (tUnqualified -> emails) -> - pure $ - filter - (\u -> userEmail u `elem` (Just <$> emails)) - initialUsers - GetUserTeam uid -> pure $ do - user <- find (\u -> userId u == uid) initialUsers - user.userTeam - GetSelfProfile uid -> - pure . fmap SelfProfile $ - find (\u -> qUnqualified u.userQualifiedId == tUnqualified uid) initialUsers + GetAccountsByEmailNoFilter (tUnqualified -> emails) -> do + uids <- catMaybes <$> traverse (UserKeyStore.lookupKey . UserKeyStore.mkEmailKey) emails + storedUsers <- UserStore.getUsers uids + pure $ mkUserFromStored testDomain testLocale <$> storedUsers + GetUserTeam uid -> runMaybeT do + user <- MaybeT $ UserStore.getUser uid + MaybeT $ pure user.teamId + GetSelfProfile uid -> do + SelfProfile . mkUserFromStored testDomain testLocale <$$> UserStore.getUser (tUnqualified uid) IsBlocked _ -> pure False GetUserProfiles _ _ -> error "GetUserProfiles: implement on demand (userSubsystemInterpreter)" GetUserProfilesWithErrors _ _ -> error "GetUserProfilesWithErrors: implement on demand (userSubsystemInterpreter)" GetLocalUserProfiles luids -> - let uids = qUnqualified $ tUntagged luids - in pure (toProfile <$> filter (\u -> userId u `elem` uids) initialUsers) + toProfile . mkUserFromStored testDomain testLocale <$$> UserStore.getUsers (tUnqualified luids) GetAccountsBy (tUnqualified -> GetBy NoPendingInvitations True True uids []) -> - pure (filter (\u -> userId u `elem` uids) initialUsers) + mkUserFromStored testDomain testLocale <$$> UserStore.getUsers uids GetAccountsBy _ -> error "GetAccountsBy: implement on demand (userSubsystemInterpreter)" UpdateUserProfile {} -> error "UpdateUserProfile: implement on demand (userSubsystemInterpreter)" CheckHandle _ -> error "CheckHandle: implement on demand (userSubsystemInterpreter)" diff --git a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs index 14d8a94ef3c..31ebb431d53 100644 --- a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs @@ -24,6 +24,7 @@ import Test.QuickCheck import Text.Email.Parser (unsafeEmailAddress) import URI.ByteString import Wire.API.Locale +import Wire.API.Password import Wire.API.Routes.Internal.Brig (IdpChangedNotification (..)) import Wire.API.Team.Member import Wire.API.Team.Permission (fullPermissions) @@ -341,6 +342,7 @@ runInterpreters :: Email.EmailSubsystem, UserStore, State [StoredUser], + State (Map UserId Password), GalleyAPIAccess, Logger (Logger.Msg -> Logger.Msg), EmailSending, @@ -351,13 +353,14 @@ runInterpreters :: IO ([Mail], [(Level, LByteString)], a) runInterpreters users teamMap teamTemplates branding action = do lr <- newLogRecorder - (mails, (_userState, res)) <- + (mails, res) <- runM . runState @[Mail] [] -- Use runState to capture and return the Mail state . recordingEmailSendingInterpreter . recordLogs lr . miniGalleyAPIAccess teamMap def - . runState @[StoredUser] users + . evalState @(Map UserId Password) mempty + . evalState @[StoredUser] users . inMemoryUserStoreInterpreter . emailSubsystemInterpreter undefined teamTemplates branding . interpretTeamSubsystemToGalleyAPI diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index b33de25637f..3cdf8408a41 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -42,8 +42,10 @@ import Wire.API.User as User import Wire.API.User.Scim import Wire.API.UserGroup import Wire.BrigAPIAccess (BrigAPIAccess (..)) +import Wire.MockInterpreters import Wire.ScimSubsystem import Wire.ScimSubsystem.Interpreter +import Wire.StoredUser import Wire.UserGroupSubsystem qualified as UGS import Wire.UserGroupSubsystem.Interpreter qualified as UGS import Wire.UserGroupSubsystem.InterpreterSpec qualified as UGS @@ -60,17 +62,17 @@ type AllDependencies = runDependencies :: forall a. (HasCallStack) => - [User] -> + [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> Either ScimSubsystemError a runDependencies initialUsers initialTeams = - either (error . show) id . runDependenciesSafe initialUsers initialTeams + either (error . show) Imports.id . runDependenciesSafe initialUsers initialTeams runDependenciesSafe :: forall a. (HasCallStack) => - [User] -> + [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> Either UGS.UserGroupSubsystemError (Either ScimSubsystemError a) @@ -88,12 +90,12 @@ runDependenciesSafe initialUsers initialTeams = scimBaseUri = Common.URI . fromJust . parseURI $ "http://nowhere.net/scim/v2" -- Mock BrigAPIAccess interpreter for tests - mockBrigAPIAccess :: (Member UGS.UserGroupSubsystem r) => [User] -> InterpreterFor BrigAPIAccess r + mockBrigAPIAccess :: (Member UGS.UserGroupSubsystem r) => [StoredUser] -> InterpreterFor BrigAPIAccess r mockBrigAPIAccess users = interpret $ \case CreateGroupInternal managedBy teamId creatorUserId newGroup -> do Right <$> UGS.createGroupInternal managedBy teamId creatorUserId newGroup GetAccountsBy getBy -> do - pure $ filter (\u -> User.userId u `elem` getBy.getByUserId) users + pure . map (mkUserFromStored testDomain testLocale) $ filter (\u -> u.id `elem` getBy.getByUserId) users GetGroupInternal tid gid False -> do UGS.getGroupInternal tid gid False DeleteGroupInternal managedBy teamId groupId -> @@ -110,8 +112,8 @@ instance Arbitrary Group.Group where members = [] } -mkScimGroupMember :: User -> Group.Member -mkScimGroupMember (idToText . User.userId -> value) = +mkScimGroupMember :: StoredUser -> Group.Member +mkScimGroupMember (idToText . (.id) -> value) = let typ = "User" ref = "$schema://$host.$domain/scim/vs/Users/$uuid" -- not a real URI, just a string for testing. in Group.Member {..} @@ -123,7 +125,7 @@ spec = UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do let newScimGroup = newScimGroup_ { Group.members = - let scimMembers = filter (\u -> u.userManagedBy == ManagedByScim) (UGS.allUsers team) + let scimMembers = filter (\u -> u.managedBy == Just ManagedByScim) (UGS.allUsers team) in mkScimGroupMember <$> scimMembers } resultOrError = do @@ -161,18 +163,18 @@ spec = UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do scimCreateUserGroup team.tid newScimGroup want = - if all (\u -> u.userManagedBy == ManagedByScim) groupMembers + if all (\u -> u.managedBy == Just ManagedByScim) groupMembers then isRight else isLeft unless (want have) do - expectationFailure . show $ ((.userManagedBy) <$> UGS.allUsers team) + expectationFailure . show $ ((.managedBy) <$> UGS.allUsers team) describe "scimDeleteUserGroup" $ do prop "deletes a SCIM-managed group" $ \(team :: UGS.ArbitraryTeam) (newScimGroup_ :: Group.Group) -> let newScimGroup = newScimGroup_ { Group.members = - let scimUsers = filter (\u -> u.userManagedBy == ManagedByScim) (UGS.allUsers team) + let scimUsers = filter (\u -> u.managedBy == Just ManagedByScim) (UGS.allUsers team) in mkScimGroupMember <$> scimUsers } resultOrError = do @@ -190,7 +192,7 @@ spec = UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do it "fails to delete non-SCIM-managed groups" $ do team :: UGS.ArbitraryTeam <- generate arbitrary - let ugName = either (error . show) id $ userGroupNameFromText "test-group" + let ugName = either (error . show) Imports.id $ userGroupNameFromText "test-group" let newGroup = NewUserGroup {name = ugName, members = mempty} let have = runDependenciesSafe (UGS.allUsers team) (UGS.galleyTeam team) $ do diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 67bbbba7b54..7797e90926d 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -50,12 +50,14 @@ import Wire.MockInterpreters import Wire.Sem.Logger.TinyLog import Wire.Sem.Now (Now) import Wire.Sem.Random +import Wire.StoredUser import Wire.TeamInvitationSubsystem import Wire.TeamInvitationSubsystem.Error import Wire.TeamInvitationSubsystem.Interpreter import Wire.TeamSubsystem import Wire.TeamSubsystem.GalleyAPI import Wire.UserKeyStore +import Wire.UserStore (UserStore) import Wire.UserSubsystem import Wire.Util @@ -75,12 +77,14 @@ type AllEffects = State UTCTime, EmailSubsystem, State (Map EmailAddress [SentMail]), - UserSubsystem + UserSubsystem, + UserStore, + UserKeyStore ] data RunAllEffectsArgs = RunAllEffectsArgs { teams :: Map TeamId [TeamMember], - initialUsers :: [User], + initialUsers :: [StoredUser], constGuardResult :: Maybe DomainRegistration } deriving (Eq, Show) @@ -88,7 +92,9 @@ data RunAllEffectsArgs = RunAllEffectsArgs runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationSubsystemError a runAllEffects args = run - . userSubsystemTestInterpreter args.initialUsers + . runInMemoryUserKeyStoreIntepreterWithStoredUsers args.initialUsers + . runInMemoryUserStoreInterpreter args.initialUsers + . inMemoryUserSubsystemInterpreter . evalState mempty . noopEmailSubsystemInterpreter . evalState defaultTime @@ -111,30 +117,38 @@ spec = do prop "honors dommain config from `brig.domain_registration`" $ \(tid :: TeamId) (preDomRegUpd :: DomainRegistrationUpdate) - (preInviter :: User) + (preInviter :: StoredUser) (inviterEmail :: EmailAddress) (inviteeEmail :: EmailAddress) - (preExistingPersonalAccount :: Maybe User) + (preExistingPersonalAccount :: Maybe StoredUser) (preRegisteredDomain {- if Nothing, use invitee's email domain -} :: Maybe Domain) (sameTeam {- team id matches the team id in the domain registration -} :: Bool) -> let -- prepare the pre* prop args -- - domRegUpd = preDomRegUpd & if sameTeam then setTeamId else id + domRegUpd = preDomRegUpd & if sameTeam then setTeamId else Imports.id where setTeamId upd = case upd.teamInvite of Team _ -> DomainRegistrationUpdate upd.domainRedirect (Team tid) _ -> upd - inviter = preInviter {userIdentity = Just $ EmailIdentity inviterEmail} + inviter = + preInviter + { email = Just inviterEmail, + activated = True, + status = Just Active + } :: + StoredUser existingPersonalAccount = preExistingPersonalAccount <&> \r -> r - { userIdentity = Just $ EmailIdentity inviteeEmail, - userStatus = Active, - userTeam = Nothing, - userManagedBy = ManagedByWire - } + { email = Just inviteeEmail, + activated = True, + status = Just Active, + teamId = Nothing, + managedBy = Just ManagedByWire + } :: + StoredUser registeredDomain :: Domain registeredDomain = fromMaybe edom preRegisteredDomain @@ -150,8 +164,8 @@ spec = do blockedDomains = HashSet.empty } - inviterUid = qUnqualified inviter.userQualifiedId - inviterLuid = let domain = qDomain inviter.userQualifiedId in toLocalUnsafe domain inviterUid + inviterUid = inviter.id + inviterLuid = toLocalUnsafe testDomain inviterUid inviterMember = mkTeamMember inviterUid fullPermissions Nothing UserLegalHoldDisabled invReq = @@ -211,14 +225,23 @@ spec = do prop "try to invite to blocked domain" $ \(tid :: TeamId) - (preExistingPersonalAccount :: Maybe User) + -- (domain :: Domain) + (preExistingPersonalAccount :: Maybe StoredUser) (preExistingInviteeEmail :: EmailAddress) + (inviterNoEmail :: StoredUser) + (inviterEmail :: EmailAddress) (emailUsername :: EmailUsername) (blockedDomains :: NonEmptyList Domain) -> do - let hasEmailIdentity user = isJust $ emailIdentity =<< userIdentity user + let inviter = + inviterNoEmail + { email = Just inviterEmail, + status = Just Active, + activated = True + } :: + StoredUser blockedEmailDomain <- anyElementOf blockedDomains - inviter <- arbitrary @User `suchThat` hasEmailIdentity + -- inviter <- arbitrary @StoredUser `suchThat` hasEmailIdentity let blockedEmailAddress :: EmailAddress = unsafeEmailAddress @@ -241,18 +264,19 @@ spec = do blockedDomains = (HashSet.fromList . getNonEmpty) blockedDomains } - inviterUid = qUnqualified inviter.userQualifiedId - inviterLuid = let domain = qDomain inviter.userQualifiedId in toLocalUnsafe domain inviterUid + inviterUid = inviter.id + inviterLuid = toLocalUnsafe testDomain inviterUid inviterMember = mkTeamMember inviterUid fullPermissions Nothing UserLegalHoldDisabled existingPersonalAccount = preExistingPersonalAccount <&> \r -> r - { userIdentity = Just $ EmailIdentity preExistingInviteeEmail, - userStatus = Active, - userTeam = Nothing, - userManagedBy = ManagedByWire - } + { email = Just preExistingInviteeEmail, + status = Just Active, + teamId = Nothing, + managedBy = Just ManagedByWire + } :: + StoredUser interpreterArgs = RunAllEffectsArgs diff --git a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs index 019cd848e36..c0a62401d1e 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs @@ -61,6 +61,7 @@ import Wire.MockInterpreters as Mock import Wire.NotificationSubsystem import Wire.Sem.Random qualified as Random import Wire.Sem.Random.Null qualified as Random +import Wire.StoredUser import Wire.TeamSubsystem import Wire.TeamSubsystem.GalleyAPI import Wire.UserGroupSubsystem @@ -82,11 +83,11 @@ type AllDependencies = Error UserGroupSubsystemError ] -runDependenciesFailOnError :: (HasCallStack) => [User] -> Map TeamId [TeamMember] -> Sem AllDependencies (IO ()) -> IO () -runDependenciesFailOnError usrs team = either (error . ("no assertion: " <>) . show) id . runDependencies usrs team +runDependenciesFailOnError :: (HasCallStack) => [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies (IO ()) -> IO () +runDependenciesFailOnError usrs team = either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team runDependencies :: - [User] -> + [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> Either UserGroupSubsystemError a @@ -95,7 +96,7 @@ runDependencies initialUsers initialTeams = interpretDependencies :: forall r a. - [User] -> + [StoredUser] -> Map TeamId [TeamMember] -> Sem (AllDependencies `Append` r) a -> Sem ('[Error UserGroupSubsystemError] `Append` r) a @@ -109,10 +110,10 @@ interpretDependencies initialUsers initialTeams = . runInMemoryUserGroupStore def . miniGalleyAPIAccess initialTeams def . interpretTeamSubsystemToGalleyAPI - . userSubsystemTestInterpreter initialUsers + . runInMemoryUserSubsytemInterpreter initialUsers runDependenciesWithReturnState :: - [User] -> + [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> Either UserGroupSubsystemError ([Push], a) @@ -128,7 +129,7 @@ runDependenciesWithReturnState initialUsers initialTeams = . runInMemoryUserGroupStore def . miniGalleyAPIAccess initialTeams def . interpretTeamSubsystemToGalleyAPI - . userSubsystemTestInterpreter initialUsers + . runInMemoryUserSubsytemInterpreter initialUsers expectRight :: (Show err) => Either err Property -> Property expectRight = \case @@ -164,7 +165,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do runDependenciesWithReturnState (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do - let newUserGroup' = (newUserGroup newUserGroupName) {members = User.userId <$> V.fromList members} :: NewUserGroup + let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList members} :: NewUserGroup createdGroup <- createGroup (ownerId team) newUserGroup' retrievedGroup <- getGroup (ownerId team) createdGroup.id_ False now <- toUTCTimeMillis <$> get @@ -234,19 +235,19 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do - let newUserGroup' = (newUserGroup newUserGroupName) {members = User.userId <$> V.fromList (allUsers team)} :: NewUserGroup + let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList (allUsers team)} :: NewUserGroup [nonAdminUser] = someAdminsOrOwners 1 team - void $ createGroup (User.userId nonAdminUser) newUserGroup' + void $ createGroup (nonAdminUser.id) newUserGroup' unexpected prop "only team members are allowed in the group" $ \team otherUsers newUserGroupName -> - let othersWithoutTeamMembers = filter (\u -> u.userTeam /= Just team.tid) otherUsers + let othersWithoutTeamMembers = filter (\u -> u.teamId /= Just team.tid) otherUsers in notNull othersWithoutTeamMembers ==> expectLeft UserGroupMemberIsNotInTheSameTeam . runDependencies (allUsers team <> otherUsers) (galleyTeam team) . interpretUserGroupSubsystem $ do - let newUserGroup' = (newUserGroup newUserGroupName) {members = User.userId <$> V.fromList otherUsers} :: NewUserGroup + let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList otherUsers} :: NewUserGroup void $ createGroup (ownerId team) newUserGroup' unexpected @@ -325,7 +326,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do it "getGroups: q=, returning 0, 1, 2 groups" $ do WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam <- generate arbitrary runDependenciesFailOnError (allUsers team1) (galleyTeam team1) . interpretUserGroupSubsystem $ do - let newGroups = [newUserGroup (either undefined id $ userGroupNameFromText name) | name <- ["1", "2", "2", "33"]] + let newGroups = [newUserGroup (either undefined Imports.id $ userGroupNameFromText name) | name <- ["1", "2", "2", "33"]] groups <- (\ng -> passTime 1 >> createGroup (ownerId team1) ng) `mapM` newGroups get0 <- getGroups (ownerId team1) def {searchString = Just "nope"} @@ -347,7 +348,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do . runDependencies (allUsers team1) (galleyTeam team1) . interpretUserGroupSubsystem $ do - let mkNewGroup = newUserGroup (either undefined id $ userGroupNameFromText "same name") + let mkNewGroup = newUserGroup (either undefined Imports.id $ userGroupNameFromText "same name") mkGroup = passTime 1 >> createGroup (ownerId team1) mkNewGroup -- groups are only distinguished by creation date @@ -435,7 +436,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do it "getGroups (ordering)" $ do WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam <- generate arbitrary runDependenciesFailOnError (allUsers team1) (galleyTeam team1) . interpretUserGroupSubsystem $ do - let mkGroup name = createGroup (ownerId team1) (newUserGroup $ either undefined id $ userGroupNameFromText name) + let mkGroup name = createGroup (ownerId team1) (newUserGroup $ either undefined Imports.id $ userGroupNameFromText name) -- construct groups such that there are groups with same name and different creation -- date and vice versa. create names in random order (not alpha). the digits are @@ -538,10 +539,10 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do - let newUserGroup' = (newUserGroup newUserGroupName) {members = User.userId <$> V.fromList (allUsers team)} :: NewUserGroup + let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList (allUsers team)} :: NewUserGroup [nonAdminUser] = someAdminsOrOwners 1 team grp <- createGroup (ownerId team) newUserGroup' - void $ updateGroup (User.userId nonAdminUser) grp.id_ (UserGroupUpdate newUserGroupName2) + void $ updateGroup nonAdminUser.id grp.id_ (UserGroupUpdate newUserGroupName2) unexpected describe "DeleteGroup :: UserId -> UserGroupId -> UserGroupSubsystem m ()" $ do @@ -608,7 +609,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do $ do grp <- createGroup (ownerId team) (newUserGroup groupName) let [nonAdminUser] = someAdminsOrOwners 1 team - void $ deleteGroup (User.userId nonAdminUser) grp.id_ + void $ deleteGroup nonAdminUser.id grp.id_ unexpected describe "AddUser, RemoveUser :: UserId -> UserGroupId -> UserId -> UserGroupSubsystem m ()" $ do @@ -621,23 +622,23 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do $ do ug :: UserGroup <- createGroup (ownerId team) (newUserGroup newGroupName) - addUser (ownerId team) ug.id_ (User.userId mbr1) + addUser (ownerId team) ug.id_ mbr1.id ugWithFirst <- getGroup (ownerId team) ug.id_ False - addUser (ownerId team) ug.id_ (User.userId mbr1) + addUser (ownerId team) ug.id_ mbr1.id ugWithIdemP <- getGroup (ownerId team) ug.id_ False - addUser (ownerId team) ug.id_ (User.userId mbr2) + addUser (ownerId team) ug.id_ mbr2.id ugWithSecond <- getGroup (ownerId team) ug.id_ False - removeUser (ownerId team) ug.id_ (User.userId mbr1) + removeUser (ownerId team) ug.id_ mbr1.id ugWithoutFirst <- getGroup (ownerId team) ug.id_ False - removeUser (ownerId team) ug.id_ (User.userId mbr1) -- idemp + removeUser (ownerId team) ug.id_ mbr1.id -- idemp let propertyCheck = - ((.members) <$> ugWithFirst) === Just (Identity $ V.fromList [User.userId mbr1]) - .&&. ((.members) <$> ugWithIdemP) === Just (Identity $ V.fromList [User.userId mbr1]) - .&&. ((sort . V.toList . runIdentity . (.members)) <$> ugWithSecond) === Just (sort [User.userId mbr1, User.userId mbr2]) - .&&. ((.members) <$> ugWithoutFirst) === Just (Identity $ V.fromList [User.userId mbr2]) + ((.members) <$> ugWithFirst) === Just (Identity $ V.fromList [mbr1.id]) + .&&. ((.members) <$> ugWithIdemP) === Just (Identity $ V.fromList [mbr1.id]) + .&&. ((sort . V.toList . runIdentity . (.members)) <$> ugWithSecond) === Just (sort [mbr1.id, mbr2.id]) + .&&. ((.members) <$> ugWithoutFirst) === Just (Identity $ V.fromList [mbr2.id]) pure (ug, propertyCheck) assertUpdateEvent :: UserGroup -> Push -> Property @@ -646,7 +647,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do push.origin === Just (ownerId team) .&&. ugid === ug.id_ .&&. Set.fromList push.recipients - === Set.fromList [Recipient {recipientUserId = User.userId user, recipientClients = RecipientClientsAll} | user <- allAdmins team] + === Set.fromList [Recipient {recipientUserId = user.id, recipientClients = RecipientClientsAll} | user <- allAdmins team] _ -> counterexample ("Failed to decode push: " <> show push) False in case resultOrError of Left err -> counterexample ("Unexpected error: " <> show err) False @@ -728,24 +729,24 @@ instance (ArbitraryWithMods mods a) => Arbitrary (WithMods mods a) where data ArbitraryTeam = ArbitraryTeam { tid :: TeamId, - owner :: (User, TeamMember), - members :: [(User, TeamMember)] + owner :: (StoredUser, TeamMember), + members :: [(StoredUser, TeamMember)] } deriving (Show, Eq) instance Arbitrary ArbitraryTeam where arbitrary = do tid <- arbitrary - let assignTeam u = u {userTeam = Just tid} + let assignTeam u = u {teamId = Just tid} :: StoredUser adminUser <- assignTeam <$> arbitrary adminMember <- arbitrary @TeamMember <&> (permissions .~ rolePermissions RoleOwner) - <&> (TM.userId .~ User.userId adminUser) + <&> (TM.userId .~ adminUser.id) otherUsers <- listOf' arbitrary otherUserWithMembers <- for otherUsers $ \u -> do mem <- arbitrary - pure (u, mem & TM.userId .~ User.userId u) + pure (u, mem & TM.userId .~ u.id) pure . ArbitraryTeam tid (adminUser, adminMember) $ map (first assignTeam) otherUserWithMembers shrink team = @@ -755,13 +756,13 @@ instance Arbitrary ArbitraryTeam where let lessMembers = take (length team.members `div` 2) team.members in [team {members = lessMembers}] -allUsers :: ArbitraryTeam -> [User] +allUsers :: ArbitraryTeam -> [StoredUser] allUsers t = fst <$> t.owner : t.members ownerId :: ArbitraryTeam -> UserId -ownerId t = User.userId (fst t.owner) +ownerId t = (fst t.owner).id -allAdmins :: ArbitraryTeam -> [User] +allAdmins :: ArbitraryTeam -> [StoredUser] allAdmins t = fst <$> filter (isAdminOrOwner . (^. permissions) . snd) (t.owner : t.members) -- | The Map is required by the mock GalleyAPIAccess @@ -771,10 +772,10 @@ galleyTeam t = galleyTeamWithExtra t [] galleyTeamWithExtra :: ArbitraryTeam -> [TeamMember] -> Map TeamId [TeamMember] galleyTeamWithExtra t tm = Map.singleton t.tid $ tm <> map snd (t.owner : t.members) -someAdminsOrOwners :: Int -> ArbitraryTeam -> [User] +someAdminsOrOwners :: Int -> ArbitraryTeam -> [StoredUser] someAdminsOrOwners num team = someMembersWithRoles num team (Just [RoleMember, RoleExternalPartner]) -someMembersWithRoles :: (HasCallStack) => Int -> ArbitraryTeam -> Maybe [Role] -> [User] +someMembersWithRoles :: (HasCallStack) => Int -> ArbitraryTeam -> Maybe [Role] -> [StoredUser] someMembersWithRoles num team mbRoles = result where result = From 03ccb7f21734967bdfdfd47385ca9ae691b1c154 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 4 Mar 2026 09:39:23 +0100 Subject: [PATCH 2/5] typo: Subsytem -> Subsystem --- libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs | 3 +-- .../unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs | 2 +- .../test/unit/Wire/MockInterpreters/UserSubsystem.hs | 4 ++-- .../test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs | 4 ++-- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 0654caed4f7..1d044ab5f2e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -96,7 +96,6 @@ import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -import Wire.TeamSubsystem qualified as TeamSubsytem import Wire.UserList data NoChanges = NoChanges @@ -162,7 +161,7 @@ ensureConnectedToLocalsOrSameTeam (tUnqualified -> u) uids = do icUsers <- getTeamCollaborators uTeams -- We collect all the relevant uids from same teams as the origin user sameTeamUids <- forM (uTeams `union` icTeams) $ \team -> - fmap (view Mem.userId) <$> TeamSubsytem.internalSelectTeamMembers team uids + fmap (view Mem.userId) <$> TeamSubsystem.internalSelectTeamMembers team uids -- Do not check connections for users that are on the same team ensureConnectedToLocals u ((uids \\ join sameTeamUids) \\ icUsers) where diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index cbc6c4d563e..88874f171bd 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -68,7 +68,7 @@ runDependencies :: Either EnterpriseLoginSubsystemError a runDependencies = run - . runInMemoryUserSubsytemInterpreter mempty + . runInMemoryUserSubsystemInterpreter mempty . (evalState mempty . inMemoryUserKeyStoreInterpreter . raiseUnder) . fakeRpc . runRandomPure diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 9b7abed4f16..bc31cfbb65a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -34,8 +34,8 @@ import Wire.UserStore (UserStore) import Wire.UserStore qualified as UserStore import Wire.UserSubsystem -runInMemoryUserSubsytemInterpreter :: [StoredUser] -> InterpreterFor UserSubsystem r -runInMemoryUserSubsytemInterpreter initialUsers = +runInMemoryUserSubsystemInterpreter :: [StoredUser] -> InterpreterFor UserSubsystem r +runInMemoryUserSubsystemInterpreter initialUsers = runInMemoryUserStoreInterpreter initialUsers . runInMemoryUserKeyStoreIntepreterWithStoredUsers initialUsers . inMemoryUserSubsystemInterpreter diff --git a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs index c0a62401d1e..5bedfca85cf 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs @@ -110,7 +110,7 @@ interpretDependencies initialUsers initialTeams = . runInMemoryUserGroupStore def . miniGalleyAPIAccess initialTeams def . interpretTeamSubsystemToGalleyAPI - . runInMemoryUserSubsytemInterpreter initialUsers + . runInMemoryUserSubsystemInterpreter initialUsers runDependenciesWithReturnState :: [StoredUser] -> @@ -129,7 +129,7 @@ runDependenciesWithReturnState initialUsers initialTeams = . runInMemoryUserGroupStore def . miniGalleyAPIAccess initialTeams def . interpretTeamSubsystemToGalleyAPI - . runInMemoryUserSubsytemInterpreter initialUsers + . runInMemoryUserSubsystemInterpreter initialUsers expectRight :: (Show err) => Either err Property -> Property expectRight = \case From 303084649c54f20dfcdbb258956a4bf915881abe Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 4 Mar 2026 09:41:56 +0100 Subject: [PATCH 3/5] AuthenticationSubsystem.InterpreterSpec: Remove UserSubsystem from test effect stack --- .../test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 6c6d891d53d..d38eacc2574 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -65,11 +65,9 @@ import Wire.SessionStore import Wire.StoredUser import Wire.UserKeyStore import Wire.UserStore -import Wire.UserSubsystem (UserSubsystem) type AllEffects = [ AuthenticationSubsystem, - UserSubsystem, Events, Error AuthenticationSubsystemError, Error RateLimitExceeded, @@ -127,7 +125,6 @@ runAllEffectsWithEventState localDomain preexistingUsers mAllowedEmailDomains = . runErrorUnsafe . runError . miniEventInterpreter - . inMemoryUserSubsystemInterpreter . interpretAuthenticationSubsystem inMemoryUserSubsystemInterpreter toInputPassword :: PlainTextPassword8 -> PlainTextPassword6 From 76f18f7574f8d28bcc877ce04bc52727c03f5072 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 4 Mar 2026 09:42:22 +0100 Subject: [PATCH 4/5] Delete stray comments --- .../test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 7797e90926d..219a324ba87 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -225,7 +225,6 @@ spec = do prop "try to invite to blocked domain" $ \(tid :: TeamId) - -- (domain :: Domain) (preExistingPersonalAccount :: Maybe StoredUser) (preExistingInviteeEmail :: EmailAddress) (inviterNoEmail :: StoredUser) @@ -241,7 +240,6 @@ spec = do StoredUser blockedEmailDomain <- anyElementOf blockedDomains - -- inviter <- arbitrary @StoredUser `suchThat` hasEmailIdentity let blockedEmailAddress :: EmailAddress = unsafeEmailAddress From bea3e6bdb725f39134e12afe3dd3c193be66c4e2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 4 Mar 2026 09:44:13 +0100 Subject: [PATCH 5/5] hlint --- .../test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index d38eacc2574..155225bff29 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -219,7 +219,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do runAllEffects testDomain [user] Nothing $ createPasswordResetCode (mkEmailKey email) <* expectNoEmailSent - in (user.status /= Just Active && user.status /= Nothing) ==> + in (isJust user.status && user.status /= Just Active) ==> createPasswordResetCodeResult === Right () prop "reset code is not generated for when there is no user for the email" $