From 0211289ae82ce8657fcdf19b15e7cde53f382e64 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 21 May 2024 17:24:42 +0200 Subject: [PATCH] [wip] more things added to user subsystem and refactor things to use the new definitions --- libs/wire-subsystems/src/Wire/MiniBackend.hs | 6 +- libs/wire-subsystems/src/Wire/UserStore.hs | 13 +-- .../src/Wire/UserStore/Cassandra.hs | 12 +-- .../wire-subsystems/src/Wire/UserSubsystem.hs | 18 +++- .../src/Wire/UserSubsystem/Interpreter.hs | 29 +++++-- services/brig/src/Brig/API/Internal.hs | 29 ++++--- services/brig/src/Brig/API/Public.hs | 51 +++++------ services/brig/src/Brig/API/User.hs | 86 +++++++------------ services/brig/src/Brig/API/Util.hs | 2 +- services/brig/src/Brig/Data/UserKey.hs | 6 +- .../brig/src/Brig/InternalEvent/Process.hs | 7 +- services/brig/src/Brig/User/API/Handle.hs | 13 +-- services/brig/src/Brig/User/API/Search.hs | 9 +- services/brig/src/Brig/User/Auth.hs | 11 ++- services/brig/src/Brig/User/EJPD.hs | 7 +- 15 files changed, 156 insertions(+), 143 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/MiniBackend.hs b/libs/wire-subsystems/src/Wire/MiniBackend.hs index 6305949e5c8..fdf4cec1cdd 100644 --- a/libs/wire-subsystems/src/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/src/Wire/MiniBackend.hs @@ -356,8 +356,10 @@ staticUserStoreInterpreter = interpret $ \case $ u doUpdate u = u -- TODO - ClaimHandle _ _ _ -> pure False - FreeHandle _ _ -> pure () + ClaimHandle {} -> pure False + FreeHandle {} -> pure () + LookupHandle {} -> undefined -- TODO(mangoiv): not yet implemented + GlimpseHandle {} -> undefined -- TODO(mangoiv): not yet implemented -- | interprets galley by statically returning the values passed miniGalleyAPIAccess :: diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 057d37a2a38..b5561142dd7 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -59,11 +59,6 @@ instance Default UserProfileUpdate where handle = Nothing } -data CheckHandleResp - = CheckHandleInvalid - | CheckHandleFound - | CheckHandleNotFound - data UserStore m a where GetUser :: UserId -> UserStore m (Maybe StoredUser) UpdateUser :: UserId -> UserProfileUpdate -> UserStore m () @@ -71,5 +66,13 @@ data UserStore m a where ClaimHandle :: UserId -> Maybe Handle -> Handle -> UserStore m Bool -- | Free a 'Handle', making it available to be claimed again. FreeHandle :: UserId -> Handle -> UserStore m () + -- | this operation looks up a handle but may not give you stale data + -- it is potentially slower and less resilient than 'GlimpseHandle' + LookupHandle :: Handle -> UserStore m (Maybe UserId) + -- | the interpretation for 'LookupHandle' and 'GlimpseHandle' + -- may differ in terms of how consistent they are, if that + -- matters for the interpretation, this operation may give you stale data + -- but is faster and more resilient + GlimpseHandle :: Handle -> UserStore m (Maybe UserId) makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index a85873c5be2..d8203b95a9d 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -20,6 +20,8 @@ interpretUserStoreCassandra casClient = UpdateUser uid update -> embed $ updateUserImpl uid update ClaimHandle uid old new -> embed $ claimHandleImpl uid old new FreeHandle uid h -> embed $ freeHandleImpl uid h + LookupHandle hdl -> embed $ lookupHandleImpl LocalQuorum hdl + GlimpseHandle hdl -> embed $ lookupHandleImpl One hdl getUserImpl :: Member (Embed Client) r => UserId -> Sem r (Maybe StoredUser) getUserImpl uid = embed $ do @@ -38,7 +40,7 @@ updateUserImpl uid update = retry x5 . batch $ do claimHandleImpl :: UserId -> Maybe Handle -> Handle -> Client Bool claimHandleImpl uid oldHandle newHandle = isJust <$> do - owner <- lookupHandle newHandle + owner <- lookupHandleImpl LocalQuorum newHandle case owner of Just uid' | uid /= uid' -> pure Nothing _ -> do @@ -56,7 +58,7 @@ claimHandleImpl uid oldHandle newHandle = freeHandleImpl :: UserId -> Handle -> Client () freeHandleImpl uid h = do - mbHandleUid <- lookupHandle h + mbHandleUid <- lookupHandleImpl LocalQuorum h case mbHandleUid of Just handleUid | handleUid == uid -> do retry x5 $ write handleDelete (params LocalQuorum (Identity h)) @@ -69,10 +71,10 @@ freeHandleImpl uid h = do -- -- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' -- and only allowing it to be parsed. -lookupHandle :: Handle -> Client (Maybe UserId) -lookupHandle h = do +lookupHandleImpl :: Consistency -> Handle -> Client (Maybe UserId) +lookupHandleImpl consistencyLevel h = do (runIdentity =<<) - <$> retry x1 (query1 handleSelect (params LocalQuorum (Identity h))) + <$> retry x1 (query1 handleSelect (params consistencyLevel (Identity h))) updateHandle :: UserId -> Handle -> Client () updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 485a7dd9ccb..08fb2a25d8c 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -2,14 +2,16 @@ module Wire.UserSubsystem where +-- FUTUREWORK(mangoiv): this should probably be renamed such that it doesn't +-- associate with the name "brig" anymore + +import Data.Handle (Handle) import Data.Id import Data.Qualified import Imports import Network.Wai.Utilities qualified as Wai import Polysemy import Wire.API.Error --- FUTUREWORK(mangoiv): this should probably be renamed such that it doesn't --- associate with the name "brig" anymore import Wire.API.Error.Brig qualified as E import Wire.API.Federation.Error import Wire.API.User @@ -48,6 +50,18 @@ data UserSubsystem m a where -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) UpdateUserProfile :: Local UserId -> Maybe ConnId -> UserProfileUpdate -> UserSubsystem m () + -- | parse and lookup a handle, return what the operation has found + CheckHandle :: Text -> UserSubsystem m CheckHandleResp + -- | checks a number of 'Handle's for availability and returns at most 'Word' amount of them + CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle] + -- | parses a handle, this may fail so it's effectful + ParseHandle :: Text -> UserSubsystem m Handle + +-- | the return type of 'CheckHandle' +data CheckHandleResp + = CheckHandleFound + | CheckHandleNotFound + deriving stock (Eq, Ord, Show) makeSem ''UserSubsystem diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 7cdce274d8c..943da6e29ed 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + module Wire.UserSubsystem.Interpreter ( runUserSubsystem, UserSubsystemConfig (..), @@ -8,6 +11,8 @@ where import Control.Lens (view) import Control.Monad.Trans.Maybe import Data.Either.Extra +import Data.Handle (Handle) +import Data.Handle qualified as Handle import Data.Id import Data.Json.Util import Data.LegalHold @@ -80,11 +85,14 @@ interpretUserSubsystem :: Typeable fedM ) => InterpreterFor UserSubsystem r -interpretUserSubsystem = interpret $ \case +interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others UpdateUserProfile self mconn update -> updateUserProfileImpl self mconn update + ParseHandle uhandle -> parseHandleImpl uhandle + CheckHandle uhandle -> checkHandleImpl uhandle + CheckHandles hdls cnt -> checkHandlesImpl hdls cnt -- | Obtain user profiles for a list of users as they can be seen by -- a given user 'self'. If 'self' is an unknown 'UserId', return '[]'. @@ -336,10 +344,13 @@ mkProfileUpdateEvent uid update = -------------------------------------------------------------------------------- -- Check Handle -checkHandle :: Text -> Sem r CheckHandleResp -checkHandle uhandle = do - xhandle <- validateHandle uhandle - owner <- lift . wrapClient $ lookupHandle xhandle +parseHandleImpl :: (Member (Error UserSubsystemError) r) => Text -> Sem r Handle +parseHandleImpl = note UserSubsystemInvalidHandle . Handle.parseHandle + +checkHandleImpl :: (Member (Error UserSubsystemError) r, Member UserStore r) => Text -> Sem r CheckHandleResp +checkHandleImpl uhandle = do + xhandle :: Handle <- parseHandleImpl uhandle + owner <- lookupHandle xhandle if | isJust owner -> -- Handle is taken (=> getHandleInfo will return 200) @@ -350,7 +361,7 @@ checkHandle uhandle = do -- FUTUREWORK: i wonder if this is correct? isn't this the error for malformed -- handles? shouldn't we throw not-found here? or should there be a fourth case -- 'CheckHandleBlacklisted'? - pure CheckHandleInvalid + throw UserSubsystemInvalidHandle | otherwise -> -- Handle is free and can be taken pure CheckHandleNotFound @@ -358,8 +369,10 @@ checkHandle uhandle = do -------------------------------------------------------------------------------- -- Check Handles -checkHandles :: [Handle] -> Word -> Sem r [Handle] -checkHandles check num = reverse <$> collectFree [] check num +-- | checks for handles @check@ to be available and returns +-- at maximum @num@ of them +checkHandlesImpl :: _ => [Handle] -> Word -> Sem r [Handle] +checkHandlesImpl check num = reverse <$> collectFree [] check num where collectFree free _ 0 = pure free collectFree free [] _ = pure free diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 7b517ab0f2a..64711dafe55 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -43,7 +43,12 @@ import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.FederationConfigStore (AddFederationRemoteResult (..), AddFederationRemoteTeamResult (..), FederationConfigStore, UpdateFederationResult (..)) +import Brig.Effects.FederationConfigStore + ( AddFederationRemoteResult (..), + AddFederationRemoteTeamResult (..), + FederationConfigStore, + UpdateFederationResult (..), + ) import Brig.Effects.FederationConfigStore qualified as E import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) @@ -107,6 +112,7 @@ import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserStore (UserProfileUpdate (..), allowScimUpdate) import Wire.UserSubsystem +import Wire.UserSubsystem qualified as UserSubsystem servantSitemap :: forall r p. @@ -555,13 +561,13 @@ listActivatedAccounts :: Member DeleteQueue r => Either [UserId] [Handle] -> Bool -> - (AppT r) [UserAccount] + AppT r [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of Left us -> byIds us Right hs -> do - us <- mapM (wrapClient . API.lookupHandle) hs + us <- liftSem $ mapM API.lookupHandle hs byIds (catMaybes us) where byIds :: Member DeleteQueue r => [UserId] -> (AppT r) [UserAccount] @@ -849,16 +855,18 @@ updateHandleH :: Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, + Member UserSubsystem r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r ) => UserId -> HandleUpdate -> - (Handler r) NoContent + Handler r NoContent updateHandleH uid (HandleUpdate handleUpd) = NoContent <$ do handle <- validateHandle handleUpd - API.changeHandle uid Nothing handle API.AllowSCIMUpdates !>> changeHandleError + quid <- qualifyLocal uid + lift (liftSem $ UserSubsystem.updateUserProfile quid Nothing def {handle = Just $ allowScimUpdate handle}) !>> changeHandleError updateUserNameH :: Member UserSubsystem r => @@ -874,12 +882,11 @@ updateUserNameH uid (NameUpdate nameUpd) = Just _ -> lift . liftSem $ updateUserProfile luid Nothing uu Nothing -> throwStd (errorToWai @'E.InvalidUser) -checkHandleInternalH :: Handle -> (Handler r) CheckHandleResponse -checkHandleInternalH (Handle h) = - API.checkHandle h >>= \case - API.CheckHandleInvalid -> throwE (StdError (errorToWai @'E.InvalidHandle)) - API.CheckHandleFound -> pure CheckHandleResponseFound - API.CheckHandleNotFound -> pure CheckHandleResponseNotFound +checkHandleInternalH :: Handle -> Handler r CheckHandleResponse +checkHandleInternalH (Handle h) = lift $ liftSem do + API.checkHandle h <&> \case + API.CheckHandleFound -> CheckHandleResponseFound + API.CheckHandleNotFound -> CheckHandleResponseNotFound getContactListH :: UserId -> (Handler r) UserIds getContactListH uid = lift . wrapClient $ UserIds <$> API.lookupContactList uid diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 3ad74c88582..d75e7ccf038 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -70,7 +70,7 @@ import Brig.User.Email import Brig.User.Phone import Cassandra qualified as C import Cassandra qualified as Data -import Control.Error hiding (bool) +import Control.Error hiding (bool, note) import Control.Lens (view, (.~), (?~), (^.)) import Control.Monad.Catch (throwM) import Control.Monad.Except @@ -84,7 +84,8 @@ import Data.CommaSeparatedList import Data.Default import Data.Domain import Data.FileEmbed -import Data.Handle (Handle, parseHandle) +import Data.Handle (Handle) +import Data.Handle qualified as Handle import Data.Id import Data.Id qualified as Id import Data.List.NonEmpty (nonEmpty) @@ -105,6 +106,7 @@ import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.Error (note) import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) @@ -165,8 +167,9 @@ import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserStore (UserProfileUpdate (..), forbidScimUpdate) -import Wire.UserSubsystem +import Wire.UserStore (UserProfileUpdate (..), UserStore, forbidScimUpdate) +import Wire.UserSubsystem hiding (checkHandle, checkHandles) +import Wire.UserSubsystem qualified as UserSubsystem -- User API ----------------------------------------------------------- @@ -854,9 +857,9 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do in listUsersByIdsOrHandlesV3 self (Public.ListUsersByHandles qualifiedRangedList) (Nothing, Nothing) -> throwStd $ badRequest "at least one ids or handles must be provided" -listUsersByIdsOrHandlesGetIds :: [Handle] -> (Handler r) [Qualified UserId] +listUsersByIdsOrHandlesGetIds :: [Handle] -> Handler r [Qualified UserId] listUsersByIdsOrHandlesGetIds localHandles = do - localUsers <- catMaybes <$> traverse (lift . wrapClient . API.lookupHandle) localHandles + localUsers <- catMaybes <$> traverse (lift . liftSem . API.lookupHandle) localHandles domain <- viewFederationDomain pure $ map (`Qualified` domain) localUsers @@ -1013,26 +1016,26 @@ changeSupportedProtocols (tUnqualified -> u) conn (Public.SupportedProtocolUpdat -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandle :: UserId -> Text -> Handler r () +checkHandle :: Member UserSubsystem r => UserId -> Text -> Handler r () checkHandle _uid hndl = - API.checkHandle hndl >>= \case - API.CheckHandleInvalid -> throwStd (errorToWai @'E.InvalidHandle) + lift (liftSem $ UserSubsystem.checkHandle hndl) >>= \case API.CheckHandleFound -> pure () API.CheckHandleNotFound -> throwStd (errorToWai @'E.HandleNotFound) -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandles :: UserId -> Public.CheckHandles -> Handler r [Handle] +checkHandles :: Member UserSubsystem r => UserId -> Public.CheckHandles -> Handler r [Handle] checkHandles _ (Public.CheckHandles hs num) = do - let handles = mapMaybe parseHandle (fromRange hs) - lift $ wrapHttpClient $ API.checkHandles handles (fromRange num) + let handles = mapMaybe Handle.parseHandle (fromRange hs) + lift $ liftSem $ API.checkHandles handles (fromRange num) -- | This endpoint returns UserHandleInfo instead of UserProfile for backwards -- compatibility, whereas the corresponding qualified endpoint (implemented by -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. getHandleInfoUnqualifiedH :: - ( Member UserSubsystem r + ( Member UserSubsystem r, + Member UserStore r ) => UserId -> Handle -> @@ -1042,27 +1045,15 @@ getHandleInfoUnqualifiedH self handle = do Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandle :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - Public.HandleUpdate -> - (Handler r) (Maybe Public.ChangeHandleError) -changeHandle u conn (Public.HandleUpdate h) = lift . exceptTToMaybe $ do - handle <- maybe (throwError Public.ChangeHandleInvalid) pure $ parseHandle h - API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates +changeHandle :: (Member UserSubsystem r) => Local UserId -> ConnId -> Public.HandleUpdate -> Handler r () +changeHandle u conn (Public.HandleUpdate h) = lift $ liftSem do + handle <- UserSubsystem.parseHandle h + UserSubsystem.updateUserProfile u (Just conn) def {handle = Just (forbidScimUpdate handle)} beginPasswordReset :: (Member PasswordResetStore r, Member TinyLog r) => Public.NewPasswordReset -> - (Handler r) () + Handler r () beginPasswordReset (Public.NewPasswordReset target) = do checkAllowlist target (u, pair) <- API.beginPasswordReset target !>> pwResetError diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e7912957b27..199055f0050 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -89,7 +89,7 @@ module Brig.API.User where import Brig.API.Error qualified as Error -import Brig.API.Handler qualified as API (Handler, UserNotAllowedToJoinTeam (..)) +import Brig.API.Handler qualified as API (UserNotAllowedToJoinTeam (..)) import Brig.API.Types import Brig.API.Util import Brig.App @@ -134,7 +134,8 @@ import Data.ByteString.Conversion import Data.Code import Data.Currency qualified as Currency import Data.Default -import Data.Handle (Handle (fromHandle), parseHandle) +import Data.Handle (Handle (fromHandle)) +import Data.Handle qualified as Handle import Data.Id as Id import Data.Json.Util import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) @@ -222,6 +223,7 @@ createUserSpar :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r ) => NewUserSpar -> @@ -263,7 +265,7 @@ createUserSpar new = do updateHandle' :: Local UserId -> Maybe Handle -> ExceptT CreateUserSparError (AppT r) () updateHandle' _ Nothing = pure () updateHandle' luid (Just h) = do - case parseHandle . fromHandle $ h of + case Handle.parseHandle . fromHandle $ h of Just handl -> lift . liftSem $ updateUserProfile luid Nothing def {handle = Just (allowScimUpdate handl)} @@ -637,50 +639,6 @@ changeSupportedProtocols uid conn prots = do wrapClient $ Data.updateSupportedProtocols uid prots liftSem $ Intra.onUserEvent uid (Just conn) (supportedProtocolUpdate uid prots) --------------------------------------------------------------------------------- --- Check Handle - -data CheckHandleResp - = CheckHandleInvalid - | CheckHandleFound - | CheckHandleNotFound - -checkHandle :: Text -> API.Handler r CheckHandleResp -checkHandle uhandle = do - xhandle <- validateHandle uhandle - owner <- lift . wrapClient $ lookupHandle xhandle - if - | isJust owner -> - -- Handle is taken (=> getHandleInfo will return 200) - pure CheckHandleFound - | isBlacklistedHandle xhandle -> - -- Handle is free but cannot be taken - -- - -- FUTUREWORK: i wonder if this is correct? isn't this the error for malformed - -- handles? shouldn't we throw not-found here? or should there be a fourth case - -- 'CheckHandleBlacklisted'? - pure CheckHandleInvalid - | otherwise -> - -- Handle is free and can be taken - pure CheckHandleNotFound - --------------------------------------------------------------------------------- --- Check Handles - -checkHandles :: MonadClient m => [Handle] -> Word -> m [Handle] -checkHandles check num = reverse <$> collectFree [] check num - where - collectFree free _ 0 = pure free - collectFree free [] _ = pure free - collectFree free (h : hs) n = - if isBlacklistedHandle h - then collectFree free hs n - else do - owner <- glimpseHandle h - case owner of - Nothing -> collectFree (h : free) hs (n - 1) - Just _ -> collectFree free hs n - ------------------------------------------------------------------------------- -- Change Email @@ -1216,6 +1174,9 @@ mkPasswordResetKey ident = case ident of -- delete them in the team settings. This protects teams against orphanhood. -- -- TODO: communicate deletions of SSO users to SSO service. +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation deleteSelfUser :: forall r. ( Member GalleyAPIAccess r, @@ -1223,6 +1184,7 @@ deleteSelfUser :: Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member (Input (Local ())) r, + Member UserStore r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r ) => @@ -1302,11 +1264,15 @@ deleteSelfUser uid pwd = do -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, + Member UserStore r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r ) => @@ -1323,13 +1289,17 @@ verifyDeleteUser d = do -- | Check if `deleteAccount` succeeded and run it again if needed. -- Called via @delete /i/user/:uid@. +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation ensureAccountDeleted :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserStore r ) => UserId -> AppT r DeleteUserResult @@ -1366,11 +1336,15 @@ ensureAccountDeleted uid = do -- N.B.: As Cassandra doesn't support transactions, the order of database -- statements matters! Other functions reason upon some states to imply other -- states. Please change this order only with care! +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation deleteAccount :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, + Member UserStore r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r ) => @@ -1379,27 +1353,27 @@ deleteAccount :: deleteAccount account@(accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") - embed $ do + do -- Free unique keys - for_ (userEmail user) $ deleteKeyForUser uid . userEmailKey - for_ (userPhone user) $ deleteKeyForUser uid . userPhoneKey + for_ (userEmail user) $ embed . deleteKeyForUser uid . userEmailKey + for_ (userPhone user) $ embed . deleteKeyForUser uid . userPhoneKey for_ (userHandle user) $ freeHandle (userId user) -- Wipe data - Data.clearProperties uid + embed $ Data.clearProperties uid tombstone <- mkTombstone - Data.insertAccount tombstone Nothing Nothing False + embed $ Data.insertAccount tombstone Nothing Nothing False Intra.rmUser uid (userAssets user) embed $ Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) luid <- embed $ qualifyLocal uid Intra.onUserEvent uid Nothing (UserDeleted (tUntagged luid)) - embed $ do + embed do -- Note: Connections can only be deleted afterwards, since -- they need to be notified. Data.deleteConnections uid revokeAllCookies uid where mkTombstone = do - defLoc <- setDefaultUserLocale <$> view settings + defLoc <- embed $ setDefaultUserLocale <$> view settings pure $ account { accountStatus = Deleted, @@ -1490,7 +1464,7 @@ getLegalHoldStatus' user = -- | Find user accounts for a given identity, both activated and those -- currently pending activation. -lookupAccountsByIdentity :: Either Email Phone -> Bool -> (AppT r) [UserAccount] +lookupAccountsByIdentity :: Either Email Phone -> Bool -> AppT r [UserAccount] lookupAccountsByIdentity emailOrPhone includePendingInvitations = do let uk = either userEmailKey userPhoneKey emailOrPhone activeUid <- wrapClient $ Data.lookupKey uk diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 80d4772cc5e..67cede64f15 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -77,7 +77,7 @@ fetchUserIdentity uid = (pure . userIdentity . selfUser) -- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> (AppT r) (Maybe SelfProfile) +lookupSelfProfile :: UserId -> AppT r (Maybe SelfProfile) lookupSelfProfile = fmap (fmap mk) . wrapClient . Data.lookupAccount where mk a = SelfProfile (accountUser a) diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index 11128014a24..a1769c68421 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -45,11 +45,7 @@ import Wire.API.User (fromEmail) data UserKey = UserEmailKey !EmailKey | UserPhoneKey !PhoneKey - -instance Eq UserKey where - (UserEmailKey k) == (UserEmailKey k') = k == k' - (UserPhoneKey k) == (UserPhoneKey k') = k == k' - _ == _ = False + deriving stock (Eq, Show) userEmailKey :: Email -> UserKey userEmailKey = UserEmailKey . mkEmailKey diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index b0e0ba1c870..484e4026e11 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -15,10 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.InternalEvent.Process - ( onEvent, - ) -where +module Brig.InternalEvent.Process (onEvent) where import Brig.API.User qualified as API import Brig.App @@ -44,6 +41,7 @@ import Wire.API.UserEvent import Wire.NotificationSubsystem import Wire.Sem.Delay import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserStore (UserStore) -- | Handle an internal event. -- @@ -56,6 +54,7 @@ onEvent :: Member Race r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member UserStore r, Member (ConnectionStore InternalPaging) r ) => InternalNotification -> diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index f39fa56a7b0..bfa3407059a 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -42,13 +42,14 @@ import Wire.API.User import Wire.API.User qualified as Public import Wire.API.User.Search import Wire.API.User.Search qualified as Public +import Wire.UserStore (UserStore) import Wire.UserSubsystem getHandleInfo :: - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => UserId -> Qualified Handle -> - (Handler r) (Maybe Public.UserProfile) + Handler r (Maybe Public.UserProfile) getHandleInfo self handle = do lself <- qualifyLocal self foldQualified @@ -57,7 +58,7 @@ getHandleInfo self handle = do getRemoteHandleInfo handle -getRemoteHandleInfo :: Remote Handle -> (Handler r) (Maybe Public.UserProfile) +getRemoteHandleInfo :: Remote Handle -> Handler r (Maybe Public.UserProfile) getRemoteHandleInfo handle = do lift . Log.info $ Log.msg (Log.val "getHandleInfo - remote lookup") @@ -65,13 +66,13 @@ getRemoteHandleInfo handle = do Federation.getUserHandleInfo handle !>> fedError getLocalHandleInfo :: - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => Local UserId -> Handle -> - (Handler r) (Maybe Public.UserProfile) + Handler r (Maybe Public.UserProfile) getLocalHandleInfo self handle = do lift . Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" - maybeOwnerId <- lift . wrapClient $ API.lookupHandle handle + maybeOwnerId <- lift . liftSem $ API.lookupHandle handle case maybeOwnerId of Nothing -> pure Nothing Just ownerId -> do diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 2d77a5e9119..4d9ae68862c 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -40,7 +40,7 @@ import Brig.User.Search.SearchIndex qualified as Q import Brig.User.Search.TeamUserSearch qualified as Q import Control.Lens (view) import Data.Domain (Domain) -import Data.Handle (parseHandle) +import Data.Handle qualified as Handle import Data.Id import Data.Range import Imports @@ -59,6 +59,7 @@ import Wire.API.User.Search import Wire.API.User.Search qualified as Public import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.UserStore (UserStore) import Wire.UserSubsystem -- FUTUREWORK: Consider augmenting 'SearchResult' with full user profiles @@ -66,6 +67,7 @@ import Wire.UserSubsystem search :: ( Member GalleyAPIAccess r, Member FederationConfigStore r, + Member UserStore r, Member UserSubsystem r ) => UserId -> @@ -116,7 +118,8 @@ searchRemotely domain mTid searchTerm = do searchLocally :: forall r. ( Member GalleyAPIAccess r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r ) => UserId -> Text -> @@ -165,7 +168,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do exactHandleSearch :: (Handler r) (Maybe Contact) exactHandleSearch = do lsearcherId <- qualifyLocal searcherId - case parseHandle searchTerm of + case Handle.parseHandle searchTerm of Nothing -> pure Nothing Just handle -> do HandleAPI.contactFromProfile diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 481a8b8cafa..ffd6a7e2fcd 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -53,7 +53,6 @@ import Brig.Options qualified as Opt import Brig.Phone import Brig.Types.Intra import Brig.User.Auth.Cookie -import Brig.User.Handle import Brig.User.Phone import Brig.ZAuth qualified as ZAuth import Cassandra @@ -87,6 +86,7 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserStore.Cassandra (lookupHandleImpl) sendLoginCode :: (Member TinyLog r) => @@ -128,6 +128,8 @@ lookupLoginCode phone = liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.lookupLoginCode") wrapHttpClient $ Data.lookupLoginCode u +-- FUTUREWORK(mangoiv): we have to think about what to do with this, it should not +-- access the UserStore directly, perhaps some more fitting "AuthenticationSubsystem"? login :: forall r. ( Member GalleyAPIAccess r, @@ -163,7 +165,7 @@ login (PasswordLogin (PasswordLoginData li pw label code)) typ = do VerificationCodeRequired -> wrapHttpClientE $ loginFailedWith LoginCodeRequired uid VerificationCodeNoEmail -> wrapHttpClientE $ loginFailed uid login (SmsLogin (SmsLoginData phone code label)) typ = do - uid <- wrapHttpClientE $ resolveLoginId (LoginByPhone phone) + uid <- wrapClientE $ resolveLoginId (LoginByPhone phone) lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.login") wrapHttpClientE $ checkRetryLimit uid ok <- wrapHttpClientE $ Data.verifyLoginCode uid code @@ -329,9 +331,12 @@ newAccess uid cid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing pure $ Access t (Just ck) +-- FUTUREWORK(mangoiv): unfortunately this uses lookupHandleImple explicity, in future, this +-- should use lookuHandle but should be moved into some place where this resolveLoginId is done +-- abstractly, perhaps some authentication subsystem resolveLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m UserId resolveLoginId li = do - usr <- validateLoginId li >>= lift . either lookupKey lookupHandle + usr <- validateLoginId li >>= lift . either lookupKey (liftClient . lookupHandleImpl LocalQuorum) case usr of Nothing -> do pending <- lift $ isPendingActivation li diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index e04538621c0..b0487daaa3a 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -48,11 +48,14 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Rpc +import Wire.UserStore (UserStore) +-- FUTUREWORK(mangoiv): this uses 'UserStore' and should hence go to 'UserSubSystem' ejpdRequest :: forall r. ( Member GalleyAPIAccess r, Member NotificationSubsystem r, + Member UserStore r, Member Rpc r ) => Maybe Bool -> @@ -62,9 +65,9 @@ ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles go1 where -- find uid given handle - go1 :: Handle -> (AppT r) (Maybe EJPDResponseItem) + go1 :: Handle -> AppT r (Maybe EJPDResponseItem) go1 handle = do - mbUid <- wrapClient $ lookupHandle handle + mbUid <- liftSem $ lookupHandle handle mbUsr <- maybe (pure Nothing) (wrapClient . lookupUser NoPendingInvitations) mbUid maybe (pure Nothing) (fmap Just . go2 includeContacts) mbUsr