From 89b1b15adab0f71700ff204f1b8282f53e81d55c Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 21 Oct 2026 11:14:30 +0000 Subject: [PATCH 1/6] WPB-22953: migrate connections to PostGreSQL --- changelog.d/5-internal/WPB-22953 | 1 + .../background-worker/configmap.yaml | 1 + charts/wire-server/values.yaml | 5 + .../src/developer/reference/config-options.md | 10 + hack/helm_vars/common.yaml.gotmpl | 1 + hack/helm_vars/wire-server/values.yaml.gotmpl | 1 + integration/integration.cabal | 1 + .../test/Test/Migration/Connections.hs | 107 ++++ libs/wire-api/src/Wire/API/Connection.hs | 32 ++ .../Wire/API/Roundtrip/PostgresMarshall.hs | 2 + .../20261021102943-connections.sql | 39 ++ .../src/Wire/ConnectionStore.hs | 111 ++++ .../src/Wire/ConnectionStore/Cassandra.hs | 382 ++++++++++++++ .../src/Wire/ConnectionStore/DualWrite.hs | 81 +++ .../src/Wire/ConnectionStore/Migration.hs | 236 +++++++++ .../src/Wire/ConnectionStore/Postgres.hs | 499 ++++++++++++++++++ .../src/Wire/PostgresMigrationOpts.hs | 4 +- libs/wire-subsystems/wire-subsystems.cabal | 5 + postgres-schema.sql | 55 ++ .../background-worker.integration.yaml | 2 + .../src/Wire/BackgroundWorker.hs | 10 +- .../src/Wire/BackgroundWorker/Options.hs | 1 + .../src/Wire/PostgresMigrations.hs | 19 + .../Wire/BackendNotificationPusherSpec.hs | 6 +- .../background-worker/test/Test/Wire/Util.hs | 3 +- services/brig/brig.cabal | 3 - services/brig/brig.integration.yaml | 1 + services/brig/default.nix | 2 - services/brig/src/Brig/API/Connection.hs | 88 ++- .../brig/src/Brig/API/Connection/Remote.hs | 36 +- services/brig/src/Brig/API/Connection/Util.hs | 11 +- services/brig/src/Brig/API/Federation.hs | 20 +- services/brig/src/Brig/API/Internal.hs | 45 +- services/brig/src/Brig/API/Public.hs | 66 ++- services/brig/src/Brig/API/User.hs | 24 +- .../brig/src/Brig/CanonicalInterpreter.hs | 25 +- services/brig/src/Brig/Data/Connection.hs | 412 ++------------- .../brig/src/Brig/Effects/ConnectionStore.hs | 52 -- .../Brig/Effects/ConnectionStore/Cassandra.hs | 41 -- services/brig/src/Brig/IO/Intra.hs | 24 +- .../brig/src/Brig/InternalEvent/Process.hs | 3 + services/brig/src/Brig/Team/API.hs | 6 +- services/brig/src/Brig/User/EJPD.hs | 7 +- .../test/integration/API/User/Connection.hs | 2 +- services/galley/galley.integration.yaml | 1 + 45 files changed, 1908 insertions(+), 575 deletions(-) create mode 100644 changelog.d/5-internal/WPB-22953 create mode 100644 integration/test/Test/Migration/Connections.hs create mode 100644 libs/wire-subsystems/postgres-migrations/20261021102943-connections.sql create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore.hs create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore/DualWrite.hs create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore/Migration.hs create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs delete mode 100644 services/brig/src/Brig/Effects/ConnectionStore.hs delete mode 100644 services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs diff --git a/changelog.d/5-internal/WPB-22953 b/changelog.d/5-internal/WPB-22953 new file mode 100644 index 00000000000..31d8706b590 --- /dev/null +++ b/changelog.d/5-internal/WPB-22953 @@ -0,0 +1 @@ +Migration of connections from cassandra to postgres diff --git a/charts/wire-server/templates/background-worker/configmap.yaml b/charts/wire-server/templates/background-worker/configmap.yaml index 8a658f15799..551655a134e 100644 --- a/charts/wire-server/templates/background-worker/configmap.yaml +++ b/charts/wire-server/templates/background-worker/configmap.yaml @@ -89,6 +89,7 @@ data: migratePasswordReset: {{ .migratePasswordReset }} migrateCustomBackend: {{ .migrateCustomBackend }} migrateNonce: {{ .migrateNonce }} + migrateConnections: {{ .migrateConnections }} migrationOptions: {{ toYaml .migrationOptions | indent 6 }} diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index f03828519b7..1b97df53e90 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -98,6 +98,7 @@ galley: customBackend: cassandra budget: cassandra nonce: cassandra + connections: cassandra settings: httpPoolSize: 128 maxTeamSize: 10000 @@ -1049,6 +1050,10 @@ background-worker: # It's important to set `settings.postgresMigration.nonce` to `migration-to-postgresql` # before starting the migration. migrateNonce: false + # This will start the migration of connection data. + # It's important to set `settings.postgresMigration.connections` to `migration-to-postgresql` + # before starting the migration. + migrateConnections: false # This will start the migration of custom backends. It's important to set # galley's postgresMigration.customBackend to migration-to-postgresql first. diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index ddc64779807..55475d6186f 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -2334,6 +2334,7 @@ galley: customBackend: postgresql budget: postgresql nonce: postgresql + connections: postgresql background-worker: config: migrateConversations: false @@ -2344,6 +2345,7 @@ background-worker: migratePasswordReset: false migrateCustomBackend: false migrateNonce: false + migrateConnections: false ``` #### Migration for existing installations @@ -2379,6 +2381,7 @@ The current settings and their background-worker flags are: - `passwordReset` -> `migratePasswordReset` - `customBackend` -> `migrateCustomBackend` - `budget` -> none (ephemeral TTL'd rate-limit counters; no backfill worker, no `wire_budget_migration_finished` metric — Cassandra rows age out on their own while new writes go to PostgreSQL under `migration-to-postgresql`). Because there is no backfill, keep `budget` on `migration-to-postgresql` for at least the longest configured `limitFailedLogins.timeout` (with PostgreSQL mirror writes healthy) before cutting over to `postgresql`; otherwise counters that only exist in Cassandra are dropped and affected users get one extra rate-limit window. +- `connections` -> `migrateConnections` **Migration pattern per migration setting** @@ -2404,6 +2407,7 @@ The current settings and their background-worker flags are: customBackend: cassandra budget: cassandra nonce: cassandra + connections: cassandra background-worker: config: migrateConversations: false @@ -2415,6 +2419,7 @@ The current settings and their background-worker flags are: migratePasswordReset: false migrateCustomBackend: false migrateNonce: false + migrateConnections: false ``` This change should restart the affected pods, and new writes will follow the @@ -2433,6 +2438,7 @@ The current settings and their background-worker flags are: migrateBlockList: true migratePasswordReset: true migrateCustomBackend: true + migrateConnections: true ``` During migration, Cassandra rows are not deleted. Writes and migration share @@ -2462,6 +2468,7 @@ The current settings and their background-worker flags are: - `passwordReset`: `wire_password_reset_migration_finished` - `customBackend`: `wire_custom_backend_migration_finished` - `nonce`: `wire_nonce_migration_finished` + - `connections`: `wire_connections_migration_finished` 3. Cut over reads and writes to PostgreSQL for the selected migration setting(s). This configuration must be used from now on for every new @@ -2481,6 +2488,7 @@ The current settings and their background-worker flags are: customBackend: postgresql budget: postgresql nonce: postgresql + connections: postgresql background-worker: config: migrateConversations: false @@ -2492,6 +2500,7 @@ The current settings and their background-worker flags are: migratePasswordReset: false migrateCustomBackend: false migrateNonce: false + migrateConnections: false ``` **How to run migrations independently or in batches** @@ -2584,6 +2593,7 @@ migrateBlockList: false migratePasswordReset: false migrateCustomBackend: false migrateNonce: false +migrateConnections: false # migration settings migrationOptions: diff --git a/hack/helm_vars/common.yaml.gotmpl b/hack/helm_vars/common.yaml.gotmpl index 606073f8727..7a01d789810 100644 --- a/hack/helm_vars/common.yaml.gotmpl +++ b/hack/helm_vars/common.yaml.gotmpl @@ -24,6 +24,7 @@ userStore: {{ $preferredStore }} blockListStore: {{ $preferredStore }} budgetStore: {{ $preferredStore }} nonceStore: {{ $preferredStore }} +connectionsStore: {{ $preferredStore }} {{- if (eq (env "UPLOAD_XML_S3_BASE_URL") "") }} uploadXml: {} diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index ae84028ec95..132a9315668 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -315,6 +315,7 @@ galley: blockList: {{ .Values.blockListStore }} budget: {{ .Values.budgetStore }} nonce: {{ .Values.nonceStore }} + connections: {{ .Values.connectionsStore }} settings: maxConvAndTeamSize: 16 maxTeamSize: 32 diff --git a/integration/integration.cabal b/integration/integration.cabal index 13b79444433..4e0a83a9d8f 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -179,6 +179,7 @@ library Test.MessageTimer Test.Migration.BlockList Test.Migration.Budget + Test.Migration.Connections Test.Migration.Conversation Test.Migration.ConversationCodes Test.Migration.CustomBackend diff --git a/integration/test/Test/Migration/Connections.hs b/integration/test/Test/Migration/Connections.hs new file mode 100644 index 00000000000..d40a6d7e578 --- /dev/null +++ b/integration/test/Test/Migration/Connections.hs @@ -0,0 +1,107 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Migration.Connections (testConnectionsMigrationToPostgres) where + +import API.Brig (getConnection, postConnection, putConnection) +import Control.Monad.Codensity +import Control.Monad.Reader +import GHC.Stack +import SetupHelpers +import Test.Migration.Util (assertMigrationSuccessful, waitForMigration) +import Testlib.Prelude +import Testlib.ResourcePool + +-- | Drives the connections store through the full cutover lifecycle +-- (cassandra -> migration-to-postgresql -> postgresql) on a dynamic backend. +-- Every phase creates a fresh pair of users and connects them via the brig +-- public API, exercising the writes of all three interpreters (Cassandra, +-- dual-write, Postgres). Connections written by earlier interpreters must +-- remain readable afterwards: the pair connected during the pure-Cassandra +-- phase proves the background worker backfilled rows that only ever existed +-- in Cassandra. +-- +-- Remote ('connection_remote') rows are not seeded explicitly here; the +-- migration's copy loop still runs over whatever dual-write produced, and +-- federated connections are covered by the brig integration suite. +testConnectionsMigrationToPostgres :: (HasCallStack) => App () +testConnectionsMigrationToPostgres = do + resourcePool <- asks (.resourcePool) + runCodensity (acquireResources 1 resourcePool) $ \[backend] -> do + let domain = backend.berDomain + + -- P1 cassandra: connect a pair via the pure Cassandra interpreter + cassandraPair <- + runCodensity (startDynamicBackend backend (conf "cassandra" False)) $ \_ -> + connectFreshPair domain + + -- P2 migration-to-postgresql (worker off): reads still come from + -- Cassandra, writes go to both stores + dualWritePair <- + runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" False)) $ \_ -> do + checkConnection cassandraPair + connectFreshPair domain + + -- P3 migration-to-postgresql (worker on): dual-write while backfilling + workerOnPair <- + runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" True)) $ \_ -> do + checkConnection dualWritePair + pair <- connectFreshPair domain + waitForMigration domain connectionsMigrationFinishedCounterName + -- The failed counter is only registered while the migration worker + -- runs, so assert it in this phase (worker on), not in P4. + assertMigrationSuccessful domain "^wire_connections_migration_failed" + pure pair + + -- P4 postgresql: reads are served exclusively from Postgres + runCodensity (startDynamicBackend backend (conf "postgresql" False)) $ \_ -> do + -- Connections written by every interpreter are visible to the pure + -- Postgres interpreter. + checkConnection cassandraPair + checkConnection dualWritePair + checkConnection workerOnPair + + -- Write and read via the pure Postgres interpreter. + pgPair <- connectFreshPair domain + checkConnection pgPair + where + conf db runMigration = + def + { brigCfg = setField "postgresMigration.connections" db, + backgroundWorkerCfg = + setField "postgresMigration.connections" db + >=> setField "migrateConnections" runMigration + } + +connectionsMigrationFinishedCounterName :: String +connectionsMigrationFinishedCounterName = "^wire_connections_migration_finished" + +-- | Create two fresh users on the given domain and connect them (request + +-- accept) via the brig public connection API. +connectFreshPair :: (HasCallStack, MakesValue domain) => domain -> App (Value, Value) +connectFreshPair domain = do + [u1, u2] <- createUsers [domain, domain] + void $ postConnection u1 u2 >>= assertSuccess + void $ putConnection u2 u1 "accepted" >>= assertSuccess + pure (u1, u2) + +-- | The connection between the two users is visible with status 'accepted'. +checkConnection :: (HasCallStack) => (Value, Value) -> App () +checkConnection (u1, u2) = + getConnection u1 u2 `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "accepted" diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index 0eba6606ea5..bd4984cdeb0 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -53,6 +53,7 @@ import Data.Schema import Data.Text as Text hiding (show) import Imports import Servant.API +import Wire.API.PostgresMarshall (PostgresMarshall (..), PostgresUnmarshall (..)) import Wire.API.Routes.MultiTablePaging import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) import Wire.Sem.Paging @@ -261,6 +262,37 @@ instance C.Cql RelationWithHistory where toCql MissingLegalholdConsentFromSent = C.CqlInt 10 toCql MissingLegalholdConsentFromCancelled = C.CqlInt 11 +instance PostgresMarshall Int32 RelationWithHistory where + postgresMarshall = \case + AcceptedWithHistory -> 0 + BlockedWithHistory -> 1 + PendingWithHistory -> 2 + IgnoredWithHistory -> 3 + SentWithHistory -> 4 + CancelledWithHistory -> 5 + MissingLegalholdConsentFromAccepted -> 6 + MissingLegalholdConsentFromBlocked -> 7 + MissingLegalholdConsentFromPending -> 8 + MissingLegalholdConsentFromIgnored -> 9 + MissingLegalholdConsentFromSent -> 10 + MissingLegalholdConsentFromCancelled -> 11 + +instance PostgresUnmarshall Int32 RelationWithHistory where + postgresUnmarshall = \case + 0 -> Right AcceptedWithHistory + 1 -> Right BlockedWithHistory + 2 -> Right PendingWithHistory + 3 -> Right IgnoredWithHistory + 4 -> Right SentWithHistory + 5 -> Right CancelledWithHistory + 6 -> Right MissingLegalholdConsentFromAccepted + 7 -> Right MissingLegalholdConsentFromBlocked + 8 -> Right MissingLegalholdConsentFromPending + 9 -> Right MissingLegalholdConsentFromIgnored + 10 -> Right MissingLegalholdConsentFromSent + 11 -> Right MissingLegalholdConsentFromCancelled + n -> Left $ "unexpected RelationWithHistory: " <> Text.pack (show n) + ---------------- -- Requests diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs index 823e0da0667..ea1a5e08031 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs @@ -46,6 +46,7 @@ import Imports import Test.Tasty qualified as T import Test.Tasty.QuickCheck import Type.Reflection (typeRep) +import Wire.API.Connection qualified as Connection import Wire.API.Password as Password import Wire.API.Password.Argon2id (Argon2HashedPassword (..), encodeArgon2HashedPassword) import Wire.API.Password.Scrypt (encodeScryptPassword) @@ -64,6 +65,7 @@ tests = testRoundTrip @ByteString @Password.Password, testRoundTrip @Int32 @FeatureStatus, testRoundTrip @Int32 @LockStatus, + testRoundTrip @Int32 @Connection.RelationWithHistory, testRoundTrip @A.Value @DbConfig ] diff --git a/libs/wire-subsystems/postgres-migrations/20261021102943-connections.sql b/libs/wire-subsystems/postgres-migrations/20261021102943-connections.sql new file mode 100644 index 00000000000..b83971724dc --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20261021102943-connections.sql @@ -0,0 +1,39 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +CREATE TABLE IF NOT EXISTS connection ( + "left" uuid NOT NULL, + "right" uuid NOT NULL, + status int NOT NULL, + last_update timestamptz NOT NULL, + conv uuid, + PRIMARY KEY ("left", "right") +); + +CREATE TABLE IF NOT EXISTS connection_remote ( + "left" uuid NOT NULL, + right_domain text NOT NULL, + right_user uuid NOT NULL, + status int NOT NULL, + last_update timestamptz NOT NULL, + conv_domain text, + conv_id uuid, + PRIMARY KEY ("left", right_domain, right_user) +); + +-- Parity with the Cassandra secondary index on connection_remote.right_domain. +CREATE INDEX IF NOT EXISTS connection_remote_right_domain_idx ON connection_remote (right_domain); diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore.hs b/libs/wire-subsystems/src/Wire/ConnectionStore.hs new file mode 100644 index 00000000000..ef9e2c56fff --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore.hs @@ -0,0 +1,111 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE TemplateHaskell #-} + +module Wire.ConnectionStore where + +import Cassandra qualified as Cas +import Data.Domain (Domain) +import Data.Id +import Data.Json.Util (UTCTimeMillis) +import Data.Qualified +import Data.Range +import Imports +import Polysemy +import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection +import Wire.Sem.Paging (Page, PagingBounds, PagingState) + +-- | One constructor per CQL-issuing operation of the (former) +-- 'Brig.Data.Connection' module. +data ConnectionStore p m a where + InsertConnection :: + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + Qualified ConvId -> + ConnectionStore p m UserConnection + UpdateConnectionStatus :: + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + ConnectionStore p m UTCTimeMillis + DeleteConnections :: UserId -> ConnectionStore p m () + DeleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> ConnectionStore p m () + LookupConnection :: + Local UserId -> + Qualified UserId -> + ConnectionStore p m (Maybe UserConnection) + LookupRelationWithHistory :: + Local UserId -> + Qualified UserId -> + ConnectionStore p m (Maybe RelationWithHistory) + LookupLocalConnections :: + Local UserId -> + Maybe UserId -> + Range 1 500 Int32 -> + ConnectionStore p m (Cas.Page UserConnection) + LookupLocalConnectionsPage :: + Local UserId -> + Maybe Cas.PagingState -> + Range 1 1000 Int32 -> + ConnectionStore p m (Cas.PageWithState ByteString UserConnection) + LookupRemoteConnectionsPage :: + Local UserId -> + Maybe Cas.PagingState -> + Int32 -> + ConnectionStore p m (Cas.PageWithState ByteString UserConnection) + LookupConnectionStatus :: [UserId] -> [UserId] -> ConnectionStore p m [ConnectionStatus] + LookupConnectionStatus' :: [UserId] -> ConnectionStore p m [ConnectionStatus] + LookupLocalConnectionStatuses :: + [UserId] -> Local [UserId] -> ConnectionStore p m [ConnectionStatusV2] + LookupRemoteConnectionStatuses :: + [UserId] -> Remote [UserId] -> ConnectionStore p m [ConnectionStatusV2] + LookupAllStatuses :: Local [UserId] -> ConnectionStore p m [ConnectionStatusV2] + RemoteConnectedUsersPaginated :: + Local UserId -> + Maybe (PagingState p (Remote UserConnection)) -> + PagingBounds p (Remote UserConnection) -> + ConnectionStore p m (Page p (Remote UserConnection)) + LookupContactListWithRelation :: + UserId -> ConnectionStore p m [(UserId, RelationWithHistory)] + CountConnections :: Local UserId -> [Relation] -> ConnectionStore p m Int64 + +makeSem ''ConnectionStore + +-- Conversions shared by the Cassandra and Postgres interpreters. + +toLocalUserConnection :: + Local x -> + (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> + UserConnection +toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = + UserConnection l (tUntagged (qualifyAs loc r)) rel time (fmap (tUntagged . qualifyAs loc) cid) + +toRemoteUserConnection :: + Local UserId -> + (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> + UserConnection +toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = + UserConnection (tUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) + +toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus +toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel + +toConnectionStatusV2 :: UserId -> Domain -> UserId -> RelationWithHistory -> ConnectionStatusV2 +toConnectionStatusV2 from toDomain toUser relWithHistory = + ConnectionStatusV2 from (Qualified toUser toDomain) (relationDropHistory relWithHistory) diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs new file mode 100644 index 00000000000..f3c18c47d78 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs @@ -0,0 +1,382 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE DeepSubsumption #-} + +module Wire.ConnectionStore.Cassandra + ( connectionStoreToCassandra, + + -- * Raw queries (used by the integration test and the migration loop) + connectionsSelect, + remoteConnectionInsert, + remoteConnectionSelect, + ) +where + +import Cassandra +import Control.Monad.Trans.Maybe +import Data.Conduit (runConduit, (.|)) +import Data.Conduit.List qualified as C +import Data.Domain (Domain) +import Data.Id +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) +import Data.Qualified +import Data.Range +import Data.Time (getCurrentTime) +import Imports hiding (local) +import Polysemy +import Polysemy.Internal.Tactics +import UnliftIO.Async (pooledForConcurrentlyN_, pooledMapConcurrentlyN, pooledMapConcurrentlyN_) +import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection +import Wire.ConnectionStore (ConnectionStore (..), toConnectionStatus, toConnectionStatusV2, toLocalUserConnection, toRemoteUserConnection) +import Wire.Sem.Paging.Cassandra (InternalPaging, ipNext, mkInternalPage) + +insertConnection :: + (MonadClient m) => + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + Qualified ConvId -> + m UserConnection +insertConnection self target rel qcnv@(Qualified cnv cdomain) = do + now <- toUTCTimeMillis <$> liftIO getCurrentTime + let local (tUnqualified -> ltarget) = + write connectionInsert $ + params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) + let remote (tUntagged -> Qualified rtarget domain) = + write remoteConnectionInsert $ + params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + retry x5 $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = now, + ucConvId = Just qcnv + } + +updateConnectionStatus :: (MonadClient m) => Local UserId -> Qualified UserId -> RelationWithHistory -> m UTCTimeMillis +updateConnectionStatus self target status = do + now <- toUTCTimeMillis <$> liftIO getCurrentTime + let local (tUnqualified -> ltarget) = + write connectionUpdate $ + params LocalQuorum (status, now, tUnqualified self, ltarget) + let remote (tUntagged -> Qualified rtarget domain) = + write remoteConnectionUpdate $ + params LocalQuorum (status, now, tUnqualified self, domain, rtarget) + retry x5 $ foldQualified self local remote target + pure now + +-- | Lookup the connection from a user 'A' to a user 'B' (A -> B). +lookupConnection :: (MonadClient m) => Local UserId -> Qualified UserId -> m (Maybe UserConnection) +lookupConnection self target = runMaybeT $ do + let local (tUnqualified -> ltarget) = do + (_, _, rel, time, mcnv) <- + MaybeT . query1 connectionSelect $ + params LocalQuorum (tUnqualified self, ltarget) + pure (rel, time, fmap (tUntagged . qualifyAs self) mcnv) + let remote (tUntagged -> Qualified rtarget domain) = do + (rel, time, cdomain, cnv) <- + MaybeT . query1 remoteConnectionSelectFrom $ + params LocalQuorum (tUnqualified self, domain, rtarget) + pure (rel, time, Just (Qualified cnv cdomain)) + (rel, time, mqcnv) <- MaybeT . retry x1 . runMaybeT $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = time, + ucConvId = mqcnv + } + +-- | 'lookupConnection' with more 'Relation' info. +lookupRelationWithHistory :: + (MonadClient m) => + -- | User 'A' + Local UserId -> + -- | User 'B' + Qualified UserId -> + m (Maybe RelationWithHistory) +lookupRelationWithHistory self target = do + let local (tUnqualified -> ltarget) = + query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) + let remote (tUntagged -> Qualified rtarget domain) = + query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) + runIdentity <$$> retry x1 (foldQualified self local remote target) + +-- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. +lookupLocalConnections :: + (MonadClient m) => + Local UserId -> + Maybe UserId -> + Range 1 500 Int32 -> + m (Page UserConnection) +lookupLocalConnections lfrom start (fromRange -> size) = + toResult <$> case start of + Just u -> + retry x1 $ + paginate connectionsSelectFrom (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) + Nothing -> + retry x1 $ + paginate connectionsSelect (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) + where + toResult = fmap (toLocalUserConnection lfrom) . trim + trim p = p {result = take (fromIntegral size) (result p)} + +-- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. +-- Similar to lookupLocalConnections +lookupLocalConnectionsPage :: + (MonadClient m) => + Local UserId -> + Maybe PagingState -> + Range 1 1000 Int32 -> + m (PageWithState ByteString UserConnection) +lookupLocalConnectionsPage self pagingState (fromRange -> size) = + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) x1 + +-- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. +lookupRemoteConnectionsPage :: + (MonadClient m) => + Local UserId -> + Maybe PagingState -> + Int32 -> + m (PageWithState ByteString UserConnection) +lookupRemoteConnectionsPage self pagingState size = + fmap (toRemoteUserConnection self) + <$> paginateWithState + remoteConnectionSelect + (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) + x1 + +-- | Lookup all relations between two sets of users (cartesian product). +lookupConnectionStatus :: (MonadClient m) => [UserId] -> [UserId] -> m [ConnectionStatus] +lookupConnectionStatus from to = + map toConnectionStatus + <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) + +-- | Lookup all relations between two sets of users (cartesian product). +lookupConnectionStatus' :: (MonadClient m) => [UserId] -> m [ConnectionStatus] +lookupConnectionStatus' from = + map toConnectionStatus + <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) + +lookupLocalConnectionStatuses :: + ( MonadClient m, + MonadUnliftIO m + ) => + [UserId] -> + Local [UserId] -> + m [ConnectionStatusV2] +lookupLocalConnectionStatuses froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) + +lookupRemoteConnectionStatuses :: + ( MonadClient m, + MonadUnliftIO m + ) => + [UserId] -> + Remote [UserId] -> + m [ConnectionStatusV2] +lookupRemoteConnectionStatuses froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) + +lookupAllStatuses :: + ( MonadClient m, + MonadUnliftIO m + ) => + Local [UserId] -> + m [ConnectionStatusV2] +lookupAllStatuses lfroms = do + let froms = tUnqualified lfroms + concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms + where + lookupAndCombine :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u + + lookupLocalStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupLocalStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) + <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) + lookupRemoteStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupRemoteStatuses from = + map (\(d, u, r) -> toConnectionStatusV2 from d u r) + <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) + +lookupRemoteConnectedUsersPaginated :: (MonadClient m) => Local UserId -> Int32 -> m (Page (Remote UserConnection)) +lookupRemoteConnectedUsersPaginated u maxResults = do + (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) + +-- | For a given user 'A', lookup the list of users that form his contact list, +-- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). +lookupContactListWithRelation :: (MonadClient m) => UserId -> m [(UserId, RelationWithHistory)] +lookupContactListWithRelation u = + retry x1 (query contactsSelect (params LocalQuorum (Identity u))) + +-- | Count the number of connections a user has in a specific relation status. +-- (If you want to distinguish 'RelationWithHistory', write a new function.) +-- Note: The count is eventually consistent. +countConnections :: (MonadClient m) => Local UserId -> [Relation] -> m Int64 +countConnections u r = do + rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) + relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) + + pure $ foldl' count 0 rels + foldl' count 0 relsRemote + where + count n (Identity s) | relationDropHistory s `elem` r = n + 1 + count n _ = n + +deleteConnections :: (MonadClient m, MonadUnliftIO m) => UserId -> m () +deleteConnections u = do + runConduit $ + paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 + .| C.mapM_ + (pooledMapConcurrentlyN_ 16 delete) + do + retry x1 . write connectionClear $ params LocalQuorum (Identity u) + retry x1 . write remoteConnectionClear $ params LocalQuorum (Identity u) + where + delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) + +deleteRemoteConnections :: + ( MonadClient m, + MonadUnliftIO m + ) => + Remote UserId -> + Range 1 1000 [UserId] -> + m () +deleteRemoteConnections (tUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = + pooledForConcurrentlyN_ 16 locals $ \u -> + write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) + +connectionStoreToCassandra :: + forall r. + (Member (Embed Client) r) => + InterpreterFor (ConnectionStore InternalPaging) r +connectionStoreToCassandra = + interpretH $ + liftT . embed @Client . \case + InsertConnection self target rel qcnv -> insertConnection self target rel qcnv + UpdateConnectionStatus self target status -> updateConnectionStatus self target status + DeleteConnections u -> deleteConnections u + DeleteRemoteConnections target locals -> deleteRemoteConnections target locals + LookupConnection self target -> lookupConnection self target + LookupRelationWithHistory self target -> lookupRelationWithHistory self target + LookupLocalConnections lfrom start size -> lookupLocalConnections lfrom start size + LookupLocalConnectionsPage self pagingState size -> lookupLocalConnectionsPage self pagingState size + LookupRemoteConnectionsPage self pagingState size -> lookupRemoteConnectionsPage self pagingState size + LookupConnectionStatus from to -> lookupConnectionStatus from to + LookupConnectionStatus' from -> lookupConnectionStatus' from + LookupLocalConnectionStatuses froms tos -> lookupLocalConnectionStatuses froms tos + LookupRemoteConnectionStatuses froms tos -> lookupRemoteConnectionStatuses froms tos + LookupAllStatuses lfroms -> lookupAllStatuses lfroms + RemoteConnectedUsersPaginated uid mps bounds -> case mps of + Nothing -> flip mkInternalPage pure =<< lookupRemoteConnectedUsersPaginated uid (fromRange bounds) + Just ps -> ipNext ps + LookupContactListWithRelation u -> lookupContactListWithRelation u + CountConnections u r -> countConnections u r + +-- Queries + +connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () +connectionInsert = "INSERT INTO connection (left, right, status, last_update, conv) VALUES (?, ?, ?, ?, ?)" + +connectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, UserId) () +connectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection SET status = ?, last_update = ? WHERE left = ? AND right = ?" + +connectionSelect :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right = ?" + +relationSelect :: PrepQuery R (UserId, UserId) (Identity RelationWithHistory) +relationSelect = "SELECT status FROM connection WHERE left = ? AND right = ?" + +relationsSelect :: PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) +relationsSelect = "SELECT right, status FROM connection where left = ? AND right IN ?" + +relationsSelectAll :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +relationsSelectAll = "SELECT right, status FROM connection where left = ?" + +-- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of +-- the table. +connectionStatusSelect :: PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) +connectionStatusSelect = "SELECT left, right, status FROM connection WHERE left IN ? AND right IN ?" + +-- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of +-- the table. +connectionStatusSelect' :: PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) +connectionStatusSelect' = "SELECT left, right, status FROM connection WHERE left IN ?" + +contactsSelect :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +contactsSelect = "SELECT right, status FROM connection WHERE left = ?" + +selectStatus :: PrepQuery R (Identity UserId) (Identity RelationWithHistory) +selectStatus = "SELECT status FROM connection WHERE left = ?" + +selectStatusRemote :: PrepQuery R (Identity UserId) (Identity RelationWithHistory) +selectStatusRemote = "SELECT status FROM connection_remote WHERE left = ?" + +connectionsSelect :: PrepQuery R (Identity UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionsSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? ORDER BY right ASC" + +connectionsSelectFrom :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionsSelectFrom = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right > ? ORDER BY right ASC" + +connectionDelete :: PrepQuery W (UserId, UserId) () +connectionDelete = "DELETE FROM connection WHERE left = ? AND right = ?" + +connectionClear :: PrepQuery W (Identity UserId) () +connectionClear = "DELETE FROM connection WHERE left = ?" + +-- Remote connections + +remoteConnectionInsert :: PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () +remoteConnectionInsert = "INSERT INTO connection_remote (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" + +remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelect = "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM connection_remote where left = ?" + +remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelectFrom = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" + +remoteConnectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () +remoteConnectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection_remote set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" + +remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () +remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" + +remoteConnectionClear :: PrepQuery W (Identity UserId) () +remoteConnectionClear = "DELETE FROM connection_remote where left = ?" + +remoteRelationSelect :: PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) +remoteRelationSelect = "SELECT status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user = ?" + +remoteRelationsSelect :: PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) +remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user IN ?" + +remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) +remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/DualWrite.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/DualWrite.hs new file mode 100644 index 00000000000..d7528774429 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/DualWrite.hs @@ -0,0 +1,81 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConnectionStore.DualWrite + ( interpretConnectionStoreToCassandraAndPostgres, + ) +where + +import Cassandra qualified as Cas +import Imports +import Polysemy +import Wire.ConnectionStore +import Wire.ConnectionStore.Cassandra (connectionStoreToCassandra) +import Wire.ConnectionStore.Postgres qualified as Postgres +import Wire.Postgres (PGConstraints) +import Wire.Sem.Paging.Cassandra (InternalPaging) + +-- | During migration, Cassandra remains the source of truth for reads while +-- writes are mirrored to Postgres. Connections have no consume-on-read +-- semantics, so every write is a plain mirror. +interpretConnectionStoreToCassandraAndPostgres :: + forall r. + ( Member (Embed Cas.Client) r, + PGConstraints r + ) => + InterpreterFor (ConnectionStore InternalPaging) r +interpretConnectionStoreToCassandraAndPostgres = interpret $ \case + InsertConnection self target rel qcnv -> do + res <- connectionStoreToCassandra $ insertConnection self target rel qcnv + _ <- Postgres.interpretConnectionStoreToPostgres $ insertConnection self target rel qcnv + pure res + UpdateConnectionStatus self target status -> do + res <- connectionStoreToCassandra $ updateConnectionStatus self target status + _ <- Postgres.interpretConnectionStoreToPostgres $ updateConnectionStatus self target status + pure res + DeleteConnections u -> do + connectionStoreToCassandra $ deleteConnections u + Postgres.interpretConnectionStoreToPostgres $ deleteConnections u + DeleteRemoteConnections u rs -> do + connectionStoreToCassandra $ deleteRemoteConnections u rs + Postgres.interpretConnectionStoreToPostgres $ deleteRemoteConnections u rs + LookupConnection self target -> + connectionStoreToCassandra $ lookupConnection self target + LookupRelationWithHistory self target -> + connectionStoreToCassandra $ lookupRelationWithHistory self target + LookupLocalConnections lfrom start size -> + connectionStoreToCassandra $ lookupLocalConnections lfrom start size + LookupLocalConnectionsPage self ps size -> + connectionStoreToCassandra $ lookupLocalConnectionsPage self ps size + LookupRemoteConnectionsPage self ps size -> + connectionStoreToCassandra $ lookupRemoteConnectionsPage self ps size + LookupConnectionStatus from to -> + connectionStoreToCassandra $ lookupConnectionStatus from to + LookupConnectionStatus' from -> + connectionStoreToCassandra $ lookupConnectionStatus' from + LookupLocalConnectionStatuses froms tos -> + connectionStoreToCassandra $ lookupLocalConnectionStatuses froms tos + LookupRemoteConnectionStatuses froms tos -> + connectionStoreToCassandra $ lookupRemoteConnectionStatuses froms tos + LookupAllStatuses lfroms -> + connectionStoreToCassandra $ lookupAllStatuses lfroms + RemoteConnectedUsersPaginated uid mps bounds -> + connectionStoreToCassandra $ remoteConnectedUsersPaginated uid mps bounds + LookupContactListWithRelation u -> + connectionStoreToCassandra $ lookupContactListWithRelation u + CountConnections u r -> + connectionStoreToCassandra $ countConnections u r diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/Migration.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Migration.hs new file mode 100644 index 00000000000..bee38612e3a --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Migration.hs @@ -0,0 +1,236 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConnectionStore.Migration + ( migrateConnectionsLoop, + ) +where + +import Cassandra +import Data.Conduit +import Data.Conduit.List qualified as C +import Data.Domain (Domain) +import Data.Id +import Data.Json.Util +import Data.Time +import Hasql.Pool qualified as Hasql +import Hasql.Pool.Extended qualified as HasqlPoolExt +import Hasql.Statement qualified as Hasql +import Hasql.TH +import Imports +import Polysemy +import Polysemy.Async +import Polysemy.AtomicState +import Polysemy.Conc (interpretRace) +import Polysemy.Conc.Effect.Race hiding (Timeout) +import Polysemy.Error (Error, runError) +import Polysemy.Input +import Polysemy.Resource (Resource, resourceToIOFinal) +import Polysemy.TinyLog +import Prometheus qualified +import System.Logger qualified as Log +import Wire.API.Connection (RelationWithHistory) +import Wire.API.PostgresMarshall (PostgresMarshall (..), lmapPG) +import Wire.ConnectionStore.Cassandra + ( connectionsSelect, + remoteConnectionSelect, + ) +import Wire.Migration +import Wire.Postgres +import Wire.Sem.Logger (mapLogger) +import Wire.Sem.Logger.TinyLog (loggerToTinyLog) + +type EffectStack = + [ AtomicState Int, + Input ClientState, + Input HasqlPoolExt.Pool, + Resource, + Async, + Race, + TinyLog, + Embed IO, + Final IO + ] + +-- | Copy-only migration of the @connection@ and @connection_remote@ tables +-- from Cassandra to Postgres. Two sequential sub-loops share one +-- @finished@ counter; the loop reports 1.0 once both tables are copied. +migrateConnectionsLoop :: + MigrationOptions -> + ClientState -> + HasqlPoolExt.Pool -> + Log.Logger -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + IO () +migrateConnectionsLoop migOpts cassClient pgPool logger migCounter migFinished migFailed migDuration = + migrationLoop + logger + "connections" + migFinished + migFailed + (interpreter cassClient pgPool logger "connections") + (migrateAllConnections migOpts migCounter migFailed migDuration) + +interpreter :: ClientState -> HasqlPoolExt.Pool -> Log.Logger -> ByteString -> Sem EffectStack a -> IO (Int, a) +interpreter cassClient pgPool logger name = + runFinal + . embedToFinal + . loggerToTinyLog logger + . mapLogger (Log.field "migration" (Log.val name) .) + . raiseUnder + . interpretRace + . asyncToIOFinal + . resourceToIOFinal + . runInputConst pgPool + . runInputConst cassClient + . atomicStateToIO 0 + +migrateAllConnections :: + ( Member (Input HasqlPoolExt.Pool) r, + Member (Input ClientState) r, + Member (Embed IO) r, + Member TinyLog r, + Member (AtomicState Int) r + ) => + MigrationOptions -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + ConduitM () Void (Sem r) () +migrateAllConnections migOpts migCounter migFailed migDuration = do + lift $ info $ Log.msg (Log.val "migrating connection table") + copyTable migOpts migCounter migFailed migDuration selectConnectionLefts connectionsSelect upsertConnection + lift $ info $ Log.msg (Log.val "migrating connection_remote table") + copyTable migOpts migCounter migFailed migDuration selectRemoteConnectionLefts remoteConnectionSelect upsertRemoteConnection + +-- | For every partition key (left user) page all rows out of Cassandra and +-- upsert them into Postgres, preserving the original @last_update@. +copyTable :: + forall row r. + ( Member (Input HasqlPoolExt.Pool) r, + Member (Input ClientState) r, + Member (Embed IO) r, + Member TinyLog r, + Member (AtomicState Int) r, + Tuple row + ) => + MigrationOptions -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + PrepQuery R () (Identity UserId) -> + PrepQuery R (Identity UserId) row -> + ( forall r2. + (Member (Input HasqlPoolExt.Pool) r2, Member (Embed IO) r2) => + UserId -> row -> Sem (Error Hasql.UsageError ': r2) () + ) -> + ConduitM () Void (Sem r) () +copyTable migOpts migCounter migFailed migDuration selectLefts selectRows upsertRow = + withCount (paginateSem selectLefts (paramsP LocalQuorum () migOpts.pageSize) x5) + .| logRetrievedPage migOpts.pageSize runIdentity + .| C.mapM_ (traverse_ copyPartition) + where + copyPartition :: UserId -> Sem r () + copyPartition left = + runConduit $ + paginateSem selectRows (paramsP LocalQuorum (Identity left) migOpts.pageSize) x1 + .| C.mapM_ (traverse_ (migrateRow left migCounter migFailed migDuration . upsertRow left)) + +migrateRow :: + ( Member (Embed IO) r, + Member TinyLog r, + Member (AtomicState Int) r + ) => + UserId -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + Sem (Error Hasql.UsageError ': r) () -> + Sem r () +migrateRow left migCounter _migFailed migDuration action = do + start <- embed @IO getCurrentTime + result <- runError action + end <- embed @IO getCurrentTime + let outcome = either (const "error") (const "success") result + liftIO $ + Prometheus.withLabel migDuration outcome (`Prometheus.observe` realToFrac (diffUTCTime end start)) + case result of + Right () -> + liftIO $ Prometheus.incCounter migCounter + Left failure -> do + warn $ + Log.msg (Log.val "connection row migration failed") + . Log.field "left" (show left) + . Log.field "error" (show failure) + -- NOTE: unlike the Prometheus counter, the AtomicState count is what + -- makes migrationLoop retry the failed rows; the counter is reserved for + -- fatal errors (see Wire.Migration.migrationLoop). + atomicModify (+ 1) + +selectConnectionLefts :: PrepQuery R () (Identity UserId) +selectConnectionLefts = "SELECT DISTINCT left FROM connection" + +selectRemoteConnectionLefts :: PrepQuery R () (Identity UserId) +selectRemoteConnectionLefts = "SELECT DISTINCT left FROM connection_remote" + +-- Upserts preserving the original Cassandra timestamps. On conflict, an +-- existing row is only overwritten when the Cassandra row is at least as new +-- (ties go to Cassandra), so a replayed stale row cannot clobber a newer row +-- that dual-write already put in Postgres. + +upsertConnection :: + ( Member (Input HasqlPoolExt.Pool) r, + Member (Embed IO) r + ) => + UserId -> + (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> + Sem (Error Hasql.UsageError ': r) () +upsertConnection _left (l, r, rel, ts, mconv) = + runStatement (l, r, postgresMarshall rel, fromUTCTimeMillis ts, mconv) stmt + where + stmt :: Hasql.Statement (UserId, UserId, Int32, UTCTime, Maybe ConvId) () + stmt = + lmapPG + [resultlessStatement|INSERT INTO connection ("left", "right", status, last_update, conv) + VALUES ($1 :: uuid, $2 :: uuid, $3 :: int4, $4 :: timestamptz, $5 :: uuid?) + ON CONFLICT ("left", "right") DO UPDATE + SET status = ($3 :: int4), last_update = ($4 :: timestamptz), conv = ($5 :: uuid?) + WHERE connection.last_update <= ($4 :: timestamptz) + |] + +upsertRemoteConnection :: + ( Member (Input HasqlPoolExt.Pool) r, + Member (Embed IO) r + ) => + UserId -> + (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> + Sem (Error Hasql.UsageError ': r) () +upsertRemoteConnection left (domain, r, rel, ts, convDomain, convId) = + runStatement (left, domain, r, postgresMarshall rel, fromUTCTimeMillis ts, convDomain, convId) stmt + where + stmt :: Hasql.Statement (UserId, Domain, UserId, Int32, UTCTime, Domain, ConvId) () + stmt = + lmapPG + [resultlessStatement|INSERT INTO connection_remote ("left", right_domain, right_user, status, last_update, conv_domain, conv_id) + VALUES ($1 :: uuid, $2 :: text, $3 :: uuid, $4 :: int4, $5 :: timestamptz, $6 :: text, $7 :: uuid) + ON CONFLICT ("left", right_domain, right_user) DO UPDATE + SET status = ($4 :: int4), last_update = ($5 :: timestamptz), conv_domain = ($6 :: text), conv_id = ($7 :: uuid) + WHERE connection_remote.last_update <= ($5 :: timestamptz) + |] diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs new file mode 100644 index 00000000000..4e3767bdd41 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs @@ -0,0 +1,499 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConnectionStore.Postgres + ( interpretConnectionStoreToPostgres, + ) +where + +import Cassandra (Page (..), PageWithState (..), PagingState (..), emptyPage) +import Cassandra qualified as Cas +import Cassandra.Exec (GeneralPaginationState (..)) +import Data.ByteString qualified as BS +import Data.ByteString.Conversion +import Data.ByteString.Lazy qualified as LBS +import Data.Domain (Domain) +import Data.Id +import Data.Json.Util +import Data.Qualified +import Data.Range +import Data.Text qualified as Text +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.UUID (UUID) +import Data.UUID qualified as UUID +import Data.Vector qualified as Vector +import Hasql.Statement qualified as Hasql +import Hasql.TH +import Imports +import Polysemy +import Wire.API.Connection +import Wire.API.PostgresMarshall (PostgresMarshall (..), PostgresUnmarshall (..), dimapPG, lmapPG) +import Wire.ConnectionStore +import Wire.Postgres +import Wire.Sem.Paging.Cassandra (InternalPage (..), InternalPaging) + +-- | Postgres interpreter for 'ConnectionStore'. The @status@ column uses the +-- same Int32 mapping as the Cassandra 'C.Cql RelationWithHistory' instance +-- (mirrored by the 'PostgresMarshall Int32 RelationWithHistory' instances). +interpretConnectionStoreToPostgres :: + (PGConstraints r) => + InterpreterFor (ConnectionStore InternalPaging) r +interpretConnectionStoreToPostgres = interpret $ \case + InsertConnection self target rel qcnv@(Qualified cnv cdomain) -> do + now <- embed @IO (toUTCTimeMillis <$> getCurrentTime) + let relInt = postgresMarshall rel + ts = fromUTCTimeMillis now + foldQualified + self + ( \(tUnqualified -> ltarget) -> + runStatement (tUnqualified self, ltarget, relInt, ts, cnv) insertLocal + ) + ( \(tUntagged -> Qualified rtarget domain) -> + runStatement (tUnqualified self, domain, rtarget, relInt, ts, cdomain, cnv) insertRemote + ) + target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = now, + ucConvId = Just qcnv + } + UpdateConnectionStatus self target status -> do + now <- embed @IO (toUTCTimeMillis <$> getCurrentTime) + let relInt = postgresMarshall status + ts = fromUTCTimeMillis now + foldQualified + self + ( \(tUnqualified -> ltarget) -> + runStatement (relInt, ts, tUnqualified self, ltarget) updateLocal + ) + ( \(tUntagged -> Qualified rtarget domain) -> + runStatement (relInt, ts, tUnqualified self, domain, rtarget) updateRemote + ) + target + pure now + DeleteConnections u -> do + runStatement u deleteIncomingLocalConnections + runStatement u deleteLocalConnections + runStatement u deleteRemoteConnectionsByLeft + DeleteRemoteConnections (tUntagged -> Qualified remoteUser remoteDomain) rs -> + runStatement (remoteUser, remoteDomain, fromRange rs) deleteRemoteConnectionsByUsers + LookupConnection self target -> do + foldQualified + self + ( \(tUnqualified -> ltarget) -> do + mrow <- runStatement (tUnqualified self, ltarget) selectLocalConnection + pure (fmap (localRowToUserConnection self target) mrow) + ) + ( \(tUntagged -> Qualified rtarget domain) -> do + mrow <- runStatement (tUnqualified self, domain, rtarget) selectRemoteConnection + pure (fmap (remoteRowToUserConnection self target) mrow) + ) + target + LookupRelationWithHistory self target -> + foldQualified + self + ( \(tUnqualified -> ltarget) -> + fmap unStatus <$> runStatement (tUnqualified self, ltarget) selectLocalRelation + ) + ( \(tUntagged -> Qualified rtarget domain) -> + fmap unStatus <$> runStatement (tUnqualified self, domain, rtarget) selectRemoteRelation + ) + target + LookupLocalConnections lfrom start (fromRange -> size) -> do + rows <- case start of + Just u -> runStatement (tUnqualified lfrom, u, size + 1) selectLocalConnectionsFrom + Nothing -> runStatement (tUnqualified lfrom, size + 1) selectLocalConnections + pure $ trimLocalPage lfrom size rows + LookupLocalConnectionsPage self pagingState (fromRange -> size) -> do + let mStart = pagingState >>= fromByteString . LBS.toStrict . unPagingState + rows <- case mStart of + Just u -> runStatement (tUnqualified self, u, size) selectLocalConnectionsFrom + Nothing -> runStatement (tUnqualified self, size) selectLocalConnections + pure $ buildPageWithState (localRowToUserConnectionByRight self) (\(_, rid, _, _) -> toByteString' rid) size rows + LookupRemoteConnectionsPage self pagingState size -> do + let mStart = pagingState >>= decodeRemoteMarker . LBS.toStrict . unPagingState + rows <- case mStart of + Just (domain, ruser) -> + runStatement (tUnqualified self, domain, ruser, size) selectRemoteConnectionsFrom + Nothing -> runStatement (tUnqualified self, size) selectRemoteConnections + pure $ buildPageWithState (remoteRowToUserConnectionByRow self) (\(d, rid, _, _, _, _) -> encodeRemoteMarker d rid) size rows + LookupConnectionStatus from to -> do + rows <- runStatement (from, to) selectConnectionStatuses + pure $ map (\(l, r, s) -> toConnectionStatus (Id l, Id r, unStatus s)) (Vector.toList rows) + LookupConnectionStatus' from -> do + rows <- runStatement from selectConnectionStatuses' + pure $ map (\(l, r, s) -> toConnectionStatus (Id l, Id r, unStatus s)) (Vector.toList rows) + LookupLocalConnectionStatuses froms tos -> + concat + <$> for + froms + ( \from -> do + rows <- runStatement (from, tUnqualified tos) selectLocalRelations + pure $ map (\(rid, s) -> toConnectionStatusV2 from (tDomain tos) (Id rid) (unStatus s)) (Vector.toList rows) + ) + LookupRemoteConnectionStatuses froms tos -> + concat + <$> for + froms + ( \from -> do + rows <- runStatement (from, tDomain tos, tUnqualified tos) selectRemoteRelations + pure $ map (\(rid, s) -> toConnectionStatusV2 from (tDomain tos) (Id rid) (unStatus s)) (Vector.toList rows) + ) + LookupAllStatuses lfroms -> do + let froms = tUnqualified lfroms + concat + <$> for + froms + ( \u -> do + localRows <- runStatement u selectAllLocalRelations + let localStatuses = + map (\(rid, s) -> toConnectionStatusV2 u (tDomain lfroms) (Id rid) (unStatus s)) (Vector.toList localRows) + remoteRows <- runStatement u selectAllRemoteRelations + let remote = + map (\(d, rid, s) -> toConnectionStatusV2 u d (Id rid) (unStatus s)) (Vector.toList remoteRows) + pure (localStatuses <> remote) + ) + RemoteConnectedUsersPaginated u _mps bounds -> do + -- This operation is only consumed by Brig.IO.Intra.withChunks, which always + -- starts from an empty paging state and iterates until the page reports + -- hasMore == False. The Postgres branch therefore serves the complete result + -- as one page with a keyset walk instead of a continuation. + rows <- fetchAllRemoteConnected u (fromRange bounds) + let items = + map + ( \(d, rid, s, ts, cdomain, cid) -> + toRemoteUnsafe d (remoteRowToUserConnectionByRow u (d, rid, s, ts, cdomain, cid)) + ) + (concatMap Vector.toList rows) + pure (InternalPage (emptyPage, \() -> error "unreachable: no continuation for a complete page", items)) + LookupContactListWithRelation u -> do + rows <- runStatement u selectAllLocalRelations + pure $ map (bimap Id unStatus) (Vector.toList rows) + CountConnections u r -> do + let codes = relationStatusCodes r + localCount <- runStatement (tUnqualified u, codes) countLocalConnectionsByStatus + remoteCount <- runStatement (tUnqualified u, codes) countRemoteConnectionsByStatus + pure (localCount + remoteCount) + +-- | All stored 'RelationWithHistory' status codes whose relation is in the +-- given set (the Postgres analogue of the Cassandra 'countConnections' fold +-- over 'relationDropHistory'). +relationStatusCodes :: [Relation] -> [Int32] +relationStatusCodes rs = + [ postgresMarshall rwh + | rwh <- + [ AcceptedWithHistory, + BlockedWithHistory, + PendingWithHistory, + IgnoredWithHistory, + SentWithHistory, + CancelledWithHistory, + MissingLegalholdConsentFromAccepted, + MissingLegalholdConsentFromBlocked, + MissingLegalholdConsentFromPending, + MissingLegalholdConsentFromIgnored, + MissingLegalholdConsentFromSent, + MissingLegalholdConsentFromCancelled + ], + relationDropHistory rwh `elem` rs + ] + +countLocalConnectionsByStatus :: Hasql.Statement (UserId, [Int32]) Int64 +countLocalConnectionsByStatus = + lmapPG @(UUID, Vector.Vector Int32) @(UserId, [Int32]) + [singletonStatement|SELECT (count(*) FILTER (WHERE status = ANY ($2 :: int4[])) :: int8) + FROM connection WHERE "left" = ($1 :: uuid)|] + +countRemoteConnectionsByStatus :: Hasql.Statement (UserId, [Int32]) Int64 +countRemoteConnectionsByStatus = + lmapPG @(UUID, Vector.Vector Int32) @(UserId, [Int32]) + [singletonStatement|SELECT (count(*) FILTER (WHERE status = ANY ($2 :: int4[])) :: int8) + FROM connection_remote WHERE "left" = ($1 :: uuid)|] + +lastRow :: [a] -> Maybe a +lastRow = listToMaybe . reverse + +-- | Shared construction of a Cassandra-style page from a keyset page: the +-- marker is the last row iff the page came back full. +buildPageWithState :: + (row -> UserConnection) -> + (row -> ByteString) -> + Int32 -> + Vector.Vector row -> + Cas.PageWithState ByteString UserConnection +buildPageWithState toUC mkMarker size rows = + PageWithState + { pwsResults = map toUC xs, + pwsState = PaginationStatePostgres <$> mMarker + } + where + xs = Vector.toList rows + mMarker = if length xs == fromIntegral size then mkMarker <$> lastRow xs else Nothing + +-- | Walk all pages of a user's remote connections (keyset by +-- (right_domain, right_user)) and return the row vectors as a list. +fetchAllRemoteConnected :: + (PGConstraints r) => + Local UserId -> + Int32 -> + Sem r [Vector.Vector (Domain, UUID, Int32, UTCTime, Maybe Domain, Maybe UUID)] +fetchAllRemoteConnected u limitSize = go Nothing [] + where + go mStart acc = do + rows <- case mStart of + Just (d, rid) -> runStatement (tUnqualified u, d, rid, limitSize) selectRemoteConnectionsFrom + Nothing -> runStatement (tUnqualified u, limitSize) selectRemoteConnections + let acc' = rows : acc + if Vector.length rows < fromIntegral limitSize + then pure (reverse acc') + else case lastRow (Vector.toList rows) of + Just (d, rid, _, _, _, _) -> go (Just (d, Id rid)) acc' + Nothing -> pure (reverse acc') + +-------------------------------------------------------------------------------- +-- Row conversions + +unStatus :: Int32 -> RelationWithHistory +unStatus = either (error . Text.unpack) id . postgresUnmarshall + +-- | (right uuid, status, last_update, conv uuid?) +localRowToUserConnection :: Local UserId -> Qualified UserId -> (UUID, Int32, UTCTime, Maybe UUID) -> UserConnection +localRowToUserConnection self target (_rid, s, ts, mcnv) = + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory (unStatus s), + ucLastUpdate = toUTCTimeMillis ts, + ucConvId = fmap (tUntagged . qualifyAs self . Id) mcnv + } + +-- | Same, but the target user is taken from the row. +localRowToUserConnectionByRight :: Local UserId -> (UUID, Int32, UTCTime, Maybe UUID) -> UserConnection +localRowToUserConnectionByRight self row@(rid, _, _, _) = + localRowToUserConnection self (tUntagged (qualifyAs self (Id rid))) row + +-- | (status, last_update, conv_domain?, conv_id?) +remoteRowToUserConnection :: Local UserId -> Qualified UserId -> (Int32, UTCTime, Maybe Domain, Maybe UUID) -> UserConnection +remoteRowToUserConnection self target (s, ts, mcdomain, mcnv) = + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory (unStatus s), + ucLastUpdate = toUTCTimeMillis ts, + ucConvId = liftA2 Qualified (Id <$> mcnv) mcdomain + } + +-- | (right_domain, right_user, status, last_update, conv_domain?, conv_id?) +remoteRowToUserConnectionByRow :: Local UserId -> (Domain, UUID, Int32, UTCTime, Maybe Domain, Maybe UUID) -> UserConnection +remoteRowToUserConnectionByRow self (d, rid, s, ts, mcdomain, mcnv) = + remoteRowToUserConnection self (Qualified (Id rid) d) (s, ts, mcdomain, mcnv) + +-- | Trim to the requested size, mirroring the Cassandra \"fetch one extra\" +-- behaviour of the original 'lookupLocalConnections'. +trimLocalPage :: Local UserId -> Int32 -> Vector.Vector (UUID, Int32, UTCTime, Maybe UUID) -> Cas.Page UserConnection +trimLocalPage lfrom size rows = + emptyPage + { result = take (fromIntegral size) (map (localRowToUserConnectionByRight lfrom) (Vector.toList rows)), + hasMore = Vector.length rows > fromIntegral size + } + +-------------------------------------------------------------------------------- +-- Paging-state markers + +-- | Remote page marker: utf8-encoded domain bytes followed by the 16-byte +-- user id. +encodeRemoteMarker :: Domain -> UUID -> ByteString +encodeRemoteMarker domain uid = toByteString' domain <> UUID.toASCIIBytes uid + +-- | Inverse of 'encodeRemoteMarker': a 36-char ASCII uuid suffix. +decodeRemoteMarker :: ByteString -> Maybe (Domain, UserId) +decodeRemoteMarker bs = do + guard (BS.length bs >= 36) + let (domainPart, uidPart) = BS.splitAt (BS.length bs - 36) bs + (,) <$> fromByteString domainPart <*> (Id <$> UUID.fromASCIIBytes uidPart) + +-------------------------------------------------------------------------------- +-- Statements +-- NOTE: \"left\" and \"right\" are reserved words in PostgreSQL and must be +-- quoted. + +insertLocal :: Hasql.Statement (UserId, UserId, Int32, UTCTime, ConvId) () +insertLocal = + lmapPG + [resultlessStatement|INSERT INTO connection ("left", "right", status, last_update, conv) + VALUES ($1 :: uuid, $2 :: uuid, $3 :: int4, $4 :: timestamptz, $5 :: uuid) + ON CONFLICT ("left", "right") DO UPDATE + SET status = ($3 :: int4), last_update = ($4 :: timestamptz), conv = ($5 :: uuid) + |] + +insertRemote :: Hasql.Statement (UserId, Domain, UserId, Int32, UTCTime, Domain, ConvId) () +insertRemote = + lmapPG + [resultlessStatement|INSERT INTO connection_remote ("left", right_domain, right_user, status, last_update, conv_domain, conv_id) + VALUES ($1 :: uuid, $2 :: text, $3 :: uuid, $4 :: int4, $5 :: timestamptz, $6 :: text, $7 :: uuid) + ON CONFLICT ("left", right_domain, right_user) DO UPDATE + SET status = ($4 :: int4), last_update = ($5 :: timestamptz), conv_domain = ($6 :: text), conv_id = ($7 :: uuid) + |] + +updateLocal :: Hasql.Statement (Int32, UTCTime, UserId, UserId) () +updateLocal = + lmapPG + [resultlessStatement|UPDATE connection SET status = ($1 :: int4), last_update = ($2 :: timestamptz) + WHERE "left" = ($3 :: uuid) AND "right" = ($4 :: uuid) + |] + +updateRemote :: Hasql.Statement (Int32, UTCTime, UserId, Domain, UserId) () +updateRemote = + lmapPG + [resultlessStatement|UPDATE connection_remote SET status = ($1 :: int4), last_update = ($2 :: timestamptz) + WHERE "left" = ($3 :: uuid) AND right_domain = ($4 :: text) AND right_user = ($5 :: uuid) + |] + +deleteLocalConnections :: Hasql.Statement UserId () +deleteLocalConnections = + lmapPG + [resultlessStatement|DELETE FROM connection WHERE "left" = ($1 :: uuid)|] + +-- | Deletes the mirror rows pointing at the deleted user ((left=contact, +-- right=u) for every contact of u), mirroring the Cassandra per-contact +-- 'connectionDelete' calls in 'Wire.ConnectionStore.Cassandra.deleteConnections'. +deleteIncomingLocalConnections :: Hasql.Statement UserId () +deleteIncomingLocalConnections = + lmapPG + [resultlessStatement|DELETE FROM connection c + WHERE c."right" = ($1 :: uuid) + AND c."left" = ANY (SELECT s."right" FROM connection s WHERE s."left" = ($1 :: uuid)) + |] + +deleteRemoteConnectionsByLeft :: Hasql.Statement UserId () +deleteRemoteConnectionsByLeft = + lmapPG + [resultlessStatement|DELETE FROM connection_remote WHERE "left" = ($1 :: uuid)|] + +deleteRemoteConnectionsByUsers :: Hasql.Statement (UserId, Domain, [UserId]) () +deleteRemoteConnectionsByUsers = + lmapPG @(UUID, Text, Vector.Vector UUID) @(UserId, Domain, [UserId]) + [resultlessStatement|DELETE FROM connection_remote + WHERE "left" = ANY ($3 :: uuid[]) AND right_domain = ($2 :: text) AND right_user = ($1 :: uuid) + |] + +selectLocalConnection :: Hasql.Statement (UserId, UserId) (Maybe (UUID, Int32, UTCTime, Maybe UUID)) +selectLocalConnection = + dimapPG + [maybeStatement|SELECT ("right" :: uuid), (status :: int4), (last_update :: timestamptz), (conv :: uuid?) + FROM connection WHERE "left" = ($1 :: uuid) AND "right" = ($2 :: uuid) + |] + +selectRemoteConnection :: Hasql.Statement (UserId, Domain, UserId) (Maybe (Int32, UTCTime, Maybe Domain, Maybe UUID)) +selectRemoteConnection = + dimapPG + [maybeStatement|SELECT (status :: int4), (last_update :: timestamptz), (conv_domain :: text?), (conv_id :: uuid?) + FROM connection_remote + WHERE "left" = ($1 :: uuid) AND right_domain = ($2 :: text) AND right_user = ($3 :: uuid) + |] + +selectLocalRelation :: Hasql.Statement (UserId, UserId) (Maybe Int32) +selectLocalRelation = + dimapPG + [maybeStatement|SELECT (status :: int4) FROM connection WHERE "left" = ($1 :: uuid) AND "right" = ($2 :: uuid)|] + +selectRemoteRelation :: Hasql.Statement (UserId, Domain, UserId) (Maybe Int32) +selectRemoteRelation = + dimapPG + [maybeStatement|SELECT (status :: int4) FROM connection_remote + WHERE "left" = ($1 :: uuid) AND right_domain = ($2 :: text) AND right_user = ($3 :: uuid) + |] + +-- | LIMIT is size + 1 in the caller, mirroring the Cassandra \"fetch one +-- extra\" behaviour. +selectLocalConnections :: Hasql.Statement (UserId, Int32) (Vector.Vector (UUID, Int32, UTCTime, Maybe UUID)) +selectLocalConnections = + dimapPG + [vectorStatement|SELECT ("right" :: uuid), (status :: int4), (last_update :: timestamptz), (conv :: uuid?) + FROM connection WHERE "left" = ($1 :: uuid) + ORDER BY "right" ASC LIMIT ($2 :: int4) + |] + +selectLocalConnectionsFrom :: Hasql.Statement (UserId, UserId, Int32) (Vector.Vector (UUID, Int32, UTCTime, Maybe UUID)) +selectLocalConnectionsFrom = + dimapPG + [vectorStatement|SELECT ("right" :: uuid), (status :: int4), (last_update :: timestamptz), (conv :: uuid?) + FROM connection WHERE "left" = ($1 :: uuid) AND "right" > ($2 :: uuid) + ORDER BY "right" ASC LIMIT ($3 :: int4) + |] + +selectRemoteConnections :: Hasql.Statement (UserId, Int32) (Vector.Vector (Domain, UUID, Int32, UTCTime, Maybe Domain, Maybe UUID)) +selectRemoteConnections = + dimapPG + [vectorStatement|SELECT (right_domain :: text), (right_user :: uuid), (status :: int4), (last_update :: timestamptz), (conv_domain :: text?), (conv_id :: uuid?) + FROM connection_remote WHERE "left" = ($1 :: uuid) + ORDER BY right_domain ASC, right_user ASC LIMIT ($2 :: int4) + |] + +selectRemoteConnectionsFrom :: Hasql.Statement (UserId, Domain, UserId, Int32) (Vector.Vector (Domain, UUID, Int32, UTCTime, Maybe Domain, Maybe UUID)) +selectRemoteConnectionsFrom = + dimapPG + [vectorStatement|SELECT (right_domain :: text), (right_user :: uuid), (status :: int4), (last_update :: timestamptz), (conv_domain :: text?), (conv_id :: uuid?) + FROM connection_remote + WHERE "left" = ($1 :: uuid) AND (right_domain, right_user) > (($2 :: text), ($3 :: uuid)) + ORDER BY right_domain ASC, right_user ASC LIMIT ($4 :: int4) + |] + +selectConnectionStatuses :: Hasql.Statement ([UserId], [UserId]) (Vector.Vector (UUID, UUID, Int32)) +selectConnectionStatuses = + dimapPG @(Vector.Vector UUID, Vector.Vector UUID) @([UserId], [UserId]) + [vectorStatement|SELECT ("left" :: uuid), ("right" :: uuid), (status :: int4) + FROM connection WHERE "left" = ANY ($1 :: uuid[]) AND "right" = ANY ($2 :: uuid[]) + |] + +selectConnectionStatuses' :: Hasql.Statement [UserId] (Vector.Vector (UUID, UUID, Int32)) +selectConnectionStatuses' = + dimapPG @(Vector.Vector UUID) @[UserId] + [vectorStatement|SELECT ("left" :: uuid), ("right" :: uuid), (status :: int4) + FROM connection WHERE "left" = ANY ($1 :: uuid[]) + |] + +selectLocalRelations :: Hasql.Statement (UserId, [UserId]) (Vector.Vector (UUID, Int32)) +selectLocalRelations = + dimapPG @(UUID, Vector.Vector UUID) @(UserId, [UserId]) + [vectorStatement|SELECT ("right" :: uuid), (status :: int4) + FROM connection WHERE "left" = ($1 :: uuid) AND "right" = ANY ($2 :: uuid[]) + |] + +selectRemoteRelations :: Hasql.Statement (UserId, Domain, [UserId]) (Vector.Vector (UUID, Int32)) +selectRemoteRelations = + dimapPG @(UUID, Text, Vector.Vector UUID) @(UserId, Domain, [UserId]) + [vectorStatement|SELECT (right_user :: uuid), (status :: int4) + FROM connection_remote WHERE "left" = ($1 :: uuid) AND right_domain = ($2 :: text) AND right_user = ANY ($3 :: uuid[]) + |] + +selectAllLocalRelations :: Hasql.Statement UserId (Vector.Vector (UUID, Int32)) +selectAllLocalRelations = + dimapPG + [vectorStatement|SELECT ("right" :: uuid), (status :: int4) + FROM connection WHERE "left" = ($1 :: uuid) + |] + +selectAllRemoteRelations :: Hasql.Statement UserId (Vector.Vector (Domain, UUID, Int32)) +selectAllRemoteRelations = + dimapPG + [vectorStatement|SELECT (right_domain :: text), (right_user :: uuid), (status :: int4) + FROM connection_remote WHERE "left" = ($1 :: uuid) + |] diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs b/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs index e0c7ff79daf..b654e43d3b9 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs @@ -61,7 +61,8 @@ data PostgresMigrationOpts = PostgresMigrationOpts passwordReset :: StorageLocation, customBackend :: StorageLocation, budget :: StorageLocation, - nonce :: StorageLocation + nonce :: StorageLocation, + connections :: StorageLocation } deriving (Show) @@ -78,3 +79,4 @@ instance FromJSON PostgresMigrationOpts where <*> o .: "customBackend" <*> o .: "budget" <*> o .: "nonce" + <*> o .: "connections" diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 8142f8f83f2..c3e1969b0e8 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -267,6 +267,11 @@ library Wire.CodeStore.DualWrite Wire.CodeStore.Migration Wire.CodeStore.Postgres + Wire.ConnectionStore + Wire.ConnectionStore.Cassandra + Wire.ConnectionStore.DualWrite + Wire.ConnectionStore.Migration + Wire.ConnectionStore.Postgres Wire.ConversationStore Wire.ConversationStore.Cassandra Wire.ConversationStore.Cassandra.Instances diff --git a/postgres-schema.sql b/postgres-schema.sql index 40a4f9d6081..d0d7badf838 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -1396,6 +1396,38 @@ CREATE TABLE public.collaborators ( ALTER TABLE public.collaborators OWNER TO "wire-server"; +-- +-- Name: connection; Type: TABLE; Schema: public; Owner: wire-server +-- + +CREATE TABLE public.connection ( + "left" uuid NOT NULL, + "right" uuid NOT NULL, + status integer NOT NULL, + last_update timestamp with time zone NOT NULL, + conv uuid +); + + +ALTER TABLE public.connection OWNER TO "wire-server"; + +-- +-- Name: connection_remote; Type: TABLE; Schema: public; Owner: wire-server +-- + +CREATE TABLE public.connection_remote ( + "left" uuid NOT NULL, + right_domain text NOT NULL, + right_user uuid NOT NULL, + status integer NOT NULL, + last_update timestamp with time zone NOT NULL, + conv_domain text, + conv_id uuid +); + + +ALTER TABLE public.connection_remote OWNER TO "wire-server"; + -- -- Name: conversation; Type: TABLE; Schema: public; Owner: wire-server -- @@ -2032,6 +2064,22 @@ ALTER TABLE ONLY public.collaborators ADD CONSTRAINT collaborators_pkey PRIMARY KEY (user_id, team_id); +-- +-- Name: connection connection_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server +-- + +ALTER TABLE ONLY public.connection + ADD CONSTRAINT connection_pkey PRIMARY KEY ("left", "right"); + + +-- +-- Name: connection_remote connection_remote_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server +-- + +ALTER TABLE ONLY public.connection_remote + ADD CONSTRAINT connection_remote_pkey PRIMARY KEY ("left", right_domain, right_user); + + -- -- Name: conversation_codes conversation_codes_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server -- @@ -2597,6 +2645,13 @@ CREATE INDEX collaborators_team_id_idx ON public.collaborators USING btree (team CREATE INDEX collaborators_user_id_idx ON public.collaborators USING btree (user_id); +-- +-- Name: connection_remote_right_domain_idx; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX connection_remote_right_domain_idx ON public.connection_remote USING btree (right_domain); + + -- -- Name: conversation_codes_expires_at_idx; Type: INDEX; Schema: public; Owner: wire-server -- diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 5adebf8e182..5ede47c1e60 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -63,6 +63,7 @@ migrateBlockList: false migratePasswordReset: false migrateCustomBackend: false migrateNonce: false +migrateConnections: false # Background jobs consumer configuration for integration backgroundJobs: @@ -102,3 +103,4 @@ postgresMigration: customBackend: postgresql budget: postgresql nonce: postgresql + connections: postgresql diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index a5f144540e0..2d42fc2648d 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -114,6 +114,13 @@ run opts galleyOpts = do withNamedLogger "migrate-custom-backend" $ Migrations.customBackend opts.migrationOptions else pure $ pure () + cleanupConnectionsMigration <- + if opts.migrateConnections + then + runAppT env $ + withNamedLogger "migrate-connections" $ + Migrations.connections opts.migrationOptions + else pure $ pure () cleanupJobs <- runAppT env $ withNamedLogger "background-job-consumer" $ @@ -125,7 +132,7 @@ run opts galleyOpts = do let cleanup = void $ runConcurrently $ - (,,,,,,,,,,,,) + (,,,,,,,,,,,,,) <$> Concurrently cleanupDeadUserNotifWatcher <*> Concurrently cleanupBackendNotifPusher <*> Concurrently cleanupConvMigration @@ -137,6 +144,7 @@ run opts galleyOpts = do <*> Concurrently cleanupNonceMigration <*> Concurrently cleanupPasswordResetMigration <*> Concurrently cleanupCustomBackendMigration + <*> Concurrently cleanupConnectionsMigration <*> Concurrently cleanupJobRunner <*> Concurrently cleanupJobs diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index eec1b625701..5bda51753e3 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -60,6 +60,7 @@ data Opts = Opts migratePasswordReset :: !Bool, migrateCustomBackend :: !Bool, migrateNonce :: !Bool, + migrateConnections :: !Bool, jobs :: JobConfig, meetingsCleanup :: MeetingsCleanupConfig, backgroundJobs :: BackgroundJobsConfig diff --git a/services/background-worker/src/Wire/PostgresMigrations.hs b/services/background-worker/src/Wire/PostgresMigrations.hs index d71532e7759..adc91725480 100644 --- a/services/background-worker/src/Wire/PostgresMigrations.hs +++ b/services/background-worker/src/Wire/PostgresMigrations.hs @@ -25,6 +25,7 @@ import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Util import Wire.BlockListStore.Migration import Wire.CodeStore.Migration +import Wire.ConnectionStore.Migration (migrateConnectionsLoop) import Wire.ConversationStore.Migration qualified as ConversationStore import Wire.CustomBackendStore.Migration import Wire.DomainRegistrationStore.Migration @@ -202,3 +203,21 @@ customBackend migOpts = do pure $ do Log.info logger $ Log.msg (Log.val "cancelling custom backend migration") cancel migrationLoop + +connections :: MigrationOptions -> AppT IO CleanupAction +connections migOpts = do + cassClient <- asks (.cassandraBrig) + pgPool <- asks (.hasqlPool) + logger <- asks (.logger) + Log.info logger $ Log.msg (Log.val "starting connections migration") + count <- register $ counter $ Prometheus.Info "wire_connections_migrated_to_pg" "Number of connections migrated to Postgresql" + finished <- register $ counter $ Prometheus.Info "wire_connections_migration_finished" "Whether the connections migration to Postgresql is finished successfully" + failed <- register $ counter $ Prometheus.Info "wire_connections_migration_failed" "Whether the connections migration to Postgresql has failed" + duration <- register $ vector "outcome" $ histogram (Prometheus.Info "wire_connections_migration_duration_seconds" "Duration of connections migration attempts") defaultBuckets + + migrationLoop <- async . lift $ migrateConnectionsLoop migOpts cassClient pgPool logger count finished failed duration + + Log.info logger $ Log.msg (Log.val "started connections migration") + pure $ do + Log.info logger $ Log.msg (Log.val "cancelling connections migration") + cancel migrationLoop diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 3798dd3deb0..a47d69b76bd 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -502,7 +502,8 @@ spec = do passwordReset = CassandraStorage, customBackend = CassandraStorage, budget = CassandraStorage, - nonce = CassandraStorage + nonce = CassandraStorage, + connections = CassandraStorage } gundeckEndpoint = undefined brigEndpoint = undefined @@ -572,7 +573,8 @@ spec = do passwordReset = CassandraStorage, customBackend = CassandraStorage, budget = CassandraStorage, - nonce = CassandraStorage + nonce = CassandraStorage, + connections = CassandraStorage } gundeckEndpoint = undefined brigEndpoint = undefined diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index fa4b593ebec..22085f71cc1 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -56,7 +56,8 @@ testEnv = do passwordReset = CassandraStorage, customBackend = CassandraStorage, budget = CassandraStorage, - nonce = CassandraStorage + nonce = CassandraStorage, + connections = CassandraStorage } statuses <- newIORef mempty backendNotificationMetrics <- mkBackendNotificationMetrics diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index db0371a3d77..9cb024ad49e 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -108,8 +108,6 @@ library Brig.Data.Types Brig.Data.User Brig.DeleteQueue.Interpreter - Brig.Effects.ConnectionStore - Brig.Effects.ConnectionStore.Cassandra Brig.Index.Eval Brig.Index.Options Brig.Index.Types @@ -260,7 +258,6 @@ library , metrics-wai >=0.3 , mime , mime-mail >=0.4 - , mmorph , MonadRandom >=0.5 , mtl >=2.1 , network >=2.4 diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 9714748b097..e0044977c51 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -183,6 +183,7 @@ postgresMigration: customBackend: postgresql budget: postgresql nonce: postgresql + connections: cassandra optSettings: setActivationTimeout: 4 diff --git a/services/brig/default.nix b/services/brig/default.nix index ede0af1fd33..0f857179bc3 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -73,7 +73,6 @@ , metrics-wai , mime , mime-mail -, mmorph , MonadRandom , mtl , network @@ -212,7 +211,6 @@ mkDerivation { metrics-wai mime mime-mail - mmorph MonadRandom mtl network diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 375a5300f93..0d906e69d7d 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -40,6 +40,7 @@ import Brig.API.User (getLegalHoldStatus) import Brig.App import Brig.Data.Connection qualified as Data import Brig.Data.Types (resultHasMore, resultList) +import Brig.Data.Types qualified as Data import Brig.IO.Intra qualified as Intra import Brig.IO.Logging import Brig.Options @@ -54,6 +55,7 @@ import Data.UUID.V4 qualified as UUID import Galley.Types.Conversations.One2One import Imports import Polysemy +import Polysemy.Input (Input) import Polysemy.TinyLog import System.Logger.Class qualified as Log import System.Logger.Message @@ -64,10 +66,12 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.ConnectionStore (ConnectionStore) import Wire.FederationAPIAccess import Wire.FederationConfigStore import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.TeamSubsystem (TeamSubsystem) import Wire.UserStore as UserStore import Wire.UserSubsystem @@ -81,6 +85,8 @@ createConnection :: Member UserSubsystem r, Member (Embed HttpClientIO) r, Member TeamSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r, HasBrigFederationAccess m r ) => Local UserId -> @@ -103,7 +109,9 @@ createConnectionToLocalUser :: Member UserStore r, Member UserSubsystem r, Member (Embed HttpClientIO) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => Local UserId -> ConnId -> @@ -116,8 +124,8 @@ createConnectionToLocalUser self conn target = do checkLegalholdPolicyConflict self target ensureNotSameTeam self target ensureNoApps self (tUntagged . fmap Left <$> [self, target]) - s2o <- lift . wrapClient $ Data.lookupConnection self (tUntagged target) - o2s <- lift . wrapClient $ Data.lookupConnection target (tUntagged self) + s2o <- lift . liftSem $ Data.lookupConnection self (tUntagged target) + o2s <- lift . liftSem $ Data.lookupConnection target (tUntagged self) case update <$> s2o <*> o2s of Just rs -> rs @@ -131,8 +139,8 @@ createConnectionToLocalUser self conn target = do logConnection (tUnqualified self) (tUntagged target) . msg (val "Creating connection") qcnv <- Intra.createConnectConv (tUntagged self) (tUntagged target) Nothing (Just conn) - s2o' <- wrapClient $ Data.insertConnection self (tUntagged target) SentWithHistory qcnv - o2s' <- wrapClient $ Data.insertConnection target (tUntagged self) PendingWithHistory qcnv + s2o' <- liftSem $ Data.insertConnection self (tUntagged target) SentWithHistory qcnv + o2s' <- liftSem $ Data.insertConnection target (tUntagged self) PendingWithHistory qcnv e2o <- ConnectionUpdated o2s' <$> liftSem (UserStore.lookupName (tUnqualified self)) let e2s = ConnectionUpdated s2o' Nothing @@ -162,9 +170,9 @@ createConnectionToLocalUser self conn target = do logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") cnv <- lift $ for (ucConvId s2o) $ Intra.acceptConnectConv self (Just conn) - s2o' <- lift . wrapClient $ Data.updateConnection s2o AcceptedWithHistory + s2o' <- lift . liftSem $ Data.updateConnection s2o AcceptedWithHistory o2s' <- - lift . wrapClient $ + lift . liftSem $ if (cnvType <$> cnv) == Just ConnectConv then Data.updateConnection o2s BlockedWithHistory else Data.updateConnection o2s AcceptedWithHistory @@ -185,7 +193,7 @@ createConnectionToLocalUser self conn target = do Existed <$> insert change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) - change c s = Existed <$> lift (wrapClient $ Data.updateConnection c s) + change c s = Existed <$> lift (liftSem $ Data.updateConnection c s) -- | Guard local connection creation against legal-hold consent conflicts. -- Rejects when one user is `no_consent` while the other has LH enabled. @@ -227,6 +235,8 @@ updateConnection :: Member (Embed HttpClientIO) r, Member GalleyAPIAccess r, Member UserStore r, + Member (Input (Local ())) r, + Member (ConnectionStore InternalPaging) r, HasBrigFederationAccess m r ) => Local UserId -> @@ -253,7 +263,9 @@ updateConnectionToLocalUser :: Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, - Member UserStore r + Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => -- | From Local UserId -> @@ -327,7 +339,7 @@ updateConnectionToLocalUser self other newStatus conn = do -- crashes. when (ucStatus o2s `elem` [Sent, Pending]) . lift $ do o2s' <- - wrapClient $ + liftSem $ if (cnvType <$> cnv) /= Just ConnectConv then Data.updateConnection o2s AcceptedWithHistory else Data.updateConnection o2s BlockedWithHistory @@ -335,7 +347,7 @@ updateConnectionToLocalUser self other newStatus conn = do ConnectionUpdated o2s' <$> liftSem (UserStore.lookupName (tUnqualified self)) liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o - lift . wrapClient $ Just <$> Data.updateConnection s2o AcceptedWithHistory + lift . liftSem $ Just <$> Data.updateConnection s2o AcceptedWithHistory block :: UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) block s2o = lift $ do @@ -348,7 +360,7 @@ updateConnectionToLocalUser self other newStatus conn = do let mlsConvId = one2OneConvId BaseProtocolMLSTag (tUntagged self) (tUntagged other) isEstablished <- isMLSOne2OneEstablished self (tUntagged other) when (isEstablished == Established) $ Intra.blockConv self mlsConvId - wrapClient $ Just <$> Data.updateConnection s2o BlockedWithHistory + liftSem $ Just <$> Data.updateConnection s2o BlockedWithHistory unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) unblock s2o o2s new = do @@ -367,7 +379,7 @@ updateConnectionToLocalUser self other newStatus conn = do unblockConversation self conn mlsConvId when (ucStatus o2s == Sent && new == Accepted) . lift $ do o2s' <- - wrapClient $ + liftSem $ if (cnvType <$> cnv) /= Just ConnectConv then Data.updateConnection o2s AcceptedWithHistory else Data.updateConnection o2s BlockedWithHistory @@ -377,7 +389,7 @@ updateConnectionToLocalUser self other newStatus conn = do <$> UserStore.lookupName (tUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o - lift . wrapClient $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) + lift . liftSem $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) cancel s2o o2s = do @@ -386,7 +398,7 @@ updateConnectionToLocalUser self other newStatus conn = do . msg (val "Cancelling connection") lfrom <- qualifyLocal (ucFrom s2o) lift $ traverse_ (liftSem . Intra.blockConv lfrom) (ucConvId s2o) - o2s' <- lift . wrapClient $ Data.updateConnection o2s CancelledWithHistory + o2s' <- lift . liftSem $ Data.updateConnection o2s CancelledWithHistory let e2o = ConnectionUpdated o2s' Nothing lift $ liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled @@ -394,14 +406,16 @@ updateConnectionToLocalUser self other newStatus conn = do change :: UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) change c s = do -- FUTUREWORK: refactor to total function. Gets only called with either Ignored, Accepted, Cancelled - lift . wrapClient $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) + lift . liftSem $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) localConnection :: + forall r. + (Member (ConnectionStore InternalPaging) r) => Local UserId -> Local UserId -> ExceptT ConnectionError (AppT r) UserConnection localConnection la lb = do - lift (wrapClient $ Data.lookupConnection la (tUntagged lb)) + lift (liftSem $ Data.lookupConnection la (tUntagged lb)) >>= tryJust (NotConnected (tUnqualified la) (tUntagged lb)) mkRelationWithHistory :: (HasCallStack) => Relation -> Relation -> RelationWithHistory @@ -428,7 +442,9 @@ updateConnectionInternal :: Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member UserStore r + Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => UpdateConnectionsInternal -> ExceptT ConnectionError (AppT r) () @@ -459,7 +475,7 @@ updateConnectionInternal = \case for_ [s2o, o2s] $ \(uconn :: UserConnection) -> lift $ do lfrom <- qualifyLocal (ucFrom uconn) traverse_ (liftSem . Intra.blockConv lfrom) (ucConvId uconn) - uconn' <- wrapClient $ Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) + uconn' <- liftSem $ Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) let ev = ConnectionUpdated uconn' Nothing liftSem $ Intra.onConnectionEvent (tUnqualified self) Nothing ev @@ -483,7 +499,7 @@ updateConnectionInternal = \case where go :: Maybe UserId -> ExceptT ConnectionError (AppT r) () go mbStart = do - page <- lift . wrapClient $ Data.lookupLocalConnections user mbStart pageSize + page <- lift . liftSem $ Data.lookupLocalConnections user mbStart pageSize handleConns (resultList page) case resultList page of (conn : rest) -> @@ -495,7 +511,7 @@ updateConnectionInternal = \case lfrom <- qualifyLocal (ucFrom uconnRev) void . lift . liftSem . for (ucConvId uconn) $ unblockConversation lfrom Nothing uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev) - uconnRev' <- lift . wrapClient $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) + uconnRev' <- lift . liftSem $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) connName <- lift . liftSem $ UserStore.lookupName (tUnqualified lfrom) let connEvent = ConnectionUpdated @@ -509,7 +525,7 @@ updateConnectionInternal = \case Qualified UserId -> ExceptT ConnectionError (AppT r) RelationWithHistory relationWithHistory self target = - lift (wrapClient $ Data.lookupRelationWithHistory self target) + lift (liftSem $ Data.lookupRelationWithHistory self target) >>= tryJust (NotConnected (tUnqualified self) target) undoRelationHistory :: RelationWithHistory -> RelationWithHistory @@ -529,20 +545,36 @@ updateConnectionInternal = \case SentWithHistory -> SentWithHistory CancelledWithHistory -> CancelledWithHistory -createLocalConnectionUnchecked :: Local UserId -> Local UserId -> (AppT r) () +createLocalConnectionUnchecked :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + Local UserId -> + Local UserId -> + (AppT r) () createLocalConnectionUnchecked self other = do qcnv <- liftIO $ tUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) - wrapClient $ do + liftSem $ do void $ Data.insertConnection self (tUntagged other) AcceptedWithHistory qcnv void $ Data.insertConnection other (tUntagged self) AcceptedWithHistory qcnv -createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> (AppT r) () +createRemoteConnectionUnchecked :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + Local UserId -> + Remote UserId -> + (AppT r) () createRemoteConnectionUnchecked self other = do qcnv <- liftIO $ tUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) - void . wrapClient $ Data.insertConnection self (tUntagged other) AcceptedWithHistory qcnv + void . liftSem $ Data.insertConnection self (tUntagged other) AcceptedWithHistory qcnv -lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppT r) UserConnectionList +lookupConnections :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + UserId -> + Maybe UserId -> + Range 1 500 Int32 -> + (AppT r) UserConnectionList lookupConnections from start size = do lusr <- qualifyLocal from - rs <- wrapClient $ Data.lookupLocalConnections lusr start size + rs <- liftSem $ Data.lookupLocalConnections lusr start size pure $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 91a8212516e..a7e2c915a06 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -37,6 +37,7 @@ import Data.Qualified import Galley.Types.Conversations.One2One (one2OneConvId) import Imports import Polysemy +import Polysemy.Input (Input) import System.Logger.Class qualified as Log import Wire.API.Component import Wire.API.Connection @@ -47,10 +48,12 @@ import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.Routes.Versioned qualified as V import Wire.API.User import Wire.API.UserEvent +import Wire.ConnectionStore (ConnectionStore) import Wire.FederationAPIAccess import Wire.FederationConfigStore import Wire.GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserStore as UserStore import Wire.UserSubsystem @@ -152,7 +155,11 @@ desiredMembership a r = -- -- Returns the connection, and whether it was updated or not. transitionTo :: - (Member GalleyAPIAccess r, Member NotificationSubsystem r) => + ( Member GalleyAPIAccess r, + Member NotificationSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r + ) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -175,7 +182,7 @@ transitionTo self mzcon other Nothing (Just rel) actor = lift $ do -- create connection connection <- - wrapClient $ + liftSem $ Data.insertConnection self (tUntagged other) @@ -206,7 +213,7 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = do $ updateOne2OneConv self Nothing other mlsConvId desiredMem actor -- update connection - connection' <- lift $ wrapClient $ Data.updateConnection connection (relationWithHistory rel) + connection' <- lift $ liftSem $ Data.updateConnection connection (relationWithHistory rel) -- send event lift $ pushEvent self mzcon connection' @@ -227,6 +234,8 @@ performLocalAction :: ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r, HasBrigFederationAccess m r ) => Local UserId -> @@ -282,7 +291,11 @@ performLocalAction luid mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: - (Member GalleyAPIAccess r, Member NotificationSubsystem r) => + ( Member GalleyAPIAccess r, + Member NotificationSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r + ) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -305,6 +318,8 @@ createConnectionToRemoteUser :: Member UserStore r, Member UserSubsystem r, Member NotificationSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r, HasBrigFederationAccess m r ) => Local UserId -> @@ -318,7 +333,7 @@ createConnectionToRemoteUser self zcon other = do selfInfo = [tUntagged $ Left <$> self] otherInfo = [tUntagged $ qualifyAs other (Right op) | op <- maybeToList mbOtherProfile] ensureNoApps self $ selfInfo <> otherInfo - mconnection <- lift . wrapClient $ Data.lookupConnection self (tUntagged other) + mconnection <- lift . liftSem $ Data.lookupConnection self (tUntagged other) fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: @@ -326,6 +341,8 @@ updateConnectionToRemoteUser :: Member NotificationSubsystem r, Member FederationConfigStore r, Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r, HasBrigFederationAccess m r ) => Local UserId -> @@ -335,7 +352,7 @@ updateConnectionToRemoteUser :: (ConnectionM r) (Maybe UserConnection) updateConnectionToRemoteUser self other rel1 zcon = do void $ ensureFederatesWith other - mconnection <- lift . wrapClient $ Data.lookupConnection self (tUntagged other) + mconnection <- lift . liftSem $ Data.lookupConnection self (tUntagged other) action <- actionForTransition rel1 ?? InvalidTransition (tUnqualified self) @@ -350,7 +367,12 @@ updateConnectionToRemoteUser self other rel1 zcon = do actionForTransition Pending = Nothing actionForTransition MissingLegalholdConsent = Nothing -checkLimitForLocalAction :: Local UserId -> Relation -> LocalConnectionAction -> (ConnectionM r) () +checkLimitForLocalAction :: + (Member (ConnectionStore InternalPaging) r) => + Local UserId -> + Relation -> + LocalConnectionAction -> + (ConnectionM r) () checkLimitForLocalAction u oldRel action = when (oldRel `notElem` [Accepted, Sent] && (action == LocalConnect)) $ checkLimit u diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index ccbba0284c1..764c8ce33bf 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -27,7 +27,6 @@ where import Brig.API.Types import Brig.App -import Brig.Data.Connection qualified as Data import Brig.Options (Settings (userMaxConnections)) import Control.Error (MaybeT, noteT) import Control.Monad.Trans.Except @@ -38,7 +37,9 @@ import Imports import Polysemy import Wire.API.Connection (Relation (..)) import Wire.API.User +import Wire.ConnectionStore (ConnectionStore, countConnections) import Wire.GalleyAPIAccess +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserStore import Wire.UserSubsystem @@ -46,9 +47,13 @@ type ConnectionM r = ExceptT ConnectionError (AppT r) -- Helpers -checkLimit :: Local UserId -> ExceptT ConnectionError (AppT r) () +checkLimit :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + Local UserId -> + ExceptT ConnectionError (AppT r) () checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do - n <- lift . wrapClient $ Data.countConnections u [Accepted, Sent] + n <- lift . liftSem $ countConnections u [Accepted, Sent] l <- asks (.settings.userMaxConnections) guard (n < l) diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 32ca6bdfe45..c8bcfe0f831 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -46,6 +46,7 @@ import Data.Set qualified as Set import Imports hiding ((\\)) import Network.Wai.Utilities.Error ((!>>)) import Polysemy +import Polysemy.Input (Input) import Servant (ServerT) import Servant.API import Wire.API.Connection @@ -71,6 +72,7 @@ import Wire.ClientStore (ClientStore) import Wire.ClientSubsystem (ClientSubsystem) import Wire.ClientSubsystem qualified as ClientSubsystem import Wire.ClientSubsystem.Error (clientErrorToHttpError) +import Wire.ConnectionStore (ConnectionStore) import Wire.Error import Wire.FederationConfigStore (FederationConfigStore) import Wire.FederationConfigStore qualified as E @@ -78,6 +80,7 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.MlsKeyPackageSubsystem (MlsKeyPackageSubsystem) import Wire.NotificationSubsystem import Wire.Sem.Concurrency +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserStore import Wire.UserStore qualified as UserStore import Wire.UserSubsystem (UserSubsystem) @@ -94,7 +97,9 @@ federationSitemap :: Member UserStore r, Member ClientStore r, Member MlsKeyPackageSubsystem r, - Member ClientSubsystem r + Member ClientSubsystem r, + Member (Input (Local ())) r, + Member (ConnectionStore InternalPaging) r ) => ServerT FederationAPI (Handler r) federationSitemap = @@ -132,7 +137,9 @@ sendConnectionAction :: ( Member FederationConfigStore r, Member GalleyAPIAccess r, Member UserStore r, - Member NotificationSubsystem r + Member NotificationSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => Domain -> NewConnectionRequest -> @@ -147,7 +154,7 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do then do self <- qualifyLocal to let other = toRemoteUnsafe originDomain from - mconnection <- lift . wrapClient $ Data.lookupConnection self (tUntagged other) + mconnection <- lift . liftSem $ Data.lookupConnection self (tUntagged other) maction <- lift $ performRemoteAction self other mconnection action pure $ NewConnectionResponseOk maction else pure NewConnectionResponseUserNotActivated @@ -308,7 +315,8 @@ getMLSClientsV0 domain mcr0 = getMLSClients domain (mlsClientsRequestFromV0 mcr0 onUserDeleted :: ( Member (Concurrency 'Unsafe) r, - Member NotificationSubsystem r + Member NotificationSubsystem r, + Member (ConnectionStore InternalPaging) r ) => Domain -> UserDeletedConnectionsNotification -> @@ -320,11 +328,11 @@ onUserDeleted origDomain udcn = lift $ do acceptedLocals <- map csv2From . filter (\x -> csv2Status x == Accepted) - <$> wrapClient (Data.lookupRemoteConnectionStatuses (fromRange connections) (fmap pure deletedUser)) + <$> liftSem (Data.lookupRemoteConnectionStatuses (fromRange connections) (fmap pure deletedUser)) liftSem $ unsafePooledForConcurrentlyN_ 16 (nonEmpty acceptedLocals) $ \recipients -> notify event (tUnqualified deletedUser) Push.RouteDirect Nothing (pure recipients) - wrapClient $ Data.deleteRemoteConnections deletedUser connections + liftSem $ Data.deleteRemoteConnections deletedUser connections pure EmptyResponse -- | If domain is not configured fall back to `NoSearch` diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index a3f520ed3bf..d1ca63be99b 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -100,6 +100,7 @@ import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore import Wire.ClientSubsystem (ClientSubsystem, ReAuthPolicy (ReAuthPolicy)) import Wire.ClientSubsystem qualified as ClientSubsystem +import Wire.ConnectionStore (ConnectionStore) import Wire.DomainRegistrationStore hiding (domain) import Wire.EmailSubsystem (EmailSubsystem) import Wire.EnterpriseLoginSubsystem @@ -127,6 +128,7 @@ import Wire.Rpc import Wire.SAMLEmailSubsystem (SAMLEmailSubsystem, sendSAMLIdPChanged) import Wire.Sem.Concurrency import Wire.Sem.Now (Now) +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.Sem.Random (Random) import Wire.SparAPIAccess (SparAPIAccess) import Wire.StoredUser (StoredUser (..)) @@ -190,7 +192,8 @@ servantSitemap :: Member AppSubsystem r, Member ClientStore r, Member ClientSubsystem r, - Member MlsKeyPackageSubsystem r + Member MlsKeyPackageSubsystem r, + Member (ConnectionStore InternalPaging) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -221,7 +224,8 @@ ejpdAPI :: Member Rpc r, Member TeamSubsystem r, Member UserSubsystem r, - Member (Input (Local ())) r + Member (Input (Local ())) r, + Member (ConnectionStore InternalPaging) r ) => ServerT BrigIRoutes.EJPDRequest (Handler r) ejpdAPI = Named @"ejpd-request" Brig.User.EJPD.ejpdRequest @@ -260,7 +264,8 @@ accountAPI :: Member EnterpriseLoginSubsystem r, Member (Concurrency Unsafe) r, Member ClientStore r, - Member ClientSubsystem r + Member ClientSubsystem r, + Member (ConnectionStore InternalPaging) r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -647,7 +652,8 @@ deleteUserNoAuthH :: Member PropertySubsystem r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => UserId -> (Handler r) DeleteUserResponse @@ -819,21 +825,30 @@ getAccountStatusH uid = do (pure . AccountStatusResp) status -getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> (Handler r) [ConnectionStatus] +getConnectionsStatusUnqualified :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + ConnectionsStatusRequest -> + Maybe Relation -> + (Handler r) [ConnectionStatus] getConnectionsStatusUnqualified ConnectionsStatusRequest {csrFrom, csrTo} flt = lift $ do - r <- wrapClient $ maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo + r <- liftSem $ maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo pure $ maybe r (filterByRelation r) flt where filterByRelation l rel = filter ((== rel) . csStatus) l -getConnectionsStatus :: ConnectionsStatusRequestV2 -> (Handler r) [ConnectionStatusV2] +getConnectionsStatus :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + ConnectionsStatusRequestV2 -> + (Handler r) [ConnectionStatusV2] getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do loc <- qualifyLocal () conns <- lift $ case mtos of - Nothing -> wrapClient . Data.lookupAllStatuses =<< qualifyLocal froms + Nothing -> liftSem . Data.lookupAllStatuses =<< qualifyLocal froms Just tos -> do let getStatusesForOneDomain = - wrapClient + liftSem <$> foldQualified loc (Data.lookupLocalConnectionStatuses froms) @@ -857,7 +872,9 @@ updateConnectionInternalH :: Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member UserStore r + Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => UpdateConnectionsInternal -> (Handler r) NoContent @@ -1004,8 +1021,12 @@ checkHandleInternalH h = lift $ liftSem do API.CheckHandleFound -> CheckHandleResponseFound API.CheckHandleNotFound -> CheckHandleResponseNotFound -getContactListH :: UserId -> (Handler r) UserIds -getContactListH uid = lift . wrapClient $ UserIds <$> API.lookupContactList uid +getContactListH :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + UserId -> + (Handler r) UserIds +getContactListH uid = lift . liftSem $ UserIds <$> API.lookupContactList uid getUserExportDataH :: (Member UserSubsystem r) => diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 189212c2635..b4b97c714d1 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -44,7 +44,6 @@ import Brig.API.Util import Brig.App import Brig.Calling.API qualified as Calling import Brig.Data.Connection qualified as Data -import Brig.Effects.ConnectionStore import Brig.Options hiding (internalEvents) import Brig.Provider.API import Brig.Team.API qualified as Team @@ -54,6 +53,7 @@ import Brig.User.Auth.Cookie qualified as Auth import Brig.User.Client qualified as API import Cassandra qualified as C import Cassandra qualified as Data +import Cassandra.Exec (GeneralPaginationState (..)) import Control.Error hiding (bool, note) import Control.Lens ((?~)) import Control.Monad.Except @@ -161,6 +161,7 @@ import Wire.ClientStore qualified as ClientStore import Wire.ClientSubsystem (ClientSubsystem) import Wire.ClientSubsystem qualified as ClientSubsystem import Wire.ClientSubsystem.Error +import Wire.ConnectionStore import Wire.DeleteQueue import Wire.DomainRegistrationStore (DomainRegistrationStore) import Wire.EmailSending (EmailSending) @@ -1370,7 +1371,9 @@ createConnectionUnqualified :: Member UserStore r, Member UserSubsystem r, Member (Embed HttpClientIO) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => UserId -> ConnId -> @@ -1390,6 +1393,8 @@ createConnection :: Member TinyLog r, Member (Embed HttpClientIO) r, Member TeamSubsystem r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r, HasBrigFederationAccess m r ) => UserId -> @@ -1405,7 +1410,9 @@ updateLocalConnection :: Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member UserStore r + Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r ) => UserId -> ConnId -> @@ -1425,6 +1432,8 @@ updateConnection :: Member (Embed HttpClientIO) r, Member GalleyAPIAccess r, Member UserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r, HasBrigFederationAccess m r ) => UserId -> @@ -1437,7 +1446,13 @@ updateConnection self conn other (Public.cuStatus -> newStatus) = do mkUpdateResult <$> API.updateConnection lself other newStatus (Just conn) !>> connError -listLocalConnections :: UserId -> Maybe UserId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.UserConnectionList +listLocalConnections :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + UserId -> + Maybe UserId -> + Maybe (Range 1 500 Int32) -> + (Handler r) Public.UserConnectionList listLocalConnections uid start msize = do let defaultSize = toRange (Proxy @100) lift $ API.lookupConnections uid start (fromMaybe defaultSize msize) @@ -1450,29 +1465,40 @@ listLocalConnections uid start msize = do -- -- - After local connections, remote connections are listed ordered -- - lexicographically by their domain and then by their id. -listConnections :: UserId -> Public.ListConnectionsRequestPaginated -> (Handler r) Public.ConnectionsPage +listConnections :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + UserId -> + Public.ListConnectionsRequestPaginated -> + (Handler r) Public.ConnectionsPage listConnections uid Public.GetMultiTablePageRequest {..} = do self <- qualifyLocal uid case gmtprState of Just (Public.ConnectionPagingState Public.PagingRemotes stateBS) -> remotesOnly self (mkState <$> stateBS) (fromRange gmtprSize) _ -> localsAndRemotes self (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize where - pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState Void Public.UserConnection -> Public.ConnectionsPage + pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState ByteString Public.UserConnection -> Public.ConnectionsPage pageToConnectionsPage table page@Data.PageWithState {..} = Public.MultiTablePage { mtpResults = pwsResults, mtpHasMore = C.pwsHasMore page, -- FUTUREWORK confusingly, using 'ConversationPagingState' instead of 'ConnectionPagingState' doesn't fail any tests. -- Is this type actually useless? Or the tests not good enough? - mtpPagingState = Public.ConnectionPagingState table (LBS.toStrict . C.unPagingState <$> (Data.paginationStateCassandra =<< pwsState)) + mtpPagingState = Public.ConnectionPagingState table (pagingStateBytes =<< pwsState) } + -- Serialise either backend's paging marker as opaque response bytes. + pagingStateBytes :: GeneralPaginationState ByteString -> Maybe ByteString + pagingStateBytes = \case + PaginationStateCassandra ps -> Just (LBS.toStrict (C.unPagingState ps)) + PaginationStatePostgres marker -> Just marker + mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict localsAndRemotes :: Local UserId -> Maybe C.PagingState -> Range 1 500 Int32 -> (Handler r) Public.ConnectionsPage localsAndRemotes self pagingState size = do - localPage <- lift $ pageToConnectionsPage Public.PagingLocals <$> wrapClient (Data.lookupLocalConnectionsPage self pagingState (rcast size)) + localPage <- lift $ pageToConnectionsPage Public.PagingLocals <$> liftSem (Data.lookupLocalConnectionsPage self pagingState (rcast size)) let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. @@ -1482,18 +1508,28 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do remotesOnly :: Local UserId -> Maybe C.PagingState -> Int32 -> (Handler r) Public.ConnectionsPage remotesOnly self pagingState size = - lift . wrapClient $ + lift . liftSem $ pageToConnectionsPage Public.PagingRemotes <$> Data.lookupRemoteConnectionsPage self pagingState size -getLocalConnection :: UserId -> UserId -> (Handler r) (Maybe Public.UserConnection) +getLocalConnection :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + UserId -> + UserId -> + (Handler r) (Maybe Public.UserConnection) getLocalConnection self other = do lother <- qualifyLocal other getConnection self (tUntagged lother) -getConnection :: UserId -> Qualified UserId -> (Handler r) (Maybe Public.UserConnection) +getConnection :: + forall r. + (Member (ConnectionStore InternalPaging) r) => + UserId -> + Qualified UserId -> + (Handler r) (Maybe Public.UserConnection) getConnection self other = do lself <- qualifyLocal self - lift . wrapClient $ Data.lookupConnection lself other + lift . liftSem $ Data.lookupConnection lself other deleteSelfUser :: ( Member GalleyAPIAccess r, @@ -1512,7 +1548,8 @@ deleteSelfUser :: Member RateLimit r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => Local UserId -> Public.DeleteUser -> @@ -1533,7 +1570,8 @@ verifyDeleteUser :: Member Events r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => Public.VerifyDeleteUser -> Handler r () diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index d26a22d5fa6..ebbb45ac295 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -68,10 +68,8 @@ import Brig.API.Util import Brig.App as App import Brig.Data.Activation (ActivationEvent (..), activationErrorToRegisterError) import Brig.Data.Activation qualified as Data -import Brig.Data.Connection (countConnections) import Brig.Data.Connection qualified as Data import Brig.Data.User -import Brig.Effects.ConnectionStore import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) import Brig.User.Auth.Cookie qualified as Auth @@ -124,6 +122,7 @@ import Wire.BackendNotificationQueueAccess import Wire.BlockListStore as BlockListStore import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore +import Wire.ConnectionStore import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error @@ -1026,7 +1025,8 @@ deleteSelfUser :: Member RateLimit r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => Local UserId -> Maybe PlainTextPassword6 -> @@ -1101,7 +1101,8 @@ verifyDeleteUser :: Member PropertySubsystem r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => VerifyDeleteUser -> ExceptT DeleteUserError (AppT r) () @@ -1132,7 +1133,8 @@ ensureAccountDeleted :: Member PropertySubsystem r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => Local UserId -> AppT r DeleteUserResult @@ -1146,7 +1148,7 @@ ensureAccountDeleted luid@(tUnqualified -> uid) = do clients <- liftSem $ ClientStore.lookupClients uid localUid <- qualifyLocal uid - conCount <- wrapClient $ countConnections localUid [(minBound @Relation) .. maxBound] + conCount <- liftSem $ countConnections localUid [(minBound @Relation) .. maxBound] cookies <- wrapClient $ Auth.listCookies uid [] if notNull probs @@ -1184,7 +1186,8 @@ deleteAccount :: Member Events r, Member AuthenticationSubsystem r, Member UserGroupSubsystem r, - Member ClientStore r + Member ClientStore r, + Member (ConnectionStore InternalPaging) r ) => User -> Sem r () @@ -1210,10 +1213,9 @@ deleteAccount user = do luid <- embed $ qualifyLocal uid User.internalUpdateSearchIndex uid Events.generateUserEvent uid Nothing (UserDeleted (tUntagged luid)) - embed do - -- Note: Connections can only be deleted afterwards, since - -- they need to be notified. - Data.deleteConnections uid + -- Note: Connections can only be deleted afterwards, since + -- they need to be notified. + Data.deleteConnections uid Auth.revokeAllCookies uid ------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 4d2b6cc2773..768779980da 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -20,8 +20,6 @@ module Brig.CanonicalInterpreter where import Brig.AWS (amazonkaEnv, prekeyTable) import Brig.App as App import Brig.DeleteQueue.Interpreter as DQ -import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) import Brig.IO.Intra (runEvents) import Brig.Options (Settings (consumableNotifications), federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt @@ -82,6 +80,10 @@ import Wire.ClientStore.DynamoDB (OptimisticLockEnv (..)) import Wire.ClientSubsystem import Wire.ClientSubsystem.Error (clientErrorToHttpError) import Wire.ClientSubsystem.Interpreter +import Wire.ConnectionStore (ConnectionStore) +import Wire.ConnectionStore.Cassandra (connectionStoreToCassandra) +import Wire.ConnectionStore.DualWrite (interpretConnectionStoreToCassandraAndPostgres) +import Wire.ConnectionStore.Postgres (interpretConnectionStoreToPostgres) import Wire.DeleteQueue import Wire.DomainRegistrationStore import Wire.DomainRegistrationStore.Cassandra @@ -480,6 +482,23 @@ runBrigToIO e (AppT ma) = do . interpretBudgetStoreToCassandraAndPostgres @Cas.Client . raiseUnder2 + -- Same slot consideration as passwordResetCodeStore above: the + -- Postgres-backed branches supply Input Pool and Error UsageError + -- locally (raiseUnder2 + runInputConst + mapError). + connectionsStoreInterpreter = + case e.postgresMigration.connections of + CassandraStorage -> connectionStoreToCassandra + PostgresqlStorage -> + runInputConst e.hasqlPool + . mapError postgresUsageErrorToHttpError + . interpretConnectionStoreToPostgres + . raiseUnder2 + MigrationToPostgresql -> + runInputConst e.hasqlPool + . mapError postgresUsageErrorToHttpError + . interpretConnectionStoreToCassandraAndPostgres + . raiseUnder2 + ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency @@ -520,7 +539,7 @@ runBrigToIO e (AppT ma) = do . runInputConst appSubsystemConfig . runInputConst e.hasqlPool . runInputConst e.casClient - . connectionStoreToCassandra + . connectionsStoreInterpreter . interpretSFT e.httpManager . interpretPropertyStoreCassandra e.casClient . interpretInvitationStoreToCassandra e.casClient diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 41a6f9a8275..de96c41b29c 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -15,82 +15,44 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +-- | Brig-side helpers around the 'Wire.ConnectionStore' effect. All CQL lives +-- in @Wire.ConnectionStore.Cassandra@; this module only re-exports the effect +-- operations and provides combinators that need brig-side context. module Brig.Data.Connection - ( -- * DB Operations - insertConnection, + ( -- * Re-exports (effect operations and conversions) + module W, + + -- * Brig-side helpers updateConnection, - updateConnectionStatus, - lookupConnection, - lookupLocalConnectionsPage, - lookupRemoteConnectionsPage, - lookupRelationWithHistory, - lookupLocalConnections, - lookupConnectionStatus, - lookupConnectionStatus', lookupContactList, - lookupContactListWithRelation, - lookupLocalConnectionStatuses, - lookupRemoteConnectionStatuses, - lookupAllStatuses, - lookupRemoteConnectedUsersPaginated, - countConnections, - deleteConnections, - deleteRemoteConnections, - remoteConnectionInsert, - remoteConnectionSelect, - remoteConnectionSelectFrom, - remoteConnectionDelete, - remoteConnectionClear, - - -- * Re-exports - module T, + lookupLocalConnections, ) where -import Brig.App -import Brig.Data.Types as T -import Cassandra -import Control.Monad.Morph -import Control.Monad.Trans.Maybe -import Data.Conduit (runConduit, (.|)) -import Data.Conduit.List qualified as C -import Data.Domain (Domain) -import Data.Id -import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) -import Data.Qualified -import Data.Range -import Data.Time (getCurrentTime) +import Brig.Data.Types (ResultPage, cassandraResultPage) +import Data.Id (UserId) +import Data.Qualified (Local) +import Data.Range (Range) import Imports hiding (local) -import UnliftIO.Async (pooledForConcurrentlyN_, pooledMapConcurrentlyN, pooledMapConcurrentlyN_) +import Polysemy +import Polysemy.Input import Wire.API.Connection -import Wire.API.Routes.Internal.Brig.Connection - -insertConnection :: - (MonadClient m) => - Local UserId -> - Qualified UserId -> + ( RelationWithHistory (AcceptedWithHistory), + UserConnection (..), + relationDropHistory, + ) +import Wire.ConnectionStore hiding (lookupLocalConnections) +import Wire.ConnectionStore qualified as W +import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.Util (qualifyLocal) + +updateConnection :: + ( Member (ConnectionStore InternalPaging) r, + Member (Input (Local ())) r + ) => + UserConnection -> RelationWithHistory -> - Qualified ConvId -> - m UserConnection -insertConnection self target rel qcnv@(Qualified cnv cdomain) = do - now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (tUnqualified -> ltarget) = - write connectionInsert $ - params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) - let remote (tUntagged -> Qualified rtarget domain) = - write remoteConnectionInsert $ - params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) - retry x5 $ foldQualified self local remote target - pure $ - UserConnection - { ucFrom = tUnqualified self, - ucTo = target, - ucStatus = relationDropHistory rel, - ucLastUpdate = now, - ucConvId = Just qcnv - } - -updateConnection :: (MonadClient m, MonadReader Env m) => UserConnection -> RelationWithHistory -> m UserConnection + Sem r UserConnection updateConnection c status = do self <- qualifyLocal (ucFrom c) now <- updateConnectionStatus self (ucTo c) status @@ -100,314 +62,20 @@ updateConnection c status = do ucLastUpdate = now } -updateConnectionStatus :: (MonadClient m) => Local UserId -> Qualified UserId -> RelationWithHistory -> m UTCTimeMillis -updateConnectionStatus self target status = do - now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (tUnqualified -> ltarget) = - write connectionUpdate $ - params LocalQuorum (status, now, tUnqualified self, ltarget) - let remote (tUntagged -> Qualified rtarget domain) = - write remoteConnectionUpdate $ - params LocalQuorum (status, now, tUnqualified self, domain, rtarget) - retry x5 $ foldQualified self local remote target - pure now - --- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupConnection :: (MonadClient m) => Local UserId -> Qualified UserId -> m (Maybe UserConnection) -lookupConnection self target = runMaybeT $ do - let local (tUnqualified -> ltarget) = do - (_, _, rel, time, mcnv) <- - MaybeT . query1 connectionSelect $ - params LocalQuorum (tUnqualified self, ltarget) - pure (rel, time, fmap (tUntagged . qualifyAs self) mcnv) - let remote (tUntagged -> Qualified rtarget domain) = do - (rel, time, cdomain, cnv) <- - MaybeT . query1 remoteConnectionSelectFrom $ - params LocalQuorum (tUnqualified self, domain, rtarget) - pure (rel, time, Just (Qualified cnv cdomain)) - (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target - pure $ - UserConnection - { ucFrom = tUnqualified self, - ucTo = target, - ucStatus = relationDropHistory rel, - ucLastUpdate = time, - ucConvId = mqcnv - } - --- | 'lookupConnection' with more 'Relation' info. -lookupRelationWithHistory :: - (MonadClient m) => - -- | User 'A' - Local UserId -> - -- | User 'B' - Qualified UserId -> - m (Maybe RelationWithHistory) -lookupRelationWithHistory self target = do - let local (tUnqualified -> ltarget) = - query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) - let remote (tUntagged -> Qualified rtarget domain) = - query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) - runIdentity <$$> retry x1 (foldQualified self local remote target) +-- | See 'lookupContactListWithRelation'. +lookupContactList :: + (Member (ConnectionStore InternalPaging) r) => + UserId -> + Sem r [UserId] +lookupContactList u = + fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelation u) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. lookupLocalConnections :: - (MonadClient m) => + (Member (ConnectionStore InternalPaging) r) => Local UserId -> Maybe UserId -> Range 1 500 Int32 -> - m (ResultPage UserConnection) -lookupLocalConnections lfrom start (fromRange -> size) = - toResult <$> case start of - Just u -> - retry x1 $ - paginate connectionsSelectFrom (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) - Nothing -> - retry x1 $ - paginate connectionsSelect (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) - where - toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim - trim p = p {result = take (fromIntegral size) (result p)} - --- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. --- Similar to lookupLocalConnections -lookupLocalConnectionsPage :: - (MonadClient m) => - Local UserId -> - Maybe PagingState -> - Range 1 1000 Int32 -> - m (PageWithState Void UserConnection) -lookupLocalConnectionsPage self pagingState (fromRange -> size) = - fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) x1 - --- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. -lookupRemoteConnectionsPage :: - (MonadClient m) => - Local UserId -> - Maybe PagingState -> - Int32 -> - m (PageWithState Void UserConnection) -lookupRemoteConnectionsPage self pagingState size = - fmap (toRemoteUserConnection self) - <$> paginateWithState - remoteConnectionSelect - (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) - x1 - --- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus :: (MonadClient m) => [UserId] -> [UserId] -> m [ConnectionStatus] -lookupConnectionStatus from to = - map toConnectionStatus - <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) - --- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus' :: (MonadClient m) => [UserId] -> m [ConnectionStatus] -lookupConnectionStatus' from = - map toConnectionStatus - <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) - -lookupLocalConnectionStatuses :: - ( MonadClient m, - MonadUnliftIO m - ) => - [UserId] -> - Local [UserId] -> - m [ConnectionStatusV2] -lookupLocalConnectionStatuses froms tos = do - concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms - where - lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupStatuses from = - map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) - -lookupRemoteConnectionStatuses :: - ( MonadClient m, - MonadUnliftIO m - ) => - [UserId] -> - Remote [UserId] -> - m [ConnectionStatusV2] -lookupRemoteConnectionStatuses froms tos = do - concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms - where - lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupStatuses from = - map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) - -lookupAllStatuses :: - ( MonadClient m, - MonadUnliftIO m - ) => - Local [UserId] -> - m [ConnectionStatusV2] -lookupAllStatuses lfroms = do - let froms = tUnqualified lfroms - concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms - where - lookupAndCombine :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u - - lookupLocalStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupLocalStatuses from = - map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) - <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) - lookupRemoteStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupRemoteStatuses from = - map (\(d, u, r) -> toConnectionStatusV2 from d u r) - <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) - -lookupRemoteConnectedUsersPaginated :: (MonadClient m) => Local UserId -> Int32 -> m (Page (Remote UserConnection)) -lookupRemoteConnectedUsersPaginated u maxResults = do - (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) - --- | See 'lookupContactListWithRelation'. -lookupContactList :: (MonadClient m) => UserId -> m [UserId] -lookupContactList u = - fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelation u) - --- | For a given user 'A', lookup the list of users that form his contact list, --- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). -lookupContactListWithRelation :: (MonadClient m) => UserId -> m [(UserId, RelationWithHistory)] -lookupContactListWithRelation u = - retry x1 (query contactsSelect (params LocalQuorum (Identity u))) - --- | Count the number of connections a user has in a specific relation status. --- (If you want to distinguish 'RelationWithHistory', write a new function.) --- Note: The count is eventually consistent. -countConnections :: (MonadClient m) => Local UserId -> [Relation] -> m Int64 -countConnections u r = do - rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) - relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) - - pure $ foldl' count 0 rels + foldl' count 0 relsRemote - where - selectStatus :: QueryString R (Identity UserId) (Identity RelationWithHistory) - selectStatus = "SELECT status FROM connection WHERE left = ?" - - selectStatusRemote :: QueryString R (Identity UserId) (Identity RelationWithHistory) - selectStatusRemote = "SELECT status FROM connection_remote WHERE left = ?" - - count n (Identity s) | relationDropHistory s `elem` r = n + 1 - count n _ = n - -deleteConnections :: (MonadClient m, MonadUnliftIO m) => UserId -> m () -deleteConnections u = do - runConduit $ - paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 - .| C.mapM_ - (pooledMapConcurrentlyN_ 16 delete) - do - retry x1 . write connectionClear $ params LocalQuorum (Identity u) - retry x1 . write remoteConnectionClear $ params LocalQuorum (Identity u) - where - delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) - -deleteRemoteConnections :: - ( MonadClient m, - MonadUnliftIO m - ) => - Remote UserId -> - Range 1 1000 [UserId] -> - m () -deleteRemoteConnections (tUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = - pooledForConcurrentlyN_ 16 locals $ \u -> - write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) - --- Queries - -connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () -connectionInsert = "INSERT INTO connection (left, right, status, last_update, conv) VALUES (?, ?, ?, ?, ?)" - -connectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, UserId) () -connectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection SET status = ?, last_update = ? WHERE left = ? AND right = ?" - -connectionSelect :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -connectionSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right = ?" - -relationSelect :: PrepQuery R (UserId, UserId) (Identity RelationWithHistory) -relationSelect = "SELECT status FROM connection WHERE left = ? AND right = ?" - -relationsSelect :: PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) -relationsSelect = "SELECT right, status FROM connection where left = ? AND right IN ?" - -relationsSelectAll :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) -relationsSelectAll = "SELECT right, status FROM connection where left = ?" - --- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of --- the table. -connectionStatusSelect :: PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) -connectionStatusSelect = "SELECT left, right, status FROM connection WHERE left IN ? AND right IN ?" - --- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of --- the table. -connectionStatusSelect' :: PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) -connectionStatusSelect' = "SELECT left, right, status FROM connection WHERE left IN ?" - -contactsSelect :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) -contactsSelect = "SELECT right, status FROM connection WHERE left = ?" - -connectionsSelect :: PrepQuery R (Identity UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -connectionsSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? ORDER BY right ASC" - -connectionsSelectFrom :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -connectionsSelectFrom = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right > ? ORDER BY right ASC" - -connectionDelete :: PrepQuery W (UserId, UserId) () -connectionDelete = "DELETE FROM connection WHERE left = ? AND right = ?" - -connectionClear :: PrepQuery W (Identity UserId) () -connectionClear = "DELETE FROM connection WHERE left = ?" - --- Remote connections - -remoteConnectionInsert :: PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () -remoteConnectionInsert = "INSERT INTO connection_remote (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" - -remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -remoteConnectionSelect = "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM connection_remote where left = ?" - -remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) -remoteConnectionSelectFrom = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" - -remoteConnectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () -remoteConnectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection_remote set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" - -remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () -remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" - -remoteConnectionClear :: PrepQuery W (Identity UserId) () -remoteConnectionClear = "DELETE FROM connection_remote where left = ?" - -remoteRelationSelect :: PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) -remoteRelationSelect = "SELECT status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user = ?" - -remoteRelationsSelect :: PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) -remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user IN ?" - -remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) -remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" - --- Conversions - -toLocalUserConnection :: - Local x -> - (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> - UserConnection -toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = - UserConnection l (tUntagged (qualifyAs loc r)) rel time (fmap (tUntagged . qualifyAs loc) cid) - -toRemoteUserConnection :: - Local UserId -> - (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> - UserConnection -toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = - UserConnection (tUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) - -toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus -toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel - -toConnectionStatusV2 :: UserId -> Domain -> UserId -> RelationWithHistory -> ConnectionStatusV2 -toConnectionStatusV2 from toDomain toUser relWithHistory = - ConnectionStatusV2 from (Qualified toUser toDomain) (relationDropHistory relWithHistory) + Sem r (ResultPage UserConnection) +lookupLocalConnections lfrom start size = + cassandraResultPage <$> W.lookupLocalConnections lfrom start size diff --git a/services/brig/src/Brig/Effects/ConnectionStore.hs b/services/brig/src/Brig/Effects/ConnectionStore.hs deleted file mode 100644 index 3d990773318..00000000000 --- a/services/brig/src/Brig/Effects/ConnectionStore.hs +++ /dev/null @@ -1,52 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2024 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2025 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Effects.ConnectionStore where - -import Data.Id -import Data.Qualified (Local, Remote) -import Imports -import Polysemy -import Wire.API.Connection (UserConnection) -import Wire.Sem.Paging (Page, PagingBounds, PagingState) - -data ConnectionStore p m a where - RemoteConnectedUsersPaginated :: - Local UserId -> - Maybe (PagingState p (Remote UserConnection)) -> - PagingBounds p (Remote UserConnection) -> - ConnectionStore p m (Page p (Remote UserConnection)) - -makeSem ''ConnectionStore diff --git a/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs b/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs deleted file mode 100644 index 35f2444ab88..00000000000 --- a/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeepSubsumption #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2024 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Effects.ConnectionStore.Cassandra where - -import Brig.Data.Connection -import Brig.Effects.ConnectionStore -import Cassandra -import Data.Range -import Imports -import Polysemy -import Polysemy.Internal.Tactics -import Wire.Sem.Paging.Cassandra - -connectionStoreToCassandra :: - forall r a. - (Member (Embed Client) r) => - Sem (ConnectionStore InternalPaging ': r) a -> - Sem r a -connectionStoreToCassandra = - interpretH $ - liftT . embed @Client . \case - RemoteConnectedUsersPaginated uid mps bounds -> case mps of - Nothing -> flip mkInternalPage pure =<< lookupRemoteConnectedUsersPaginated uid (fromRange bounds) - Just ps -> ipNext ps diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 2e8c17117a8..bb0f48d1b38 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -51,8 +51,8 @@ import Brig.API.Error (internalServerError) import Brig.App import Brig.Data.Connection import Brig.Data.Connection qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.ConnectionStore qualified as E +import Brig.Data.Types (resultList) +import Brig.Data.Types qualified as Data import Brig.IO.Journal qualified as Journal import Brig.IO.Logging import Brig.RPC @@ -92,6 +92,7 @@ import Wire.API.Team.Member qualified as Team import Wire.API.User import Wire.API.UserEvent import Wire.BackendNotificationQueueAccess +import Wire.ConnectionStore qualified as E import Wire.Events import Wire.FederationAPIAccess import Wire.GalleyAPIAccess (GalleyAPIAccess) @@ -225,8 +226,7 @@ journalEvent orig e = case e of -- as well as his other clients about a change to his user account -- or profile. dispatchNotifications :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, + ( Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member Now r, @@ -265,10 +265,10 @@ dispatchNotifications orig conn e = case e of notifyUserDeletionLocals :: forall r. - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, + ( Member NotificationSubsystem r, Member (Input (Local ())) r, - Member Now r + Member Now r, + Member (ConnectionStore InternalPaging) r ) => UserId -> Maybe ConnId -> @@ -309,7 +309,7 @@ notifyUserDeletionLocals deleted conn event = do connectionPages :: Maybe UserId -> Local UserId -> Range 1 500 Int32 -> Sem r () connectionPages mbStart user pageSize = do - page <- embed $ Data.lookupLocalConnections user mbStart pageSize + page <- Data.lookupLocalConnections user mbStart pageSize case resultList page of [] -> pure () xs -> do @@ -406,9 +406,9 @@ notifySelf event orig route conn = notifyContacts :: forall r. - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r + ( Member NotificationSubsystem r, + Member GalleyAPIAccess r, + Member (ConnectionStore InternalPaging) r ) => Event -> -- | Origin user. @@ -423,7 +423,7 @@ notifyContacts event orig route conn = do (:|) orig <$> liftA2 (++) contacts teamContacts where contacts :: Sem r [UserId] - contacts = embed $ lookupContactList orig + contacts = lookupContactList orig teamContacts :: Sem r [UserId] teamContacts = screenMemberList <$> GalleyAPIAccess.getTeamContacts orig diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 9d148ac70ff..5825bcfded8 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -37,12 +37,14 @@ import System.Logger.Class (field, msg, val, (~~)) import Wire.API.UserEvent import Wire.AuthenticationSubsystem import Wire.ClientStore (ClientStore) +import Wire.ConnectionStore (ConnectionStore) import Wire.Events (Events) import Wire.InvitationStore (InvitationStore) import Wire.NotificationSubsystem import Wire.PropertySubsystem import Wire.Sem.Concurrency import Wire.Sem.Delay +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserGroupSubsystem import Wire.UserKeyStore import Wire.UserStore (UserStore) @@ -56,6 +58,7 @@ onEvent :: Member TinyLog r, Member (Embed HttpClientIO) r, Member Delay r, + Member (ConnectionStore InternalPaging) r, Member Race r, Member (Input (Local ())) r, Member UserKeyStore r, diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index ce88b50a63f..cab5f307683 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -70,6 +70,7 @@ import Wire.API.User hiding (fromEmail) import Wire.AuthenticationSubsystem import Wire.BlockListStore import Wire.ClientStore (ClientStore) +import Wire.ConnectionStore (ConnectionStore) import Wire.EmailSubsystem.Interpreter (renderInvitationUrl) import Wire.Error import Wire.Events (Events) @@ -81,6 +82,7 @@ import Wire.InvitationStore qualified as Store import Wire.NotificationSubsystem (NotificationSubsystem) import Wire.PropertySubsystem (PropertySubsystem) import Wire.Sem.Concurrency +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.SparAPIAccess (SparAPIAccess) import Wire.SparAPIAccess qualified as SparAPIAccess import Wire.TeamInvitationSubsystem @@ -117,7 +119,8 @@ servantAPI :: Member AuthenticationSubsystem r, Member UserStore r, Member UserKeyStore r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member (ConnectionStore InternalPaging) r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -223,6 +226,7 @@ logInvitationRequest context action = deleteInvitation :: forall p r. ( Member InvitationStore r, + Member (ConnectionStore InternalPaging) r, Member (Error UserSubsystemError) r, Member TeamSubsystem r, Member SparAPIAccess r, diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index b6d1216fa00..fb8b18fec09 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -44,10 +44,12 @@ import Wire.API.Push.Token qualified as PushTok import Wire.API.Routes.Internal.Brig import Wire.API.Team.Member qualified as Team import Wire.API.User +import Wire.ConnectionStore (ConnectionStore) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Rpc +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserSubsystem (UserSubsystem) @@ -61,7 +63,8 @@ ejpdRequest :: Member Rpc r, Member TeamSubsystem r, Member UserSubsystem r, - Member (Input (Local ())) r + Member (Input (Local ())) r, + Member (ConnectionStore InternalPaging) r ) => Maybe Bool -> EJPDRequestBody -> @@ -96,7 +99,7 @@ ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do if reallyIncludeContacts then do contacts <- - wrapClient $ -- FUTUREWORK: use polysemy effect, not wrapClient + liftSem $ Conn.lookupContactListWithRelation uid localContacts <- diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 6cc80db1cb8..b43623c4dce 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -25,7 +25,6 @@ where import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert -import Brig.Data.Connection (remoteConnectionInsert) import Cassandra qualified as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion @@ -47,6 +46,7 @@ import Wire.API.Federation.Component import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging import Wire.API.User as User +import Wire.ConnectionStore.Cassandra (remoteConnectionInsert) tests :: ConnectionLimit -> diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 48edf26a391..47ea803bc6f 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -274,3 +274,4 @@ postgresMigration: passwordReset: postgresql customBackend: postgresql budget: postgresql + connections: postgresql From 7583996d0f95720700920012fc358b67dc42a72d Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 30 Oct 2026 16:30:39 +0000 Subject: [PATCH 2/6] WPB-22953: warm legacy fed-v* federator ingress before integration test pool --- integration/test/Testlib/ModService.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 94ffb8f0d34..69099489532 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -63,6 +63,7 @@ import qualified Data.Yaml as Yaml import GHC.Stack import qualified Network.HTTP.Client as HTTP import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removeFile) +import System.Environment (lookupEnv) import System.Exit import System.FilePath import System.IO @@ -694,6 +695,18 @@ warmupFederation = do [(env.domain1, env.domain2), (env.domain2, env.domain1)] retryRequestUntil checkBoth "Static federator ingress (domain1 <-> domain2)" + -- The legacy fed-v* backends (ENABLE_FEDERATION_V0..V3) are static + -- deployments not covered by the warmup above; the first test burst against + -- them can fail with transient federator-transport errors (521 connection + -- refused, 525 SSL, 533 unreachable backend). Warm them from the local + -- domain before the pool starts, same doctrine as the static warmup above. + for_ (zip [0 :: Int ..] [env.federationV0Domain, env.federationV1Domain, env.federationV2Domain, env.federationV3Domain]) $ \(n, fedDomain) -> do + enabled <- liftIO (lookupEnv ("ENABLE_FEDERATION_V" <> show n)) + when (enabled == Just "1") $ + retryRequestUntil + (checkFederationIngress env.domain1 fedDomain) + ("Legacy federator ingress (domain1 -> fed-v" <> show n <> ")") + retryRequestUntil :: (HasCallStack) => ((HasCallStack) => App Bool) -> String -> App () retryRequestUntil = retryRequestUntilDebug federatorIngressDelay Nothing From 92f7950e58b5d53380b8360e812c66749c8afc4b Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 30 Oct 2026 17:47:57 +0000 Subject: [PATCH 3/6] WPB-22953: seed made-up remote connections into the active connections store in brig-integration testAllConnectionsPaging wrote remote rows straight to Cassandra while brig under PostgresqlStorage reads them from Postgres, so the test saw 5 instead of 8. Branch the seeding on postgresMigration.connections. --- .../src/Wire/ConnectionStore/Postgres.hs | 20 ++++ libs/wire-subsystems/src/Wire/Postgres.hs | 1 + services/brig/test/integration/API/User.hs | 2 +- .../test/integration/API/User/Connection.hs | 93 +++++++++++-------- 4 files changed, 78 insertions(+), 38 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs index 4e3767bdd41..ab8629e275d 100644 --- a/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs @@ -17,12 +17,14 @@ module Wire.ConnectionStore.Postgres ( interpretConnectionStoreToPostgres, + insertRemoteConnectionRaw, ) where import Cassandra (Page (..), PageWithState (..), PagingState (..), emptyPage) import Cassandra qualified as Cas import Cassandra.Exec (GeneralPaginationState (..)) +import Control.Exception (ErrorCall (..), throwIO) import Data.ByteString qualified as BS import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as LBS @@ -36,6 +38,8 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Data.UUID (UUID) import Data.UUID qualified as UUID import Data.Vector qualified as Vector +import Hasql.Pool.Extended qualified as HasqlPoolExt +import Hasql.Session (statement) import Hasql.Statement qualified as Hasql import Hasql.TH import Imports @@ -343,6 +347,22 @@ insertLocal = SET status = ($3 :: int4), last_update = ($4 :: timestamptz), conv = ($5 :: uuid) |] +-- | Insert a remote connection row directly, bypassing the 'ConnectionStore' +-- effect (which cannot create a connection to an arbitrary remote domain). +-- Exposed for the brig integration suite, mirroring the raw Cassandra insert +-- via 'Wire.ConnectionStore.Cassandra.remoteConnectionInsert'. 'Hasql.UsageError' +-- has no 'Exception' instance in this hasql version, so failures surface as +-- an 'ErrorCall'. +insertRemoteConnectionRaw :: + HasqlPoolExt.Pool -> + (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> + IO () +insertRemoteConnectionRaw pool (l, rdom, r, rel, now, cdom, cnv) = + useWithResetAndRetry + pool + (statement (l, rdom, r, postgresMarshall rel, fromUTCTimeMillis now, cdom, cnv) insertRemote) + >>= either (throwIO . ErrorCall . show) pure + insertRemote :: Hasql.Statement (UserId, Domain, UserId, Int32, UTCTime, Domain, ConvId) () insertRemote = lmapPG diff --git a/libs/wire-subsystems/src/Wire/Postgres.hs b/libs/wire-subsystems/src/Wire/Postgres.hs index f91f3637efe..929994b3b41 100644 --- a/libs/wire-subsystems/src/Wire/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/Postgres.hs @@ -42,6 +42,7 @@ module Wire.Postgres runSessionWithRetry, runTransaction, runTransactionWithRetry, + useWithResetAndRetry, runPipeline, parseCount, PGConstraints, diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index 5fd105f333c..ecab53203f5 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -74,7 +74,7 @@ tests conf fbc p b c ch g n aws db userJournalWatcher = do [ API.User.Client.tests cl at conf p db n b c g, API.User.Account.tests cl at conf p b c ch g aws userJournalWatcher, API.User.Auth.tests conf p authenticationSubsystemConfig b g n, - API.User.Connection.tests cl at p b c g fbc db, + API.User.Connection.tests cl at conf p b c g fbc db, API.User.Handles.tests cl at conf p b c g, API.User.RichInfo.tests cl at conf p b c g ] diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index b43623c4dce..3ef0c7ec44a 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -25,6 +25,7 @@ where import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert +import Brig.Options qualified as Opt import Cassandra qualified as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion @@ -33,6 +34,7 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified import Data.UUID.V4 qualified as UUID +import Hasql.Pool.Extended qualified as HasqlPool import Imports import Network.Wai.Utilities.Error qualified as Error import Test.Tasty hiding (Timeout) @@ -47,10 +49,13 @@ import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging import Wire.API.User as User import Wire.ConnectionStore.Cassandra (remoteConnectionInsert) +import Wire.ConnectionStore.Postgres (insertRemoteConnectionRaw) +import Wire.PostgresMigrationOpts (PostgresMigrationOpts (connections), StorageLocation (..)) tests :: ConnectionLimit -> Timeout -> + Opt.Opts -> Manager -> Brig -> Cannon -> @@ -58,7 +63,7 @@ tests :: FedClient 'Brig -> DB.ClientState -> TestTree -tests cl _at p b _c g fedBrigClient db = +tests cl _at conf p b _c g fedBrigClient db = testGroup "connection" [ test p "post /connections" $ testCreateManualConnections b, @@ -88,7 +93,7 @@ tests cl _at p b _c g fedBrigClient db = test p "put /connections/:id noop" $ testUpdateConnectionNoop b, test p "put /connections/:domain/:id noop" $ testUpdateConnectionNoopQualified b, test p "get /connections - 200 (paging)" $ testLocalConnectionsPaging b, - test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b db, + test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging conf b db, test p "post /connections - 400 (max conns)" $ testConnectionLimit b cl, test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl, test p "Remote connections: connect with no federation" (testConnectFederationNotAvailable b), @@ -611,49 +616,63 @@ testLocalConnectionsPaging b = do liftIO $ assertEqual "has more" (Just (count' < total)) more pure (count', conns >>= fmap (qUnqualified . ucTo) . listToMaybe . reverse) -testAllConnectionsPaging :: Brig -> DB.ClientState -> Http () -testAllConnectionsPaging b db = do - quid <- userQualifiedId <$> randomUser b - let uid = qUnqualified quid - replicateM_ totalLocal $ do - qOther <- userQualifiedId <$> randomUser b - postConnectionQualified b uid qOther !!! const 201 === statusCode - - -- FUTUREWORK: For now, because we do not support creating remote connections - -- yet (as of Oct 1, 2021), we write some made-up remote connections directly - -- to the database such that querying works. - now <- toUTCTimeMillis <$> liftIO getCurrentTime - replicateM_ totalRemote $ createRemoteConnection uid now - - -- get all connections at once - resAll :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing Nothing - liftIO $ assertEqual "all: size" total (length . mtpResults $ resAll) - liftIO $ assertEqual "all: has_more" False (mtpHasMore resAll) - - -- paginate by passing the pagingState - resFirst :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid (Just size) Nothing - liftIO $ assertEqual "first: size" size (length . mtpResults $ resFirst) - liftIO $ assertEqual "first: has_more" True (mtpHasMore resFirst) - - resNext :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing (Just $ mtpPagingState resFirst) - liftIO $ assertEqual "next: size" (total - size) (length . mtpResults $ resNext) - liftIO $ assertEqual "next: has_more" False (mtpHasMore resNext) +-- | The made-up remote connections must be seeded into the store the brig +-- under test reads from: 'PostgresqlStorage' reads (and the raw seeding) go +-- to Postgres, every other storage location reads Cassandra. +testAllConnectionsPaging :: Opt.Opts -> Brig -> DB.ClientState -> Http () +testAllConnectionsPaging conf b db = case conf.postgresMigration.connections of + PostgresqlStorage -> do + pool <- liftIO $ HasqlPool.initPostgresPool conf.postgresqlPool conf.postgresql conf.postgresqlPassword + run (createPostgresRemoteConnection pool) + _ -> + run createCassandraRemoteConnection where + run :: (UserId -> UTCTimeMillis -> Http ()) -> Http () + run createRemoteConnection = do + quid <- userQualifiedId <$> randomUser b + let uid = qUnqualified quid + replicateM_ totalLocal $ do + qOther <- userQualifiedId <$> randomUser b + postConnectionQualified b uid qOther !!! const 201 === statusCode + + -- FUTUREWORK: For now, because we do not support creating remote connections + -- yet (as of Oct 1, 2021), we write some made-up remote connections directly + -- to the database such that querying works. + now <- toUTCTimeMillis <$> liftIO getCurrentTime + replicateM_ totalRemote $ createRemoteConnection uid now + + -- get all connections at once + resAll :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing Nothing + liftIO $ assertEqual "all: size" total (length . mtpResults $ resAll) + liftIO $ assertEqual "all: has_more" False (mtpHasMore resAll) + + -- paginate by passing the pagingState + resFirst :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid (Just size) Nothing + liftIO $ assertEqual "first: size" size (length . mtpResults $ resFirst) + liftIO $ assertEqual "first: has_more" True (mtpHasMore resFirst) + + resNext :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing (Just $ mtpPagingState resFirst) + liftIO $ assertEqual "next: size" (total - size) (length . mtpResults $ resNext) + liftIO $ assertEqual "next: has_more" False (mtpHasMore resNext) + size = 2 totalLocal = 5 totalRemote = 3 total = totalLocal + totalRemote remoteDomain = Domain "faraway.example.com" - createRemoteConnection :: UserId -> UTCTimeMillis -> Http () - createRemoteConnection self now = do + madeUpRemoteRow :: + UserId -> UTCTimeMillis -> Http (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) + madeUpRemoteRow self now = do qOther <- (`Qualified` remoteDomain) <$> randomId qConv <- (`Qualified` remoteDomain) <$> randomId - liftIO . DB.runClient db $ - DB.retry DB.x5 $ - DB.write remoteConnectionInsert $ - DB.params - DB.LocalQuorum - (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) + pure (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) + createPostgresRemoteConnection :: HasqlPool.Pool -> UserId -> UTCTimeMillis -> Http () + createPostgresRemoteConnection pool self now = + liftIO . insertRemoteConnectionRaw pool =<< madeUpRemoteRow self now + createCassandraRemoteConnection :: UserId -> UTCTimeMillis -> Http () + createCassandraRemoteConnection self now = + liftIO . DB.runClient db . DB.retry DB.x5 . DB.write remoteConnectionInsert . DB.params DB.LocalQuorum + =<< madeUpRemoteRow self now testConnectionLimit :: Brig -> ConnectionLimit -> Http () testConnectionLimit brig (ConnectionLimit l) = do From c2433340003d6a7a9443c70f2c490710c3613a47 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 30 Oct 2026 21:11:16 +0100 Subject: [PATCH 4/6] Hello CI From 33b02955133c4d55e05bc2bf7020f8cbd472037a Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 30 Oct 2026 22:19:44 +0100 Subject: [PATCH 5/6] Hello CI From ca0d64d4cc187fde49b6286c2a57449e80ffa5cd Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 30 Oct 2026 21:55:02 +0000 Subject: [PATCH 6/6] WPB-22953: fix local connections paging-state marker roundtrip LookupLocalConnectionsPage's marker lambda bound the status Int32 (second row field) instead of the right-user UUID, so every continuation request failed to decode the paging state, treated it as absent, and re-returned the full result set. Encode/decode now use the explicit ASCII UUID codec, mirroring the remote marker. --- .../src/Wire/ConnectionStore/Postgres.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs index ab8629e275d..96111b3ed58 100644 --- a/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Postgres.hs @@ -126,11 +126,11 @@ interpretConnectionStoreToPostgres = interpret $ \case Nothing -> runStatement (tUnqualified lfrom, size + 1) selectLocalConnections pure $ trimLocalPage lfrom size rows LookupLocalConnectionsPage self pagingState (fromRange -> size) -> do - let mStart = pagingState >>= fromByteString . LBS.toStrict . unPagingState + let mStart = pagingState >>= decodeLocalMarker . LBS.toStrict . unPagingState rows <- case mStart of Just u -> runStatement (tUnqualified self, u, size) selectLocalConnectionsFrom Nothing -> runStatement (tUnqualified self, size) selectLocalConnections - pure $ buildPageWithState (localRowToUserConnectionByRight self) (\(_, rid, _, _) -> toByteString' rid) size rows + pure $ buildPageWithState (localRowToUserConnectionByRight self) (\(rid, _, _, _) -> UUID.toASCIIBytes rid) size rows LookupRemoteConnectionsPage self pagingState size -> do let mStart = pagingState >>= decodeRemoteMarker . LBS.toStrict . unPagingState rows <- case mStart of @@ -321,8 +321,14 @@ trimLocalPage lfrom size rows = -------------------------------------------------------------------------------- -- Paging-state markers --- | Remote page marker: utf8-encoded domain bytes followed by the 16-byte --- user id. +-- | Local page marker: the 36-char ASCII encoding of the last connection's +-- @right@ user id. The inverse of the 'UUID.toASCIIBytes' marker built in +-- 'LookupLocalConnectionsPage'. +decodeLocalMarker :: ByteString -> Maybe UserId +decodeLocalMarker = fmap Id . UUID.fromASCIIBytes + +-- | Remote page marker: utf8-encoded domain bytes followed by the 36-char +-- ASCII encoding of the user id. encodeRemoteMarker :: Domain -> UUID -> ByteString encodeRemoteMarker domain uid = toByteString' domain <> UUID.toASCIIBytes uid @@ -331,7 +337,7 @@ decodeRemoteMarker :: ByteString -> Maybe (Domain, UserId) decodeRemoteMarker bs = do guard (BS.length bs >= 36) let (domainPart, uidPart) = BS.splitAt (BS.length bs - 36) bs - (,) <$> fromByteString domainPart <*> (Id <$> UUID.fromASCIIBytes uidPart) + (,) <$> fromByteString domainPart <*> decodeLocalMarker uidPart -------------------------------------------------------------------------------- -- Statements