From d2d42e08b38847fb1d53970cbf8aacaed1ac3834 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 23 Jul 2024 13:37:21 +0000 Subject: [PATCH 1/4] moved blocklist to subsystems --- .../src/Wire/BlockListStore.hs | 14 ++++++ .../src/Wire/BlockListStore/Cassandra.hs | 45 +++++++++++++++++++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 6 +++ .../src/Wire/UserSubsystem/Interpreter.hs | 15 +++++++ .../test/unit/Wire/MiniBackend.hs | 16 ++++++- .../test/unit/Wire/MockInterpreters.hs | 1 + .../Wire/MockInterpreters/BlockListStore.hs | 13 ++++++ libs/wire-subsystems/wire-subsystems.cabal | 3 ++ 8 files changed, 111 insertions(+), 2 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/BlockListStore.hs create mode 100644 libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/BlockListStore.hs diff --git a/libs/wire-subsystems/src/Wire/BlockListStore.hs b/libs/wire-subsystems/src/Wire/BlockListStore.hs new file mode 100644 index 00000000000..55ce155d46f --- /dev/null +++ b/libs/wire-subsystems/src/Wire/BlockListStore.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.BlockListStore where + +import Imports +import Polysemy +import Wire.UserKeyStore + +data BlockListStore m a where + Insert :: EmailKey -> BlockListStore m () + Exists :: EmailKey -> BlockListStore m Bool + Delete :: EmailKey -> BlockListStore m () + +makeSem ''BlockListStore diff --git a/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs new file mode 100644 index 00000000000..d8e0e0f077a --- /dev/null +++ b/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs @@ -0,0 +1,45 @@ +module Wire.BlockListStore.Cassandra + ( interpretBlockListStoreToCassandra, + ) +where + +import Cassandra +import Imports +import Polysemy +import Wire.BlockListStore (BlockListStore (..)) +import Wire.UserKeyStore + +interpretBlockListStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (BlockListStore ': r) a -> + Sem r a +interpretBlockListStoreToCassandra = + interpret $ + embed @m . \case + Insert uk -> insert uk + Exists uk -> exists uk + Delete uk -> delete uk + +-------------------------------------------------------------------------------- +-- UserKey block listing + +insert :: (MonadClient m) => EmailKey -> m () +insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ emailKeyUniq uk)) + +exists :: (MonadClient m) => EmailKey -> m Bool +exists uk = + (pure . isJust) . fmap runIdentity + =<< retry x1 (query1 keySelect (params LocalQuorum (Identity $ emailKeyUniq uk))) + +delete :: (MonadClient m) => EmailKey -> m () +delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq uk)) + +keyInsert :: PrepQuery W (Identity Text) () +keyInsert = "INSERT INTO blacklist (key) VALUES (?)" + +keySelect :: PrepQuery R (Identity Text) (Identity Text) +keySelect = "SELECT key FROM blacklist WHERE key = ?" + +keyDelete :: PrepQuery W (Identity Text) () +keyDelete = "DELETE FROM blacklist WHERE key = ?" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index e7209dd1ecf..0838da2bb18 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -74,6 +74,12 @@ data UserSubsystem m a where GetLocalUserAccountByUserKey :: Local EmailKey -> UserSubsystem m (Maybe UserAccount) -- | returns the user's locale or the default locale if the users exists LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale) + -- | checks if an email is blocked + IsBlocked :: Email -> UserSubsystem m Bool + -- | removes an email from the block list + BlockListDelete :: Email -> UserSubsystem m () + -- | adds an email to the block list + BlockListInsert :: Email -> UserSubsystem m () -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 505f763e7dc..7daba81f6d8 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -28,6 +28,7 @@ import Wire.API.Team.Member hiding (userId) import Wire.API.User import Wire.API.UserEvent import Wire.Arbitrary +import Wire.BlockListStore as BlockList import Wire.DeleteQueue import Wire.Events import Wire.FederationAPIAccess @@ -55,6 +56,7 @@ runUserSubsystem :: ( Member GalleyAPIAccess r, Member UserStore r, Member UserKeyStore r, + Member BlockListStore r, Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect. Member (Error FederationError) r, Member (Error UserSubsystemError) r, @@ -74,6 +76,7 @@ interpretUserSubsystem :: ( Member GalleyAPIAccess r, Member UserStore r, Member UserKeyStore r, + Member BlockListStore r, Member (Concurrency 'Unsafe) r, Member (Error FederationError) r, Member (Error UserSubsystemError) r, @@ -98,6 +101,18 @@ interpretUserSubsystem = interpret \case UpdateHandle uid mconn mb uhandle -> updateHandleImpl uid mconn mb uhandle GetLocalUserAccountByUserKey userKey -> getLocalUserAccountByUserKeyImpl userKey LookupLocaleWithDefault luid -> lookupLocaleOrDefaultImpl luid + IsBlocked email -> isBlockedImpl email + BlockListDelete email -> blockListDeleteImpl email + BlockListInsert email -> blockListInsertImpl email + +isBlockedImpl :: (Member BlockListStore r) => Email -> Sem r Bool +isBlockedImpl = BlockList.exists . mkEmailKey + +blockListDeleteImpl :: (Member BlockListStore r) => Email -> Sem r () +blockListDeleteImpl = BlockList.delete . mkEmailKey + +blockListInsertImpl :: (Member BlockListStore r) => Email -> Sem r () +blockListInsertImpl = BlockList.insert . mkEmailKey lookupLocaleOrDefaultImpl :: (Member UserStore r, Member (Input UserSubsystemConfig) r) => Local UserId -> Sem r (Maybe Locale) lookupLocaleOrDefaultImpl luid = do diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 72bc9a465b9..8d31d806a9b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -51,6 +51,7 @@ import Wire.API.Team.Feature import Wire.API.Team.Member hiding (userId) import Wire.API.User as User hiding (DeleteUser) import Wire.API.User.Password +import Wire.BlockListStore import Wire.DeleteQueue import Wire.DeleteQueue.InMemory import Wire.Events @@ -95,6 +96,8 @@ type AllErrors = type MiniBackendEffects = [ UserSubsystem, GalleyAPIAccess, + BlockListStore, + State [EmailKey], UserStore, State [StoredUser], UserKeyStore, @@ -118,7 +121,8 @@ data MiniBackend = MkMiniBackend -- invariant: for each key, the user.id and the key are the same users :: [StoredUser], userKeys :: Map EmailKey UserId, - passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity) + passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity), + blockList :: [EmailKey] } instance Default MiniBackend where @@ -126,7 +130,8 @@ instance Default MiniBackend where MkMiniBackend { users = mempty, userKeys = mempty, - passwordResetCodes = mempty + passwordResetCodes = mempty, + blockList = mempty } -- | represents an entire federated, stateful world of backends @@ -354,9 +359,16 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem . inMemoryUserKeyStoreInterpreter . liftUserStoreState . inMemoryUserStoreInterpreter + . liftBlockListStoreState + . inMemoryBlockListStoreInterpreter . miniGalleyAPIAccess teamMember galleyConfigs . runUserSubsystem cfg +liftBlockListStoreState :: (Member (State MiniBackend) r) => Sem (State [EmailKey] : r) a -> Sem r a +liftBlockListStoreState = interpret $ \case + Polysemy.State.Get -> gets (.blockList) + Put newBlockList -> modify $ \b -> b {blockList = newBlockList} + liftUserKeyStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey UserId) : r) a -> Sem r a liftUserKeyStoreState = interpret $ \case Polysemy.State.Get -> gets (.userKeys) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs index 5dc96a34f9a..ebd8d4d1ee5 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs @@ -3,6 +3,7 @@ module Wire.MockInterpreters (module MockInterpreters) where -- Run this from project root to generate the imports: -- ls libs/wire-subsystems/test/unit/Wire/MockInterpreters | sed 's|\(.*\)\.hs|import Wire.MockInterpreters.\1 as MockInterpreters|' +import Wire.MockInterpreters.BlockListStore as MockInterpreters import Wire.MockInterpreters.EmailSubsystem as MockInterpreters import Wire.MockInterpreters.Error as MockInterpreters import Wire.MockInterpreters.Events as MockInterpreters diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/BlockListStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/BlockListStore.hs new file mode 100644 index 00000000000..2ed63f4e081 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/BlockListStore.hs @@ -0,0 +1,13 @@ +module Wire.MockInterpreters.BlockListStore where + +import Imports +import Polysemy +import Polysemy.State +import Wire.BlockListStore +import Wire.UserKeyStore + +inMemoryBlockListStoreInterpreter :: (Member (State [EmailKey]) r) => InterpreterFor BlockListStore r +inMemoryBlockListStoreInterpreter = interpret $ \case + Insert uk -> modify (uk :) + Exists uk -> gets (elem uk) + Delete uk -> modify (filter (/= uk)) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 2169aa80aca..e2763335c9f 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -73,6 +73,8 @@ library Wire.AuthenticationSubsystem.Error Wire.AuthenticationSubsystem.Interpreter Wire.AWS + Wire.BlockListStore + Wire.BlockListStore.Cassandra Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.EmailSending @@ -204,6 +206,7 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.MiniBackend Wire.MockInterpreters + Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.EmailSubsystem Wire.MockInterpreters.Error Wire.MockInterpreters.Events From c105ca2366283ba32da662f6c67b4e44939bc313 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 24 Jul 2024 10:18:46 +0200 Subject: [PATCH 2/4] Drop old BlacklistStore effect in Brig --- services/brig/brig.cabal | 2 - services/brig/src/Brig/API/Auth.hs | 4 +- services/brig/src/Brig/API/Internal.hs | 23 +++++----- services/brig/src/Brig/API/Public.hs | 10 ++--- services/brig/src/Brig/API/User.hs | 37 ++++++++------- services/brig/src/Brig/AWS/SesNotification.hs | 14 +++--- .../brig/src/Brig/CanonicalInterpreter.hs | 8 ++-- .../brig/src/Brig/Effects/BlacklistStore.hs | 14 ------ .../Brig/Effects/BlacklistStore/Cassandra.hs | 45 ------------------- services/brig/src/Brig/Team/API.hs | 21 ++++----- 10 files changed, 56 insertions(+), 122 deletions(-) delete mode 100644 services/brig/src/Brig/Effects/BlacklistStore.hs delete mode 100644 services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 428264a318f..e3237b22240 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -113,8 +113,6 @@ library Brig.Data.Types Brig.Data.User Brig.DeleteQueue.Interpreter - Brig.Effects.BlacklistStore - Brig.Effects.BlacklistStore.Cassandra Brig.Effects.ConnectionStore Brig.Effects.ConnectionStore.Cassandra Brig.Effects.FederationConfigStore diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index 581876fe0ce..cb167140ffb 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -23,7 +23,6 @@ import Brig.API.Types import Brig.API.User import Brig.App import Brig.Data.User qualified as User -import Brig.Effects.BlacklistStore import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Options import Brig.User.Auth qualified as Auth @@ -53,6 +52,7 @@ import Wire.API.User.Auth hiding (access) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso +import Wire.BlockListStore import Wire.EmailSubsystem (EmailSubsystem) import Wire.GalleyAPIAccess import Wire.NotificationSubsystem @@ -139,7 +139,7 @@ logout _ Nothing = throwStd authMissingToken logout uts (Just at) = Auth.logout (List1 uts) at !>> zauthError changeSelfEmailH :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r ) => diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 1f764b4b126..85d5342bc0b 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -37,7 +37,6 @@ import Brig.Data.Client qualified as Data import Brig.Data.Connection qualified as Data import Brig.Data.MLS.KeyPackage qualified as Data import Brig.Data.User qualified as Data -import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.FederationConfigStore ( AddFederationRemoteResult (..), @@ -100,6 +99,7 @@ import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent import Wire.AuthenticationSubsystem (AuthenticationSubsystem) +import Wire.BlockListStore (BlockListStore) import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem (EmailSubsystem) @@ -119,7 +119,7 @@ import Wire.VerificationCodeSubsystem servantSitemap :: forall r p. - ( Member BlacklistStore r, + ( Member BlockListStore r, Member DeleteQueue r, Member (Concurrency 'Unsafe) r, Member (ConnectionStore InternalPaging) r, @@ -174,7 +174,7 @@ mlsAPI :: ServerT BrigIRoutes.MLSAPI (Handler r) mlsAPI = getMLSClients accountAPI :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member GalleyAPIAccess r, Member AuthenticationSubsystem r, Member DeleteQueue r, @@ -232,7 +232,7 @@ accountAPI = teamsAPI :: ( Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, - Member BlacklistStore r, + Member BlockListStore r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member UserKeyStore r, @@ -241,7 +241,8 @@ teamsAPI :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member EmailSending r + Member EmailSending r, + Member UserSubsystem r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = @@ -458,7 +459,7 @@ internalListFullClientsH (UserSet usrs) = lift $ do UserClientsFull <$> wrapClient (Data.lookupClientsBulk (Set.toList usrs)) createUserNoVerify :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, @@ -528,14 +529,14 @@ deleteUserNoAuthH uid = do AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted AccountDeleted -> pure UserResponseAccountDeleted -changeSelfEmailMaybeSendH :: (Member BlacklistStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSendH :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSendH u body (fromMaybe False -> validate) = do let email = euEmail body changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email UpdateOriginScim data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailMaybeSend :: (Member BlacklistStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> MaybeSendEmail -> Email -> UpdateOriginType -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSend :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> MaybeSendEmail -> Email -> UpdateOriginType -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do API.changeSelfEmail u email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do @@ -695,13 +696,13 @@ updateConnectionInternalH updateConn = do API.updateConnectionInternal updateConn !>> connError pure NoContent -checkBlacklist :: (Member BlacklistStore r) => Email -> Handler r CheckBlacklistResponse +checkBlacklist :: (Member BlockListStore r) => Email -> Handler r CheckBlacklistResponse checkBlacklist email = lift $ bool NotBlacklisted YesBlacklisted <$> API.isBlacklisted email -deleteFromBlacklist :: (Member BlacklistStore r) => Email -> Handler r NoContent +deleteFromBlacklist :: (Member BlockListStore r) => Email -> Handler r NoContent deleteFromBlacklist email = lift $ NoContent <$ API.blacklistDelete email -addBlacklist :: (Member BlacklistStore r) => Email -> Handler r NoContent +addBlacklist :: (Member BlockListStore r) => Email -> Handler r NoContent addBlacklist email = lift $ NoContent <$ API.blacklistInsert email updateSSOIdH :: diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index fb2b03b23f6..e7881044116 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -41,7 +41,6 @@ import Brig.Calling.API qualified as Calling import Brig.Data.Connection qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data -import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.JwtTools (JwtTools) @@ -146,6 +145,7 @@ import Wire.API.User.RichInfo qualified as Public import Wire.API.UserMap qualified as Public import Wire.API.Wrapped qualified as Public import Wire.AuthenticationSubsystem (AuthenticationSubsystem, createPasswordResetCode, resetPassword) +import Wire.BlockListStore (BlockListStore) import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem @@ -277,7 +277,7 @@ internalEndpointsSwaggerDocsAPI service examplePort swagger Nothing = servantSitemap :: forall r p. - ( Member BlacklistStore r, + ( Member BlockListStore r, Member DeleteQueue r, Member (Concurrency 'Unsafe) r, Member (ConnectionStore InternalPaging) r, @@ -697,7 +697,7 @@ createAccessToken method luid cid proof = do -- | docs/reference/user/registration.md {#RefRegistration} createUser :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, @@ -1029,7 +1029,7 @@ completePasswordReset req = do -- docs/reference/user/activation.md {#RefActivationRequest} -- docs/reference/user/registration.md {#RefRegistration} sendActivationCode :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member EmailSubsystem r, Member GalleyAPIAccess r, Member UserKeyStore r @@ -1223,7 +1223,7 @@ verifyDeleteUser body = API.verifyDeleteUser body !>> deleteUserError updateUserEmail :: forall r. - ( Member BlacklistStore r, + ( Member BlockListStore r, Member UserKeyStore r, Member GalleyAPIAccess r, Member EmailSubsystem r diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 543ec6d839e..3fa288a39fb 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -86,8 +86,6 @@ import Brig.Data.Connection (countConnections) import Brig.Data.Connection qualified as Data import Brig.Data.User import Brig.Data.User qualified as Data -import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Effects.BlacklistStore qualified as BlacklistStore import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore @@ -145,6 +143,7 @@ import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode) +import Wire.BlockListStore as BlockListStore import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error @@ -180,14 +179,14 @@ identityErrorToBrigError = \case IdentityErrorUserKeyExists -> StdError $ errorToWai @'E.UserKeyExists verifyUniquenessAndCheckBlacklist :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member UserKeyStore r ) => EmailKey -> ExceptT IdentityError (AppT r) () verifyUniquenessAndCheckBlacklist uk = do checkKey Nothing uk - blacklisted <- lift $ liftSem $ BlacklistStore.exists uk + blacklisted <- lift $ liftSem $ BlockListStore.exists uk when blacklisted $ throwE IdentityErrorBlacklistedEmail where checkKey u k = do @@ -267,7 +266,7 @@ createUserSpar new = do -- docs/reference/user/registration.md {#RefRegistration} createUser :: forall r p. - ( Member BlacklistStore r, + ( Member BlockListStore r, Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member UserKeyStore r, @@ -497,7 +496,7 @@ initAccountFeatureConfig uid = do -- all over the place there, we add a new function that handles just the one new flow where -- users are invited to the team via scim. createUserInviteViaScim :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member UserKeyStore r, Member (UserPendingActivationStore p) r, Member TinyLog r @@ -562,7 +561,7 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: (Member BlacklistStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> Email -> UpdateOriginType -> ExceptT HttpError (AppT r) ChangeEmailResponse +changeSelfEmail :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> Email -> UpdateOriginType -> ExceptT HttpError (AppT r) ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> @@ -582,7 +581,7 @@ changeSelfEmail u email allowScim = do (Just (userLocale usr)) -- | Prepare changing the email (checking a number of invariants). -changeEmail :: (Member BlacklistStore r, Member UserKeyStore r) => UserId -> Email -> UpdateOriginType -> ExceptT ChangeEmailError (AppT r) ChangeEmailResult +changeEmail :: (Member BlockListStore r, Member UserKeyStore r) => UserId -> Email -> UpdateOriginType -> ExceptT ChangeEmailError (AppT r) ChangeEmailResult changeEmail u email updateOrigin = do em <- either @@ -590,7 +589,7 @@ changeEmail u email updateOrigin = do pure (validateEmail email) let ek = mkEmailKey em - blacklisted <- lift . liftSem $ BlacklistStore.exists ek + blacklisted <- lift . liftSem $ BlockListStore.exists ek when blacklisted $ throwE (ChangeBlacklistedEmail email) available <- lift $ liftSem $ keyAvailable ek (Just u) @@ -804,7 +803,7 @@ onActivated (EmailActivated uid email) = do -- docs/reference/user/activation.md {#RefActivationRequest} sendActivationCode :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member EmailSubsystem r, Member GalleyAPIAccess r, Member UserKeyStore r @@ -819,11 +818,11 @@ sendActivationCode email loc _call = do (const . throwE . InvalidRecipient $ mkEmailKey email) (pure . mkEmailKey) (validateEmail email) - exists <- lift $ liftSem $ isJust <$> lookupKey ek - when exists $ + doesExist <- lift $ liftSem $ isJust <$> lookupKey ek + when doesExist $ throwE $ UserKeyInUse ek - blacklisted <- lift . liftSem $ BlacklistStore.exists ek + blacklisted <- lift . liftSem $ BlockListStore.exists ek when blacklisted $ throwE (ActivationBlacklistedUserKey ek) uc <- lift . wrapClient $ Data.lookupActivationCode ek @@ -1202,17 +1201,17 @@ lookupAccountsByIdentity email includePendingInvitations = do then pure result else pure $ filter ((/= PendingInvitation) . accountStatus) result -isBlacklisted :: (Member BlacklistStore r) => Email -> AppT r Bool +isBlacklisted :: (Member BlockListStore r) => Email -> AppT r Bool isBlacklisted email = do let uk = mkEmailKey email - liftSem $ BlacklistStore.exists uk + liftSem $ BlockListStore.exists uk -blacklistInsert :: (Member BlacklistStore r) => Email -> AppT r () +blacklistInsert :: (Member BlockListStore r) => Email -> AppT r () blacklistInsert email = do let uk = mkEmailKey email - liftSem $ BlacklistStore.insert uk + liftSem $ BlockListStore.insert uk -blacklistDelete :: (Member BlacklistStore r) => Email -> AppT r () +blacklistDelete :: (Member BlockListStore r) => Email -> AppT r () blacklistDelete email = do let uk = mkEmailKey email - liftSem $ BlacklistStore.delete uk + liftSem $ BlockListStore.delete uk diff --git a/services/brig/src/Brig/AWS/SesNotification.hs b/services/brig/src/Brig/AWS/SesNotification.hs index 9902d260830..261a9fd2ddb 100644 --- a/services/brig/src/Brig/AWS/SesNotification.hs +++ b/services/brig/src/Brig/AWS/SesNotification.hs @@ -22,25 +22,23 @@ where import Brig.AWS.Types import Brig.App -import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Effects.BlacklistStore qualified as BlacklistStore import Imports import Polysemy (Member) import System.Logger.Class (field, msg, (~~)) import System.Logger.Class qualified as Log import Wire.API.User.Identity -import Wire.UserKeyStore +import Wire.UserSubsystem -onEvent :: (Member BlacklistStore r) => SESNotification -> AppT r () +onEvent :: (Member UserSubsystem r) => SESNotification -> AppT r () onEvent (MailBounce BouncePermanent es) = onPermanentBounce es onEvent (MailBounce BounceTransient es) = onTransientBounce es onEvent (MailBounce BounceUndetermined es) = onUndeterminedBounce es onEvent (MailComplaint es) = onComplaint es -onPermanentBounce :: (Member BlacklistStore r) => [Email] -> AppT r () +onPermanentBounce :: (Member UserSubsystem r) => [Email] -> AppT r () onPermanentBounce = mapM_ $ \e -> do logEmailEvent "Permanent bounce" e - liftSem $ BlacklistStore.insert (mkEmailKey e) + liftSem $ blockListInsert e onTransientBounce :: [Email] -> AppT r () onTransientBounce = mapM_ (logEmailEvent "Transient bounce") @@ -48,10 +46,10 @@ onTransientBounce = mapM_ (logEmailEvent "Transient bounce") onUndeterminedBounce :: [Email] -> AppT r () onUndeterminedBounce = mapM_ (logEmailEvent "Undetermined bounce") -onComplaint :: (Member BlacklistStore r) => [Email] -> AppT r () +onComplaint :: (Member UserSubsystem r) => [Email] -> AppT r () onComplaint = mapM_ $ \e -> do logEmailEvent "Complaint" e - liftSem $ BlacklistStore.insert (mkEmailKey e) + liftSem $ blockListInsert e logEmailEvent :: Text -> Email -> AppT r () logEmailEvent t e = Log.info $ field "email" (fromEmail e) ~~ msg t diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 3e8a92f48d5..62aca48a5f8 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -3,8 +3,6 @@ module Brig.CanonicalInterpreter where import Brig.AWS (amazonkaEnv) import Brig.App as App import Brig.DeleteQueue.Interpreter as DQ -import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Effects.BlacklistStore.Cassandra (interpretBlacklistStoreToCassandra) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) import Brig.Effects.FederationConfigStore (FederationConfigStore) @@ -36,6 +34,8 @@ import Wire.API.Federation.Client qualified import Wire.API.Federation.Error import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Interpreter +import Wire.BlockListStore +import Wire.BlockListStore.Cassandra import Wire.DeleteQueue import Wire.EmailSending import Wire.EmailSending.SES @@ -120,7 +120,7 @@ type BrigCanonicalEffects = Jwk, PublicKeyBundle, JwtTools, - BlacklistStore, + BlockListStore, UserPendingActivationStore InternalPaging, Now, Delay, @@ -182,7 +182,7 @@ runBrigToIO e (AppT ma) = do . runDelay . nowToIOAction (e ^. currentTime) . userPendingActivationStoreToCassandra - . interpretBlacklistStoreToCassandra @Cas.Client + . interpretBlockListStoreToCassandra @Cas.Client . interpretJwtTools . interpretPublicKeyBundle . interpretJwk diff --git a/services/brig/src/Brig/Effects/BlacklistStore.hs b/services/brig/src/Brig/Effects/BlacklistStore.hs deleted file mode 100644 index e888194d7a3..00000000000 --- a/services/brig/src/Brig/Effects/BlacklistStore.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Brig.Effects.BlacklistStore where - -import Imports -import Polysemy -import Wire.UserKeyStore - -data BlacklistStore m a where - Insert :: EmailKey -> BlacklistStore m () - Exists :: EmailKey -> BlacklistStore m Bool - Delete :: EmailKey -> BlacklistStore m () - -makeSem ''BlacklistStore diff --git a/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs b/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs deleted file mode 100644 index 45ada1cebc9..00000000000 --- a/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Brig.Effects.BlacklistStore.Cassandra - ( interpretBlacklistStoreToCassandra, - ) -where - -import Brig.Effects.BlacklistStore (BlacklistStore (..)) -import Cassandra -import Imports -import Polysemy -import Wire.UserKeyStore - -interpretBlacklistStoreToCassandra :: - forall m r a. - (MonadClient m, Member (Embed m) r) => - Sem (BlacklistStore ': r) a -> - Sem r a -interpretBlacklistStoreToCassandra = - interpret $ - embed @m . \case - Insert uk -> insert uk - Exists uk -> exists uk - Delete uk -> delete uk - --------------------------------------------------------------------------------- --- UserKey blacklisting - -insert :: (MonadClient m) => EmailKey -> m () -insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ emailKeyUniq uk)) - -exists :: (MonadClient m) => EmailKey -> m Bool -exists uk = - (pure . isJust) . fmap runIdentity - =<< retry x1 (query1 keySelect (params LocalQuorum (Identity $ emailKeyUniq uk))) - -delete :: (MonadClient m) => EmailKey -> m () -delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq uk)) - -keyInsert :: PrepQuery W (Identity Text) () -keyInsert = "INSERT INTO blacklist (key) VALUES (?)" - -keySelect :: PrepQuery R (Identity Text) (Identity Text) -keySelect = "SELECT key FROM blacklist WHERE key = ?" - -keyDelete :: PrepQuery W (Identity Text) () -keyDelete = "DELETE FROM blacklist WHERE key = ?" diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 900506d6bd7..0bda80a9f68 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -32,8 +32,6 @@ import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App -import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Effects.BlacklistStore qualified as BlacklistStore import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) @@ -77,6 +75,7 @@ import Wire.API.Team.Role qualified as Public import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public import Wire.API.User.Identity qualified as Email +import Wire.BlockListStore import Wire.EmailSending (EmailSending) import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) @@ -88,8 +87,7 @@ import Wire.UserKeyStore import Wire.UserSubsystem servantAPI :: - ( Member BlacklistStore r, - Member GalleyAPIAccess r, + ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, Member EmailSending r @@ -118,8 +116,7 @@ getInvitationCode t r = do maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode) code createInvitationPublicH :: - ( Member BlacklistStore r, - Member GalleyAPIAccess r, + ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, Member EmailSending r @@ -143,8 +140,7 @@ data CreateInvitationInviter = CreateInvitationInviter deriving (Eq, Show) createInvitationPublic :: - ( Member BlacklistStore r, - Member GalleyAPIAccess r, + ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, Member EmailSending r @@ -173,12 +169,13 @@ createInvitationPublic uid tid body = do (createInvitation' tid Nothing inviteeRole (Just (inviterUid inviter)) (inviterEmail inviter) body) createInvitationViaScim :: - ( Member BlacklistStore r, + ( Member BlockListStore r, Member GalleyAPIAccess r, Member UserKeyStore r, Member (UserPendingActivationStore p) r, Member TinyLog r, - Member EmailSending r + Member EmailSending r, + Member UserSubsystem r ) => TeamId -> NewUserScimInvitation -> @@ -225,7 +222,7 @@ logInvitationRequest context action = pure (Right result) createInvitation' :: - ( Member BlacklistStore r, + ( Member UserSubsystem r, Member GalleyAPIAccess r, Member UserKeyStore r, Member EmailSending r @@ -244,7 +241,7 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do -- Validate e-mail inviteeEmail <- either (const $ throwStd (errorToWai @'E.InvalidEmail)) pure (Email.validateEmail (irInviteeEmail body)) let uke = mkEmailKey inviteeEmail - blacklistedEm <- lift $ liftSem $ BlacklistStore.exists uke + blacklistedEm <- lift $ liftSem $ isBlocked inviteeEmail when blacklistedEm $ throwStd blacklistedEmail emailTaken <- lift $ liftSem $ isJust <$> lookupKey uke From b3e3e22973c14f6727a692ae63228f3eca8f9282 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 24 Jul 2024 10:47:47 +0200 Subject: [PATCH 3/4] Add a changelog --- changelog.d/5-internal/WPB-8892 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/WPB-8892 diff --git a/changelog.d/5-internal/WPB-8892 b/changelog.d/5-internal/WPB-8892 new file mode 100644 index 00000000000..e808269195c --- /dev/null +++ b/changelog.d/5-internal/WPB-8892 @@ -0,0 +1 @@ +Brig was refactored by pulling out email block-listing into a wire subsystems effect, and its actions are exposed via the user subsystem. From 6f43ed61f376b62b4e9e7ab07680f3add75b5f41 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 24 Jul 2024 11:32:38 +0000 Subject: [PATCH 4/4] hi ci