[WPB-8892] Add block list operations to the user subsystem

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.

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

services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs → libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs

@@ -1,28 +1,28 @@
-module Brig.Effects.BlacklistStore.Cassandra
-  ( interpretBlacklistStoreToCassandra,
+module Wire.BlockListStore.Cassandra
+  ( interpretBlockListStoreToCassandra,
   )
 where
 
-import Brig.Effects.BlacklistStore (BlacklistStore (..))
 import Cassandra
 import Imports
 import Polysemy
+import Wire.BlockListStore (BlockListStore (..))
 import Wire.UserKeyStore
 
-interpretBlacklistStoreToCassandra ::
+interpretBlockListStoreToCassandra ::
   forall m r a.
   (MonadClient m, Member (Embed m) r) =>
-  Sem (BlacklistStore ': r) a ->
+  Sem (BlockListStore ': r) a ->
   Sem r a
-interpretBlacklistStoreToCassandra =
+interpretBlockListStoreToCassandra =
   interpret $
     embed @m . \case
       Insert uk -> insert uk
       Exists uk -> exists uk
       Delete uk -> delete uk
 
 --------------------------------------------------------------------------------
--- UserKey blacklisting
+-- UserKey block listing
 
 insert :: (MonadClient m) => EmailKey -> m ()
 insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ emailKeyUniq uk))

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

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

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,15 +121,17 @@ 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
   def =
     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)

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

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

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

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

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

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

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