From 618b994c60a5366ee2f6ff11a3a915c15b4c323a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 26 Jan 2026 16:58:52 +0000 Subject: [PATCH 01/11] generic migration lock --- .../src/Wire/ConversationStore/Cassandra.hs | 51 ++++++++++++++----- .../src/Wire/ConversationStore/Migration.hs | 6 +-- .../Wire/ConversationStore/Migration/Types.hs | 21 ++++++++ .../{ConversationStore => }/MigrationLock.hs | 42 +++++++-------- libs/wire-subsystems/wire-subsystems.cabal | 2 +- 5 files changed, 81 insertions(+), 41 deletions(-) rename libs/wire-subsystems/src/Wire/{ConversationStore => }/MigrationLock.hs (80%) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index 66f3943b90e..77ea2d6f00c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -76,8 +76,8 @@ import Wire.ConversationStore.Cassandra.Queries qualified as Cql import Wire.ConversationStore.Cassandra.Queries qualified as Queries import Wire.ConversationStore.MLS.Types import Wire.ConversationStore.Migration.Cleanup -import Wire.ConversationStore.MigrationLock import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) +import Wire.MigrationLock import Wire.Postgres import Wire.Sem.Paging.Cassandra import Wire.StoredConversation @@ -1094,7 +1094,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case True -> interpretConversationStoreToPostgres $ ConvStore.getConversationEpoch cid GetConversations cids -> do logEffect "ConversationStore.GetConversations" - withMigrationLocksAndCleanup client LockShared (Seconds 2) (Left <$> cids) $ do + withMigrationLocksAndConvCleanup client LockShared (Seconds 2) cids $ do let indexByConvId = foldr (\storedConv -> Map.insert storedConv.id_ storedConv) Map.empty cassConvs <- indexByConvId <$> localConversations client cids pgConvs <- indexByConvId <$> interpretConversationStoreToPostgres (ConvStore.getConversations cids) @@ -1163,7 +1163,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case True -> interpretConversationStoreToPostgres (ConvStore.isConversationAlive cid) SelectConversations uid cids -> do logEffect "ConversationStore.SelectConversations" - withMigrationLocksAndCleanup client LockShared (Seconds 2) (Left <$> cids) $ do + withMigrationLocksAndConvCleanup client LockShared (Seconds 2) cids $ do cassConvs <- embedClient client $ localConversationIdsOf uid cids pgConvs <- interpretConversationStoreToPostgres $ ConvStore.selectConversations uid cids pure $ List.nubOrd (pgConvs <> cassConvs) @@ -1287,7 +1287,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case logEffect "ConversationStore.CreateMembersInRemoteConversation" -- Save users joining their first remote conv in postgres - withMigrationLocksAndCleanup client LockShared (Seconds 2) (Right <$> uids) $ do + withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do filterUsersInPostgres uids >>= \pgUids -> do let -- These are not in Postgres, but that doesn't mean they're in -- cassandra @@ -1334,7 +1334,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case True -> interpretConversationStoreToPostgres $ ConvStore.checkLocalMemberRemoteConv uid rcnv SelectRemoteMembers uids rcnv -> do logEffect "ConversationStore.SelectRemoteMembers" - withMigrationLocksAndCleanup client LockShared (Seconds 2) (Right <$> uids) $ do + withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do filterUsersInPostgres uids >>= \pgUids -> do (pgUsers, _) <- interpretConversationStoreToPostgres $ ConvStore.selectRemoteMembers pgUids rcnv (cassUsers, _) <- embedClient client $ filterRemoteConvMembers uids rcnv @@ -1369,7 +1369,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case interpretConversationStoreToPostgres $ ConvStore.deleteMembers cid ul DeleteMembersInRemoteConversation rcnv uids -> do logEffect "ConversationStore.DeleteMembersInRemoteConversation" - withMigrationLocksAndCleanup client LockShared (Seconds 2) (Right <$> uids) $ do + withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do -- No need to check where these are, we just delete them from both places embedClient client $ removeLocalMembersFromRemoteConv rcnv uids interpretConversationStoreToPostgres $ ConvStore.deleteMembersInRemoteConversation rcnv uids @@ -1487,7 +1487,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case True -> interpretConversationStoreToPostgres $ ConvStore.isConversationOutOfSync convId HaveRemoteConvs uids -> do logEffect "ConversationStore.DeleteSubConversation" - withMigrationLocksAndCleanup client LockShared (Seconds 2) (Right <$> uids) $ do + withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do remotesInCass <- embedClient client $ haveRemoteConvs uids remotesInPG <- interpretConversationStoreToPostgres $ ConvStore.haveRemoteConvs uids pure $ List.nubOrd (remotesInPG <> remotesInCass) @@ -1532,10 +1532,12 @@ withMigrationLockAndCleanup :: Either ConvId UserId -> Sem (Error MigrationLockError : r) a -> Sem r a -withMigrationLockAndCleanup cassClient ty key = - withMigrationLocksAndCleanup cassClient ty (MilliSeconds 500) [key] +withMigrationLockAndCleanup cassClient ty (Left convId) = + withMigrationLocksAndConvCleanup cassClient ty (MilliSeconds 500) [convId] +withMigrationLockAndCleanup cassClient ty (Right userId) = + withMigrationLocksAndUserCleanup cassClient ty (MilliSeconds 500) [userId] -withMigrationLocksAndCleanup :: +withMigrationLocksAndConvCleanup :: ( PGConstraints r, Member Async r, Member TinyLog r, @@ -1546,12 +1548,33 @@ withMigrationLocksAndCleanup :: ClientState -> LockType -> u -> - [Either ConvId UserId] -> + [ConvId] -> + Sem (Error MigrationLockError : r) a -> + Sem r a +withMigrationLocksAndConvCleanup cassClient lockType maxWait convIds action = + mapError FailedToAcquireMigrationLock . withMigrationLocks lockType maxWait convIds $ do + interpretConversationStoreToCassandra cassClient + . runInputConst cassClient + $ cleanupIfNecessary (Left <$> convIds) + action + +withMigrationLocksAndUserCleanup :: + ( PGConstraints r, + Member Async r, + Member TinyLog r, + Member Race r, + Member (Error MigrationError) r, + TimeUnit u + ) => + ClientState -> + LockType -> + u -> + [UserId] -> Sem (Error MigrationLockError : r) a -> Sem r a -withMigrationLocksAndCleanup cassClient lockType maxWait convOrUsers action = - mapError FailedToAcquireMigrationLock . withMigrationLocks lockType maxWait convOrUsers $ do +withMigrationLocksAndUserCleanup cassClient lockType maxWait userIds action = + mapError FailedToAcquireMigrationLock . withMigrationLocks lockType maxWait userIds $ do interpretConversationStoreToCassandra cassClient . runInputConst cassClient - $ cleanupIfNecessary convOrUsers + $ cleanupIfNecessary (Right <$> userIds) action diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs index a3bf288c239..44cd9195115 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs @@ -67,8 +67,8 @@ import Wire.ConversationStore.Cassandra (interpretConversationStoreToCassandra) import Wire.ConversationStore.MLS.Types import Wire.ConversationStore.Migration.Cleanup import Wire.ConversationStore.Migration.Types -import Wire.ConversationStore.MigrationLock import Wire.Migration +import Wire.MigrationLock import Wire.Postgres import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (..), unsafePooledMapConcurrentlyN_) import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) @@ -216,7 +216,7 @@ migrateConversation :: ConvId -> Sem r () migrateConversation migCounter cid = do - void . withMigrationLocks LockExclusive (Seconds 10) [Left cid] $ do + void . withMigrationLocks LockExclusive (Seconds 10) [cid] $ do mConvData <- withCassandra $ getAllConvData cid for_ mConvData $ \convData -> do saveConvToPostgres convData @@ -445,7 +445,7 @@ saveConvToPostgres allConvData = do migrateUser :: (PGConstraints r, Member (Input ClientState) r, Member TinyLog r, Member Async r, Member (Error MigrationLockError) r, Member Race r) => Prometheus.Counter -> UserId -> Sem r () migrateUser migCounter uid = do - withMigrationLocks LockExclusive (Seconds 10) [Right uid] $ do + withMigrationLocks LockExclusive (Seconds 10) [uid] $ do statusses <- getRemoteMemberStatusFromCassandra uid saveRemoteMemberStatusToPostgres uid statusses deleteRemoteMemberStatusesFromCassandra uid diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs index 37e1bbe193c..dbab6c24efd 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -17,10 +20,14 @@ module Wire.ConversationStore.Migration.Types where +import Data.Bits +import Data.Id +import Data.UUID qualified as UUID import Imports import Wire.API.MLS.GroupInfo import Wire.API.MLS.LeafNode import Wire.ConversationStore.MLS.Types +import Wire.MigrationLock import Wire.StoredConversation data ConvMLSDetails = ConvMLSDetails @@ -39,3 +46,17 @@ data AllConvData = AllConvData mlsDetails :: Maybe ConvMLSDetails, subConvs :: [AllSubConvData] } + +instance MigrationLockable ConvId where + lockKey = hashUUID + lockScope _ = "conv" + +instance MigrationLockable UserId where + lockKey = hashUUID + lockScope _ = "user" + +hashUUID :: Id a -> Int64 +hashUUID (toUUID -> uuid) = + let (w1, w2) = UUID.toWords64 uuid + mixed = w1 `xor` (w2 `shiftR` 32) `xor` (w2 `shiftL` 32) + in fromIntegral mixed diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/MigrationLock.hs b/libs/wire-subsystems/src/Wire/MigrationLock.hs similarity index 80% rename from libs/wire-subsystems/src/Wire/ConversationStore/MigrationLock.hs rename to libs/wire-subsystems/src/Wire/MigrationLock.hs index e0830b5b176..c2121b123f3 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/MigrationLock.hs +++ b/libs/wire-subsystems/src/Wire/MigrationLock.hs @@ -15,11 +15,9 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationStore.MigrationLock where +module Wire.MigrationLock where -import Data.Bits -import Data.Id -import Data.UUID qualified as UUID +import Data.Proxy import Data.Vector (Vector) import Hasql.Pool qualified as Hasql import Hasql.Session qualified as Session @@ -38,8 +36,15 @@ import System.Logger.Message qualified as Log import Wire.API.PostgresMarshall import Wire.Postgres +class MigrationLockable a where + -- | namespace (e.g. "conv", "user", etc.), used for logging only + lockScope :: proxy a -> ByteString + + -- | globally unique key + lockKey :: a -> Int64 + data LockType - = -- | Used for migrating a conversation, will block any other locks + = -- | Used for migrating a single row, will block any other locks LockExclusive | -- | Used for reading and writing to Cassandra, will block exclusive locks LockShared @@ -48,25 +53,27 @@ data MigrationLockError = TimedOutAcquiringLock deriving (Show) withMigrationLocks :: + forall x a u r. ( PGConstraints r, Member Async r, Member TinyLog r, Member Race r, Member (Error MigrationLockError) r, - TimeUnit u + TimeUnit u, + MigrationLockable x ) => LockType -> u -> - [Either ConvId UserId] -> + [x] -> Sem r a -> Sem r a -withMigrationLocks lockType maxWait convOrUsers action = do +withMigrationLocks lockType maxWait lockables action = do lockAcquired <- embed newEmptyMVar actionCompleted <- embed newEmptyMVar pool <- input lockThread <- async . embed . Hasql.use pool $ do - let lockIds = map mkLockId convOrUsers + let lockIds = fmap lockKey lockables Session.statement lockIds acquireLocks liftIO $ putMVar lockAcquired () @@ -80,14 +87,14 @@ withMigrationLocks lockType maxWait convOrUsers action = do mEithErr <- timeout (cancel lockThread) (Seconds 1) $ await lockThread let logFirstLock = - case convOrUsers of + case lockables of [] -> id - (convOrUser : _) -> Log.field (either (const "first_conv") (const "first_user") convOrUser) (either idToText idToText convOrUser) + (x : _) -> Log.field ("first_" <> lockScope (Proxy @x)) (lockKey x) logError errorStr = TinyLog.warn $ Log.msg (Log.val "Failed to cleanly unlock the migration locks") . logFirstLock - . Log.field "numberOfLocks" (length convOrUsers) + . Log.field "numberOfLocks" (length lockables) . Log.field "error" errorStr case mEithErr of Left () -> logError "timed out waiting for unlock" @@ -97,17 +104,6 @@ withMigrationLocks lockType maxWait convOrUsers action = do pure res where - mkLockId :: Either ConvId UserId -> Int64 - mkLockId convOrUser = fromIntegral $ case convOrUser of - Left convId -> hashUUID convId - Right userId -> hashUUID userId - - hashUUID :: Id a -> Int64 - hashUUID (toUUID -> uuid) = - let (w1, w2) = UUID.toWords64 uuid - mixed = w1 `xor` (w2 `shiftR` 32) `xor` (w2 `shiftL` 32) - in fromIntegral mixed - acquireLocks :: Hasql.Statement [Int64] () acquireLocks = lmapPG @(Vector _) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 5dc5e19c770..000f00229ed 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -239,7 +239,6 @@ library Wire.ConversationStore.Migration Wire.ConversationStore.Migration.Cleanup Wire.ConversationStore.Migration.Types - Wire.ConversationStore.MigrationLock Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem @@ -298,6 +297,7 @@ library Wire.LegalHoldStore.Env Wire.ListItems Wire.Migration + Wire.MigrationLock Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter Wire.PaginationState From 8ee3c9c2d9533e9cb693db13272ef46ec9848667 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 26 Jan 2026 17:10:59 +0000 Subject: [PATCH 02/11] changelog --- changelog.d/5-internal/WPB-22959 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/WPB-22959 diff --git a/changelog.d/5-internal/WPB-22959 b/changelog.d/5-internal/WPB-22959 new file mode 100644 index 00000000000..8515eb0fbcc --- /dev/null +++ b/changelog.d/5-internal/WPB-22959 @@ -0,0 +1 @@ +Generalized the migration lock for better reuse From 12f4ac7396f71c841a679c01fc09e017cd0cbeaa Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 26 Jan 2026 17:14:00 +0000 Subject: [PATCH 03/11] correction of description --- libs/wire-subsystems/src/Wire/MigrationLock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/MigrationLock.hs b/libs/wire-subsystems/src/Wire/MigrationLock.hs index c2121b123f3..e70b0500640 100644 --- a/libs/wire-subsystems/src/Wire/MigrationLock.hs +++ b/libs/wire-subsystems/src/Wire/MigrationLock.hs @@ -44,7 +44,7 @@ class MigrationLockable a where lockKey :: a -> Int64 data LockType - = -- | Used for migrating a single row, will block any other locks + = -- | Used for migrating a set of data, will block any other locks LockExclusive | -- | Used for reading and writing to Cassandra, will block exclusive locks LockShared From 52e8f7c1915a439072906fbe9f6f3f77d2d95e4a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 26 Jan 2026 17:19:50 +0000 Subject: [PATCH 04/11] replace proxy with type application --- .../src/Wire/ConversationStore/Migration/Types.hs | 4 ++-- libs/wire-subsystems/src/Wire/MigrationLock.hs | 7 ++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs index dbab6c24efd..0683700b83b 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs @@ -49,11 +49,11 @@ data AllConvData = AllConvData instance MigrationLockable ConvId where lockKey = hashUUID - lockScope _ = "conv" + lockScope = "conv" instance MigrationLockable UserId where lockKey = hashUUID - lockScope _ = "user" + lockScope = "user" hashUUID :: Id a -> Int64 hashUUID (toUUID -> uuid) = diff --git a/libs/wire-subsystems/src/Wire/MigrationLock.hs b/libs/wire-subsystems/src/Wire/MigrationLock.hs index e70b0500640..305c1e27600 100644 --- a/libs/wire-subsystems/src/Wire/MigrationLock.hs +++ b/libs/wire-subsystems/src/Wire/MigrationLock.hs @@ -14,10 +14,11 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} module Wire.MigrationLock where -import Data.Proxy import Data.Vector (Vector) import Hasql.Pool qualified as Hasql import Hasql.Session qualified as Session @@ -38,7 +39,7 @@ import Wire.Postgres class MigrationLockable a where -- | namespace (e.g. "conv", "user", etc.), used for logging only - lockScope :: proxy a -> ByteString + lockScope :: ByteString -- | globally unique key lockKey :: a -> Int64 @@ -89,7 +90,7 @@ withMigrationLocks lockType maxWait lockables action = do let logFirstLock = case lockables of [] -> id - (x : _) -> Log.field ("first_" <> lockScope (Proxy @x)) (lockKey x) + (x : _) -> Log.field ("first_" <> lockScope @x) (lockKey x) logError errorStr = TinyLog.warn $ Log.msg (Log.val "Failed to cleanly unlock the migration locks") From 5dba29ac37bb921857057d431fc946b3b5d734cf Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 27 Jan 2026 08:27:32 +0000 Subject: [PATCH 05/11] moved instances, changed comment --- .../Wire/ConversationStore/Migration/Types.hs | 19 --------------- .../wire-subsystems/src/Wire/MigrationLock.hs | 23 ++++++++++++++++++- 2 files changed, 22 insertions(+), 20 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs index 0683700b83b..39487845d65 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Migration/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- This file is part of the Wire Server implementation. -- @@ -20,14 +19,10 @@ module Wire.ConversationStore.Migration.Types where -import Data.Bits -import Data.Id -import Data.UUID qualified as UUID import Imports import Wire.API.MLS.GroupInfo import Wire.API.MLS.LeafNode import Wire.ConversationStore.MLS.Types -import Wire.MigrationLock import Wire.StoredConversation data ConvMLSDetails = ConvMLSDetails @@ -46,17 +41,3 @@ data AllConvData = AllConvData mlsDetails :: Maybe ConvMLSDetails, subConvs :: [AllSubConvData] } - -instance MigrationLockable ConvId where - lockKey = hashUUID - lockScope = "conv" - -instance MigrationLockable UserId where - lockKey = hashUUID - lockScope = "user" - -hashUUID :: Id a -> Int64 -hashUUID (toUUID -> uuid) = - let (w1, w2) = UUID.toWords64 uuid - mixed = w1 `xor` (w2 `shiftR` 32) `xor` (w2 `shiftL` 32) - in fromIntegral mixed diff --git a/libs/wire-subsystems/src/Wire/MigrationLock.hs b/libs/wire-subsystems/src/Wire/MigrationLock.hs index 305c1e27600..20e847a8907 100644 --- a/libs/wire-subsystems/src/Wire/MigrationLock.hs +++ b/libs/wire-subsystems/src/Wire/MigrationLock.hs @@ -16,9 +16,13 @@ -- with this program. If not, see . {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Wire.MigrationLock where +import Data.Bits +import Data.Id +import Data.UUID qualified as UUID import Data.Vector (Vector) import Hasql.Pool qualified as Hasql import Hasql.Session qualified as Session @@ -41,7 +45,7 @@ class MigrationLockable a where -- | namespace (e.g. "conv", "user", etc.), used for logging only lockScope :: ByteString - -- | globally unique key + -- | key used for advisory locks; should be collision-resistant (unique with high probability) lockKey :: a -> Int64 data LockType @@ -130,3 +134,20 @@ withMigrationLocks lockType maxWait lockables action = do [resultlessStatement|SELECT (1 :: int) FROM (SELECT pg_advisory_unlock_shared(lockId) FROM (SELECT UNNEST($1 :: bigint[]) as lockId))|] + +-------------------------------------------------------------------------------- +-- INSTANCES + +instance MigrationLockable ConvId where + lockKey = hashUUID + lockScope = "conv" + +instance MigrationLockable UserId where + lockKey = hashUUID + lockScope = "user" + +hashUUID :: Id a -> Int64 +hashUUID (toUUID -> uuid) = + let (w1, w2) = UUID.toWords64 uuid + mixed = w1 `xor` (w2 `shiftR` 32) `xor` (w2 `shiftL` 32) + in fromIntegral mixed From 4d8a5f48f2de054912c40207ec13a0f8082b250e Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 27 Jan 2026 08:38:13 +0000 Subject: [PATCH 06/11] removed redundant ghc option --- libs/wire-subsystems/src/Wire/MigrationLock.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/MigrationLock.hs b/libs/wire-subsystems/src/Wire/MigrationLock.hs index 20e847a8907..d76448fb285 100644 --- a/libs/wire-subsystems/src/Wire/MigrationLock.hs +++ b/libs/wire-subsystems/src/Wire/MigrationLock.hs @@ -16,7 +16,6 @@ -- with this program. If not, see . {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Wire.MigrationLock where From e196c80c86584efd77ba2f1a652b09ef1a9a3fa3 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 27 Jan 2026 10:48:34 +0000 Subject: [PATCH 07/11] remove additional logic from TeamFeatureStore interpreter --- .../src/Wire/FeaturesConfigSubsystem.hs | 23 ++---- .../FeaturesConfigSubsystem/Interpreter.hs | 74 ++++++++++++----- .../src/Wire/TeamFeatureStore.hs | 25 ++++-- .../src/Wire/TeamFeatureStore/Cassandra.hs | 81 +++++++++---------- services/galley/src/Galley/API/LegalHold.hs | 25 +++--- .../galley/src/Galley/API/LegalHold/Team.hs | 10 +-- services/galley/src/Galley/API/Teams.hs | 15 ++-- .../galley/src/Galley/API/Teams/Features.hs | 6 +- .../src/Galley/API/Teams/Features/Get.hs | 20 +---- services/galley/src/Galley/App.hs | 2 +- 10 files changed, 149 insertions(+), 132 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs index 8d0e802d9f3..d8824e685c2 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs @@ -23,26 +23,15 @@ import Data.Id (TeamId, UserId) import Data.Qualified (Local) import Imports import Polysemy -import Wire.API.Team.Feature (AllTeamFeatures, LockableFeature) +import Wire.API.Team.Feature (AllTeamFeatures, DbFeature, LockableFeature) import Wire.FeaturesConfigSubsystem.Types data FeaturesConfigSubsystem m a where - GetFeature :: - forall cfg m. - (GetFeatureConfig cfg) => - UserId -> TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg) - GetFeatureForTeam :: - forall cfg m. - (GetFeatureConfig cfg) => - TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg) - GetFeatureForServer :: - forall cfg m. - (GetFeatureConfig cfg) => - FeaturesConfigSubsystem m (LockableFeature cfg) - GetFeatureForTeamUser :: - forall cfg m. - (GetFeatureConfig cfg) => - UserId -> Maybe TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg) + GetDbFeatureRawInternal :: forall cfg m. (GetFeatureConfig cfg) => TeamId -> FeaturesConfigSubsystem m (DbFeature cfg) + GetFeature :: forall cfg m. (GetFeatureConfig cfg) => UserId -> TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg) + GetFeatureForTeam :: forall cfg m. (GetFeatureConfig cfg) => TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg) + GetFeatureForServer :: forall cfg m. (GetFeatureConfig cfg) => FeaturesConfigSubsystem m (LockableFeature cfg) + GetFeatureForTeamUser :: forall cfg m. (GetFeatureConfig cfg) => UserId -> Maybe TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg) GetAllTeamFeaturesForTeamMember :: Local UserId -> TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForTeam :: TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForServer :: FeaturesConfigSubsystem m AllTeamFeatures diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs index e82d02a1d7a..0956d348447 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Wire.FeaturesConfigSubsystem.Interpreter where +import Data.Aeson.Types qualified as A import Data.Id import Data.Qualified (tUnqualified) import Data.SOP +import Data.Text.Lazy qualified as LT import Galley.Types.Teams import Imports import Polysemy +import Polysemy.Error import Polysemy.Input import Wire.API.Error import Wire.API.Error.Galley @@ -20,77 +25,108 @@ import Wire.TeamFeatureStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem +data TeamFeatureStoreError = TeamFeatureStoreErrorInternalError LText + runFeaturesConfigSubsystem :: forall r a. ( Member TeamFeatureStore r, Member TeamSubsystem r, + Member (Error TeamFeatureStoreError) r, Member (ErrorS 'NotATeamMember) r, GetFeatureConfigEffects r ) => Sem (FeaturesConfigSubsystem : r) a -> Sem r a runFeaturesConfigSubsystem = interpret $ \case + GetDbFeatureRawInternal tid -> getDbFeatureRawInternalImpl tid GetFeature uid tid -> do void $ TeamSubsystem.internalGetTeamMember uid tid >>= noteS @'NotATeamMember - doGetFeatureForTeam tid + getFeatureForTeamImpl tid GetFeatureForTeam tid -> - doGetFeatureForTeam tid + getFeatureForTeamImpl tid GetFeatureForServer -> resolveServerFeature GetFeatureForTeamUser uid mTid -> - doGetFeatureForTeamUser uid mTid + getFeatureForTeamUserImpl uid mTid GetAllTeamFeaturesForTeamMember luid tid -> do void $ TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid >>= noteS @'NotATeamMember - doGetAllTeamFeatures tid + getAllTeamFeaturesImpl tid GetAllTeamFeaturesForTeam tid -> - doGetAllTeamFeatures tid + getAllTeamFeaturesImpl tid GetAllTeamFeaturesForServer -> - doGetAllTeamFeaturesForServer + getAllTeamFeaturesForServerImpl -- Internal helpers -doGetFeatureForTeam :: +getFeatureForTeamImpl :: forall cfg r. ( GetFeatureConfig cfg, Member TeamFeatureStore r, + Member (Error TeamFeatureStoreError) r, GetFeatureConfigEffects r ) => TeamId -> Sem r (LockableFeature cfg) -doGetFeatureForTeam tid = do - dbFeature <- getDbFeature tid +getFeatureForTeamImpl tid = do + dbFeature <- getDbFeatureRawInternalImpl tid defFeature <- resolveServerFeature computeFeature tid defFeature dbFeature -doGetFeatureForTeamUser :: +getFeatureForTeamUserImpl :: forall cfg r. ( GetFeatureConfig cfg, Member TeamFeatureStore r, + Member (Error TeamFeatureStoreError) r, GetFeatureConfigEffects r ) => UserId -> Maybe TeamId -> Sem r (LockableFeature cfg) -doGetFeatureForTeamUser uid Nothing = getFeatureForUser uid -doGetFeatureForTeamUser _uid (Just tid) = doGetFeatureForTeam tid +getFeatureForTeamUserImpl uid Nothing = getFeatureForUser uid +getFeatureForTeamUserImpl _uid (Just tid) = getFeatureForTeamImpl tid -doGetAllTeamFeatures :: +getAllTeamFeaturesImpl :: forall r. ( Member TeamFeatureStore r, + Member (Error TeamFeatureStoreError) r, GetFeatureConfigEffects r ) => TeamId -> Sem r AllTeamFeatures -doGetAllTeamFeatures tid = do +getAllTeamFeaturesImpl tid = do features <- getAllDbFeatures tid - defFeatures <- doGetAllTeamFeaturesForServer + defFeatures <- getAllTeamFeaturesForServerImpl hsequence' $ hcliftA2 (Proxy @(GetAllFeaturesForServerConstraints r)) compute defFeatures features where - compute :: forall p. (GetFeatureConfig p) => LockableFeature p -> DbFeature p -> (Sem r :.: LockableFeature) p - compute defFeature feat = Comp $ computeFeature tid defFeature feat + compute :: forall p. (GetFeatureConfig p) => LockableFeature p -> K (Maybe DbFeaturePatch) p -> (Sem r :.: LockableFeature) p + compute defFeature (K mPatch) = Comp $ do + dbFeature <- maybe mempty id <$> traverse parseDbFeatureOrThrow mPatch + computeFeature tid defFeature dbFeature -doGetAllTeamFeaturesForServer :: forall r. (Member (Input FeatureFlags) r) => Sem r AllTeamFeatures -doGetAllTeamFeaturesForServer = +getAllTeamFeaturesForServerImpl :: forall r. (Member (Input FeatureFlags) r) => Sem r AllTeamFeatures +getAllTeamFeaturesForServerImpl = hsequence' $ hcpure (Proxy @GetFeatureConfig) $ Comp resolveServerFeature + +getDbFeatureRawInternalImpl :: + forall cfg r. + ( IsFeatureConfig cfg, + Member (Error TeamFeatureStoreError) r, + Member TeamFeatureStore r + ) => + TeamId -> Sem r (DbFeature cfg) +getDbFeatureRawInternalImpl tid = + maybe mempty id <$> (getDbFeature @cfg tid >>= traverse parseDbFeatureOrThrow) + +parseDbFeatureOrThrow :: + forall cfg r. + ( IsFeatureConfig cfg, + Member (Error TeamFeatureStoreError) r + ) => + DbFeaturePatch -> + Sem r (DbFeature cfg) +parseDbFeatureOrThrow feat = + mapError (TeamFeatureStoreErrorInternalError . LT.pack) + . fromEither + $ A.parseEither (const (parseDbFeature feat)) () diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs index 7be546ed65d..9f9a2527f2e 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs @@ -14,19 +14,27 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Wire.TeamFeatureStore where import Data.Id +import Data.SOP (K (..)) +import Imports import Polysemy import Wire.API.Team.Feature +type DbFeaturePatch = LockableFeaturePatch DbConfig + +type AllDbFeaturePatches = AllFeatures (K (Maybe DbFeaturePatch)) + data TeamFeatureStore m a where -- | Returns all stored feature values excluding lock status. GetDbFeature :: FeatureSingleton cfg -> TeamId -> - TeamFeatureStore m (DbFeature cfg) + TeamFeatureStore m (Maybe DbFeaturePatch) SetDbFeature :: FeatureSingleton cfg -> TeamId -> @@ -44,27 +52,30 @@ data TeamFeatureStore m a where TeamFeatureStore m () GetAllDbFeatures :: TeamId -> - TeamFeatureStore m (AllFeatures DbFeature) + TeamFeatureStore m AllDbFeaturePatches getDbFeature :: + forall cfg r. (Member TeamFeatureStore r, IsFeatureConfig cfg) => TeamId -> - Sem r (DbFeature cfg) -getDbFeature tid = send (GetDbFeature featureSingleton tid) + Sem r (Maybe DbFeaturePatch) +getDbFeature tid = send (GetDbFeature (featureSingleton @cfg) tid) setDbFeature :: + forall cfg r. (Member TeamFeatureStore r, IsFeatureConfig cfg) => TeamId -> LockableFeature cfg -> Sem r () -setDbFeature tid feat = send (SetDbFeature featureSingleton tid feat) +setDbFeature tid feat = send (SetDbFeature (featureSingleton @cfg) tid feat) patchDbFeature :: + forall cfg r. (Member TeamFeatureStore r, IsFeatureConfig cfg) => TeamId -> (LockableFeaturePatch cfg) -> Sem r () -patchDbFeature tid featPatch = send (PatchDbFeature featureSingleton tid featPatch) +patchDbFeature tid featPatch = send (PatchDbFeature (featureSingleton @cfg) tid featPatch) setFeatureLockStatus :: forall cfg r. @@ -75,5 +86,5 @@ setFeatureLockStatus :: setFeatureLockStatus tid lockStatus = send (SetFeatureLockStatus (featureSingleton @cfg) tid lockStatus) -getAllDbFeatures :: (Member TeamFeatureStore r) => TeamId -> Sem r (AllFeatures DbFeature) +getAllDbFeatures :: (Member TeamFeatureStore r) => TeamId -> Sem r AllDbFeaturePatches getAllDbFeatures tid = send (GetAllDbFeatures tid) diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs index 2a897bc6b3e..29ed1db7f26 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs @@ -17,65 +17,60 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.TeamFeatureStore.Cassandra (interpretTeamFeatureStoreToCassandra, TeamFeatureStoreError (..)) where +module Wire.TeamFeatureStore.Cassandra (interpretTeamFeatureStoreToCassandra) where import Cassandra -import Data.Aeson.Types qualified as A import Data.Constraint import Data.Id import Data.Map qualified as M -import Data.Text.Lazy qualified as LT +import Data.Proxy +import Data.SOP (K (..), hcpure) +import Data.SOP.Constraint qualified as SOP import Imports import Polysemy -import Polysemy.Error import Polysemy.Input import Wire.API.Team.Feature import Wire.API.Team.Feature.TH import Wire.ConversationStore.Cassandra.Instances () -import Wire.TeamFeatureStore (TeamFeatureStore (..)) +import Wire.TeamFeatureStore (AllDbFeaturePatches, DbFeaturePatch, TeamFeatureStore (..)) import Wire.Util -data TeamFeatureStoreError = TeamFeatureStoreErrorInternalError LText - interpretTeamFeatureStoreToCassandra :: ( Member (Embed IO) r, - Member (Input ClientState) r, - Member (Error TeamFeatureStoreError) r + Member (Input ClientState) r ) => Sem (TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case GetDbFeature sing tid -> do - getDbFeatureDyn sing tid + getDbFeatureImpl sing tid SetDbFeature sing tid feat -> do - setDbFeatureDyn sing tid feat + setDbFeatureImpl sing tid feat SetFeatureLockStatus sing tid lock -> do - setFeatureLockStatusDyn sing tid (Tagged lock) + setFeatureLockStatusImpl sing tid (Tagged lock) GetAllDbFeatures tid -> do - getAllDbFeaturesDyn tid + getAllDbFeaturesImpl tid PatchDbFeature sing tid feat -> do - patchDbFeatureDyn sing tid feat + patchDbFeatureImpl sing tid feat -getDbFeatureDyn :: +getDbFeatureImpl :: forall cfg r. ( Member (Input ClientState) r, - Member (Embed IO) r, - Member (Error TeamFeatureStoreError) r + Member (Embed IO) r ) => FeatureSingleton cfg -> TeamId -> - Sem r (DbFeature cfg) -getDbFeatureDyn sing tid = case featureSingIsFeature sing of + Sem r (Maybe DbFeaturePatch) +getDbFeatureImpl sing tid = case featureSingIsFeature sing of Dict -> do let q :: PrepQuery R (TeamId, Text) (Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) q = "select status, lock_status, config from team_features_dyn where team = ? and feature = ?" (embedClientInput (retry x1 $ query1 q (params LocalQuorum (tid, featureName @cfg)))) >>= \case - Nothing -> pure mempty + Nothing -> pure Nothing Just (status, lockStatus, config) -> - runFeatureParser . parseDbFeature $ - LockableFeaturePatch {..} + pure $ Just LockableFeaturePatch {..} -setDbFeatureDyn :: +setDbFeatureImpl :: forall cfg r. ( Member (Input ClientState) r, Member (Embed IO) r @@ -84,8 +79,8 @@ setDbFeatureDyn :: TeamId -> LockableFeature cfg -> Sem r () -setDbFeatureDyn sing tid feat = - patchDbFeatureDyn +setDbFeatureImpl sing tid feat = + patchDbFeatureImpl sing tid ( LockableFeaturePatch @@ -95,7 +90,7 @@ setDbFeatureDyn sing tid feat = } ) -patchDbFeatureDyn :: +patchDbFeatureImpl :: forall cfg r. ( Member (Input ClientState) r, Member (Embed IO) r @@ -104,7 +99,7 @@ patchDbFeatureDyn :: TeamId -> LockableFeaturePatch cfg -> Sem r () -patchDbFeatureDyn sing tid patch = case featureSingIsFeature sing of +patchDbFeatureImpl sing tid patch = case featureSingIsFeature sing of Dict -> embedClientInput $ do retry x5 . batch $ do setType BatchLogged @@ -122,7 +117,7 @@ patchDbFeatureDyn sing tid patch = case featureSingIsFeature sing of writeConfig :: PrepQuery W (DbConfig, TeamId, Text) () writeConfig = "update team_features_dyn set config = ? where team = ? and feature = ?" -setFeatureLockStatusDyn :: +setFeatureLockStatusImpl :: forall cfg r. ( Member (Input ClientState) r, Member (Embed IO) r @@ -131,7 +126,7 @@ setFeatureLockStatusDyn :: TeamId -> Tagged cfg LockStatus -> Sem r () -setFeatureLockStatusDyn sing tid (Tagged lockStatus) = case featureSingIsFeature sing of +setFeatureLockStatusImpl sing tid (Tagged lockStatus) = case featureSingIsFeature sing of Dict -> do let q :: PrepQuery W (LockStatus, TeamId, Text) () q = "update team_features_dyn set lock_status = ? where team = ? and feature = ?" @@ -139,28 +134,26 @@ setFeatureLockStatusDyn sing tid (Tagged lockStatus) = case featureSingIsFeature retry x5 $ write q (params LocalQuorum (lockStatus, tid, featureName @cfg)) -getAllDbFeaturesDyn :: +getAllDbFeaturesImpl :: ( Member (Embed IO) r, - Member (Input ClientState) r, - Member (Error TeamFeatureStoreError) r + Member (Input ClientState) r ) => TeamId -> - Sem r (AllFeatures DbFeature) -getAllDbFeaturesDyn tid = do + Sem r AllDbFeaturePatches +getAllDbFeaturesImpl tid = do let q :: PrepQuery R (Identity TeamId) (Text, Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) q = "select feature, status, lock_status, config from team_features_dyn where team = ?" rows <- embedClientInput $ retry x1 $ query q (params LocalQuorum (Identity tid)) let m = M.fromList $ do (name, status, lockStatus, config) <- rows pure (name, LockableFeaturePatch {..}) - runFeatureParser $ mkAllFeatures m + pure $ mkAllDbFeaturePatches m -runFeatureParser :: - forall r a. - (Member (Error TeamFeatureStoreError) r) => - A.Parser a -> - Sem r a -runFeatureParser p = - mapError (TeamFeatureStoreErrorInternalError . LT.pack) - . fromEither - $ A.parseEither (const p) () +mkAllDbFeaturePatches :: + (SOP.All IsFeatureConfig Features) => + M.Map Text DbFeaturePatch -> + AllDbFeaturePatches +mkAllDbFeaturePatches m = hcpure (Proxy @IsFeatureConfig) get + where + get :: forall cfg. (IsFeatureConfig cfg) => K (Maybe DbFeaturePatch) cfg + get = K (M.lookup (featureName @cfg) m) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 2aa4a480886..6faadb492ee 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -80,6 +80,7 @@ import Wire.BrigAPIAccess import Wire.ConversationStore import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.FeaturesConfigSubsystem import Wire.FireAndForget import Wire.LegalHoldStore qualified as LegalHoldData import Wire.NotificationSubsystem @@ -101,10 +102,10 @@ createSettings :: Member (ErrorS 'LegalHoldServiceInvalidKey) r, Member (ErrorS 'LegalHoldServiceBadResponse) r, Member LegalHoldStore r, - Member TeamFeatureStore r, Member P.TinyLog r, Member (Input (FeatureDefaults LegalholdConfig)) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r ) => Local UserId -> TeamId -> @@ -131,9 +132,9 @@ getSettings :: forall r. ( Member (ErrorS 'NotATeamMember) r, Member LegalHoldStore r, - Member TeamFeatureStore r, Member (Input (FeatureDefaults LegalholdConfig)) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r ) => Local UserId -> TeamId -> @@ -177,7 +178,6 @@ removeSettingsInternalPaging :: Member ProposalStore r, Member P.TinyLog r, Member Random r, - Member TeamFeatureStore r, Member (TeamMemberStore InternalPaging) r, Member TeamStore r, Member (Embed IO) r, @@ -185,7 +185,8 @@ removeSettingsInternalPaging :: Member MLSCommitLockStore r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input ConversationSubsystemConfig) r, + Member FeaturesConfigSubsystem r ) => Local UserId -> TeamId -> @@ -197,7 +198,6 @@ removeSettings :: forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), - Member TeamFeatureStore r, Member (TeamMemberStore p) r, Member TeamStore r, Member BackendNotificationQueueAccess r, @@ -231,7 +231,8 @@ removeSettings :: Member MLSCommitLockStore r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input ConversationSubsystemConfig) r, + Member FeaturesConfigSubsystem r ) => UserId -> TeamId -> @@ -388,14 +389,14 @@ requestDevice :: Member ProposalStore r, Member P.TinyLog r, Member Random r, - Member TeamFeatureStore r, Member TeamStore r, Member (Embed IO) r, Member TeamCollaboratorsSubsystem r, Member MLSCommitLockStore r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input ConversationSubsystemConfig) r, + Member FeaturesConfigSubsystem r ) => Local UserId -> TeamId -> @@ -485,14 +486,14 @@ approveDevice :: Member ProposalStore r, Member P.TinyLog r, Member Random r, - Member TeamFeatureStore r, Member TeamStore r, Member (Embed IO) r, Member TeamCollaboratorsSubsystem r, Member MLSCommitLockStore r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input ConversationSubsystemConfig) r, + Member FeaturesConfigSubsystem r ) => Local UserId -> ConnId -> diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index 977fcfb2918..92f1eac3fb4 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -37,15 +37,15 @@ import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.Size import Wire.BrigAPIAccess +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) import Wire.LegalHold -import Wire.TeamFeatureStore assertLegalHoldEnabledForTeam :: forall r. ( Member LegalHoldStore r, - Member TeamFeatureStore r, Member (Input (FeatureDefaults LegalholdConfig)) r, - Member (ErrorS 'LegalHoldNotEnabled) r + Member (ErrorS 'LegalHoldNotEnabled) r, + Member FeaturesConfigSubsystem r ) => TeamId -> Sem r () @@ -56,13 +56,13 @@ assertLegalHoldEnabledForTeam tid = isLegalHoldEnabledForTeam :: forall r. ( Member LegalHoldStore r, - Member TeamFeatureStore r, + Member FeaturesConfigSubsystem r, Member (Input (FeatureDefaults LegalholdConfig)) r ) => TeamId -> Sem r Bool isLegalHoldEnabledForTeam tid = do - dbFeature <- getDbFeature tid + dbFeature <- getDbFeatureRawInternal tid status <- computeLegalHoldFeatureStatus tid dbFeature pure $ status == FeatureStatusEnabled diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 2ac49386349..8d38865b50c 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -526,13 +526,13 @@ addTeamMember :: Member (Input Opts) r, Member Now r, Member LegalHoldStore r, - Member TeamFeatureStore r, Member TeamNotificationStore r, Member TeamStore r, Member P.TinyLog r, Member (Input FanoutLimit) r, Member (Input (FeatureDefaults LegalholdConfig)) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r ) => Local UserId -> ConnId -> @@ -575,7 +575,8 @@ uncheckedAddTeamMember :: Member TeamStore r, Member (Input FanoutLimit) r, Member (Input (FeatureDefaults LegalholdConfig)) r, - Member TeamJournal r + Member TeamJournal r, + Member FeaturesConfigSubsystem r ) => TeamId -> NewTeamMember -> @@ -1115,10 +1116,10 @@ ensureNotTooLarge tid = do ensureNotTooLargeForLegalHold :: forall r. ( Member LegalHoldStore r, - Member TeamFeatureStore r, Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, Member (Input FanoutLimit) r, - Member (Input (FeatureDefaults LegalholdConfig)) r + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member FeaturesConfigSubsystem r ) => TeamId -> Int -> @@ -1204,10 +1205,10 @@ canUserJoinTeam :: forall r. ( Member BrigAPIAccess r, Member LegalHoldStore r, - Member TeamFeatureStore r, Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, Member (Input FanoutLimit) r, - Member (Input (FeatureDefaults LegalholdConfig)) r + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member FeaturesConfigSubsystem r ) => TeamId -> Sem r () diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 4c9bf4b9797..d16588f9d2d 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -71,7 +71,7 @@ import Wire.CodeStore import Wire.ConversationStore (MLSCommitLockStore) import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem import Wire.FeaturesConfigSubsystem.Types (GetFeatureConfigEffects) import Wire.FeaturesConfigSubsystem.Utils (resolveServerFeature) import Wire.NotificationSubsystem @@ -104,8 +104,8 @@ patchFeatureInternal :: Sem r (LockableFeature cfg) patchFeatureInternal tid patch = do assertTeamExists tid - dbFeature <- getDbFeature tid - (defFeature :: LockableFeature cfg) <- resolveServerFeature + dbFeature <- getDbFeatureRawInternal tid + defFeature :: LockableFeature cfg <- resolveServerFeature let dbFeatureWithDefaults = dbFeature.applyDbFeature defFeature let patchedFeature = applyPatch dbFeatureWithDefaults prepareFeature tid patchedFeature diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index ece1922543c..0c2dd6ddd38 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -50,11 +50,11 @@ import Wire.API.Team.Feature import Wire.ConversationStore as ConversationStore import Wire.FeaturesConfigSubsystem import Wire.FeaturesConfigSubsystem.Types -import Wire.TeamFeatureStore import Wire.TeamStore qualified as TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem +-- FUTUREWORK: everything in this module should be moved to the FeatureConfigSubsystem data DoAuth = DoAuth UserId | DontDoAuth getFeatureInternal :: @@ -90,29 +90,15 @@ getTeamAndCheckMembership uid = do getAllTeamFeatures :: forall r. - ( Member TeamFeatureStore r, - Member FeaturesConfigSubsystem r, - GetFeatureConfigEffects r - ) => + (Member FeaturesConfigSubsystem r) => TeamId -> Sem r AllTeamFeatures -getAllTeamFeatures tid = do - features <- getAllDbFeatures tid - defFeatures <- getAllTeamFeaturesForServer - hsequence' $ hcliftA2 (Proxy @(GetAllFeaturesForServerConstraints r)) compute defFeatures features - where - compute :: - (GetFeatureConfig p) => - LockableFeature p -> - DbFeature p -> - (Sem r :.: LockableFeature) p - compute defFeature feat = Comp $ computeFeature tid defFeature feat +getAllTeamFeatures tid = getAllTeamFeaturesForTeam tid getAllTeamFeaturesForUser :: forall r. ( Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TeamNotFound) r, - Member TeamFeatureStore r, Member TeamStore r, Member TeamSubsystem r, Member FeaturesConfigSubsystem r, diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 2035a64c1cf..9f7798f85d4 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -115,7 +115,7 @@ import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..), import Wire.Error import Wire.ExternalAccess.External import Wire.FeaturesConfigSubsystem -import Wire.FeaturesConfigSubsystem.Interpreter (runFeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem.Interpreter import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist (..)) import Wire.FederationAPIAccess.Interpreter import Wire.FireAndForget From ea108b902b362b7f8bae1e29d13b22db3089ae5a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 27 Jan 2026 10:50:47 +0000 Subject: [PATCH 08/11] changelog --- changelog.d/5-internal/WPB-22959 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/changelog.d/5-internal/WPB-22959 b/changelog.d/5-internal/WPB-22959 index 8515eb0fbcc..c073df6a257 100644 --- a/changelog.d/5-internal/WPB-22959 +++ b/changelog.d/5-internal/WPB-22959 @@ -1 +1,3 @@ -Generalized the migration lock for better reuse +- Generalized the migration lock for better reuse +- Move logic from `TeamFeatureStore` interpreter to `FeatureConfigSubsystem` +(#4982, #4983) From 0614d33e7e8a9f520ffbe8fe2dd5373057f8db7e Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 27 Jan 2026 13:13:08 +0000 Subject: [PATCH 09/11] fix lint issue --- .../src/Wire/FeaturesConfigSubsystem/Interpreter.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs index 0956d348447..852e4d57c87 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs @@ -100,7 +100,7 @@ getAllTeamFeaturesImpl tid = do where compute :: forall p. (GetFeatureConfig p) => LockableFeature p -> K (Maybe DbFeaturePatch) p -> (Sem r :.: LockableFeature) p compute defFeature (K mPatch) = Comp $ do - dbFeature <- maybe mempty id <$> traverse parseDbFeatureOrThrow mPatch + dbFeature <- fromMaybe mempty <$> traverse parseDbFeatureOrThrow mPatch computeFeature tid defFeature dbFeature getAllTeamFeaturesForServerImpl :: forall r. (Member (Input FeatureFlags) r) => Sem r AllTeamFeatures @@ -117,7 +117,7 @@ getDbFeatureRawInternalImpl :: ) => TeamId -> Sem r (DbFeature cfg) getDbFeatureRawInternalImpl tid = - maybe mempty id <$> (getDbFeature @cfg tid >>= traverse parseDbFeatureOrThrow) + fromMaybe mempty <$> (getDbFeature @cfg tid >>= traverse parseDbFeatureOrThrow) parseDbFeatureOrThrow :: forall cfg r. From 0ea15879e9958772df68e754d4662e04a984ee41 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 27 Jan 2026 13:39:02 +0000 Subject: [PATCH 10/11] lint issue --- services/galley/src/Galley/API/Teams.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 8d38865b50c..32539143f44 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -570,7 +570,6 @@ uncheckedAddTeamMember :: Member Now r, Member LegalHoldStore r, Member P.TinyLog r, - Member TeamFeatureStore r, Member TeamNotificationStore r, Member TeamStore r, Member (Input FanoutLimit) r, From 2961863f348dcfca6943a9e00cc566c26e317309 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 29 Jan 2026 09:05:30 +0000 Subject: [PATCH 11/11] revomved unused extensions --- libs/wire-subsystems/src/Wire/TeamFeatureStore.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs index 9f9a2527f2e..3da95cbd4e0 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore.hs @@ -14,9 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - module Wire.TeamFeatureStore where import Data.Id