From 0983caef794c04734bae35eddeb2e93d37d1d9f7 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 12 Mar 2026 18:04:19 +0100 Subject: [PATCH 01/39] WPB-23789: Move operation to `ConversationSubsystem` --- changelog.d/5-internal/WPB-23789 | 12 + charts/wire-server/templates/_helpers.tpl | 174 +++++ .../src/Wire/API/Team/FeatureFlags.hs | 13 +- libs/wire-subsystems/default.nix | 6 + .../Wire/BackgroundJobsRunner/Interpreter.hs | 2 +- .../wire-subsystems/src/Wire/BrigAPIAccess.hs | 18 + .../src/Wire/ConversationStore/Cassandra.hs | 2 +- .../src/Wire/ConversationSubsystem.hs | 634 +++++++++++++++++- .../src/Wire/ConversationSubsystem}/Action.hs | 80 ++- .../ConversationSubsystem}/Action/Kick.hs | 8 +- .../ConversationSubsystem}/Action/Leave.hs | 4 +- .../ConversationSubsystem}/Action/Notify.hs | 18 +- .../ConversationSubsystem}/Action/Reset.hs | 8 +- .../Wire/ConversationSubsystem}/Clients.hs | 19 +- .../src/Wire/ConversationSubsystem/Create.hs | 258 +++++++ .../ConversationSubsystem/CreateInternal.hs | 2 +- .../Wire/ConversationSubsystem/Federation.hs | 116 ++-- .../Wire/ConversationSubsystem/Internal.hs | 6 +- .../Wire/ConversationSubsystem/Interpreter.hs | 618 ++++++++++++++++- .../LegalholdConflicts.hs | 11 +- .../src/Wire/ConversationSubsystem}/MLS.hs | 14 +- .../MLS/CheckClients.hs | 4 +- .../ConversationSubsystem}/MLS/Commit/Core.hs | 8 +- .../MLS/Commit/ExternalCommit.hs | 12 +- .../MLS/Commit/InternalCommit.hs | 22 +- .../MLS/Conversation.hs | 2 +- .../ConversationSubsystem}/MLS/Enabled.hs | 4 +- .../ConversationSubsystem}/MLS/GroupInfo.hs | 6 +- .../MLS/GroupInfoCheck.hs | 5 +- .../MLS/IncomingMessage.hs | 2 +- .../Wire/ConversationSubsystem}/MLS/Keys.hs | 2 +- .../ConversationSubsystem}/MLS/Message.hs | 115 ++-- .../ConversationSubsystem}/MLS/Migration.hs | 2 +- .../ConversationSubsystem}/MLS/One2One.hs | 2 +- .../ConversationSubsystem}/MLS/OutOfSync.hs | 4 +- .../ConversationSubsystem}/MLS/Propagate.hs | 2 +- .../ConversationSubsystem}/MLS/Proposal.hs | 4 +- .../ConversationSubsystem}/MLS/Removal.hs | 8 +- .../Wire/ConversationSubsystem}/MLS/Reset.hs | 18 +- .../MLS/SubConversation.hs | 26 +- .../Wire/ConversationSubsystem}/MLS/Util.hs | 2 +- .../ConversationSubsystem}/MLS/Welcome.hs | 2 +- .../Wire/ConversationSubsystem}/Mapping.hs | 2 +- .../Wire/ConversationSubsystem}/Message.hs | 30 +- .../src/Wire/ConversationSubsystem/One2One.hs | 6 +- .../src/Wire/ConversationSubsystem}/Query.hs | 34 +- .../src/Wire/ConversationSubsystem}/Update.hs | 134 ++-- .../src/Wire/ConversationSubsystem/Util.hs | 156 +---- .../src/Wire/FeaturesConfigSubsystem.hs | 25 +- .../FeaturesConfigSubsystem/Interpreter.hs | 155 +++++ .../src/Wire/GalleyAPIAccess/Rpc.hs | 30 +- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 2 +- .../Wire/NotificationSubsystem/Interpreter.hs | 5 +- .../src/Wire/Options/Galley.hs | 16 +- .../TeamInvitationSubsystem/Interpreter.hs | 2 +- .../wire-subsystems/src/Wire/TeamSubsystem.hs | 107 +++ .../src/Wire/TeamSubsystem/GalleyAPI.hs | 49 +- .../src/Wire/TeamSubsystem/Interpreter.hs | 175 ++++- .../src/Wire/UserClientIndexStore.hs | 105 +++ .../Wire/ConversationSubsystem/MappingSpec.hs | 108 ++- .../Wire/ConversationSubsystem/MessageSpec.hs | 130 ++-- .../Wire/ConversationSubsystem/One2OneSpec.hs | 23 +- .../Wire/MeetingsSubsystem/InterpreterSpec.hs | 13 + .../test/unit/Wire/MiniBackend.hs | 66 +- .../MockInterpreters/ConversationSubsystem.hs | 8 +- .../SAMLEmailSubsystem/InterpreterSpec.hs | 9 + .../Wire/ScimSubsystem/InterpreterSpec.hs | 4 +- .../InterpreterSpec.hs | 45 +- .../UserGroupSubsystem/InterpreterSpec.hs | 59 +- libs/wire-subsystems/wire-subsystems.cabal | 40 ++ .../src/Wire/BackgroundWorker/Env.hs | 15 +- .../Wire/BackgroundWorker/Jobs/Registry.hs | 80 ++- .../src/Wire/BackgroundWorker/Options.hs | 29 +- .../Wire/BackendNotificationPusherSpec.hs | 36 +- .../background-worker/test/Test/Wire/Util.hs | 18 + .../brig/src/Brig/CanonicalInterpreter.hs | 11 + services/galley/default.nix | 29 - services/galley/galley.cabal | 75 --- services/galley/src/Galley/API/Create.hs | 140 ---- services/galley/src/Galley/API/Federation.hs | 48 +- services/galley/src/Galley/API/Internal.hs | 87 +-- services/galley/src/Galley/API/LegalHold.hs | 258 +++---- .../galley/src/Galley/API/LegalHold/Get.hs | 78 --- .../galley/src/Galley/API/LegalHold/Team.hs | 18 + services/galley/src/Galley/API/Public/Bot.hs | 30 +- .../src/Galley/API/Public/Conversation.hs | 8 +- .../galley/src/Galley/API/Public/Feature.hs | 6 +- .../galley/src/Galley/API/Public/LegalHold.hs | 1 + services/galley/src/Galley/API/Public/MLS.hs | 3 +- .../galley/src/Galley/API/Public/Messaging.hs | 2 +- services/galley/src/Galley/API/Public/Team.hs | 2 +- services/galley/src/Galley/API/Teams.hs | 142 ++-- .../galley/src/Galley/API/Teams/Features.hs | 44 +- .../src/Galley/API/Teams/Features/Get.hs | 168 ----- services/galley/src/Galley/App.hs | 19 +- services/galley/src/Galley/Env.hs | 57 +- services/galley/test/integration/API.hs | 2 +- services/galley/test/integration/API/Teams.hs | 2 +- .../test/integration/API/Teams/LegalHold.hs | 2 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 4 +- services/galley/test/unit/Run.hs | 37 - 101 files changed, 3502 insertions(+), 1762 deletions(-) create mode 100644 changelog.d/5-internal/WPB-23789 rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Kick.hs (93%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Leave.hs (94%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Notify.hs (76%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Reset.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Clients.hs (89%) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs rename services/galley/src/Galley/API/Federation/Handlers.hs => libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs (93%) rename services/galley/src/Galley/API/LegalHold/Conflicts.hs => libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS.hs (88%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/CheckClients.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Commit/Core.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Commit/ExternalCommit.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Commit/InternalCommit.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Conversation.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Enabled.hs (95%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/GroupInfo.hs (95%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/GroupInfoCheck.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/IncomingMessage.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Keys.hs (95%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Message.hs (90%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Migration.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/One2One.hs (99%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/OutOfSync.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Propagate.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Proposal.hs (99%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Removal.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Reset.hs (93%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/SubConversation.hs (94%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Util.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Welcome.hs (99%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Mapping.hs (99%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Message.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Query.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Update.hs (95%) rename services/galley/test/unit/Test/Galley/Mapping.hs => libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs (59%) rename services/galley/test/unit/Test/Galley/API/Message.hs => libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs (56%) rename services/galley/test/unit/Test/Galley/API/One2One.hs => libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs (80%) delete mode 100644 services/galley/src/Galley/API/Create.hs delete mode 100644 services/galley/src/Galley/API/LegalHold/Get.hs delete mode 100644 services/galley/src/Galley/API/Teams/Features/Get.hs delete mode 100644 services/galley/test/unit/Run.hs diff --git a/changelog.d/5-internal/WPB-23789 b/changelog.d/5-internal/WPB-23789 new file mode 100644 index 00000000000..12ca52d1d09 --- /dev/null +++ b/changelog.d/5-internal/WPB-23789 @@ -0,0 +1,12 @@ +### ConversationSubsystem Migration + +* Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. + This consolidation improves code organization and separation of concerns for conversation logic. + +* Library updates: + - Introduced dedicated error types for ConversationSubsystem to improve error handling + - Consolidated conversation-related operations that were previously scattered across multiple stores and subsystems + +**Note:** The background-worker configuration now has a dependency on the shared global settings. +Deployments that previously set these values in both galley and background-worker sections +can consolidate them into the global.settings section. diff --git a/charts/wire-server/templates/_helpers.tpl b/charts/wire-server/templates/_helpers.tpl index 5edb0251456..fc74d3b41bc 100644 --- a/charts/wire-server/templates/_helpers.tpl +++ b/charts/wire-server/templates/_helpers.tpl @@ -155,6 +155,180 @@ {{- end -}} {{- end -}} +{{/* SHARED SETTINGS */}} +{{- define "wire-server.settings.common" -}} +maxTeamSize: {{ .maxTeamSize }} +maxConvSize: {{ .maxConvSize }} +intraListing: {{ .intraListing }} +{{- if .maxFanoutSize }} +maxFanoutSize: {{ .maxFanoutSize }} +{{- end }} +{{- if .exposeInvitationURLsTeamAllowlist }} +exposeInvitationURLsTeamAllowlist: {{ toYaml .exposeInvitationURLsTeamAllowlist | nindent 8 }} +{{- end }} +{{- if .conversationCodeURI }} +conversationCodeURI: {{ .conversationCodeURI | quote }} +{{- else if .multiIngress }} +multiIngress: {{- toYaml .multiIngress | nindent 8 }} +{{- else }} +{{ fail "Either settings.conversationCodeURI or settings.multiIngress have to be set" }} +{{- end }} +{{- if (and .conversationCodeURI .multiIngress) }} +{{ fail "settings.conversationCodeURI and settings.multiIngress are mutually exclusive" }} +{{- end }} +{{- if hasKey . "httpPoolSize" }} +httpPoolSize: {{ .httpPoolSize }} +{{- end }} +{{- if hasKey . "federationDomain" }} +federationDomain: {{ .federationDomain }} +{{- end }} +{{- if .federationProtocols }} +federationProtocols: {{ .federationProtocols | toJson }} +{{- end }} +{{- if .mlsPrivateKeyPaths }} +mlsPrivateKeyPaths: {{- toYaml .mlsPrivateKeyPaths | nindent 8 }} +{{- end }} +{{- if .concurrentDeletionEvents }} +concurrentDeletionEvents: {{ .concurrentDeletionEvents }} +{{- end }} +{{- if .deleteConvThrottleMillis }} +deleteConvThrottleMillis: {{ .deleteConvThrottleMillis }} +{{- end }} +{{- if hasKey . "disabledAPIVersions" }} +disabledAPIVersions: {{ toJson .disabledAPIVersions }} +{{- end }} +{{- if .guestLinkTTLSeconds }} +guestLinkTTLSeconds: {{ .guestLinkTTLSeconds }} +{{- end }} +passwordHashingOptions: {{ toYaml .passwordHashingOptions | nindent 8 }} +passwordHashingRateLimit: {{ toYaml .passwordHashingRateLimit | nindent 8 }} +{{- if .checkGroupInfo }} +checkGroupInfo: {{ .checkGroupInfo }} +{{- end }} +{{- if hasKey . "meetings" }} +meetings: + {{- toYaml .meetings | nindent 8 }} +{{- end }} +{{- if .featureFlags }} +featureFlags: + sso: {{ .featureFlags.sso }} + legalhold: {{ .featureFlags.legalhold }} + teamSearchVisibility: {{ .featureFlags.teamSearchVisibility }} + classifiedDomains: + {{- toYaml .featureFlags.classifiedDomains | nindent 10 }} + {{- if .featureFlags.fileSharing }} + fileSharing: + {{- toYaml .featureFlags.fileSharing | nindent 10 }} + {{- end }} + {{- if .featureFlags.enforceFileDownloadLocation }} + enforceFileDownloadLocation: + {{- toYaml .featureFlags.enforceFileDownloadLocation | nindent 10 }} + {{- end }} + {{- if .featureFlags.sndFactorPasswordChallenge }} + sndFactorPasswordChallenge: + {{- toYaml .featureFlags.sndFactorPasswordChallenge | nindent 10 }} + {{- end }} + {{- if .featureFlags.searchVisibilityInbound }} + searchVisibilityInbound: + {{- toYaml .featureFlags.searchVisibilityInbound | nindent 10 }} + {{- end }} + {{- /* Accept the legacy typo in Helm values, but always render the canonical Galley key. */}} + {{- $validateSAMLemails := .featureFlags.validateSAMLemails | default .featureFlags.validateSAMLEmails }} + {{- if $validateSAMLemails }} + validateSAMLemails: + {{- toYaml $validateSAMLemails | nindent 10 }} + {{- end }} + {{- if .featureFlags.appLock }} + appLock: + {{- toYaml .featureFlags.appLock | nindent 10 }} + {{- end }} + {{- if .featureFlags.conferenceCalling }} + conferenceCalling: + {{- toYaml .featureFlags.conferenceCalling | nindent 10 }} + {{- end }} + {{- if .featureFlags.selfDeletingMessages }} + selfDeletingMessages: + {{- toYaml .featureFlags.selfDeletingMessages | nindent 10 }} + {{- end }} + {{- if .featureFlags.conversationGuestLinks }} + conversationGuestLinks: + {{- toYaml .featureFlags.conversationGuestLinks | nindent 10 }} + {{- end }} + {{- if .featureFlags.mls }} + mls: + {{- toYaml .featureFlags.mls | nindent 10 }} + {{- end }} + {{- if .featureFlags.outlookCalIntegration }} + outlookCalIntegration: + {{- toYaml .featureFlags.outlookCalIntegration | nindent 10 }} + {{- end }} + {{- if .featureFlags.mlsE2EId }} + mlsE2EId: + {{- toYaml .featureFlags.mlsE2EId | nindent 10 }} + {{- end }} + {{- if .featureFlags.mlsMigration }} + mlsMigration: + {{- toYaml .featureFlags.mlsMigration | nindent 10 }} + {{- end }} + {{- if .featureFlags.limitedEventFanout }} + limitedEventFanout: + {{- toYaml .featureFlags.limitedEventFanout | nindent 10 }} + {{- end }} + {{- if .featureFlags.domainRegistration }} + domainRegistration: + {{- toYaml .featureFlags.domainRegistration | nindent 10 }} + {{- end }} + {{- if .featureFlags.channels }} + channels: + {{- toYaml .featureFlags.channels | nindent 10 }} + {{- end }} + {{- if .featureFlags.cells }} + cells: + {{- toYaml .featureFlags.cells | nindent 10 }} + {{- end }} + {{- if .featureFlags.cellsInternal }} + cellsInternal: + {{- toYaml .featureFlags.cellsInternal | nindent 10 }} + {{- end }} + {{- if .featureFlags.allowedGlobalOperations }} + allowedGlobalOperations: + {{- toYaml .featureFlags.allowedGlobalOperations | nindent 10 }} + {{- end }} + {{- if .featureFlags.assetAuditLog }} + assetAuditLog: + {{- toYaml .featureFlags.assetAuditLog | nindent 10 }} + {{- end }} + {{- if .featureFlags.consumableNotifications }} + consumableNotifications: + {{- toYaml .featureFlags.consumableNotifications | nindent 10 }} + {{- end }} + {{- if .featureFlags.chatBubbles }} + chatBubbles: + {{- toYaml .featureFlags.chatBubbles | nindent 10 }} + {{- end }} + {{- if .featureFlags.apps }} + apps: + {{- toYaml .featureFlags.apps | nindent 10 }} + {{- end }} + {{- if .featureFlags.simplifiedUserConnectionRequestQRCode }} + simplifiedUserConnectionRequestQRCode: + {{- toYaml .featureFlags.simplifiedUserConnectionRequestQRCode | nindent 10 }} + {{- end }} + {{- if .featureFlags.stealthUsers }} + stealthUsers: + {{- toYaml .featureFlags.stealthUsers | nindent 10 }} + {{- end }} + {{- if .featureFlags.meetings }} + meetings: + {{- toYaml .featureFlags.meetings | nindent 10 }} + {{- end }} + {{- if .featureFlags.meetingsPremium }} + meetingsPremium: + {{- toYaml .featureFlags.meetingsPremium | nindent 10 }} + {{- end }} +{{- end }} +{{- end -}} + {{/* Compute the SCIM base URI The rules are: diff --git a/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs b/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs index 7915eb9a126..638da672409 100644 --- a/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs +++ b/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs @@ -25,6 +25,8 @@ module Wire.API.Team.FeatureFlags FeatureFlags, FanoutLimit, featureDefaults, + defaultFanoutLimit, + currentFanoutLimit, notTeamMember, findTeamMember, isTeamMember, @@ -42,7 +44,7 @@ import Data.ByteString.UTF8 qualified as UTF8 import Data.Default import Data.Id (UserId) import Data.OpenApi qualified as S -import Data.Range (Range) +import Data.Range (Range, fromRange, toRange, unsafeRange) import Data.SOP import Data.Schema import Data.Set qualified as Set @@ -53,6 +55,15 @@ import Wire.API.Team.Permission type FanoutLimit = Range 1 HardTruncationLimit Int32 +defaultFanoutLimit :: FanoutLimit +defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) + +currentFanoutLimit :: Word32 -> Maybe FanoutLimit -> FanoutLimit +currentFanoutLimit maxTeamSize maxFanoutSize = + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit maxFanoutSize + maxSize = fromIntegral maxTeamSize + in unsafeRange (min maxSize optFanoutLimit) + -- | Used to extract the feature config type out of 'FeatureDefaults' or -- related types. type family ConfigOf a diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index e62655cecc3..88cd2d1e2e9 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -25,6 +25,7 @@ , bytestring-conversion , case-insensitive , cassandra-util +, comonad , conduit , constraints , containers @@ -69,6 +70,7 @@ , imports , iproute , iso639 +, kan-extensions , lens , lens-aeson , lib @@ -164,6 +166,7 @@ mkDerivation { bytestring-conversion case-insensitive cassandra-util + comonad conduit constraints containers @@ -204,6 +207,7 @@ mkDerivation { imports iproute iso639 + kan-extensions lens lens-aeson lrucaching @@ -289,6 +293,7 @@ mkDerivation { bytestring-conversion case-insensitive cassandra-util + comonad conduit constraints containers @@ -330,6 +335,7 @@ mkDerivation { imports iproute iso639 + kan-extensions lens lens-aeson lrucaching diff --git a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs index 7353ad6092f..fc2ba75eb69 100644 --- a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs @@ -44,7 +44,7 @@ import Wire.API.UserGroup import Wire.BackgroundJobsPublisher import Wire.BackgroundJobsRunner (BackgroundJobsRunner (..)) import Wire.ConversationStore (ConversationStore, getConversation, upsertMembers) -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem hiding (getConversation) import Wire.Sem.Random import Wire.StoredConversation import Wire.UserGroupStore (UserGroupStore, getUserGroup, getUserGroupChannels) diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index a4e53f2b9b3..1f9dabb13b6 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -75,6 +75,9 @@ module Wire.BrigAPIAccess -- * Account status setAccountStatus, + + -- * Assertions + ensureConnectedToLocals, ) where @@ -92,6 +95,7 @@ import Polysemy import Polysemy.Error import Web.Scim.Filter qualified as Scim import Wire.API.Connection +import Wire.API.Error import Wire.API.Error.Galley import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig @@ -198,3 +202,17 @@ getConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 = do res1 <- getConnectionsUnqualified uids1 (Just uids2) mrel1 res2 <- getConnectionsUnqualified uids2 (Just uids1) mrel2 pure (res1, res2) + +ensureConnectedToLocals :: + ( Member (ErrorS 'NotConnected) r, + Member BrigAPIAccess r + ) => + UserId -> + [UserId] -> + Sem r () +ensureConnectedToLocals _ [] = pure () +ensureConnectedToLocals u uids = do + (connsFrom, connsTo) <- + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) + unless (length connsFrom == length uids && length connsTo == length uids) $ + throwS @'NotConnected diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index 6fdd631757d..bc36f8de6bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -455,7 +455,7 @@ addMembers conv (UserList lusers rusers) = do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has - -- been (or will be) made separately. See Galley.API.Update.addMembers + -- been (or will be) made separately. See Wire.ConversationSubsystem.Update.addMembers addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 3a4593cf22a..cd10f465eca 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -17,20 +17,66 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem where +module Wire.ConversationSubsystem + ( module Wire.ConversationSubsystem, + Util.BotsAndMembers (..), + Util.canDeleteMember, + Util.isMember, + Util.userLHEnabled, + MLSRemoval.RemoveUserIncludeMain (..), + LegalholdConflicts.guardLegalholdPolicyConflicts, + ) +where +import Data.Code qualified as Code +import Data.CommaSeparatedList (CommaSeparatedList) +import Data.Domain import Data.Id +import Data.Misc (IpAddr) import Data.Qualified -import Data.Range (Range) +import Data.Range import Data.Singletons (Sing) -import Galley.Types.Clients (Clients) import Imports import Polysemy -import Wire.API.Conversation (ConvIdsPage, ConversationPagingState, ExtraConversationData, NewConv, NewOne2OneConv) +import Wire.API.Bot (AddBot, RemoveBot) +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action +import Wire.API.Conversation.CellsState (CellsState) +import Wire.API.Conversation.Code (ConversationCodeInfo, CreateConversationCodeRequest, JoinConversationByCode) +import Wire.API.Conversation.Pagination (ConversationPage) +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role (ConversationRolesList) +import Wire.API.Conversation.Typing import Wire.API.Event.Conversation +import Wire.API.Federation.API.Common +import Wire.API.Federation.API.Galley +import Wire.API.MLS.CommitBundle +import Wire.API.MLS.GroupInfo (GroupInfoData) +import Wire.API.MLS.Keys (MLSKeys, MLSKeysByPurpose, MLSPublicKey, MLSPublicKeyFormat, SomeKey) +import Wire.API.MLS.Message +import Wire.API.MLS.OutOfSync (EnableOutOfSyncCheck) +import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation (ConvOrSubConvId, PublicSubConversation, SubConvId) +import Wire.API.Message (ClientMismatch, IgnoreMissing, MessageSendingStatus, NewOtrMessage, QualifiedNewOtrMessage, ReportMissing) +import Wire.API.Pagination (PageSize, SortOrder) +import Wire.API.Provider.Bot qualified as Public (BotConvView) +import Wire.API.Routes.Internal.Galley.ConversationsIntra (UpsertOne2OneConversationRequest) +import Wire.API.Routes.Public (ZHostValue) +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Galley.MLS (MLSReset) +import Wire.API.Routes.Public.Galley.Messaging (MessageNotSent, PostOtrResponse) +import Wire.API.Routes.Public.Util (UpdateResult) +import Wire.API.Routes.Version +import Wire.API.ServantProto (RawProto (..)) +import Wire.API.Team.Feature (GuestLinksConfig, LockableFeature) +import Wire.ConversationStore.MLS.Types (ListGlobalSelfConvs) +import Wire.ConversationSubsystem.LegalholdConflicts qualified as LegalholdConflicts +import Wire.ConversationSubsystem.MLS.IncomingMessage (IncomingBundle, IncomingMessage) +import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval +import Wire.ConversationSubsystem.Util qualified as Util import Wire.NotificationSubsystem (LocalConversationUpdate) -import Wire.StoredConversation +import Wire.StoredConversation (BotMember, LocalMember, StoredConversation) data ConversationSubsystem m a where NotifyConversationAction :: @@ -45,24 +91,39 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate - CreateGroupConversation :: + InternalCreateGroupConversation :: Local UserId -> Maybe ConnId -> NewConv -> ConversationSubsystem m StoredConversation + CreateGroupConversationUpToV3 :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m (ConversationResponse Public.OwnConversation) + CreateGroupOwnConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m CreateGroupConversationResponseV9 + CreateGroupConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m CreateGroupConversation + CreateProteusSelfConversation :: + Local UserId -> + ConversationSubsystem m (ConversationResponse Public.OwnConversation) CreateOne2OneConversation :: Local UserId -> ConnId -> NewOne2OneConv -> - ConversationSubsystem m (StoredConversation, Bool) - CreateProteusSelfConversation :: - Local UserId -> - ConversationSubsystem m (StoredConversation, Bool) + ConversationSubsystem m (ConversationResponse Public.OwnConversation) CreateConnectConversation :: Local UserId -> Maybe ConnId -> Connect -> - ConversationSubsystem m (StoredConversation, Bool) + ConversationSubsystem m (ConversationResponse Public.OwnConversation) GetConversations :: [ConvId] -> ConversationSubsystem m [StoredConversation] @@ -71,10 +132,559 @@ data ConversationSubsystem m a where Range 1 1000 Int32 -> Maybe ConversationPagingState -> ConversationSubsystem r ConvIdsPage - InternalGetClientIds :: [UserId] -> ConversationSubsystem m Clients InternalGetLocalMember :: ConvId -> UserId -> ConversationSubsystem m (Maybe LocalMember) + InternalGetMember :: + Qualified ConvId -> + UserId -> + ConversationSubsystem m (Maybe Public.Member) + GetConversationMeta :: + ConvId -> + ConversationSubsystem m ConversationMetadata + GetMLSOne2OneConversationInternal :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Public.OwnConversation + IsMLSOne2OneEstablished :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Bool + GetLocalConversationInternal :: + ConvId -> + ConversationSubsystem m Conversation + RemoveClient :: + Local StoredConversation -> + Qualified UserId -> + ClientId -> + ConversationSubsystem m () + AddBot :: + Local UserId -> + ConnId -> + AddBot -> + ConversationSubsystem m Event + RmBot :: + Local UserId -> + Maybe ConnId -> + RemoveBot -> + ConversationSubsystem m (UpdateResult Event) + UpdateCellsState :: + ConvId -> + CellsState -> + ConversationSubsystem m () + RemoveUser :: + Local StoredConversation -> + MLSRemoval.RemoveUserIncludeMain -> + Qualified UserId -> + ConversationSubsystem m () + PostMLSCommitBundle :: + Local x -> + Qualified UserId -> + ClientId -> + ConvType -> + Qualified ConvOrSubConvId -> + Maybe ConnId -> + EnableOutOfSyncCheck -> + IncomingBundle -> + ConversationSubsystem m [LocalConversationUpdate] + PostMLSCommitBundleFromLocalUser :: + Version -> + Local UserId -> + ClientId -> + ConnId -> + RawMLS CommitBundle -> + ConversationSubsystem m MLSMessageSendingStatus + PostMLSMessage :: + Local x -> + Qualified UserId -> + ClientId -> + ConvType -> + Qualified ConvOrSubConvId -> + Maybe ConnId -> + EnableOutOfSyncCheck -> + IncomingMessage -> + ConversationSubsystem m [LocalConversationUpdate] + PostMLSMessageFromLocalUser :: + Version -> + Local UserId -> + ClientId -> + ConnId -> + RawMLS Message -> + ConversationSubsystem m MLSMessageSendingStatus + IsMLSEnabled :: ConversationSubsystem m Bool + IterateConversations :: + Local UserId -> + Range 1 500 Int32 -> + ([StoredConversation] -> m a) -> + ConversationSubsystem m () + RemoveMemberFromLocalConv :: + Local ConvId -> + Local UserId -> + Maybe ConnId -> + Qualified UserId -> + ConversationSubsystem m (Maybe Event) + FederationOnConversationCreated :: + Domain -> + ConversationCreated ConvId -> + ConversationSubsystem m EmptyResponse + FederationGetConversationsV1 :: + Domain -> + GetConversationsRequest -> + ConversationSubsystem m GetConversationsResponse + FederationGetConversations :: + Domain -> + GetConversationsRequest -> + ConversationSubsystem m GetConversationsResponseV2 + FederationLeaveConversation :: + Domain -> + LeaveConversationRequest -> + ConversationSubsystem m LeaveConversationResponse + FederationSendMessage :: + Domain -> + ProteusMessageSendRequest -> + ConversationSubsystem m MessageSendResponse + FederationUpdateConversation :: + Domain -> + ConversationUpdateRequest -> + ConversationSubsystem m ConversationUpdateResponse + FederationMlsSendWelcome :: + Domain -> + MLSWelcomeRequest -> + ConversationSubsystem m MLSWelcomeResponse + FederationSendMLSMessage :: + Domain -> + MLSMessageSendRequest -> + ConversationSubsystem m MLSMessageResponse + FederationSendMLSCommitBundle :: + Domain -> + MLSMessageSendRequest -> + ConversationSubsystem m MLSMessageResponse + FederationQueryGroupInfo :: + Domain -> + GetGroupInfoRequest -> + ConversationSubsystem m GetGroupInfoResponse + FederationUpdateTypingIndicator :: + Domain -> + TypingDataUpdateRequest -> + ConversationSubsystem m TypingDataUpdateResponse + FederationOnTypingIndicatorUpdated :: + Domain -> + TypingDataUpdated -> + ConversationSubsystem m EmptyResponse + FederationGetSubConversationForRemoteUser :: + Domain -> + GetSubConversationsRequest -> + ConversationSubsystem m GetSubConversationsResponse + FederationDeleteSubConversationForRemoteUser :: + Domain -> + DeleteSubConversationFedRequest -> + ConversationSubsystem m DeleteSubConversationResponse + FederationLeaveSubConversation :: + Domain -> + LeaveSubConversationRequest -> + ConversationSubsystem m LeaveSubConversationResponse + FederationGetOne2OneConversationV1 :: + Domain -> + GetOne2OneConversationRequest -> + ConversationSubsystem m GetOne2OneConversationResponse + FederationGetOne2OneConversation :: + Domain -> + GetOne2OneConversationRequest -> + ConversationSubsystem m GetOne2OneConversationResponseV2 + FederationOnClientRemoved :: + Domain -> + ClientRemovedRequest -> + ConversationSubsystem m EmptyResponse + FederationOnMessageSent :: + Domain -> + RemoteMessage ConvId -> + ConversationSubsystem m EmptyResponse + FederationOnMLSMessageSent :: + Domain -> + RemoteMLSMessage -> + ConversationSubsystem m EmptyResponse + FederationOnConversationUpdatedV0 :: + Domain -> + ConversationUpdateV0 -> + ConversationSubsystem m EmptyResponse + FederationOnConversationUpdated :: + Domain -> + ConversationUpdate -> + ConversationSubsystem m EmptyResponse + FederationOnUserDeleted :: + Domain -> + UserDeletedConversationsNotification -> + ConversationSubsystem m EmptyResponse + PostOtrMessageUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (PostOtrResponse ClientMismatch) + PostOtrBroadcastUnqualified :: + Local UserId -> + ConnId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (PostOtrResponse ClientMismatch) + PostProteusMessage :: + Local UserId -> + ConnId -> + Qualified ConvId -> + RawProto QualifiedNewOtrMessage -> + ConversationSubsystem m (PostOtrResponse MessageSendingStatus) + PostProteusBroadcast :: + Local UserId -> + ConnId -> + QualifiedNewOtrMessage -> + ConversationSubsystem m (PostOtrResponse MessageSendingStatus) + DeleteLocalConversation :: + Local UserId -> + ConnId -> + Local ConvId -> + ConversationSubsystem m (UpdateResult Event) + GetMLSPublicKeys :: + Maybe MLSPublicKeyFormat -> + ConversationSubsystem m (MLSKeysByPurpose (MLSKeys SomeKey)) + ResetMLSConversation :: + Local UserId -> + MLSReset -> + ConversationSubsystem m () + GetSubConversation :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m PublicSubConversation + GetBotConversation :: + BotId -> + ConvId -> + ConversationSubsystem m Public.BotConvView + -- Query functions + GetUnqualifiedOwnConversation :: + Local UserId -> + ConvId -> + ConversationSubsystem m Public.OwnConversation + GetOwnConversation :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m Public.OwnConversation + GetPaginatedConversations :: + Local UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + ConversationSubsystem m (Public.ConversationList Public.OwnConversation) + GetConversation :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m Public.Conversation + InternalGetConversation :: + ConvId -> + ConversationSubsystem m (Maybe StoredConversation) + GetConversationRoles :: + Local UserId -> + ConvId -> + ConversationSubsystem m ConversationRolesList + SearchChannels :: + Local UserId -> + TeamId -> + Maybe Text -> + Maybe SortOrder -> + Maybe PageSize -> + Maybe Text -> + Maybe ConvId -> + Bool -> + ConversationSubsystem m ConversationPage + GetGroupInfo :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m GroupInfoData + ConversationIdsPageFromUnqualified :: + Local UserId -> + Maybe ConvId -> + Maybe (Range 1 1000 Int32) -> + ConversationSubsystem m (ConversationList ConvId) + ConversationIdsPageFromV2 :: + ListGlobalSelfConvs -> + Local UserId -> + Public.GetPaginatedConversationIds -> + ConversationSubsystem m Public.ConvIdsPage + ConversationIdsPageFrom :: + Local UserId -> + Public.GetPaginatedConversationIds -> + ConversationSubsystem m Public.ConvIdsPage + ListConversations :: + Local UserId -> + Public.ListConversations -> + ConversationSubsystem m ConversationsResponse + GetConversationByReusableCode :: + Local UserId -> + Code.Key -> + Code.Value -> + ConversationSubsystem m ConversationCoverView + GetMLSSelfConversationWithError :: + Local UserId -> + ConversationSubsystem m Public.OwnConversation + GetMLSOne2OneConversationV5 :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Public.OwnConversation + GetMLSOne2OneConversationV6 :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m (MLSOne2OneConversation MLSPublicKey) + GetMLSOne2OneConversation :: + Local UserId -> + Qualified UserId -> + Maybe MLSPublicKeyFormat -> + ConversationSubsystem m (MLSOne2OneConversation SomeKey) + GetLocalSelf :: + Local UserId -> + ConvId -> + ConversationSubsystem m (Maybe Public.Member) + GetSelfMember :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m (Maybe Public.Member) + GetConversationGuestLinksStatus :: + UserId -> + ConvId -> + ConversationSubsystem m (LockableFeature GuestLinksConfig) + GetCode :: + Maybe Text -> + Local UserId -> + ConvId -> + ConversationSubsystem m ConversationCodeInfo + -- Update functions + AddMembersUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + Invite -> + ConversationSubsystem m (UpdateResult Event) + AddMembersUnqualifiedV2 :: + Local UserId -> + ConnId -> + ConvId -> + InviteQualified -> + ConversationSubsystem m (UpdateResult Event) + AddMembers :: + Local UserId -> + ConnId -> + Qualified ConvId -> + InviteQualified -> + ConversationSubsystem m (UpdateResult Event) + ReplaceMembers :: + Local UserId -> + ConnId -> + Qualified ConvId -> + InviteQualified -> + ConversationSubsystem m () + JoinConversationById :: + Local UserId -> + ConnId -> + ConvId -> + ConversationSubsystem m (UpdateResult Event) + JoinConversationByReusableCode :: + Local UserId -> + ConnId -> + JoinConversationByCode -> + ConversationSubsystem m (UpdateResult Event) + CheckReusableCode :: + IpAddr -> + ConversationCode -> + ConversationSubsystem m () + AddCodeUnqualified :: + Maybe CreateConversationCodeRequest -> + UserId -> + Maybe ZHostValue -> + Maybe ConnId -> + ConvId -> + ConversationSubsystem m AddCodeResult + AddCodeUnqualifiedWithReqBody :: + UserId -> + Maybe Text -> + Maybe ConnId -> + ConvId -> + CreateConversationCodeRequest -> + ConversationSubsystem m AddCodeResult + RmCodeUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + ConversationSubsystem m Event + MemberTypingUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + TypingStatus -> + ConversationSubsystem m () + MemberTyping :: + Local UserId -> + ConnId -> + Qualified ConvId -> + TypingStatus -> + ConversationSubsystem m () + RemoveMemberUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + UserId -> + ConversationSubsystem m (Maybe Event) + RemoveMemberQualified :: + Local UserId -> + ConnId -> + Qualified ConvId -> + Qualified UserId -> + ConversationSubsystem m (Maybe Event) + UpdateOtherMemberUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + UserId -> + OtherMemberUpdate -> + ConversationSubsystem m () + UpdateOtherMember :: + Local UserId -> + ConnId -> + Qualified ConvId -> + Qualified UserId -> + OtherMemberUpdate -> + ConversationSubsystem m () + UpdateUnqualifiedConversationName :: + Local UserId -> + ConnId -> + ConvId -> + ConversationRename -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationName :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationRename -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationMessageTimerUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + ConversationMessageTimerUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationMessageTimer :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationMessageTimerUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationReceiptModeUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + ConversationReceiptModeUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationReceiptMode :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationReceiptModeUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationAccessUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + ConversationAccessData -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationAccess :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationAccessData -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationHistory :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationHistoryUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateUnqualifiedSelfMember :: + Local UserId -> + ConnId -> + ConvId -> + MemberUpdate -> + ConversationSubsystem m () + UpdateSelfMember :: + Local UserId -> + ConnId -> + Qualified ConvId -> + MemberUpdate -> + ConversationSubsystem m () + UpdateConversationProtocolWithLocalUser :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ProtocolUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateChannelAddPermission :: + Local UserId -> + ConnId -> + Qualified ConvId -> + AddPermissionUpdate -> + ConversationSubsystem m (UpdateResult Event) + PostBotMessageUnqualified :: + BotId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (Either (MessageNotSent ClientMismatch) ClientMismatch) + -- Sub-conversation functions + DeleteSubConversation :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + MLSReset -> + ConversationSubsystem m () + GetSubConversationGroupInfo :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m GroupInfoData + LeaveSubConversation :: + Local UserId -> + ClientId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m () + SendConversationActionNotifications :: + forall tag m. + Sing tag -> + Qualified UserId -> + Bool -> + Maybe ConnId -> + Local StoredConversation -> + Util.BotsAndMembers -> + ConversationAction (tag :: ConversationActionTag) -> + ExtraConversationData -> + ConversationSubsystem m LocalConversationUpdate + InternalUpsertOne2OneConversation :: + UpsertOne2OneConversationRequest -> + ConversationSubsystem m () + AcceptConv :: + QualifiedWithTag QLocal UserId -> + Maybe ConnId -> + ConvId -> + ConversationSubsystem m OwnConversation + BlockConv :: + QualifiedWithTag QLocal UserId -> + Qualified ConvId -> + ConversationSubsystem m () + UnblockConv :: + QualifiedWithTag QLocal UserId -> + Maybe ConnId -> + Qualified ConvId -> + ConversationSubsystem m () makeSem ''ConversationSubsystem diff --git a/services/galley/src/Galley/API/Action.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs similarity index 97% rename from services/galley/src/Galley/API/Action.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs index 7a0816a0153..3c81ed700f9 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action +module Wire.ConversationSubsystem.Action ( -- * Conversation action types ConversationActionTag (..), ConversationJoin (..), @@ -73,14 +73,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Time.Clock import GHC.TypeLits (KnownNat) -import Galley.API.Action.Kick -import Galley.API.Action.Leave -import Galley.API.Action.Notify -import Galley.API.Action.Reset -import Galley.API.MLS.Conversation -import Galley.API.MLS.Migration -import Galley.API.MLS.Removal -import Galley.API.Teams.Features.Get import Galley.Types.Error import Imports hiding ((\\)) import Polysemy @@ -122,7 +114,13 @@ import Wire.BrigAPIAccess qualified as E import Wire.CodeStore import Wire.CodeStore qualified as E import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Kick +import Wire.ConversationSubsystem.Action.Leave +import Wire.ConversationSubsystem.Action.Notify +import Wire.ConversationSubsystem.Action.Reset +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Migration +import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem @@ -140,7 +138,7 @@ import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList import Wire.Util @@ -189,7 +187,6 @@ instance IsConversationAction 'ConversationJoinTag where HasConversationActionEffects 'ConversationJoinTag r = ( -- TODO: Replace with subsystems Member BackendNotificationQueueAccess r, - Member ConversationSubsystem r, Member TeamCollaboratorsSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -461,7 +458,6 @@ instance IsConversationAction 'ConversationAccessDataTag where Member Random r, Member (Error FederationError) r, Member BackendNotificationQueueAccess r, - Member ConversationSubsystem r, Member TeamSubsystem r ) @@ -694,7 +690,6 @@ instance IsConversationAction 'ConversationResetTag where ( Member BackendNotificationQueueAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member E.ConversationStore r, Member NotificationSubsystem r, Member ProposalStore r, @@ -825,7 +820,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do -- - ensure that a consented conv admin exists -- - and kick all existing members that do not consent to LH from the conversation -- See also: "Brig.API.Connection.checkLegalholdPolicyConflict" - -- and "Galley.API.LegalHold.Conflicts.guardLegalholdPolicyConflictsUid". + -- and "Wire.ConversationSubsystem.LegalholdConflicts.guardLegalholdPolicyConflictsUid". checkLHPolicyConflictsLocal :: [UserId] -> Sem r () @@ -843,7 +838,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do throwS @'MissingLegalholdConsent convUsersLHStatus <- do - uidsStatus <- getLHStatusForUsers ((.id_) <$> convUsers) + uidsStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> convUsers) pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus if any @@ -995,7 +990,6 @@ updateLocalConversationJoin :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationJoinTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, @@ -1034,7 +1028,6 @@ updateLocalConversationLeave :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationLeaveTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, Member ExternalAccess r, @@ -1057,7 +1050,10 @@ updateLocalConversationMemberUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationMemberUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member (ErrorS ConvMemberNotFound) r, Member E.ConversationStore r @@ -1074,7 +1070,10 @@ updateLocalConversationDelete :: ( Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationDeleteTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member CodeStore r, Member E.ConversationStore r, @@ -1093,7 +1092,10 @@ updateLocalConversationRename :: ( Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRenameTag))) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member (Error InvalidInput) r, Member E.ConversationStore r, @@ -1112,7 +1114,10 @@ updateLocalConversationMessageTimerUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationMessageTimerUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member E.ConversationStore r, Member (Error NoChanges) r @@ -1130,7 +1135,10 @@ updateLocalConversationReceiptModeUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationReceiptModeUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member E.ConversationStore r, Member (Error NoChanges) r, @@ -1149,7 +1157,6 @@ updateLocalConversationAccessData :: Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationAccessDataTag))) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member TinyLog r, Member E.ConversationStore r, @@ -1179,7 +1186,6 @@ updateLocalConversationRemoveMembers :: ( Member BackendNotificationQueueAccess r, Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRemoveMembersTag))) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member TinyLog r, Member E.ConversationStore r, @@ -1207,7 +1213,6 @@ updateLocalConversationUpdateProtocol :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationUpdateProtocolTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member (E.FederationAPIAccess FederatorClient) r, Member TinyLog r, @@ -1237,7 +1242,10 @@ updateLocalConversationUpdateAddPermission :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationUpdateAddPermissionTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member (Error NoChanges) r, Member E.ConversationStore r, Member TeamSubsystem r, @@ -1257,7 +1265,6 @@ updateLocalConversationReset :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationResetTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (E.FederationAPIAccess FederatorClient) r, Member TinyLog r, Member E.ConversationStore r, @@ -1285,7 +1292,10 @@ updateLocalConversationHistoryUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationHistoryUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member E.ConversationStore r, Member TeamSubsystem r, Member (ErrorS HistoryNotSupported) r @@ -1304,7 +1314,6 @@ updateLocalConversationUncheckedJoin :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationJoinTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, @@ -1343,7 +1352,6 @@ updateLocalConversationUncheckedRemoveMembers :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRemoveMembersTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, Member (Error NoChanges) r, @@ -1370,7 +1378,10 @@ updateLocalConversation :: Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, HasConversationActionEffects tag r, IsConversationAction tag, SingI tag, @@ -1405,7 +1416,10 @@ updateLocalConversationUnchecked :: Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, HasConversationActionEffects tag r, Member TeamSubsystem r ) => diff --git a/services/galley/src/Galley/API/Action/Kick.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs similarity index 93% rename from services/galley/src/Galley/API/Action/Kick.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs index 7356b04c10b..ddb1caae8a0 100644 --- a/services/galley/src/Galley/API/Action/Kick.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs @@ -15,14 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Kick where +module Wire.ConversationSubsystem.Action.Kick where import Data.Default import Data.Id import Data.Qualified import Data.Singletons -import Galley.API.Action.Leave -import Galley.API.Action.Notify import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -35,7 +33,8 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.Error import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore) -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Leave +import Wire.ConversationSubsystem.Action.Notify import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.NotificationSubsystem @@ -53,7 +52,6 @@ kickMember :: ( Member BackendNotificationQueueAccess r, Member (Error FederationError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member ProposalStore r, Member Now r, diff --git a/services/galley/src/Galley/API/Action/Leave.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs similarity index 94% rename from services/galley/src/Galley/API/Action/Leave.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs index 0141cc4ad2c..4e88fd77f9a 100644 --- a/services/galley/src/Galley/API/Action/Leave.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs @@ -15,12 +15,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Leave (leaveConversation) where +module Wire.ConversationSubsystem.Action.Leave (leaveConversation) where import Control.Lens import Data.Id import Data.Qualified -import Galley.API.MLS.Removal import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -30,6 +29,7 @@ import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Federation.Error import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Action/Notify.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs similarity index 76% rename from services/galley/src/Galley/API/Action/Notify.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs index 77c8167ebc3..4a11ac20012 100644 --- a/services/galley/src/Galley/API/Action/Notify.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs @@ -15,24 +15,34 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Notify where +module Wire.ConversationSubsystem.Action.Notify where import Data.Id import Data.Qualified import Data.Singletons import Imports hiding ((\\)) import Polysemy +import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Event.Conversation -import Wire.ConversationSubsystem +import Wire.API.Federation.Error +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.ConversationSubsystem.Notify (notifyConversationActionImpl) import Wire.ConversationSubsystem.Util +import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) import Wire.StoredConversation sendConversationActionNotifications :: forall tag r. - (Member ConversationSubsystem r) => + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, + Member (Error FederationError) r, + Member Now r, + Member NotificationSubsystem r + ) => Sing tag -> Qualified UserId -> Bool -> @@ -43,7 +53,7 @@ sendConversationActionNotifications :: ExtraConversationData -> Sem r LocalConversationUpdate sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData = do - notifyConversationAction + notifyConversationActionImpl tag (EventFromUser quid) notifyOrigDomain diff --git a/services/galley/src/Galley/API/Action/Reset.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs similarity index 96% rename from services/galley/src/Galley/API/Action/Reset.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs index 49614ab300d..c31399a3b4d 100644 --- a/services/galley/src/Galley/API/Action/Reset.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs @@ -15,15 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Reset (resetLocalMLSMainConversation) where +module Wire.ConversationSubsystem.Action.Reset (resetLocalMLSMainConversation) where import Control.Monad.Codensity hiding (reset) import Data.Aeson qualified as A import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Qualified -import Galley.API.Action.Kick -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -47,7 +45,8 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.API.VersionInfo import Wire.BackendNotificationQueueAccess import Wire.ConversationStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Kick +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess @@ -65,7 +64,6 @@ resetLocalMLSMainConversation :: Member BackendNotificationQueueAccess r, Member (FederationAPIAccess FederatorClient) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member ProposalStore r, Member Random r, diff --git a/services/galley/src/Galley/API/Clients.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs similarity index 89% rename from services/galley/src/Galley/API/Clients.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs index 7aa4c2f12e9..52dae02033a 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs @@ -15,9 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Clients - ( getClients, - rmClient, +module Wire.ConversationSubsystem.Clients + ( rmClient, ) where @@ -25,8 +24,6 @@ import Data.Id import Data.Proxy import Data.Qualified import Data.Range -import Galley.API.MLS.Removal -import Galley.API.Query qualified as Query import Galley.Types.Clients (clientIds) import Galley.Types.Error import Imports @@ -45,7 +42,8 @@ import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Routes.MultiTablePaging import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore, getConversation) -import Wire.ConversationSubsystem qualified as ConvSubsystem +import Wire.ConversationSubsystem.MLS.Removal qualified as Removal +import Wire.ConversationSubsystem.Query qualified as Query import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem import Wire.ProposalStore (ProposalStore) @@ -54,12 +52,6 @@ import Wire.Sem.Random (Random) import Wire.UserClientIndexStore qualified as E import Wire.Util -getClients :: - (Member ConvSubsystem.ConversationSubsystem r) => - UserId -> - Sem r [ClientId] -getClients usr = clientIds usr <$> ConvSubsystem.internalGetClientIds [usr] - -- | Remove a client from conversations it is part of according to the -- conversation protocol (Proteus or MLS). In addition, remove the client from -- the "clients" table in Galley. @@ -67,7 +59,6 @@ rmClient :: forall r. ( Member E.UserClientIndexStore r, Member ConversationStore r, - Member ConvSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member ExternalAccess r, Member BackendNotificationQueueAccess r, @@ -107,7 +98,7 @@ rmClient usr cid = do mConv <- getConversation convId for_ mConv $ \conv -> do lconv <- qualifyLocal conv - removeClient lconv (tUntagged lusr) cid + Removal.removeClient lconv (tUntagged lusr) cid traverse_ removeRemoteMLSClients (rangedChunks remoteConvs) when (mtpHasMore page) $ do let nextState = mtpPagingState page diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs new file mode 100644 index 00000000000..26c7fab9178 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.ConversationSubsystem.Create where + +import Data.Id +import Data.Qualified +import Data.Set qualified as Set +import Galley.Types.Error +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.Config +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Event.Conversation +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.FederationStatus (RemoteDomains (..)) +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.API.User +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.BrigAPIAccess +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.CreateInternal +import Wire.ConversationSubsystem.Mapping +import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) +import Wire.LegalHoldStore (LegalHoldStore) +import Wire.NotificationSubsystem as NS +import Wire.Sem.Now (Now) +import Wire.Sem.Random (Random) +import Wire.TeamCollaboratorsSubsystem +import Wire.TeamStore (TeamStore) +import Wire.TeamSubsystem (TeamSubsystem) + +---------------------------------------------------------------------------- +-- API Handlers + +createGroupConversationUpToV3 :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error UnreachableBackendsLegacy) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do + dbConv <- createGroupConversationGeneric lusr conn newConv + Created <$> conversationViewV9 lusr dbConv + +createGroupOwnConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error InternalError) r, + Member FederationSubsystem r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) + +createGroupConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member FederationSubsystem r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + pure $ + CreateGroupConversation + { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, + failedToAdd = mempty + } + +createProteusSelfConversation :: + ( Member ConversationStore r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + (c, created) <- createProteusSelfConversationLogic lusr + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c + +createOne2OneConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'NotConnected) r, + Member TeamStore r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + ConnId -> + NewOne2OneConv -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversation lusr zcon j = do + (c, created) <- createOne2OneConversationLogic lusr zcon j + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c + +---------------------------------------------------------------------------- +-- Helpers + +createConnectConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (Error UnreachableBackends) r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member (FederationAPIAccess FederatorClient) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Sem r (ConversationResponse Public.OwnConversation) +createConnectConversation lusr conn j = do + (c, created) <- createConnectConversationLogic lusr conn j + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs index f2aab2d82e3..e28425c9061 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs @@ -80,7 +80,7 @@ import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) diff --git a/services/galley/src/Galley/API/Federation/Handlers.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs similarity index 93% rename from services/galley/src/Galley/API/Federation/Handlers.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index b62d7ed3980..ee1f24f0de7 100644 --- a/services/galley/src/Galley/API/Federation/Handlers.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Federation.Handlers where +module Wire.ConversationSubsystem.Federation where import Control.Error hiding (note) import Control.Lens @@ -36,20 +36,6 @@ import Data.Set qualified as Set import Data.Singletons (SingI (..), demote, sing) import Data.Tagged import Data.Text.Lazy qualified as LT -import Galley.API.Action -import Galley.API.MLS -import Galley.API.MLS.Enabled -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled) -import Galley.API.MLS.Message -import Galley.API.MLS.One2One -import Galley.API.MLS.Removal -import Galley.API.MLS.SubConversation hiding (leaveSubConversation) -import Galley.API.MLS.Util -import Galley.API.MLS.Welcome -import Galley.API.Mapping -import Galley.API.Mapping qualified as Mapping -import Galley.API.Message import Galley.Types.Conversations.One2One import Galley.Types.Error import Imports @@ -83,12 +69,26 @@ import Wire.API.Message import Wire.API.Push.V2 (RecipientClients (..)) import Wire.API.Routes.Public.Galley.MLS import Wire.API.ServantProto +import Wire.API.Team.FeatureFlags (FeatureFlags) import Wire.API.User (BaseProtocolTag (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.CodeStore import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.GroupInfo +import Wire.ConversationSubsystem.MLS.GroupInfoCheck (GroupInfoCheckEnabled) +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Message +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.Removal +import Wire.ConversationSubsystem.MLS.SubConversation hiding (leaveSubConversation) +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.MLS.Welcome +import Wire.ConversationSubsystem.Mapping +import Wire.ConversationSubsystem.Mapping qualified as Mapping +import Wire.ConversationSubsystem.Message import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem @@ -97,7 +97,6 @@ import Wire.FederationSubsystem (FederationSubsystem) import Wire.FireAndForget qualified as E import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem -import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -192,7 +191,7 @@ getConversationsV1 :: GetConversationsRequest -> Sem r GetConversationsResponse getConversationsV1 domain req = - getConversationsResponseFromV2 <$> Galley.API.Federation.Handlers.getConversations domain req + getConversationsResponseFromV2 <$> getConversations domain req getConversations :: ( Member E.ConversationStore r, @@ -246,7 +245,6 @@ leaveConversation :: Member E.ConversationStore r, Member (Error InternalError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, @@ -365,13 +363,14 @@ onMessageSent domain rmUnqualified = do sendMessage :: ( Member BrigAPIAccess r, Member UserClientIndexStore r, + Member (Input IntraListing) r, + Member (Input FeatureFlags) r, Member E.ConversationStore r, Member (Error InvalidInput) r, Member (FederationAPIAccess FederatorClient) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, - Member (Input Opts) r, Member Now r, Member ExternalAccess r, Member TeamSubsystem r, @@ -394,7 +393,6 @@ onUserDeleted :: Member E.FireAndForget r, Member (Error FederationError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, @@ -456,7 +454,6 @@ updateConversation :: Member (Error InvalidInput) r, Member ExternalAccess r, Member (FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -559,6 +556,16 @@ updateConversation origDomain updateRequest = do . runError @UnreachableBackends . fmap ConversationUpdateResponseUpdate +type MLSBundleStaticErrors = + Append + MLSMessageStaticErrors + '[ ErrorS 'MLSWelcomeMismatch, + ErrorS 'MLSIdentityMismatch, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSGroupConversationMismatch + ] + handleMLSMessageErrors :: ( r1 ~ Append @@ -599,8 +606,10 @@ sendMLSCommitBundle :: Member ExternalAccess r, Member (Error FederationError) r, Member (Error InternalError) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member (FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input (Maybe GroupInfoCheckEnabled)) r, @@ -635,25 +644,25 @@ sendMLSCommitBundle remoteDomain msr = handleMLSMessageErrors $ do when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch -- this cannot throw the error since we always pass the sender which is qualified to be remote - runInputConst (fromMaybe def msr.enableOutOfSyncCheck) $ - MLSMessageResponseUpdates - . fmap lcuUpdate - <$> mapToRuntimeError @MLSLegalholdIncompatible - (InternalErrorWithDescription "expected group conversation while handling policy conflicts") - ( postMLSCommitBundle - loc - -- Type application to prevent future changes from introducing errors. - -- It is only safe to assume that we can discard the error when the sender - -- is actually remote. - -- Since `tUntagged` works on local and remote, a future changed may - -- go unchecked without this. - (tUntagged @QRemote sender) - msr.senderClient - ctype - qConvOrSub - Nothing - ibundle - ) + MLSMessageResponseUpdates + . fmap lcuUpdate + <$> mapToRuntimeError @MLSLegalholdIncompatible + (InternalErrorWithDescription "expected group conversation while handling policy conflicts") + ( postMLSCommitBundle + loc + -- Type application to prevent future changes from introducing errors. + -- It is only safe to assume that we can discard the error when the sender + -- is actually remote. + -- Since `tUntagged` works on local and remote, a future changed may + -- go unchecked without this. + (tUntagged @QRemote sender) + msr.senderClient + ctype + qConvOrSub + Nothing + (fromMaybe def msr.enableOutOfSyncCheck) + ibundle + ) sendMLSMessage :: ( Member BackendNotificationQueueAccess r, @@ -663,6 +672,9 @@ sendMLSMessage :: Member (Error FederationError) r, Member (Error InternalError) r, Member (FederationAPIAccess FederatorClient) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, @@ -684,16 +696,16 @@ sendMLSMessage remoteDomain msr = handleMLSMessageErrors $ do msg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage raw (ctype, qConvOrSub) <- getConvFromGroupId msg.groupId when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch - runInputConst (fromMaybe def msr.enableOutOfSyncCheck) $ - MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSMessage - loc - (tUntagged sender) - msr.senderClient - ctype - qConvOrSub - Nothing - msg + MLSMessageResponseUpdates . map lcuUpdate + <$> postMLSMessage + loc + (tUntagged sender) + msr.senderClient + ctype + qConvOrSub + Nothing + (fromMaybe def msr.enableOutOfSyncCheck) + msg getSubConversationForRemoteUser :: ( Member E.ConversationStore r, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs index 68bf8c32a3d..2d36e8eeb7c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem.Internal (internalGetClientIdsImpl) where +module Wire.ConversationSubsystem.Internal (internalGetClientIds) where import Data.Id import Galley.Types.Clients (Clients, fromUserClients) @@ -27,14 +27,14 @@ import Wire.BrigAPIAccess import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserClientIndexStore qualified as UserClientIndexStore -internalGetClientIdsImpl :: +internalGetClientIds :: ( Member BrigAPIAccess r, Member UserClientIndexStore r, Member (Input ConversationSubsystemConfig) r ) => [UserId] -> Sem r Clients -internalGetClientIdsImpl users = do +internalGetClientIds users = do isInternal <- inputs (.listClientsUsingBrig) if isInternal then fromUserClients <$> lookupClients users diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9a3d9270bc4..3137f2e90bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -19,60 +19,88 @@ module Wire.ConversationSubsystem.Interpreter ( interpretConversationSubsystem, + GroupInfoCheckEnabled (..), + IntraListing (..), + ConversationSubsystemError (..), ) where +import Data.Qualified +import Data.Tagged import Galley.Types.Error (InternalError, InvalidInput (..)) import Imports +import Network.Wai.Utilities.JSONResponse (JSONResponse) import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.Internal.Tactics (liftT) +import Polysemy.Resource (Resource) +import Polysemy.TinyLog (TinyLog) import Wire.API.Conversation.Config +import Wire.API.Conversation.Role qualified as ConvRole import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) +import Wire.API.Routes.API (ServerEffect (interpretServerEffect)) +import Wire.API.Team.Feature (LegalholdConfig) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults, FeatureFlags) import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BrigAPIAccess +import Wire.CodeStore (CodeStore) import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Notify qualified as ActionNotify +import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.CreateInternal qualified as CreateInternal +import Wire.ConversationSubsystem.Federation qualified as Federation import Wire.ConversationSubsystem.Fetch qualified as Fetch -import Wire.ConversationSubsystem.Internal qualified as Internal +import Wire.ConversationSubsystem.MLS qualified as MLS +import Wire.ConversationSubsystem.MLS.Enabled qualified as MLSEnabled +import Wire.ConversationSubsystem.MLS.GroupInfo qualified as MLSGroupInfo +import Wire.ConversationSubsystem.MLS.GroupInfoCheck (GroupInfoCheckEnabled (..)) +import Wire.ConversationSubsystem.MLS.Message qualified as MLSMessage +import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval +import Wire.ConversationSubsystem.MLS.Reset qualified as MLSReset +import Wire.ConversationSubsystem.MLS.SubConversation qualified as MLSSubConversation +import Wire.ConversationSubsystem.Message (IntraListing (..)) import Wire.ConversationSubsystem.Notify qualified as Notify +import Wire.ConversationSubsystem.One2One qualified as One2One +import Wire.ConversationSubsystem.Query qualified as Query +import Wire.ConversationSubsystem.Update qualified as Update import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem +import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist) import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationSubsystem (FederationSubsystem) +import Wire.FireAndForget (FireAndForget) +import Wire.HashPassword (HashPassword) import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem as NS +import Wire.Options.Galley (GuestLinkTTLSeconds) +import Wire.ProposalStore (ProposalStore) +import Wire.RateLimit (RateLimit) import Wire.Sem.Now (Now) import Wire.Sem.Random (Random) import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamSubsystem (TeamSubsystem) import Wire.UserClientIndexStore (UserClientIndexStore) +import Wire.UserGroupStore (UserGroupStore) interpretConversationSubsystem :: - ( Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'MLSNotEnabled) r, - Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r, - Member (ErrorS HistoryNotSupported) r, + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member UserGroupStore r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, + Member HashPassword r, + Member RateLimit r, + Member CodeStore r, + Member FireAndForget r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -84,29 +112,553 @@ interpretConversationSubsystem :: Member TeamCollaboratorsSubsystem r, Member Random r, Member TeamSubsystem r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member (Input ConversationSubsystemConfig) r, + Member (Input (Local ())) r, + Member (Input (Maybe GroupInfoCheckEnabled)) r, + Member ProposalStore r, Member LegalHoldStore r, + Member (Input ExposeInvitationURLsAllowlist) r, Member TeamStore r, - Member UserClientIndexStore r + Member ConvStore.MLSCommitLockStore r, + Member FederationSubsystem r, + Member Resource r, + Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member UserClientIndexStore r, + Member (Input FanoutLimit) r, + Member TinyLog r ) => Sem (ConversationSubsystem : r) a -> Sem r a -interpretConversationSubsystem = interpret $ \case +interpretConversationSubsystem = interpretH $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> - Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + liftT $ mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + InternalCreateGroupConversation lusr conn newConv -> + liftT $ mapErrors $ CreateInternal.createGroupConversationGeneric lusr conn newConv + CreateGroupConversationUpToV3 lusr conn newConv -> + liftT $ mapErrors $ Create.createGroupConversationUpToV3 lusr conn newConv + CreateGroupOwnConversation lusr conn newConv -> + liftT $ mapErrors $ Create.createGroupOwnConversation lusr conn newConv CreateGroupConversation lusr conn newConv -> - CreateInternal.createGroupConversationGeneric lusr conn newConv - CreateOne2OneConversation lusr conn newOne2One -> - CreateInternal.createOne2OneConversationLogic lusr conn newOne2One + liftT $ mapErrors $ Create.createGroupConversation lusr conn newConv CreateProteusSelfConversation lusr -> - CreateInternal.createProteusSelfConversationLogic lusr + liftT $ mapErrors $ Create.createProteusSelfConversation lusr + CreateOne2OneConversation lusr zcon j -> + liftT $ mapErrors $ Create.createOne2OneConversation lusr zcon j CreateConnectConversation lusr conn j -> - CreateInternal.createConnectConversationLogic lusr conn j + liftT $ mapErrors $ Create.createConnectConversation lusr conn j GetConversations convIds -> - ConvStore.getConversations convIds + liftT $ mapErrors $ ConvStore.getConversations convIds GetConversationIds lusr maxIds pagingState -> - Fetch.getConversationIdsImpl lusr maxIds pagingState - InternalGetClientIds uids -> - Internal.internalGetClientIdsImpl uids + liftT $ mapErrors $ Fetch.getConversationIdsImpl lusr maxIds pagingState InternalGetLocalMember cid uid -> - ConvStore.getLocalMember cid uid + liftT $ mapErrors $ ConvStore.getLocalMember cid uid + PostMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle -> + liftT $ mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle + PostMLSCommitBundleFromLocalUser v lusr c conn bundle -> + liftT $ mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle + PostMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg -> + liftT $ mapErrors $ MLSMessage.postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg + PostMLSMessageFromLocalUser v lusr c conn smsg -> + liftT $ mapErrors $ MLSMessage.postMLSMessageFromLocalUser v lusr c conn smsg + IsMLSEnabled -> + liftT $ mapErrors $ MLSEnabled.isMLSEnabled + IterateConversations luid pageSize handleConvs -> do + handleConvsT <- bindT handleConvs + ins <- getInitialStateT + void $ raise $ interpretConversationSubsystem $ Query.iterateConversations luid pageSize $ handleConvsT . ($>) ins + pureT () + RemoveMemberFromLocalConv lcnv lusr con victim -> + liftT $ mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim + FederationOnConversationCreated domain rc -> + liftT $ mapErrors $ Federation.onConversationCreated domain rc + FederationGetConversationsV1 domain req -> + liftT $ mapErrors $ Federation.getConversationsV1 domain req + FederationGetConversations domain req -> + liftT $ mapErrors $ Federation.getConversations domain req + FederationLeaveConversation domain lc -> + liftT $ mapErrors $ Federation.leaveConversation domain lc + FederationSendMessage domain msr -> + liftT $ mapErrors $ Federation.sendMessage domain msr + FederationUpdateConversation domain uc -> + liftT $ mapErrors $ Federation.updateConversation domain uc + FederationMlsSendWelcome domain req -> + liftT $ mapErrors $ Federation.mlsSendWelcome domain req + FederationSendMLSMessage domain msr -> + liftT $ mapErrors $ Federation.sendMLSMessage domain msr + FederationSendMLSCommitBundle domain msr -> + liftT $ mapErrors $ Federation.sendMLSCommitBundle domain msr + FederationQueryGroupInfo domain req -> + liftT $ mapErrors $ Federation.queryGroupInfo domain req + FederationUpdateTypingIndicator domain req -> + liftT $ mapErrors $ Federation.updateTypingIndicator domain req + FederationOnTypingIndicatorUpdated domain td -> + liftT $ mapErrors $ Federation.onTypingIndicatorUpdated domain td + FederationGetSubConversationForRemoteUser domain req -> + liftT $ mapErrors $ Federation.getSubConversationForRemoteUser domain req + FederationDeleteSubConversationForRemoteUser domain req -> + liftT $ mapErrors $ Federation.deleteSubConversationForRemoteUser domain req + FederationLeaveSubConversation domain lscr -> + liftT $ mapErrors $ Federation.leaveSubConversation domain lscr + FederationGetOne2OneConversationV1 domain req -> + liftT $ mapErrors $ Federation.getOne2OneConversationV1 domain req + FederationGetOne2OneConversation domain req -> + liftT $ mapErrors $ Federation.getOne2OneConversation domain req + FederationOnClientRemoved domain req -> + liftT $ mapErrors $ Federation.onClientRemoved domain req + FederationOnMessageSent domain rm -> + liftT $ mapErrors $ Federation.onMessageSent domain rm + FederationOnMLSMessageSent domain rmm -> + liftT $ mapErrors $ Federation.onMLSMessageSent domain rmm + FederationOnConversationUpdatedV0 domain cu -> + liftT $ mapErrors $ Federation.onConversationUpdatedV0 domain cu + FederationOnConversationUpdated domain cu -> + liftT $ mapErrors $ Federation.onConversationUpdated domain cu + FederationOnUserDeleted domain udcn -> + liftT $ mapErrors $ Federation.onUserDeleted domain udcn + PostOtrMessageUnqualified lusr con cnv ignore report msg -> + liftT $ mapErrors $ Update.postOtrMessageUnqualified lusr con cnv ignore report msg + PostOtrBroadcastUnqualified lusr con ignore report msg -> + liftT $ mapErrors $ Update.postOtrBroadcastUnqualified lusr con ignore report msg + PostProteusMessage lusr con cnv msg -> + liftT $ mapErrors $ Update.postProteusMessage lusr con cnv msg + PostProteusBroadcast lusr con msg -> + liftT $ mapErrors $ Update.postProteusBroadcast lusr con msg + DeleteLocalConversation lusr con lcnv -> + liftT $ mapErrors $ Update.deleteLocalConversation lusr con lcnv + GetMLSPublicKeys fmt -> + liftT $ mapErrors $ MLS.getMLSPublicKeys fmt + ResetMLSConversation lusr reset -> + liftT $ mapErrors $ MLSReset.resetMLSConversation lusr reset + GetSubConversation lusr cnv sub -> + liftT $ mapErrors $ MLSSubConversation.getSubConversation lusr cnv sub + GetBotConversation bid cnv -> + liftT $ mapErrors $ Query.getBotConversation bid cnv + GetUnqualifiedOwnConversation lusr cnv -> + liftT $ mapErrors $ Query.getUnqualifiedOwnConversation lusr cnv + GetOwnConversation lusr qcnv -> + liftT $ mapErrors $ Query.getOwnConversation lusr qcnv + GetConversation lusr qcnv -> + liftT $ mapErrors $ Query.getConversation lusr qcnv + InternalGetConversation cnv -> + liftT $ mapErrors $ ConvStore.getConversation cnv + GetConversationRoles lusr cnv -> + liftT $ mapErrors $ Query.getConversationRoles lusr cnv + GetGroupInfo lusr qcnv -> + liftT $ mapErrors $ MLSGroupInfo.getGroupInfo lusr qcnv + ConversationIdsPageFromUnqualified lusr mstart msize -> + liftT $ mapErrors $ Query.conversationIdsPageFromUnqualified lusr mstart msize + ConversationIdsPageFromV2 listGlobalSelf lself req -> + liftT $ mapErrors $ Query.conversationIdsPageFromV2 listGlobalSelf lself req + ConversationIdsPageFrom lusr req -> + liftT $ mapErrors $ Query.conversationIdsPageFrom lusr req + ListConversations luser req -> + liftT $ mapErrors $ Query.listConversations luser req + GetConversationByReusableCode lusr key value -> + liftT $ mapErrors $ Query.getConversationByReusableCode lusr key value + GetMLSSelfConversationWithError lusr -> + liftT $ mapErrors $ Query.getMLSSelfConversationWithError lusr + GetMLSOne2OneConversationV5 lself qother -> + liftT $ mapErrors $ Query.getMLSOne2OneConversationV5 lself qother + GetMLSOne2OneConversationV6 lself qother -> + liftT $ mapErrors $ Query.getMLSOne2OneConversationV6 lself qother + GetMLSOne2OneConversation lself qother fmt -> + liftT $ mapErrors $ Query.getMLSOne2OneConversation lself qother fmt + GetLocalSelf lusr cnv -> + liftT $ mapErrors $ Query.getLocalSelf lusr cnv + GetSelfMember lusr qcnv -> + liftT $ mapErrors $ Query.getSelfMember lusr qcnv + GetConversationGuestLinksStatus uid cid -> + liftT $ mapErrors $ Query.getConversationGuestLinksStatus uid cid + GetCode mcode lusr cnv -> + liftT $ mapErrors $ Update.getCode mcode lusr cnv + AddMembersUnqualified lusr con cnv invite -> + liftT $ mapErrors $ Update.addMembersUnqualified lusr con cnv invite + AddMembersUnqualifiedV2 lusr con cnv invite -> + liftT $ mapErrors $ Update.addMembersUnqualifiedV2 lusr con cnv invite + AddMembers lusr zcon qcnv invite -> + liftT $ mapErrors $ Update.addMembers lusr zcon qcnv invite + ReplaceMembers lusr zcon qcnv invite -> + liftT $ mapErrors $ Update.replaceMembers lusr zcon qcnv invite + JoinConversationById lusr con cnv -> + liftT $ mapErrors $ Update.joinConversationById lusr con cnv + JoinConversationByReusableCode lusr con req -> + liftT $ mapErrors $ Update.joinConversationByReusableCode lusr con req + CheckReusableCode addr code -> + liftT $ mapErrors $ Update.checkReusableCode addr code + AddCodeUnqualified mReq usr mbZHost mZcon cnv -> + liftT $ mapErrors $ Update.addCodeUnqualified mReq usr mbZHost mZcon cnv + AddCodeUnqualifiedWithReqBody lusr mname mconn cnv req -> + liftT $ mapErrors $ Update.addCodeUnqualifiedWithReqBody lusr mname mconn cnv req + RmCodeUnqualified lusr con cnv -> + liftT $ mapErrors $ Update.rmCodeUnqualified lusr con cnv + MemberTypingUnqualified lusr con cnv status -> + liftT $ mapErrors $ Update.memberTypingUnqualified lusr con cnv status + MemberTyping lusr con qcnv status -> + liftT $ mapErrors $ Update.memberTyping lusr con qcnv status + RemoveMemberUnqualified lusr con cnv uid -> + liftT $ mapErrors $ Update.removeMemberUnqualified lusr con cnv uid + RemoveMemberQualified lusr con qcnv quid -> + liftT $ mapErrors $ Update.removeMemberQualified lusr con qcnv quid + UpdateOtherMemberUnqualified lusr con cnv uid update -> + liftT $ mapErrors $ Update.updateOtherMemberUnqualified lusr con cnv uid update + UpdateOtherMember lusr con qcnv quid update -> + liftT $ mapErrors $ Update.updateOtherMember lusr con qcnv quid update + UpdateUnqualifiedConversationName lusr con cnv rename -> + liftT $ mapErrors $ Update.updateUnqualifiedConversationName lusr con cnv rename + UpdateConversationName lusr zcon qcnv rename -> + liftT $ mapErrors $ Update.updateConversationName lusr zcon qcnv rename + UpdateConversationMessageTimerUnqualified lusr con cnv update -> + liftT $ mapErrors $ Update.updateConversationMessageTimerUnqualified lusr con cnv update + UpdateConversationMessageTimer lusr zcon qcnv update -> + liftT $ mapErrors $ Update.updateConversationMessageTimer lusr zcon qcnv update + UpdateConversationReceiptModeUnqualified lusr con cnv update -> + liftT $ mapErrors $ Update.updateConversationReceiptModeUnqualified lusr con cnv update + UpdateConversationReceiptMode lusr zcon qcnv update -> + liftT $ mapErrors $ Update.updateConversationReceiptMode lusr zcon qcnv update + UpdateConversationAccessUnqualified lusr con cnv update -> + liftT $ mapErrors $ Update.updateConversationAccessUnqualified lusr con cnv update + UpdateConversationAccess lusr zcon qcnv update -> + liftT $ mapErrors $ Update.updateConversationAccess lusr zcon qcnv update + UpdateConversationHistory lusr zcon qcnv update -> + liftT $ mapErrors $ Update.updateConversationHistory lusr zcon qcnv update + UpdateUnqualifiedSelfMember lusr con cnv update -> + liftT $ mapErrors $ Update.updateUnqualifiedSelfMember lusr con cnv update + UpdateSelfMember lusr zcon qcnv update -> + liftT $ mapErrors $ Update.updateSelfMember lusr zcon qcnv update + UpdateConversationProtocolWithLocalUser lusr conn qcnv update -> + liftT $ mapErrors $ Update.updateConversationProtocolWithLocalUser lusr conn qcnv update + UpdateChannelAddPermission lusr conn qcnv update -> + liftT $ mapErrors $ Update.updateChannelAddPermission lusr conn qcnv update + PostBotMessageUnqualified bid cnv ignore report msg -> + liftT $ mapErrors $ Update.postBotMessageUnqualified bid cnv ignore report msg + DeleteSubConversation lusr qcnv sub reset -> + liftT $ mapErrors $ MLSSubConversation.deleteSubConversation lusr qcnv sub reset + GetSubConversationGroupInfo lusr qcnv sub -> + liftT $ mapErrors $ MLSSubConversation.getSubConversationGroupInfo lusr qcnv sub + LeaveSubConversation lusr cli qcnv sub -> + liftT $ mapErrors $ MLSSubConversation.leaveSubConversation lusr cli qcnv sub + SendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData -> + liftT $ mapErrors $ ActionNotify.sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData + GetPaginatedConversations lusr mids mstart msize -> + liftT $ mapErrors $ Query.getConversations lusr mids mstart msize + SearchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable -> + liftT $ mapErrors $ Query.searchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable + InternalGetMember qcnv usr -> + liftT $ mapErrors $ Query.internalGetMember qcnv usr + GetConversationMeta cnv -> + liftT $ mapErrors $ Query.getConversationMeta cnv + GetMLSOne2OneConversationInternal lself qother -> + liftT $ mapErrors $ Query.getMLSOne2OneConversationInternal lself qother + IsMLSOne2OneEstablished lself qother -> + liftT $ mapErrors $ Query.isMLSOne2OneEstablished lself qother + GetLocalConversationInternal cid -> + liftT $ mapErrors $ Query.getLocalConversationInternal cid + RemoveClient lc qusr c -> + liftT $ mapErrors $ MLSRemoval.removeClient lc qusr c + AddBot lusr zcon b -> + liftT $ mapErrors $ Update.addBot lusr zcon b + RmBot lusr zcon b -> + liftT $ mapErrors $ Update.rmBot lusr zcon b + UpdateCellsState cnv state -> + liftT $ mapErrors $ Update.updateCellsState cnv state + RemoveUser lc includeMain qusr -> + liftT $ mapErrors $ MLSRemoval.removeUser lc includeMain qusr + InternalUpsertOne2OneConversation req -> + liftT $ mapErrors $ One2One.internalUpsertOne2OneConversation req + AcceptConv lusr conn cnv -> + liftT $ mapErrors $ Update.acceptConv lusr conn cnv + BlockConv lusr qcnv -> + liftT $ mapErrors $ Update.blockConv lusr qcnv + UnblockConv lusr conn qcnv -> + liftT $ mapErrors $ Update.unblockConv lusr conn qcnv + +data ConversationSubsystemError + = ConversationSubsystemErrorConvAccessDenied + | ConversationSubsystemErrorNotATeamMember + | ConversationSubsystemErrorperationDenied + | ConversationSubsystemErrorNotConnected + | ConversationSubsystemErrorMLSNotEnabled + | ConversationSubsystemErrorMLSNonEmptyMemberList + | ConversationSubsystemErrorMissingLegalholdConsent + | ConversationSubsystemErrorNonBindingTeam + | ConversationSubsystemErrorNoBindingTeamMembers + | ConversationSubsystemErrorTeamNotFound + | ConversationSubsystemErrorInvalidOperation + | ConversationSubsystemErrorConvNotFound + | ConversationSubsystemErrorChannelsNotEnabled + | ConversationSubsystemErrorNotAnMlsConversation + | ConversationSubsystemErrorMLSLegalholdIncompatible + | ConversationSubsystemErrorMLSIdentityMismatch + | ConversationSubsystemErrorMLSUnsupportedMessage + | ConversationSubsystemErrorMLSStaleMessage + | ConversationSubsystemErrorMLSProposalNotFound + | ConversationSubsystemErrorMLSCommitMissingReferences + | ConversationSubsystemErrorMLSSelfRemovalNotAllowed + | ConversationSubsystemErrorMLSClientSenderUserMismatch + | ConversationSubsystemErrorMLSSubConvClientNotInParent + | ConversationSubsystemErrorMLSInvalidLeafNodeSignature + | ConversationSubsystemErrorMLSClientMismatch + | ConversationSubsystemErrorMLSInvalidLeafNodeIndex + | ConversationSubsystemErrorMLSUnsupportedProposal + | ConversationSubsystemErrorGroupIdVersionNotSupported + | ConversationSubsystemErrorConvMemberNotFound + | ConversationSubsystemErrorHistoryNotSupported + | ConversationSubsystemErrorLSGroupConversationMismatch + | ConversationSubsystemErrorActionDeniedLeaveConversation + | ConversationSubsystemErrorActionDeniedRemoveConversationMember + | ConversationSubsystemErrorActionDeniedDeleteConversation + | ConversationSubsystemErrorBroadcastLimitExceeded + | ConversationSubsystemErrorMLSFederatedResetNotSupported + | ConversationSubsystemErrorMLSSubConvUnsupportedConvType + | ConversationSubsystemErrorTeamMemberNotFound + | ConversationSubsystemErrorAccessDenied + | ConversationSubsystemErrorMLSMissingGroupInfo + | ConversationSubsystemErrorCodeNotFound + | ConversationSubsystemErrorInvalidConversationPassword + | ConversationSubsystemErrorGuestLinksDisabled + | ConversationSubsystemErrorMLSFederatedOne2OneNotSupported + | ConversationSubsystemErrorTooManyMembers + | ConversationSubsystemErrorCreateConversationCodeConflict + | ConversationSubsystemErrorInvalidTarget + | ConversationSubsystemErrorMLSReadReceiptsNotAllowed + | ConversationSubsystemErrorInvalidTargetAccess + | ConversationSubsystemErrorConvInvalidProtocolTransition + | ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied + | ConversationSubsystemErrorActionDeniedAddConversationMember + | ConversationSubsystemErrorActionDeniedModifyOtherConversationMember + | ConversationSubsystemErrorActionDeniedModifyConversationName + | ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer + | ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode + | ConversationSubsystemErrorActionDeniedModifyConversationAccess + | ConversationSubsystemErrorActionDeniedModifyAddPermission + | ConversationSubsystemErrorFederationError FederationError + | ConversationSubsystemErrorUnreachableBackends UnreachableBackends + | ConversationSubsystemErrorInternalError InternalError + | ConversationSubsystemErrorInvalidInput InvalidInput + | ConversationSubsystemErrorMLSProtocolError MLSProtocolError + | ConversationSubsystemErrorGroupInfoDiagnostics GroupInfoDiagnostics + | ConversationSubsystemErrorMLSOutOfSyncError MLSOutOfSyncError + | ConversationSubsystemErrorNonFederatingBackends NonFederatingBackends + | ConversationSubsystemErrorUnreachableBackendsLegacy UnreachableBackendsLegacy + +instance APIError ConversationSubsystemError where + toResponse = + \case + ConversationSubsystemErrorConvAccessDenied -> toResponse $ Tagged @'ConvAccessDenied () + ConversationSubsystemErrorNotATeamMember -> toResponse $ Tagged @'NotATeamMember () + ConversationSubsystemErrorperationDenied -> toResponse $ Tagged @OperationDenied () + ConversationSubsystemErrorNotConnected -> toResponse $ Tagged @'NotConnected () + ConversationSubsystemErrorMLSNotEnabled -> toResponse $ Tagged @'MLSNotEnabled () + ConversationSubsystemErrorMLSNonEmptyMemberList -> toResponse $ Tagged @'MLSNonEmptyMemberList () + ConversationSubsystemErrorMissingLegalholdConsent -> toResponse $ Tagged @'MissingLegalholdConsent () + ConversationSubsystemErrorNonBindingTeam -> toResponse $ Tagged @'NonBindingTeam () + ConversationSubsystemErrorNoBindingTeamMembers -> toResponse $ Tagged @'NoBindingTeamMembers () + ConversationSubsystemErrorTeamNotFound -> toResponse $ Tagged @'TeamNotFound () + ConversationSubsystemErrorInvalidOperation -> toResponse $ Tagged @'InvalidOperation () + ConversationSubsystemErrorConvNotFound -> toResponse $ Tagged @'ConvNotFound () + ConversationSubsystemErrorChannelsNotEnabled -> toResponse $ Tagged @'ChannelsNotEnabled () + ConversationSubsystemErrorNotAnMlsConversation -> toResponse $ Tagged @'NotAnMlsConversation () + ConversationSubsystemErrorMLSLegalholdIncompatible -> toResponse $ Tagged @'MLSLegalholdIncompatible () + ConversationSubsystemErrorMLSIdentityMismatch -> toResponse $ Tagged @'MLSIdentityMismatch () + ConversationSubsystemErrorMLSUnsupportedMessage -> toResponse $ Tagged @'MLSUnsupportedMessage () + ConversationSubsystemErrorMLSStaleMessage -> toResponse $ Tagged @'MLSStaleMessage () + ConversationSubsystemErrorMLSProposalNotFound -> toResponse $ Tagged @'MLSProposalNotFound () + ConversationSubsystemErrorMLSCommitMissingReferences -> toResponse $ Tagged @'MLSCommitMissingReferences () + ConversationSubsystemErrorMLSSelfRemovalNotAllowed -> toResponse $ Tagged @'MLSSelfRemovalNotAllowed () + ConversationSubsystemErrorMLSClientSenderUserMismatch -> toResponse $ Tagged @'MLSClientSenderUserMismatch () + ConversationSubsystemErrorMLSSubConvClientNotInParent -> toResponse $ Tagged @'MLSSubConvClientNotInParent () + ConversationSubsystemErrorMLSInvalidLeafNodeSignature -> toResponse $ Tagged @'MLSInvalidLeafNodeSignature () + ConversationSubsystemErrorMLSClientMismatch -> toResponse $ Tagged @'MLSClientMismatch () + ConversationSubsystemErrorMLSInvalidLeafNodeIndex -> toResponse $ Tagged @'MLSInvalidLeafNodeIndex () + ConversationSubsystemErrorMLSUnsupportedProposal -> toResponse $ Tagged @'MLSUnsupportedProposal () + ConversationSubsystemErrorGroupIdVersionNotSupported -> toResponse $ Tagged @'GroupIdVersionNotSupported () + ConversationSubsystemErrorConvMemberNotFound -> toResponse $ Tagged @'ConvMemberNotFound () + ConversationSubsystemErrorHistoryNotSupported -> toResponse $ Tagged @'HistoryNotSupported () + ConversationSubsystemErrorLSGroupConversationMismatch -> toResponse $ Tagged @MLSGroupConversationMismatch () + ConversationSubsystemErrorActionDeniedLeaveConversation -> toResponse $ Tagged @('ActionDenied ConvRole.LeaveConversation) () + ConversationSubsystemErrorActionDeniedRemoveConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.RemoveConversationMember) () + ConversationSubsystemErrorActionDeniedDeleteConversation -> toResponse $ Tagged @('ActionDenied ConvRole.DeleteConversation) () + ConversationSubsystemErrorBroadcastLimitExceeded -> toResponse $ Tagged @'BroadcastLimitExceeded () + ConversationSubsystemErrorMLSFederatedResetNotSupported -> toResponse $ Tagged @'MLSFederatedResetNotSupported () + ConversationSubsystemErrorMLSSubConvUnsupportedConvType -> toResponse $ Tagged @'MLSSubConvUnsupportedConvType () + ConversationSubsystemErrorTeamMemberNotFound -> toResponse $ Tagged @'TeamMemberNotFound () + ConversationSubsystemErrorAccessDenied -> toResponse $ Tagged @'AccessDenied () + ConversationSubsystemErrorMLSMissingGroupInfo -> toResponse $ Tagged @'MLSMissingGroupInfo () + ConversationSubsystemErrorCodeNotFound -> toResponse $ Tagged @'CodeNotFound () + ConversationSubsystemErrorInvalidConversationPassword -> toResponse $ Tagged @'InvalidConversationPassword () + ConversationSubsystemErrorGuestLinksDisabled -> toResponse $ Tagged @'GuestLinksDisabled () + ConversationSubsystemErrorMLSFederatedOne2OneNotSupported -> toResponse $ Tagged @'MLSFederatedOne2OneNotSupported () + ConversationSubsystemErrorTooManyMembers -> toResponse $ Tagged @'TooManyMembers () + ConversationSubsystemErrorCreateConversationCodeConflict -> toResponse $ Tagged @'CreateConversationCodeConflict () + ConversationSubsystemErrorInvalidTarget -> toResponse $ Tagged @'InvalidTarget () + ConversationSubsystemErrorMLSReadReceiptsNotAllowed -> toResponse $ Tagged @'MLSReadReceiptsNotAllowed () + ConversationSubsystemErrorInvalidTargetAccess -> toResponse $ Tagged @'InvalidTargetAccess () + ConversationSubsystemErrorConvInvalidProtocolTransition -> toResponse $ Tagged @'ConvInvalidProtocolTransition () + ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied -> toResponse $ Tagged @'MLSMigrationCriteriaNotSatisfied () + ConversationSubsystemErrorActionDeniedAddConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.AddConversationMember) () + ConversationSubsystemErrorActionDeniedModifyOtherConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyOtherConversationMember) () + ConversationSubsystemErrorActionDeniedModifyConversationName -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationName) () + ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationMessageTimer) () + ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationReceiptMode) () + ConversationSubsystemErrorActionDeniedModifyConversationAccess -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationAccess) () + ConversationSubsystemErrorActionDeniedModifyAddPermission -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyAddPermission) () + ConversationSubsystemErrorFederationError x -> toResponse x + ConversationSubsystemErrorUnreachableBackends x -> toResponse x + ConversationSubsystemErrorInternalError x -> toResponse x + ConversationSubsystemErrorInvalidInput x -> toResponse x + ConversationSubsystemErrorMLSProtocolError x -> toResponse $ (dynError @(MapError 'MLSProtocolErrorTag)) {eMessage = unTagged x} + ConversationSubsystemErrorGroupInfoDiagnostics x -> toResponse x + ConversationSubsystemErrorMLSOutOfSyncError x -> toResponse x + ConversationSubsystemErrorNonFederatingBackends x -> toResponse x + ConversationSubsystemErrorUnreachableBackendsLegacy x -> toResponse x + +type ConversationSubsystemErrorEffects = + '[ ErrorS 'ConvAccessDenied, + ErrorS 'NotATeamMember, + ErrorS OperationDenied, + ErrorS 'NotConnected, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSNonEmptyMemberList, + ErrorS 'MissingLegalholdConsent, + ErrorS 'NonBindingTeam, + ErrorS 'NoBindingTeamMembers, + ErrorS 'TeamNotFound, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ChannelsNotEnabled, + ErrorS 'NotAnMlsConversation, + ErrorS 'MLSLegalholdIncompatible, + ErrorS 'MLSIdentityMismatch, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MLSCommitMissingReferences, + ErrorS 'MLSSelfRemovalNotAllowed, + ErrorS 'MLSClientSenderUserMismatch, + ErrorS 'MLSSubConvClientNotInParent, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSClientMismatch, + ErrorS 'MLSInvalidLeafNodeIndex, + ErrorS 'MLSUnsupportedProposal, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'ConvMemberNotFound, + ErrorS 'HistoryNotSupported, + ErrorS MLSGroupConversationMismatch, + ErrorS ('ActionDenied ConvRole.LeaveConversation), + ErrorS ('ActionDenied ConvRole.RemoveConversationMember), + ErrorS ('ActionDenied ConvRole.DeleteConversation), + ErrorS 'BroadcastLimitExceeded, + ErrorS 'MLSFederatedResetNotSupported, + ErrorS 'MLSSubConvUnsupportedConvType, + ErrorS 'TeamMemberNotFound, + ErrorS 'AccessDenied, + ErrorS 'MLSMissingGroupInfo, + ErrorS 'CodeNotFound, + ErrorS 'InvalidConversationPassword, + ErrorS 'GuestLinksDisabled, + ErrorS 'MLSFederatedOne2OneNotSupported, + ErrorS 'TooManyMembers, + ErrorS 'CreateConversationCodeConflict, + ErrorS 'InvalidTarget, + ErrorS 'MLSReadReceiptsNotAllowed, + ErrorS 'InvalidTargetAccess, + ErrorS 'ConvInvalidProtocolTransition, + ErrorS 'MLSMigrationCriteriaNotSatisfied, + ErrorS ('ActionDenied ConvRole.AddConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyOtherConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyConversationName), + ErrorS ('ActionDenied ConvRole.ModifyConversationMessageTimer), + ErrorS ('ActionDenied ConvRole.ModifyConversationReceiptMode), + ErrorS ('ActionDenied ConvRole.ModifyConversationAccess), + ErrorS ('ActionDenied ConvRole.ModifyAddPermission), + Error FederationError, + Error UnreachableBackends, + Error InternalError, + Error InvalidInput, + Error AuthenticationError, + Error MLSProtocolError, + Error GroupInfoDiagnostics, + Error MLSOutOfSyncError, + Error MLSProposalFailure, + Error NonFederatingBackends, + Error UnreachableBackendsLegacy + ] + +mapErrors :: + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r + ) => + InterpretersFor ConversationSubsystemErrorEffects r +mapErrors = + mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) + . mapError (ConversationSubsystemErrorNonFederatingBackends) + . interpretServerEffect + . mapError (ConversationSubsystemErrorMLSOutOfSyncError) + . mapError (ConversationSubsystemErrorGroupInfoDiagnostics) + . mapError (ConversationSubsystemErrorMLSProtocolError) + . interpretServerEffect + . mapError (ConversationSubsystemErrorInvalidInput) + . mapError (ConversationSubsystemErrorInternalError) + . mapError (ConversationSubsystemErrorUnreachableBackends) + . mapError (ConversationSubsystemErrorFederationError) + . mapError (const ConversationSubsystemErrorActionDeniedModifyAddPermission) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationAccess) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationName) + . mapError (const ConversationSubsystemErrorActionDeniedModifyOtherConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedAddConversationMember) + . mapError (const ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied) + . mapError (const ConversationSubsystemErrorConvInvalidProtocolTransition) + . mapError (const ConversationSubsystemErrorInvalidTargetAccess) + . mapError (const ConversationSubsystemErrorMLSReadReceiptsNotAllowed) + . mapError (const ConversationSubsystemErrorInvalidTarget) + . mapError (const ConversationSubsystemErrorCreateConversationCodeConflict) + . mapError (const ConversationSubsystemErrorTooManyMembers) + . mapError (const ConversationSubsystemErrorMLSFederatedOne2OneNotSupported) + . mapError (const ConversationSubsystemErrorGuestLinksDisabled) + . mapError (const ConversationSubsystemErrorInvalidConversationPassword) + . mapError (const ConversationSubsystemErrorCodeNotFound) + . mapError (const ConversationSubsystemErrorMLSMissingGroupInfo) + . mapError (const ConversationSubsystemErrorAccessDenied) + . mapError (const ConversationSubsystemErrorTeamMemberNotFound) + . mapError (const ConversationSubsystemErrorMLSSubConvUnsupportedConvType) + . mapError (const ConversationSubsystemErrorMLSFederatedResetNotSupported) + . mapError (const ConversationSubsystemErrorBroadcastLimitExceeded) + . mapError (const ConversationSubsystemErrorActionDeniedDeleteConversation) + . mapError (const ConversationSubsystemErrorActionDeniedRemoveConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedLeaveConversation) + . mapError (const ConversationSubsystemErrorLSGroupConversationMismatch) + . mapError (const ConversationSubsystemErrorHistoryNotSupported) + . mapError (const ConversationSubsystemErrorConvMemberNotFound) + . mapError (const ConversationSubsystemErrorGroupIdVersionNotSupported) + . mapError (const ConversationSubsystemErrorMLSUnsupportedProposal) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeIndex) + . mapError (const ConversationSubsystemErrorMLSClientMismatch) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeSignature) + . mapError (const ConversationSubsystemErrorMLSSubConvClientNotInParent) + . mapError (const ConversationSubsystemErrorMLSClientSenderUserMismatch) + . mapError (const ConversationSubsystemErrorMLSSelfRemovalNotAllowed) + . mapError (const ConversationSubsystemErrorMLSCommitMissingReferences) + . mapError (const ConversationSubsystemErrorMLSProposalNotFound) + . mapError (const ConversationSubsystemErrorMLSStaleMessage) + . mapError (const ConversationSubsystemErrorMLSUnsupportedMessage) + . mapError (const ConversationSubsystemErrorMLSIdentityMismatch) + . mapError (const ConversationSubsystemErrorMLSLegalholdIncompatible) + . mapError (const ConversationSubsystemErrorNotAnMlsConversation) + . mapError (const ConversationSubsystemErrorChannelsNotEnabled) + . mapError (const ConversationSubsystemErrorConvNotFound) + . mapError (const ConversationSubsystemErrorInvalidOperation) + . mapError (const ConversationSubsystemErrorTeamNotFound) + . mapError (const ConversationSubsystemErrorNoBindingTeamMembers) + . mapError (const ConversationSubsystemErrorNonBindingTeam) + . mapError (const ConversationSubsystemErrorMissingLegalholdConsent) + . mapError (const ConversationSubsystemErrorMLSNonEmptyMemberList) + . mapError (const ConversationSubsystemErrorMLSNotEnabled) + . mapError (const ConversationSubsystemErrorNotConnected) + . mapError (const ConversationSubsystemErrorperationDenied) + . mapError (const ConversationSubsystemErrorNotATeamMember) + . mapError (const ConversationSubsystemErrorConvAccessDenied) diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs similarity index 96% rename from services/galley/src/Galley/API/LegalHold/Conflicts.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs index 23adf1c22bb..0c45f09b645 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.LegalHold.Conflicts +module Wire.ConversationSubsystem.LegalholdConflicts ( guardQualifiedLegalholdPolicyConflicts, guardLegalholdPolicyConflicts, LegalholdConflicts (LegalholdConflicts), @@ -46,7 +46,6 @@ import Wire.API.Team.Member import Wire.API.User import Wire.API.User.Client as Client import Wire.BrigAPIAccess -import Wire.Options.Galley import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.Util @@ -59,7 +58,7 @@ guardQualifiedLegalholdPolicyConflicts :: ( Member BrigAPIAccess r, Member (Error LegalholdConflicts) r, Member (Input (Local ())) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => @@ -83,7 +82,7 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do guardLegalholdPolicyConflicts :: ( Member BrigAPIAccess r, Member (Error LegalholdConflicts) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => @@ -94,7 +93,7 @@ guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClient guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do opts <- input - case view (settings . featureFlags . to npProject) opts of + case view (to npProject) opts of FeatureLegalHoldDisabledPermanently -> case FutureWork @'LegalholdPlusFederationNotImplemented () of FutureWork () -> -- FUTUREWORK: once we support federation and LH in combination, we still need to run @@ -107,7 +106,7 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do -- | Guard notification handling against legal-hold policy conflicts. -- Ensures that if any user has a LH client then no user can be missing consent. -- See also: "Brig.API.Connection.checkLegalholdPolicyConflict" --- and "Galley.API.Action.checkLHPolicyConflictsLocal". +-- and "Wire.ConversationSubsystem.Action.checkLHPolicyConflictsLocal". guardLegalholdPolicyConflictsUid :: forall r. ( Member BrigAPIAccess r, diff --git a/services/galley/src/Galley/API/MLS.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs similarity index 88% rename from services/galley/src/Galley/API/MLS.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs index 8da6d00620c..a8fedb7fd5d 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs @@ -15,28 +15,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS - ( isMLSEnabled, - assertMLSEnabled, - postMLSMessage, - postMLSCommitBundleFromLocalUser, - postMLSMessageFromLocalUser, - getMLSPublicKeys, +module Wire.ConversationSubsystem.MLS + ( getMLSPublicKeys, formatPublicKeys, ) where import Data.Default -import Galley.API.MLS.Enabled -import Galley.API.MLS.Message import Galley.Types.Error import Imports import Polysemy import Polysemy.Error import Polysemy.Input -import Wire.API.Error +import Wire.API.Error (ErrorS) import Wire.API.Error.Galley import Wire.API.MLS.Keys +import Wire.ConversationSubsystem.MLS.Enabled (getMLSPrivateKeys) getMLSPublicKeys :: ( Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, diff --git a/services/galley/src/Galley/API/MLS/CheckClients.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/CheckClients.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs index 22ff3de4813..388d6a16422 100644 --- a/services/galley/src/Galley/API/MLS/CheckClients.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.CheckClients +module Wire.ConversationSubsystem.MLS.CheckClients ( checkClients, getClientData, ClientData (..), @@ -29,7 +29,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra -import Galley.API.MLS.Commit.Core import Imports import Polysemy import Polysemy.Error @@ -43,6 +42,7 @@ import Wire.API.MLS.LeafNode import Wire.API.User.Client import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Commit.Core import Wire.FederationAPIAccess (FederationAPIAccess) checkClients :: diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Commit/Core.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs index 0318881e606..a51f0adcbcd 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.Core +module Wire.ConversationSubsystem.MLS.Commit.Core ( getCommitData, incrementEpoch, getClientInfo, @@ -31,9 +31,6 @@ where import Control.Comonad import Data.Id import Data.Qualified -import Galley.API.MLS.Conversation -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.Proposal import Galley.Types.Error import Imports import Polysemy @@ -66,6 +63,9 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Proposal import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.LegalHoldStore (LegalHoldStore) diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs index 9aec3fa0ea1..10fa4e6bd58 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.ExternalCommit +module Wire.ConversationSubsystem.MLS.Commit.ExternalCommit ( ExternalCommitAction (..), getExternalCommitData, processExternalCommit, @@ -28,11 +28,6 @@ import Control.Monad.Codensity import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.Commit.Core -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.Proposal -import Galley.API.MLS.Removal -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -51,6 +46,11 @@ import Wire.API.MLS.ProposalTag import Wire.API.MLS.SubConversation import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Commit.Core +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Removal +import Wire.ConversationSubsystem.MLS.Util data ExternalCommitAction = ExternalCommitAction { add :: LeafIndex, diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs index 53c51cfa62a..8abc46eefb0 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.InternalCommit (processInternalCommit) where +module Wire.ConversationSubsystem.MLS.Commit.InternalCommit (processInternalCommit) where import Control.Comonad import Control.Error.Util (hush) @@ -29,14 +29,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra -import Galley.API.Action -import Galley.API.MLS.CheckClients -import Galley.API.MLS.Commit.Core -import Galley.API.MLS.Conversation -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.One2One -import Galley.API.MLS.Proposal -import Galley.API.MLS.Util import Galley.Types.Error import Imports import Polysemy @@ -60,7 +52,14 @@ import Wire.API.MLS.SubConversation import Wire.API.Unreachable import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.CheckClients +import Wire.ConversationSubsystem.MLS.Commit.Core +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.FederationSubsystem import Wire.ProposalStore @@ -78,7 +77,6 @@ processInternalCommit :: Member (ErrorS 'MLSIdentityMismatch) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'GroupIdVersionNotSupported) r, - Member ConversationSubsystem r, Member Resource r, Member Random r, Member (ErrorS MLSInvalidLeafNodeSignature) r, @@ -258,7 +256,6 @@ processInternalCommit senderIdentity con lConvOrSub ciphersuite ciphersuiteUpdat addMembers :: ( HasProposalActionEffects r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r ) => @@ -286,7 +283,6 @@ addMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of removeMembers :: ( HasProposalActionEffects r, - Member ConversationSubsystem r, Member TeamSubsystem r ) => Qualified UserId -> diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/Conversation.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs index 0b979880816..b129d31c00e 100644 --- a/services/galley/src/Galley/API/MLS/Conversation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Conversation +module Wire.ConversationSubsystem.MLS.Conversation ( mkMLSConversation, newMLSConversation, mcConv, diff --git a/services/galley/src/Galley/API/MLS/Enabled.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/Enabled.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs index 158d511e291..1910f5945fb 100644 --- a/services/galley/src/Galley/API/MLS/Enabled.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Enabled where +module Wire.ConversationSubsystem.MLS.Enabled where import Imports hiding (getFirst) import Polysemy @@ -25,7 +25,7 @@ import Wire.API.Error.Galley import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) isMLSEnabled :: (Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r) => Sem r Bool -isMLSEnabled = inputs (isJust) +isMLSEnabled = inputs isJust -- | Fail if MLS is not enabled. Only use this function at the beginning of an -- MLS endpoint, NOT in utility functions. diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/GroupInfo.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs index 69f667cab77..f52928307d2 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.GroupInfo +module Wire.ConversationSubsystem.MLS.GroupInfo ( MLSGroupInfoStaticErrors, getGroupInfo, getGroupInfoFromLocalConv, @@ -26,8 +26,6 @@ where import Data.Id as Id import Data.Json.Util import Data.Qualified -import Galley.API.MLS.Enabled -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -42,6 +40,8 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.MLS.SubConversation import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.FederationAPIAccess qualified as E diff --git a/services/galley/src/Galley/API/MLS/GroupInfoCheck.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/GroupInfoCheck.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs index 667a29dc3fe..d3bdabf3e3b 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfoCheck.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.GroupInfoCheck +module Wire.ConversationSubsystem.MLS.GroupInfoCheck ( checkGroupState, GroupInfoMismatch (..), GroupInfoCheckEnabled (..), @@ -24,7 +24,6 @@ where import Data.Bifunctor import Data.Id -import Galley.API.Teams.Features.Get import Imports import Polysemy import Polysemy.Error @@ -43,7 +42,7 @@ import Wire.API.MLS.Serialisation import Wire.API.Team.Feature import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) data GroupInfoMismatch = GroupInfoMismatch {clients :: [(Int, ClientIdentity)]} diff --git a/services/galley/src/Galley/API/MLS/IncomingMessage.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/IncomingMessage.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs index 3a3fba62514..b88c90fbf7d 100644 --- a/services/galley/src/Galley/API/MLS/IncomingMessage.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.IncomingMessage +module Wire.ConversationSubsystem.MLS.IncomingMessage ( IncomingMessage (..), IncomingMessageContent (..), IncomingPublicMessageContent (..), diff --git a/services/galley/src/Galley/API/MLS/Keys.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/Keys.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs index ddafc4e0e2d..b5a84d89f50 100644 --- a/services/galley/src/Galley/API/MLS/Keys.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Keys (getMLSRemovalKey, SomeKeyPair (..)) where +module Wire.ConversationSubsystem.MLS.Keys (getMLSRemovalKey, SomeKeyPair (..)) where import Control.Error.Util (hush) import Data.Proxy diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs similarity index 90% rename from services/galley/src/Galley/API/MLS/Message.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 6425512192b..1059711effd 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -15,17 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Message - ( IncomingBundle (..), - mkIncomingBundle, - IncomingMessage (..), - mkIncomingMessage, +module Wire.ConversationSubsystem.MLS.Message + ( MLSMessageStaticErrors, postMLSCommitBundle, postMLSCommitBundleFromLocalUser, postMLSMessageFromLocalUser, postMLSMessage, - MLSMessageStaticErrors, - MLSBundleStaticErrors, ) where @@ -40,27 +35,11 @@ import Data.Set qualified as Set import Data.Tagged import Data.Text.Lazy qualified as LT import Data.Tuple.Extra -import Galley.API.Action -import Galley.API.LegalHold.Get (getUserStatus) -import Galley.API.MLS.Commit.Core (getCommitData) -import Galley.API.MLS.Commit.ExternalCommit -import Galley.API.MLS.Commit.InternalCommit -import Galley.API.MLS.Conversation -import Galley.API.MLS.Enabled -import Galley.API.MLS.GroupInfoCheck -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.One2One -import Galley.API.MLS.OutOfSync -import Galley.API.MLS.Propagate -import Galley.API.MLS.Proposal -import Galley.API.MLS.Util -import Galley.API.MLS.Welcome (sendWelcomes) import Galley.Types.Error import Imports import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.Internal import Polysemy.Output import Polysemy.Resource (Resource) import Polysemy.TinyLog @@ -88,7 +67,20 @@ import Wire.API.Team.LegalHold import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Commit.Core (getCommitData) +import Wire.ConversationSubsystem.MLS.Commit.ExternalCommit +import Wire.ConversationSubsystem.MLS.Commit.InternalCommit +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.GroupInfoCheck +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.OutOfSync +import Wire.ConversationSubsystem.MLS.Propagate +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.MLS.Welcome (sendWelcomes) import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem @@ -99,7 +91,7 @@ import Wire.Sem.Now qualified as Now import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, getUserStatus) -- FUTUREWORK -- - Check that the capabilities of a leaf node in an add proposal contains all @@ -116,25 +108,12 @@ type MLSMessageStaticErrors = ErrorS 'MLSStaleMessage, ErrorS 'MLSProposalNotFound, ErrorS 'MissingLegalholdConsent, - ErrorS 'MLSInvalidLeafNodeIndex, - ErrorS 'MLSClientMismatch, - ErrorS 'MLSUnsupportedProposal, ErrorS 'MLSCommitMissingReferences, ErrorS 'MLSSelfRemovalNotAllowed, ErrorS 'MLSClientSenderUserMismatch, - ErrorS 'MLSGroupConversationMismatch, ErrorS 'MLSSubConvClientNotInParent ] -type MLSBundleStaticErrors = - Append - MLSMessageStaticErrors - '[ ErrorS 'MLSWelcomeMismatch, - ErrorS 'MLSIdentityMismatch, - ErrorS 'GroupIdVersionNotSupported, - ErrorS 'MLSInvalidLeafNodeSignature - ] - enableOutOfSyncCheckFromVersion :: Version -> EnableOutOfSyncCheck enableOutOfSyncCheckFromVersion v | v < V13 = DisableOutOfSyncCheck @@ -149,7 +128,6 @@ postMLSMessageFromLocalUser :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, @@ -171,9 +149,8 @@ postMLSMessageFromLocalUser v lusr c conn smsg = do imsg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage smsg (ctype, cnvOrSub) <- getConvFromGroupId imsg.groupId events <- - runInputConst (enableOutOfSyncCheckFromVersion v) $ - map lcuEvent - <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) imsg + map lcuEvent + <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) imsg t <- toUTCTimeMillis <$> Now.get pure $ MLSMessageSendingStatus events t @@ -183,13 +160,12 @@ postMLSCommitBundle :: Member (Error GroupInfoDiagnostics) r, Member (Error MLSOutOfSyncError) r, Member (ErrorS GroupIdVersionNotSupported) r, - Member (Input EnableOutOfSyncCheck) r, Member (Input (Maybe GroupInfoCheckEnabled)) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -202,14 +178,16 @@ postMLSCommitBundle :: ConvType -> Qualified ConvOrSubConvId -> Maybe ConnId -> + EnableOutOfSyncCheck -> IncomingBundle -> Sem r [LocalConversationUpdate] -postMLSCommitBundle loc qusr c ctype qConvOrSub conn bundle = - foldQualified - loc - (postMLSCommitBundleToLocalConv qusr c conn bundle ctype) - (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype) - qConvOrSub +postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle = + runInputConst oosCheck $ + foldQualified + loc + (postMLSCommitBundleToLocalConv qusr c conn bundle ctype) + (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype) + qConvOrSub postMLSCommitBundleFromLocalUser :: ( Member (ErrorS MLSLegalholdIncompatible) r, @@ -221,9 +199,9 @@ postMLSCommitBundleFromLocalUser :: Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -242,9 +220,8 @@ postMLSCommitBundleFromLocalUser v lusr c conn bundle = do (ctype, qConvOrSub) <- getConvFromGroupId ibundle.groupId events <- - runInputConst (enableOutOfSyncCheckFromVersion v) $ - map lcuEvent - <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) ibundle + map lcuEvent + <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) ibundle t <- toUTCTimeMillis <$> Now.get pure $ MLSMessageSendingStatus events t @@ -258,9 +235,9 @@ postMLSCommitBundleToLocalConv :: Member (Input (Maybe GroupInfoCheckEnabled)) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -405,7 +382,7 @@ handleGroupInfoMismatch lConvId bundle m = postMLSCommitBundleToRemoteConv :: ( Member BrigAPIAccess r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, Member (Error FederationError) r, Member (Error MLSProtocolError) r, Member (Error MLSProposalFailure) r, @@ -448,7 +425,7 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle ctype rConvOrSubId = do enableOutOfSyncCheck } case resp of - MLSMessageResponseError e -> rethrowErrors @MLSBundleStaticErrors e + MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e MLSMessageResponseProtocolError e -> throw (mlsProtocolError e) MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e) MLSMessageResponseUnreachableBackends ds -> throw (UnreachableBackends (toList ds)) @@ -470,7 +447,6 @@ postMLSMessage :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (ErrorS 'MLSStaleMessage) r, @@ -478,8 +454,7 @@ postMLSMessage :: Member (ErrorS 'MLSSubConvClientNotInParent) r, Member (ErrorS MLSInvalidLeafNodeSignature) r, Member (Error MLSOutOfSyncError) r, - Member (Error GroupInfoDiagnostics) r, - Member (Input EnableOutOfSyncCheck) r + Member (Error GroupInfoDiagnostics) r ) => Local x -> Qualified UserId -> @@ -487,14 +462,16 @@ postMLSMessage :: ConvType -> Qualified ConvOrSubConvId -> Maybe ConnId -> + EnableOutOfSyncCheck -> IncomingMessage -> Sem r [LocalConversationUpdate] -postMLSMessage loc qusr c ctype qconvOrSub con msg = do - foldQualified - loc - (postMLSMessageToLocalConv qusr c con msg ctype) - (postMLSMessageToRemoteConv loc qusr c con msg) - qconvOrSub +postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg = do + runInputConst oosCheck $ + foldQualified + loc + (postMLSMessageToLocalConv qusr c con msg ctype) + (postMLSMessageToRemoteConv loc qusr c con msg) + qconvOrSub getSenderIdentity :: ( Member (ErrorS 'MLSClientSenderUserMismatch) r, diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Migration.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs index 1db5ce29576..0922d1588f2 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Migration where +module Wire.ConversationSubsystem.MLS.Migration where import Data.Qualified import Data.Set qualified as Set diff --git a/services/galley/src/Galley/API/MLS/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/One2One.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs index 3f8550b4b94..3082a3dc257 100644 --- a/services/galley/src/Galley/API/MLS/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.One2One +module Wire.ConversationSubsystem.MLS.One2One ( localMLSOne2OneConversation, localMLSOne2OneConversationAsRemote, localMLSOne2OneConversationMetadata, diff --git a/services/galley/src/Galley/API/MLS/OutOfSync.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/OutOfSync.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs index 03556f89ade..b9aaceb5bbd 100644 --- a/services/galley/src/Galley/API/MLS/OutOfSync.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.OutOfSync +module Wire.ConversationSubsystem.MLS.OutOfSync ( checkConversationOutOfSync, updateOutOfSyncFlag, ) @@ -25,7 +25,6 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.CheckClients import Imports import Polysemy import Polysemy.Error @@ -39,6 +38,7 @@ import Wire.API.MLS.SubConversation import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.CheckClients import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Propagate.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs index 8e71e7463e3..8445a089f4b 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Propagate where +module Wire.ConversationSubsystem.MLS.Propagate where import Control.Comonad import Data.Id diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/Proposal.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs index fdff658e2ad..712fd32aee4 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Proposal +module Wire.ConversationSubsystem.MLS.Proposal ( -- * Proposal processing derefOrCheckProposal, checkProposal, @@ -38,7 +38,6 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.IncomingMessage import Galley.Types.Error import Imports import Polysemy @@ -67,6 +66,7 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.IncomingMessage import Wire.ExternalAccess import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.LegalHoldStore (LegalHoldStore) diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Removal.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs index fbdc427bbcf..3daa9b661ed 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Removal +module Wire.ConversationSubsystem.MLS.Removal ( createAndSendRemoveProposals, removeExtraneousClients, removeClient, @@ -31,9 +31,6 @@ import Data.Map qualified as Map import Data.Proxy import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.Conversation -import Galley.API.MLS.Keys -import Galley.API.MLS.Propagate import Imports import Polysemy import Polysemy.Error @@ -54,6 +51,9 @@ import Wire.API.MLS.SubConversation import Wire.BackendNotificationQueueAccess import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Keys +import Wire.ConversationSubsystem.MLS.Propagate import Wire.ExternalAccess import Wire.NotificationSubsystem import Wire.ProposalStore diff --git a/services/galley/src/Galley/API/MLS/Reset.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs similarity index 93% rename from services/galley/src/Galley/API/MLS/Reset.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs index 18955e75c1e..0f88ab79699 100644 --- a/services/galley/src/Galley/API/MLS/Reset.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs @@ -15,14 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Reset (resetMLSConversation) where +module Wire.ConversationSubsystem.MLS.Reset (resetMLSConversation) where import Data.Id import Data.Qualified -import Galley.API.Action -import Galley.API.MLS.Enabled -import Galley.API.MLS.Util -import Galley.API.Update import Galley.Types.Error import Imports import Polysemy @@ -42,7 +38,10 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled) +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.Update import Wire.ExternalAccess (ExternalAccess) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.NotificationSubsystem @@ -52,10 +51,8 @@ import Wire.Sem.Random (Random) import Wire.TeamSubsystem (TeamSubsystem) resetMLSConversation :: - ( Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member Now r, + ( Member Now r, Member (Input (Local ())) r, - Member (ErrorS MLSNotEnabled) r, Member (ErrorS MLSStaleMessage) r, Member (ErrorS (ActionDenied LeaveConversation)) r, Member (ErrorS ConvNotFound) r, @@ -63,6 +60,8 @@ resetMLSConversation :: Member (Error InternalError) r, Member (ErrorS InvalidOperation) r, Member (ErrorS MLSFederatedResetNotSupported) r, + Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (ErrorS MLSNotEnabled) r, Member BackendNotificationQueueAccess r, Member ConversationStore r, Member (FederationAPIAccess FederatorClient) r, @@ -70,7 +69,6 @@ resetMLSConversation :: Member (Error FederationError) r, Member BrigAPIAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member ProposalStore r, Member Random r, Member Resource r, diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs similarity index 94% rename from services/galley/src/Galley/API/MLS/SubConversation.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs index a404476e377..14574b31c26 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.SubConversation +module Wire.ConversationSubsystem.MLS.SubConversation ( getSubConversation, getLocalSubConversation, deleteSubConversation, @@ -35,11 +35,6 @@ import Control.Arrow import Control.Monad.Codensity hiding (reset) import Data.Id import Data.Qualified -import Galley.API.MLS -import Galley.API.MLS.Conversation -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.Removal -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -65,6 +60,11 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.BackendNotificationQueueAccess import Wire.ConversationStore qualified as Conversation import Wire.ConversationStore.MLS.Types as Conversation +import Wire.ConversationSubsystem.MLS.Conversation (mkMLSConversation) +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled) +import Wire.ConversationSubsystem.MLS.GroupInfo (getGroupInfoFromRemoteConv) +import Wire.ConversationSubsystem.MLS.Removal (createAndSendRemoveProposals) +import Wire.ConversationSubsystem.MLS.Util (getLocalConvForUser, withCommitLock) import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.FederationAPIAccess @@ -169,10 +169,12 @@ getSubConversationGroupInfo :: '[ Conversation.ConversationStore, Error FederationError, FederationAPIAccess FederatorClient, - Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)) + Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)), + ErrorS 'MLSNotEnabled, + ErrorS 'ConvNotFound, + ErrorS 'MLSMissingGroupInfo ] - r, - Members MLSGroupInfoStaticErrors r + r ) => Local UserId -> Qualified ConvId -> @@ -187,8 +189,10 @@ getSubConversationGroupInfo lusr qcnvId subconv = do qcnvId getSubConversationGroupInfoFromLocalConv :: - (Member Conversation.ConversationStore r) => - (Members MLSGroupInfoStaticErrors r) => + ( Member Conversation.ConversationStore r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'MLSMissingGroupInfo) r + ) => Qualified UserId -> SubConvId -> Local ConvId -> diff --git a/services/galley/src/Galley/API/MLS/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Util.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs index 742f820b1bb..814603f64ff 100644 --- a/services/galley/src/Galley/API/MLS/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Util where +module Wire.ConversationSubsystem.MLS.Util where import Control.Comonad import Control.Monad.Codensity diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/Welcome.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs index 44484dda0a5..b16bb87e1af 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Welcome +module Wire.ConversationSubsystem.MLS.Welcome ( sendWelcomes, sendLocalWelcomes, ) diff --git a/services/galley/src/Galley/API/Mapping.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs similarity index 99% rename from services/galley/src/Galley/API/Mapping.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs index 3837b9e623b..c4cea7981d0 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Mapping +module Wire.ConversationSubsystem.Mapping ( conversationViewV9, conversationView, conversationViewWithCachedOthers, diff --git a/services/galley/src/Galley/API/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs similarity index 97% rename from services/galley/src/Galley/API/Message.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs index ff384a45fe9..214bdcf6ed8 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Message +module Wire.ConversationSubsystem.Message ( UserType (..), sendLocalMessages, postQualifiedOtrMessage, @@ -24,6 +24,7 @@ module Galley.API.Message legacyClientMismatchStrategy, Unqualify (..), MessageMetadata (..), + IntraListing (..), -- * Only exported for tests checkMessageClients, @@ -48,7 +49,6 @@ import Data.Range import Data.Set qualified as Set import Data.Set.Lens import Data.Time.Clock (UTCTime) -import Galley.API.LegalHold.Conflicts import Galley.Types.Clients qualified as Clients import Imports hiding (forkIO) import Network.AMQP qualified as Q @@ -57,6 +57,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class qualified as Log +import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley @@ -68,7 +69,7 @@ import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Message import Wire.API.Routes.Public.Galley.Messaging -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.API.Team.LegalHold import Wire.API.Team.Member import Wire.API.User.Client @@ -76,22 +77,26 @@ import Wire.API.UserMap (UserMap (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore -import Wire.ConversationSubsystem qualified as ConvSubsystem +import Wire.ConversationSubsystem.Internal qualified as ConvSubsystem +import Wire.ConversationSubsystem.LegalholdConflicts import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.NotificationSubsystem (BotMap, NotificationSubsystem, newMessagePush, runMessagePush) -import Wire.Options.Galley import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.StoredConversation import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, getTeamMembersForFanout) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore data UserType = User | Bot -- FUTUREWORK: there is UserType in Wire.API.User now, should we use that? (there is also UserType variant for searcho/contacts, but there is a good reason for that one.) +newtype IntraListing + = IntraListing {unIntraListing :: Bool} + deriving stock (Eq, Ord, Show) + userToProtectee :: UserType -> UserId -> LegalholdProtectee userToProtectee User user = ProtectedUser user userToProtectee Bot _ = UnprotectedBot @@ -259,14 +264,15 @@ postBroadcast :: Member (ErrorS 'NonBindingTeam) r, Member (ErrorS 'BroadcastLimitExceeded) r, Member ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member P.TinyLog r, Member NotificationSubsystem r, Member (Input FanoutLimit) r, + Member (Input ConversationSubsystemConfig) r, Member TeamSubsystem r, - Member ConvSubsystem.ConversationSubsystem r + Member UserClientIndexStore r ) => Local UserId -> Maybe ConnId -> @@ -354,7 +360,6 @@ postBroadcast lusr con msg = runError $ do maybeFetchAllMembersInTeam :: ( Member (ErrorS 'BroadcastLimitExceeded) r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -372,7 +377,8 @@ postQualifiedOtrMessage :: Member (FederationAPIAccess FederatorClient) r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member (Input Opts) r, + Member (Input IntraListing) r, + Member (Input FeatureFlags) r, Member Now r, Member P.TinyLog r, Member NotificationSubsystem r, @@ -411,7 +417,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = Set.fromList $ map (tUntagged . qualifyAs lcnv) localMemberIds <> map (tUntagged . (.id_)) conv.remoteMembers - isInternal <- view (settings . intraListing) <$> input + IntraListing isInternal <- input -- check if the sender is part of the conversation unless (Set.member sender members) $ @@ -533,7 +539,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = guardQualifiedLegalholdPolicyConflictsWrapper :: ( Member BrigAPIAccess r, Member (Error (MessageNotSent MessageSendingStatus)) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs index afe039381b8..a73b430d57b 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs @@ -19,7 +19,7 @@ module Wire.ConversationSubsystem.One2One ( one2OneConvId, - iUpsertOne2OneConversation, + internalUpsertOne2OneConversation, ) where @@ -51,12 +51,12 @@ newConnectConversationWithRemote creator users = groupId = Nothing } -iUpsertOne2OneConversation :: +internalUpsertOne2OneConversation :: forall r. (Member ConversationStore r) => UpsertOne2OneConversationRequest -> Sem r () -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do +internalUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let dolocal :: Local ConvId -> Sem r () dolocal lconvId = do mbConv <- getConversation (tUnqualified lconvId) diff --git a/services/galley/src/Galley/API/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs similarity index 98% rename from services/galley/src/Galley/API/Query.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 201b7572bd3..d64ec116e6f 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Query +module Wire.ConversationSubsystem.Query ( getBotConversation, getUnqualifiedOwnConversation, getOwnConversation, @@ -66,12 +66,6 @@ import Data.Qualified import Data.Range import Data.Set qualified as Set import Data.Tagged -import Galley.API.MLS -import Galley.API.MLS.Enabled -import Galley.API.MLS.One2One -import Galley.API.Mapping -import Galley.API.Mapping qualified as Mapping -import Galley.API.Teams.Features.Get import Galley.Types.Error import Imports import Polysemy @@ -107,7 +101,12 @@ import Wire.CodeStore.Code (Code (codeConversation)) import Wire.CodeStore.Code qualified as Data import Wire.ConversationStore qualified as ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Fetch (getConversationIdsImpl) +import Wire.ConversationSubsystem.MLS +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled, getMLSPrivateKeys, isMLSEnabled) +import Wire.ConversationSubsystem.MLS.One2One (localMLSOne2OneConversation, remoteMLSOne2OneConversation) +import Wire.ConversationSubsystem.Mapping +import Wire.ConversationSubsystem.Mapping qualified as Mapping import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem @@ -119,7 +118,7 @@ import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList import Wire.Util @@ -402,13 +401,13 @@ conversationIdsPageFromUnqualified lusr start msize = do -- FUTUREWORK: Move the body of this function to 'conversationIdsPageFrom' once -- support for V2 is dropped. conversationIdsPageFromV2 :: - (Member ConversationSubsystem.ConversationSubsystem r) => + (Member ConversationStore.ConversationStore r) => ListGlobalSelfConvs -> Local UserId -> Public.GetPaginatedConversationIds -> Sem r Public.ConvIdsPage conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do - filterOut <$> ConversationSubsystem.getConversationIds lusr gmtprSize gmtprState + filterOut <$> getConversationIdsImpl lusr gmtprSize gmtprState where -- MLS self-conversation of this user selfConvId = mlsSelfConvId (tUnqualified lusr) @@ -437,9 +436,8 @@ conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {. conversationIdsPageFrom :: forall r. ( Member ConversationStore.ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -711,9 +709,9 @@ getConversationGuestLinksFeatureStatus (Just tid) = getFeatureForTeam tid getMLSSelfConversationWithError :: forall r. ( Member ConversationStore.ConversationStore r, - Member (Error InternalError) r, - Member (ErrorS 'MLSNotEnabled) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (ErrorS MLSNotEnabled) r, + Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -864,10 +862,10 @@ getMLSOne2OneConversation lself qother fmt = do getLocalMLSOne2OneConversation :: ( Member ConversationStore.ConversationStore r, - Member (Error InternalError) r, - Member P.TinyLog r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member (ErrorS MLSNotEnabled) r + Member (ErrorS MLSNotEnabled) r, + Member (Error InternalError) r, + Member P.TinyLog r ) => Local UserId -> Local ConvId -> diff --git a/services/galley/src/Galley/API/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs similarity index 95% rename from services/galley/src/Galley/API/Update.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 66a7d0030e9..6aa276b8699 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Update +module Wire.ConversationSubsystem.Update ( -- * Managing Conversations acceptConv, blockConv, @@ -90,13 +90,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Singletons import Data.Vector qualified as V -import Galley.API.Action -import Galley.API.Action.Kick (kickMember) -import Galley.API.Mapping -import Galley.API.Message -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features.Get -import Galley.App import Galley.Types.Error import Imports hiding (forkIO) import Polysemy @@ -126,7 +119,7 @@ import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.Feature -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.API.Team.Member import Wire.API.User.Client import Wire.API.UserGroup @@ -137,7 +130,11 @@ import Wire.CodeStore qualified as E import Wire.CodeStore.Code import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.Action.Kick (kickMember) +import Wire.ConversationSubsystem.Mapping +import Wire.ConversationSubsystem.Message +import Wire.ConversationSubsystem.Query qualified as Query import Wire.ConversationSubsystem.Util import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem @@ -156,7 +153,7 @@ import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore qualified as E import Wire.UserGroupStore (UserGroupStore, getUserGroupsForConv) @@ -291,8 +288,6 @@ type UpdateConversationAccessEffects = E.FederationAPIAccess FederatorClient, FireAndForget, NotificationSubsystem, - ConversationSubsystem, - Input Env, Input ConversationSubsystemConfig, ProposalStore, Random, @@ -322,7 +317,10 @@ updateConversationHistory :: Member (ErrorS ConvNotFound) r, Member (ErrorS HistoryNotSupported) r, Member ConversationStore r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -367,9 +365,10 @@ updateConversationReceiptMode :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'MLSReadReceiptsNotAllowed) r, Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member TeamSubsystem r @@ -444,9 +443,10 @@ updateConversationReceiptModeUnqualified :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'MLSReadReceiptsNotAllowed) r, Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member TeamSubsystem r @@ -464,7 +464,10 @@ updateConversationMessageTimer :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r ) => Local UserId -> @@ -493,7 +496,10 @@ updateConversationMessageTimerUnqualified :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r ) => Local UserId -> @@ -511,7 +517,10 @@ deleteLocalConversation :: Member (ErrorS ('ActionDenied 'DeleteConversation)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member ProposalStore r, Member TeamSubsystem r ) => @@ -536,7 +545,7 @@ addCodeUnqualifiedWithReqBody :: Member (Input (Local ())) r, Member Now r, Member HashPassword r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member FeaturesConfigSubsystem r, Member RateLimit r, Member TeamSubsystem r @@ -561,7 +570,7 @@ addCodeUnqualified :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member HashPassword r, Member FeaturesConfigSubsystem r, Member RateLimit r, @@ -590,7 +599,7 @@ addCode :: Member HashPassword r, Member NotificationSubsystem r, Member Now r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member FeaturesConfigSubsystem r, Member RateLimit r, Member TeamSubsystem r @@ -612,7 +621,7 @@ addCode lusr mbZHost mZcon lcnv mReq = do key <- E.makeKey (tUnqualified lcnv) E.getCode key >>= \case Nothing -> do - ttl <- realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds . view (settings . guestLinkTTLSeconds) <$> input + ttl <- inputs (realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds) code <- E.generateCode (tUnqualified lcnv) (Timeout ttl) mPw <- for (mReq >>= (.password)) $ HashPassword.hashPassword8 (RateLimitUser (tUnqualified lusr)) E.createCode code mPw @@ -742,7 +751,6 @@ updateConversationProtocolWithLocalUser :: Member ConversationStore r, Member TinyLog r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member Random r, @@ -780,8 +788,9 @@ updateChannelAddPermission :: Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member (Error NonFederatingBackends) r, @@ -824,11 +833,15 @@ joinConversationByReusableCode :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, Member FeaturesConfigSubsystem r, Member HashPassword r, Member RateLimit r, Member TeamSubsystem r, + Member Now r, Member (Input ConversationSubsystemConfig) r ) => Local UserId -> @@ -850,8 +863,12 @@ joinConversationById :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, Member (Input ConversationSubsystemConfig) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -869,9 +886,13 @@ joinConversation :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, Member (Input ConversationSubsystemConfig) r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, Member ConversationStore r, + Member Now r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -927,7 +948,6 @@ addMembers :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -979,7 +999,6 @@ addMembersUnqualifiedV2 :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -1020,7 +1039,6 @@ addMembersUnqualified :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -1073,7 +1091,6 @@ replaceMembers :: Member TinyLog r, Member TeamCollaboratorsSubsystem r, Member UserGroupStore r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r @@ -1201,7 +1218,10 @@ updateOtherMemberLocalConv :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local ConvId -> @@ -1224,7 +1244,10 @@ updateOtherMemberUnqualified :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -1246,7 +1269,10 @@ updateOtherMember :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -1279,7 +1305,6 @@ removeMemberUnqualified :: Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1307,7 +1332,6 @@ removeMemberQualified :: Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1382,7 +1406,6 @@ removeMemberFromLocalConv :: Member (ErrorS 'InvalidOperation) r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1425,7 +1448,6 @@ removeMemberFromChannel :: Member Now r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Random r, Member TinyLog r, Member (Error FederationError) r, @@ -1462,7 +1484,8 @@ postProteusMessage :: Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member Now r, Member TinyLog r, Member TeamSubsystem r @@ -1486,13 +1509,14 @@ postProteusBroadcast :: Member (ErrorS 'BroadcastLimitExceeded) r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member TinyLog r, Member (Input FanoutLimit) r, Member TeamSubsystem r, - Member ConversationSubsystem r + Member (Input ConversationSubsystemConfig) r, + Member E.UserClientIndexStore r ) => Local UserId -> ConnId -> @@ -1540,7 +1564,8 @@ postBotMessageUnqualified :: Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member TinyLog r, Member Now r, Member TeamSubsystem r @@ -1568,13 +1593,14 @@ postOtrBroadcastUnqualified :: Member (ErrorS 'BroadcastLimitExceeded) r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member TinyLog r, Member (Input FanoutLimit) r, Member TeamSubsystem r, - Member ConversationSubsystem r + Member (Input ConversationSubsystemConfig) r, + Member E.UserClientIndexStore r ) => Local UserId -> ConnId -> @@ -1595,7 +1621,8 @@ postOtrMessageUnqualified :: Member BackendNotificationQueueAccess r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member Now r, Member TinyLog r, Member TeamSubsystem r @@ -1620,7 +1647,10 @@ updateConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -1643,7 +1673,10 @@ updateUnqualifiedConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -1662,7 +1695,10 @@ updateLocalConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 16f70e955ca..e61b1c4505a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -24,7 +24,6 @@ import Control.Lens (view, (^.)) import Control.Monad.Extra (allM, anyM) import Control.Monad.Trans.Maybe import Data.Bifunctor -import Data.Code qualified as Code import Data.Default import Data.Domain (Domain) import Data.Id as Id @@ -34,7 +33,7 @@ import Data.List.Extra (chunksOf, nubOrd) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map -import Data.Misc (PlainTextPassword6, PlainTextPassword8) +import Data.Misc (PlainTextPassword8) import Data.Qualified import Data.Set qualified as Set import Data.Singletons @@ -71,10 +70,8 @@ import Wire.API.Team.Collaborator qualified as CollaboratorPermission (Collabora import Wire.API.Team.FeatureFlags import Wire.API.Team.Member import Wire.API.Team.Member qualified as Mem -import Wire.API.Team.Member.Error import Wire.API.Team.Role import Wire.API.User hiding (userId) -import Wire.API.User.Auth.ReAuth import Wire.API.VersionInfo import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess @@ -94,7 +91,7 @@ import Wire.Sem.Now qualified as Now import Wire.StoredConversation as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven, getLHStatus) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList @@ -195,20 +192,6 @@ ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: - ( Member (ErrorS 'NotConnected) r, - Member BrigAPIAccess r - ) => - UserId -> - [UserId] -> - Sem r () -ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do - (connsFrom, connsTo) <- - getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) - unless (length connsFrom == length uids && length connsTo == length uids) $ - throwS @'NotConnected - ensureConnectedToRemotes :: ( Member BrigAPIAccess r, Member (ErrorS 'NotConnected) r @@ -222,18 +205,6 @@ ensureConnectedToRemotes u remotes = do when (length acceptedConns /= length remotes) $ throwS @'NotConnected -ensureReAuthorised :: - ( Member BrigAPIAccess r, - Member (Error AuthenticationError) r - ) => - UserId -> - Maybe PlainTextPassword6 -> - Maybe Code.Value -> - Maybe VerificationAction -> - Sem r () -ensureReAuthorised u secret mbAction mbCode = - reauthUser u (ReAuthUser secret mbAction mbCode) >>= fromEither - ensureManageChannelsPermission :: (Member (ErrorS 'ConvNotFound) r) => StoredConversation -> TeamMember -> Sem r () ensureManageChannelsPermission conv tm = do unless (hasManageChannelsPermission conv tm) $ throwS @'ConvNotFound @@ -323,72 +294,6 @@ checkGroupIdSupport loc conv joinAction = void $ runMaybeT $ do failOnFirstError :: (Member (ErrorS GroupIdVersionNotSupported) r) => [Either e x] -> Sem r () failOnFirstError = traverse_ $ either (\_ -> throwS @GroupIdVersionNotSupported) pure --- | Same as 'permissionCheck', but for a statically known permission. -permissionCheckS :: - forall teamAssociation perm (p :: perm) r. - ( SingKind perm, - IsPerm teamAssociation (Demote perm), - ( Member (ErrorS (PermError p)) r, - Member (ErrorS 'NotATeamMember) r - ) - ) => - Sing p -> - Maybe teamAssociation -> - Sem r teamAssociation -permissionCheckS p = - \case - Just m -> do - if m `hasPermission` fromSing p - then pure m - else throwS @(PermError p) - -- FUTUREWORK: factor `noteS` out of this function. - Nothing -> throwS @'NotATeamMember - --- | If a team member is not given throw 'notATeamMember'; if the given team --- member does not have the given permission, throw 'operationDenied'. --- Otherwise, return the team member. -permissionCheck :: - ( IsPerm teamAssociation perm, - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r - ) - ) => - perm -> - Maybe teamAssociation -> - Sem r teamAssociation --- FUTUREWORK: factor `noteS` out of this function. -permissionCheck p = \case - Just m -> do - if m `hasPermission` p - then pure m - else throwS @OperationDenied - -- FUTUREWORK: factor `noteS` out of this function. - Nothing -> throwS @'NotATeamMember - -assertTeamExists :: - ( Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ) => - TeamId -> - Sem r () -assertTeamExists tid = do - teamExists <- isJust <$> getTeam tid - if teamExists - then pure () - else throwS @'TeamNotFound - -assertOnTeam :: - ( Member (ErrorS 'NotATeamMember) r, - Member TeamSubsystem r - ) => - UserId -> - TeamId -> - Sem r () -assertOnTeam uid tid = - TeamSubsystem.internalGetTeamMember uid tid >>= \case - Nothing -> throwS @'NotATeamMember - Just _ -> pure () - -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: ( Member ConversationStore r, @@ -997,38 +902,6 @@ userLHEnabled = \case UserLegalHoldDisabled -> False UserLegalHoldNoConsent -> False -data ConsentGiven = ConsentGiven | ConsentNotGiven - deriving (Eq, Ord, Show) - -consentGiven :: UserLegalHoldStatus -> ConsentGiven -consentGiven = \case - UserLegalHoldDisabled -> ConsentGiven - UserLegalHoldPending -> ConsentGiven - UserLegalHoldEnabled -> ConsentGiven - UserLegalHoldNoConsent -> ConsentNotGiven - -checkConsent :: - (Member TeamSubsystem r) => - Map UserId TeamId -> - UserId -> - Sem r ConsentGiven -checkConsent teamsOfUsers other = do - consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other - --- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user --- doesn't belong to a team. -getLHStatus :: - (Member TeamSubsystem r) => - Maybe TeamId -> - UserId -> - Sem r UserLegalHoldStatus -getLHStatus teamOfUser other = do - case teamOfUser of - Nothing -> pure defUserLegalHoldStatus - Just team -> do - mMember <- TeamSubsystem.internalGetTeamMember other team - pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember - anyLegalholdActivated :: ( Member (Input ConversationSubsystemConfig) r, Member TeamStore r, @@ -1075,31 +948,6 @@ allLegalholdConsentGiven uids = do eitherTeamMemberAndLHAllowedOrDefLHStatus teamsPage uid = do fromMaybe (consentGiven defUserLegalHoldStatus == ConsentGiven) <$> (for (Map.lookup uid teamsPage) isTeamLegalholdWhitelisted) --- | Add to every uid the legalhold status -getLHStatusForUsers :: - (Member TeamStore r, Member TeamSubsystem r) => - [UserId] -> - Sem r [(UserId, UserLegalHoldStatus)] -getLHStatusForUsers uids = - mconcat - <$> for - (chunksOf 32 uids) - ( \uidsChunk -> do - teamsOfUsers <- getUsersTeams uidsChunk - for uidsChunk $ \uid -> do - (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid - ) - -getTeamMembersForFanout :: - ( Member (Input FanoutLimit) r, - Member TeamSubsystem r - ) => - TeamId -> - Sem r TeamMemberList -getTeamMembersForFanout tid = do - lim <- input - TeamSubsystem.internalGetTeamMembersWithLimit tid (Just lim) - ensureMemberLimit :: ( Foldable f, ( Member (ErrorS 'TooManyMembers) r, diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs index d8824e685c2..2b5da0c95fe 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs @@ -19,7 +19,8 @@ module Wire.FeaturesConfigSubsystem where -import Data.Id (TeamId, UserId) +import Data.Id (ConvId, TeamId, UserId) +import Data.Proxy (Proxy) import Data.Qualified (Local) import Imports import Polysemy @@ -35,5 +36,27 @@ data FeaturesConfigSubsystem m a where GetAllTeamFeaturesForTeamMember :: Local UserId -> TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForTeam :: TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForServer :: FeaturesConfigSubsystem m AllTeamFeatures + GuardSecondFactorDisabled :: + UserId -> + ConvId -> + FeaturesConfigSubsystem m () + FeatureEnabledForTeam :: + forall cfg m. + (GetFeatureConfig cfg) => + Proxy cfg -> + TeamId -> + FeaturesConfigSubsystem m Bool + GetAllTeamFeaturesForUser :: + UserId -> + FeaturesConfigSubsystem m AllTeamFeatures + GetSingleFeatureForUser :: + forall cfg m. + (GetFeatureConfig cfg) => + UserId -> + FeaturesConfigSubsystem m (LockableFeature cfg) + GetFeatureInternal :: + (GetFeatureConfig cfg) => + TeamId -> + FeaturesConfigSubsystem m (LockableFeature cfg) makeSem ''FeaturesConfigSubsystem diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs index d3842f68bf5..70936a806e0 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs @@ -5,24 +5,31 @@ module Wire.FeaturesConfigSubsystem.Interpreter where +import Control.Error (hush) import Data.Aeson.Types qualified as A import Data.Id import Data.Qualified (tUnqualified) import Data.SOP +import Data.Tagged import Data.Text.Lazy qualified as LT import Imports import Polysemy import Polysemy.Error import Polysemy.Input +import Wire.API.Conversation (ConversationMetadata (..)) import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.ConversationStore qualified as ConversationStore import Wire.FeaturesConfigSubsystem import Wire.FeaturesConfigSubsystem.Types import Wire.FeaturesConfigSubsystem.Utils +import Wire.LegalHoldStore (LegalHoldStore) import Wire.TeamFeatureStore import Wire.TeamFeatureStore.Error (TeamFeatureStoreError (..)) +import Wire.TeamStore qualified as TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem @@ -30,8 +37,11 @@ runFeaturesConfigSubsystem :: forall r a. ( Member TeamFeatureStore r, Member TeamSubsystem r, + Member TeamStore.TeamStore r, + Member ConversationStore.ConversationStore r, Member (Error TeamFeatureStoreError) r, Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'AccessDenied) r, GetFeatureConfigEffects r ) => Sem (FeaturesConfigSubsystem : r) a -> @@ -54,6 +64,16 @@ runFeaturesConfigSubsystem = interpret $ \case getAllTeamFeaturesImpl tid GetAllTeamFeaturesForServer -> getAllTeamFeaturesForServerImpl + GuardSecondFactorDisabled uid cid -> + guardSecondFactorDisabledImpl uid cid + FeatureEnabledForTeam (Proxy :: Proxy cfg) tid -> + featureEnabledForTeamImpl @cfg tid + GetAllTeamFeaturesForUser uid -> + getAllTeamFeaturesForUserImpl uid + GetSingleFeatureForUser uid -> + getSingleFeatureForUserImpl uid + GetFeatureInternal tid -> + getFeatureInternalImpl tid -- Internal helpers @@ -129,3 +149,138 @@ parseDbFeatureOrThrow feat = mapError (TeamFeatureStoreErrorInternalError . LT.pack) . fromEither $ A.parseEither (const (parseDbFeature feat)) () + +getFeatureInternalImpl :: + ( GetFeatureConfig cfg, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member TeamSubsystem r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r (LockableFeature cfg) +getFeatureInternalImpl tid = do + TeamSubsystem.assertTeamExists tid + getFeatureForTeamImpl tid + +getTeamAndCheckMembership :: + ( Member TeamStore.TeamStore r, + Member (ErrorS 'NotATeamMember) r, + Member TeamSubsystem r + ) => + UserId -> + Sem r (Maybe TeamId) +getTeamAndCheckMembership uid = do + mTid <- TeamStore.getOneUserTeam uid + for_ mTid $ \tid -> do + zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid + void $ maybe (throwS @'NotATeamMember) pure zusrMembership + TeamSubsystem.assertTeamExists tid + pure mTid + +getAllTeamFeatures :: + forall r. + ( Member TeamFeatureStore r, + Member LegalHoldStore r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r AllTeamFeatures +getAllTeamFeatures tid = getAllTeamFeaturesImpl tid + +getAllTeamFeaturesForUserImpl :: + forall r. + ( Member (ErrorS 'NotATeamMember) r, + Member TeamStore.TeamStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member (Error TeamFeatureStoreError) r, + GetFeatureConfigEffects r + ) => + UserId -> + Sem r AllTeamFeatures +getAllTeamFeaturesForUserImpl uid = do + mTid <- getTeamAndCheckMembership uid + case mTid of + Nothing -> hsequence' $ hcpure (Proxy @(GetAllTeamFeaturesForUserConstraints r)) $ Comp $ getFeatureForUser uid + Just tid -> getAllTeamFeatures tid + +getSingleFeatureForUserImpl :: + forall cfg r. + ( GetFeatureConfig cfg, + Member (ErrorS 'NotATeamMember) r, + Member (Error TeamFeatureStoreError) r, + Member TeamStore.TeamStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member BrigAPIAccess r, + Member LegalHoldStore r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r + ) => + UserId -> + Sem r (LockableFeature cfg) +getSingleFeatureForUserImpl uid = do + mTid <- getTeamAndCheckMembership uid + getFeatureForTeamUserImpl @cfg uid mTid + +-- | If second factor auth is enabled, make sure that end-points that don't support it, but +-- should, are blocked completely. (This is a workaround until we have 2FA for those +-- end-points as well.) +-- +-- This function exists to resolve a cyclic dependency. +guardSecondFactorDisabledImpl :: + forall r. + ( Member (ErrorS 'AccessDenied) r, + Member (Error TeamFeatureStoreError) r, + Member ConversationStore.ConversationStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member BrigAPIAccess r, + Member LegalHoldStore r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r + ) => + UserId -> + ConvId -> + Sem r () +guardSecondFactorDisabledImpl uid cid = do + mTid <- fmap hush . runError @() $ do + convData <- ConversationStore.getConversationMetadata cid >>= note () + tid <- note () convData.cnvmTeam + mapError (unTagged @'TeamNotFound @()) $ TeamSubsystem.assertTeamExists tid + pure tid + + tf <- getFeatureForTeamUserImpl @SndFactorPasswordChallengeConfig uid mTid + case tf.status of + FeatureStatusDisabled -> pure () + FeatureStatusEnabled -> throwS @'AccessDenied + +featureEnabledForTeamImpl :: + forall cfg r. + ( GetFeatureConfig cfg, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r Bool +featureEnabledForTeamImpl tid = + (==) FeatureStatusEnabled + . (.status) + <$> getFeatureInternalImpl @cfg tid diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 3479c082df8..0aa2989693e 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -132,7 +132,7 @@ galleyRequest req = do ep <- input rpcWithRetries "galley" ep req --- | Calls 'Galley.API.createSelfConversationH'. +-- | Calls 'Wire.ConversationSubsystem.createSelfConversationH'. createSelfConv :: ( Member Rpc r, Member (Input Endpoint) r @@ -148,7 +148,7 @@ createSelfConv v u = do . zUser u . expect2xx --- | Calls 'Galley.API.getConversationH'. +-- | Calls 'Wire.ConversationSubsystem.getConversationH'. getConv :: ( Member (Error ParseException) r, Member Rpc r, @@ -175,7 +175,7 @@ getConv v usr lcnv = do . zUser usr . expect [status200, status404] --- | Calls 'Galley.API.getTeamConversationH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamConversationH'. getTeamConv :: ( Member (Error ParseException) r, Member Rpc r, @@ -204,7 +204,7 @@ getTeamConv v usr tid cnv = do . zUser usr . expect [status200, status404] --- | Calls 'Galley.API.addClientH'. +-- | Calls 'Wire.ConversationSubsystem.addClientH'. newClient :: ( Member Rpc r, Member (Input Endpoint) r @@ -219,7 +219,7 @@ newClient u c = do . zUser u . expect2xx --- | Calls 'Galley.API.canUserJoinTeamH'. +-- | Calls 'Wire.ConversationSubsystem.canUserJoinTeamH'. checkUserCanJoinTeam :: ( Member Rpc r, Member (Input Endpoint) r @@ -239,7 +239,7 @@ checkUserCanJoinTeam tid = do . paths ["i", "teams", toByteString' tid, "members", "check"] . header "Content-Type" "application/json" --- | Calls 'Galley.API.uncheckedAddTeamMemberH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedAddTeamMemberH'. addTeamMember :: ( Member Rpc r, Member (Input Endpoint) r @@ -265,7 +265,7 @@ addTeamMember u tid minvmeta role = do . expect [status200, status403] . lbytes (encode bdy) --- | Calls 'Galley.API.createBindingTeamH'. +-- | Calls 'Wire.ConversationSubsystem.createBindingTeamH'. createTeam :: ( Member Rpc r, Member (Input Endpoint) r @@ -285,7 +285,7 @@ createTeam u t teamid = do . expect2xx . lbytes (encode t) --- | Calls 'Galley.API.uncheckedGetTeamMemberH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedGetTeamMemberH'. getTeamMember :: ( Member (Error ParseException) r, Member Rpc r, @@ -306,7 +306,7 @@ getTeamMember u tid = do . zUser u . expect [status200, status404] --- | Calls 'Galley.API.uncheckedGetTeamMembersH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedGetTeamMembersH'. -- -- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which -- means that only the first 2000 members of a team (according to some arbitrary order) will @@ -393,7 +393,7 @@ memberIsTeamOwner tid uid = do . paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] pure $ responseStatus r /= status403 --- | Calls 'Galley.API.getBindingTeamIdH'. +-- | Calls 'Wire.ConversationSubsystem.getBindingTeamIdH'. getTeamId :: ( Member (Error ParseException) r, Member Rpc r, @@ -412,7 +412,7 @@ getTeamId u = do . paths ["i", "users", toByteString' u, "team"] . expect [status200, status404] --- | Calls 'Galley.API.getTeamInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeam :: ( Member (Error ParseException) r, Member Rpc r, @@ -428,7 +428,7 @@ getTeam tid = do . paths ["i", "teams", toByteString' tid] . expect2xx --- | Calls 'Galley.API.getTeamInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeamName :: ( Member (Error ParseException) r, Member Rpc r, @@ -444,7 +444,7 @@ getTeamName tid = do . paths ["i", "teams", toByteString' tid, "name"] . expect2xx --- | Calls 'Galley.API.getTeamFeatureStatusH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: ( Member (Error ParseException) r, Member Rpc r, @@ -460,7 +460,7 @@ getTeamLegalHoldStatus tid = do . paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] . expect2xx --- | Calls 'Galley.API.getSearchVisibilityInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getSearchVisibilityInternalH'. getTeamSearchVisibility :: ( Member (Error ParseException) r, Member Rpc r, @@ -541,7 +541,7 @@ getConfiguredFeatureFlags = do . expect2xx ) --- | Calls 'Galley.API.updateTeamStatusH'. +-- | Calls 'Wire.ConversationSubsystem.updateTeamStatusH'. changeTeamStatus :: ( Member Rpc r, Member (Input Endpoint) r diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 45d06de2cae..9fa3d151686 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -122,7 +122,7 @@ createMeetingImpl zUser newMeeting = do } -- Create and store the conversation via ConversationSubsystem - storedConv <- ConversationSubsystem.createGroupConversation zUser Nothing newConv + storedConv <- ConversationSubsystem.internalCreateGroupConversation zUser Nothing newConv -- Store meeting (trial status is provided by caller) storedMeeting <- diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index c93258449c8..adb170507d4 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -23,7 +23,6 @@ import Data.Aeson import Data.Id import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty -import Data.Proxy import Data.Range import Data.Set qualified as Set import Data.Time.Clock.DiffTime @@ -38,6 +37,7 @@ import Polysemy.TinyLog qualified as P import System.Logger.Class as Log import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 +import Wire.API.Team.FeatureFlags (defaultFanoutLimit) import Wire.API.Team.HardTruncationLimit (HardTruncationLimit) import Wire.GundeckAPIAccess (GundeckAPIAccess) import Wire.GundeckAPIAccess qualified as GundeckAPIAccess @@ -75,9 +75,6 @@ defaultNotificationSubsystemConfig :: RequestId -> NotificationSubsystemConfig defaultNotificationSubsystemConfig reqId = NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay reqId -defaultFanoutLimit :: Range 1 HardTruncationLimit Int32 -defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) - defaultChunkSize :: Natural defaultChunkSize = 128 diff --git a/libs/wire-subsystems/src/Wire/Options/Galley.hs b/libs/wire-subsystems/src/Wire/Options/Galley.hs index 8383ee97e4f..47efc924ad7 100644 --- a/libs/wire-subsystems/src/Wire/Options/Galley.hs +++ b/libs/wire-subsystems/src/Wire/Options/Galley.hs @@ -56,21 +56,21 @@ module Wire.Options.Galley logNetStrings, logFormat, guestLinkTTLSeconds, - defGuestLinkTTLSeconds, passwordHashingOptions, passwordHashingRateLimit, checkGroupInfo, meetings, validityPeriod, postgresMigration, - GuestLinkTTLSeconds (..), PostgresMigrationOpts (..), StorageLocation (..), + GuestLinkTTLSeconds (..), + defGuestLinkTTLSeconds, ) where import Control.Lens hiding (Level, (.=)) -import Data.Aeson +import Data.Aeson (FromJSON (..)) import Data.Aeson.TH (deriveFromJSON) import Data.Domain (Domain) import Data.Id (TeamId) @@ -86,7 +86,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Routes.Version import Wire.API.Team.FeatureFlags import Wire.API.Team.Member -import Wire.Options.Keys +import Wire.Options.Keys (MLSPrivateKeyPaths) import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter (RateLimitConfig) @@ -102,6 +102,10 @@ instance FromJSON GuestLinkTTLSeconds where then pure $ GuestLinkTTLSeconds n else fail "GuestLinkTTLSeconds must be in (0, 31536000]" +-- | Default guest link TTL in days. 365 days if not set. +defGuestLinkTTLSeconds :: GuestLinkTTLSeconds +defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year + data Settings = Settings { -- | Number of connections for the HTTP client pool _httpPoolSize :: !Int, @@ -184,10 +188,6 @@ makeLenses ''MeetingsConfig defConcurrentDeletionEvents :: Int defConcurrentDeletionEvents = 128 --- | Default guest link TTL in days. 365 days if not set. -defGuestLinkTTLSeconds :: GuestLinkTTLSeconds -defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year - data JournalOpts = JournalOpts { -- | SQS queue name to send team events _queueName :: !Text, diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index c42d8c58d1e..d7e7b9e4682 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -286,7 +286,7 @@ logInvitationRequest context action = -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- --- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. +-- There is some code duplication with 'Wire.ConversationSubsystem.Teams.ensureNotElevated'. ensurePermissionToAddUser :: ( Member (Error TeamInvitationSubsystemError) r, Member TeamSubsystem r diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem.hs index 7c7213aee72..cd4fa9a7cac 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem.hs @@ -20,13 +20,30 @@ module Wire.TeamSubsystem where import Data.Id +import Data.LegalHold +import Data.Map qualified as Map import Data.Qualified import Data.Range +import Data.Singletons (Demote, Sing, SingKind, fromSing) import Imports import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Team.LegalHold (UserLegalHoldStatusResponse) import Wire.API.Team.Member +import Wire.API.Team.Member.Error import Wire.API.Team.Member.Info (TeamMemberInfoList) +data PermissionCheckArgs teamAssociation where + PermissionCheckArgs :: + forall k (p :: k) teamAssociation. + ( SingKind k, + IsPerm teamAssociation (Demote k) + ) => + Sing p -> + Maybe teamAssociation -> + PermissionCheckArgs teamAssociation + data TeamSubsystem m a where InternalGetTeamMember :: UserId -> TeamId -> TeamSubsystem m (Maybe TeamMember) InternalGetTeamMembersWithLimit :: TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> TeamSubsystem m TeamMemberList @@ -35,5 +52,95 @@ data TeamSubsystem m a where InternalGetTeamAdmins :: TeamId -> TeamSubsystem m TeamMemberList InternalGetOneUserTeam :: UserId -> TeamSubsystem m (Maybe TeamId) InternalFinalizeDeleteTeam :: Local UserId -> Maybe ConnId -> TeamId -> TeamSubsystem m () + GetUserStatus :: + Local UserId -> + TeamId -> + UserId -> + TeamSubsystem m UserLegalHoldStatusResponse + GetTeamMembersForFanout :: + TeamId -> + TeamSubsystem m TeamMemberList + AssertTeamExists :: + TeamId -> + TeamSubsystem m () + GetLHStatusForUsers :: + [UserId] -> + TeamSubsystem m [(UserId, UserLegalHoldStatus)] + GetLHStatus :: + Maybe TeamId -> + UserId -> + TeamSubsystem m UserLegalHoldStatus makeSem ''TeamSubsystem + +assertOnTeam :: + ( Member (ErrorS 'NotATeamMember) r, + Member TeamSubsystem r + ) => + UserId -> + TeamId -> + Sem r () +assertOnTeam uid tid = + internalGetTeamMember uid tid >>= \case + Nothing -> throwS @'NotATeamMember + Just _ -> pure () + +-- | If a team member is not given throw 'notATeamMember'; if the given team +-- member does not have the given permission, throw 'operationDenied'. +-- Otherwise, return the team member. +permissionCheck :: + ( IsPerm teamAssociation perm, + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r + ) + ) => + perm -> + Maybe teamAssociation -> + Sem r teamAssociation +-- FUTUREWORK: factor `noteS` out of this function. +permissionCheck p = \case + Just m -> do + if m `hasPermission` p + then pure m + else throwS @OperationDenied + -- FUTUREWORK: factor `noteS` out of this function. + Nothing -> throwS @'NotATeamMember + +-- | Same as 'permissionCheck', but for a statically known permission. +permissionCheckS :: + forall teamAssociation perm (p :: perm) r. + ( SingKind perm, + IsPerm teamAssociation (Demote perm), + ( Member (ErrorS (PermError p)) r, + Member (ErrorS 'NotATeamMember) r + ) + ) => + Sing p -> + Maybe teamAssociation -> + Sem r teamAssociation +permissionCheckS p = + \case + Just m -> do + if m `hasPermission` fromSing p + then pure m + else throwS @(PermError p) + -- FUTUREWORK: factor `noteS` out of this function. + Nothing -> throwS @'NotATeamMember + +data ConsentGiven = ConsentGiven | ConsentNotGiven + deriving (Eq, Ord, Show) + +consentGiven :: UserLegalHoldStatus -> ConsentGiven +consentGiven = \case + UserLegalHoldDisabled -> ConsentGiven + UserLegalHoldPending -> ConsentGiven + UserLegalHoldEnabled -> ConsentGiven + UserLegalHoldNoConsent -> ConsentNotGiven + +checkConsent :: + (Member TeamSubsystem r) => + Map UserId TeamId -> + UserId -> + Sem r ConsentGiven +checkConsent teamsOfUsers other = do + consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs index 0f4e4342cc7..52cfb0da574 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs @@ -17,13 +17,22 @@ module Wire.TeamSubsystem.GalleyAPI where +import Data.LegalHold (UserLegalHoldStatus (..)) import Imports import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Team.Feature (FeatureStatus (FeatureStatusEnabled), LockableFeature (..)) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.TeamSubsystem -interpretTeamSubsystemToGalleyAPI :: (Member GalleyAPIAccess r) => InterpreterFor TeamSubsystem r +interpretTeamSubsystemToGalleyAPI :: + ( Member GalleyAPIAccess r, + Member (ErrorS TeamMemberNotFound) r, + Member (ErrorS TeamNotFound) r + ) => + InterpreterFor TeamSubsystem r interpretTeamSubsystemToGalleyAPI = interpret $ \case InternalGetTeamMember userId teamId -> GalleyAPIAccess.getTeamMember userId teamId InternalGetTeamMembersWithLimit teamId maxResults -> GalleyAPIAccess.getTeamMembersWithLimit teamId maxResults @@ -32,3 +41,41 @@ interpretTeamSubsystemToGalleyAPI = interpret $ \case InternalGetTeamAdmins teamId -> GalleyAPIAccess.getTeamAdmins teamId InternalGetOneUserTeam userId -> GalleyAPIAccess.getTeamId userId InternalFinalizeDeleteTeam lusr mcon teamId -> GalleyAPIAccess.finalizeDeleteTeam lusr mcon teamId + GetUserStatus lusr tid uid -> do + GalleyAPIAccess.getTeamMember uid tid >>= \case + Nothing -> throwS @'TeamMemberNotFound + Just _ -> do + GalleyAPIAccess.getUserLegalholdStatus lusr tid >>= \case + Nothing -> throwS @'TeamNotFound + Just status -> pure status + GetTeamMembersForFanout tid -> + GalleyAPIAccess.getTeamMembersWithLimit tid Nothing + AssertTeamExists tid -> do + void $ GalleyAPIAccess.getTeam tid + GetLHStatusForUsers uids -> do + for uids $ \uid -> do + mteamId <- GalleyAPIAccess.getTeamId uid + status <- case mteamId of + Nothing -> pure UserLegalHoldDisabled + Just tid -> do + GalleyAPIAccess.getTeamMember uid tid >>= \case + Nothing -> pure UserLegalHoldDisabled + Just _ -> do + LockableFeature {status} <- GalleyAPIAccess.getTeamLegalHoldStatus tid + pure $ + if status == FeatureStatusEnabled + then UserLegalHoldEnabled + else UserLegalHoldDisabled + pure (uid, status) + GetLHStatus mtid uid -> do + case mtid of + Nothing -> pure UserLegalHoldDisabled + Just tid -> do + GalleyAPIAccess.getTeamMember uid tid >>= \case + Nothing -> pure UserLegalHoldDisabled + Just _ -> do + LockableFeature {status} <- GalleyAPIAccess.getTeamLegalHoldStatus tid + pure $ + if status == FeatureStatusEnabled + then UserLegalHoldEnabled + else UserLegalHoldDisabled diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs index 749bfd978d3..f598ec35d74 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs @@ -18,22 +18,34 @@ module Wire.TeamSubsystem.Interpreter where import Control.Lens (view, (%~), (^.)) +import Data.ByteString.Conversion (toByteString') import Data.Default import Data.Id import Data.Json.Util -import Data.LegalHold (UserLegalHoldStatus (..)) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra qualified as List import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map qualified as Map import Data.Qualified import Data.Time +import Galley.Types.Error import Imports import Polysemy +import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog qualified as P +import System.Logger.Class qualified as Log +import Wire.API.Error +import Wire.API.Error.Galley import Wire.API.Event.Conversation qualified as Conv import Wire.API.Event.Team +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.API.Team.HardTruncationLimit +import Wire.API.Team.LegalHold +import Wire.API.Team.LegalHold qualified as Public import Wire.API.Team.Member import Wire.API.Team.Member.Info (TeamMemberInfoList (TeamMemberInfoList)) +import Wire.API.User.Client.Prekey import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.ConversationStore @@ -42,6 +54,7 @@ import Wire.ExternalAccess import Wire.ExternalAccess qualified as ExternalAccess import Wire.LegalHoldStore (LegalHoldStore) import Wire.LegalHoldStore qualified as LH +import Wire.LegalHoldStore qualified as LegalHoldData import Wire.NotificationSubsystem import Wire.Sem.Now import Wire.Sem.Now qualified as Now @@ -65,7 +78,12 @@ interpretTeamSubsystem :: Member Now r, Member SparAPIAccess r, Member ConversationStore r, - Member TeamJournal r + Member TeamJournal r, + Member (Input FanoutLimit) r, + Member (Error InternalError) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member P.TinyLog r ) => TeamSubsystemConfig -> InterpreterFor TeamSubsystem r @@ -79,23 +97,23 @@ interpretTeamSubsystemWithInputConfig :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input TeamSubsystemConfig) r, + Member (Input FanoutLimit) r, Member Now r, Member SparAPIAccess r, Member ConversationStore r, - Member TeamJournal r + Member TeamJournal r, + Member (Error InternalError) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member P.TinyLog r ) => InterpreterFor TeamSubsystem r interpretTeamSubsystemWithInputConfig = interpret $ \case - InternalGetTeamMember uid tid -> do - tms <- TeamStore.getTeamMember tid uid - for tms $ \tm -> do - hasImplicitConsent <- LH.isTeamLegalholdWhitelisted tid - pure $ if hasImplicitConsent then grantImplicitConsent tm else tm - InternalGetTeamMembersWithLimit tid maxResults -> do - tmList <- TeamStore.getTeamMembersWithLimit tid (fromMaybe hardTruncationLimitRange maxResults) - ms <- adjustMembersForImplicitConsent tid (tmList ^. teamMembers) - pure $ newTeamMemberList ms (tmList ^. teamMemberListType) + InternalGetTeamMember uid tid -> + internalGetTeamMemberImpl uid tid + InternalGetTeamMembersWithLimit tid maxResults -> + internalGetTeamMembersWithLimitImpl tid maxResults InternalSelectTeamMemberInfos tid uids -> TeamMemberInfoList <$> TeamStore.selectTeamMemberInfos tid uids InternalSelectTeamMembers tid uids -> do tms <- TeamStore.selectTeamMembers tid uids @@ -106,9 +124,20 @@ interpretTeamSubsystemWithInputConfig = >>= TeamStore.selectTeamMembers tid >>= adjustMembersForImplicitConsent tid pure $ newTeamMemberList admins ListComplete - InternalGetOneUserTeam uid -> TeamStore.getOneUserTeam uid + InternalGetOneUserTeam uid -> + TeamStore.getOneUserTeam uid InternalFinalizeDeleteTeam luid mcon tid -> internalFinalizeDeleteTeamImpl luid mcon tid + GetUserStatus lzusr tid uid -> + getUserStatusImpl lzusr tid uid + AssertTeamExists tid -> + assertTeamExistsImpl tid + GetTeamMembersForFanout tid -> + getTeamMembersForFanoutImpl tid + GetLHStatus teamOfUser other -> + getLHStatusImpl teamOfUser other + GetLHStatusForUsers uids -> + getLHStatusForUsersImpl uids adjustMembersForImplicitConsent :: (Member LegalHoldStore r) => TeamId -> [TeamMember] -> Sem r [TeamMember] adjustMembersForImplicitConsent tid ms = do @@ -123,6 +152,31 @@ grantImplicitConsent = UserLegalHoldPending -> UserLegalHoldPending UserLegalHoldEnabled -> UserLegalHoldEnabled +internalGetTeamMemberImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + UserId -> + TeamId -> + Sem r (Maybe TeamMember) +internalGetTeamMemberImpl uid tid = do + tms <- TeamStore.getTeamMember tid uid + for tms $ \tm -> do + hasImplicitConsent <- LH.isTeamLegalholdWhitelisted tid + pure $ if hasImplicitConsent then grantImplicitConsent tm else tm + +internalGetTeamMembersWithLimitImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + TeamId -> + Maybe FanoutLimit -> + Sem r TeamMemberList +internalGetTeamMembersWithLimitImpl tid maxResults = do + tmList <- TeamStore.getTeamMembersWithLimit tid (fromMaybe hardTruncationLimitRange maxResults) + ms <- adjustMembersForImplicitConsent tid (tmList ^. teamMembers) + pure $ newTeamMemberList ms (tmList ^. teamMemberListType) + -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. internalFinalizeDeleteTeamImpl :: forall r. @@ -204,3 +258,98 @@ internalFinalizeDeleteTeamImpl lusr zcon tid = do let ee' = map (,e) bots let pp' = (p {conn = zcon}) : pp pure (pp', ee' ++ ee) + +-- | Learn whether a user has LH enabled and fetch pre-keys. +-- Note that this is accessible to ANY authenticated user, even ones outside the team +getUserStatusImpl :: + forall r. + ( Member (Error InternalError) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member LegalHoldData.LegalHoldStore r, + Member TeamStore r, + Member P.TinyLog r + ) => + Local UserId -> + TeamId -> + UserId -> + Sem r Public.UserLegalHoldStatusResponse +getUserStatusImpl _lzusr tid uid = do + teamMember <- noteS @'TeamMemberNotFound =<< internalGetTeamMemberImpl uid tid + let status = view legalHoldStatus teamMember + (mlk, lcid) <- case status of + UserLegalHoldNoConsent -> pure (Nothing, Nothing) + UserLegalHoldDisabled -> pure (Nothing, Nothing) + UserLegalHoldPending -> makeResponseDetails + UserLegalHoldEnabled -> makeResponseDetails + pure $ UserLegalHoldStatusResponse status mlk lcid + where + makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails = do + mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid + lastKey <- case mLastKey of + Nothing -> do + P.err + . Log.msg + $ "expected to find a prekey for user: " + <> toByteString' uid + <> " but none was found" + throw NoPrekeyForUser + Just lstKey -> pure lstKey + let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey + pure (Just lastKey, Just clientId) + +assertTeamExistsImpl :: + ( Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) => + TeamId -> + Sem r () +assertTeamExistsImpl tid = do + teamExists <- isJust <$> TeamStore.getTeam tid + if teamExists + then pure () + else throwS @'TeamNotFound + +getTeamMembersForFanoutImpl :: + ( Member TeamStore r, + Member LegalHoldStore r, + Member (Input FanoutLimit) r + ) => + TeamId -> + Sem r TeamMemberList +getTeamMembersForFanoutImpl tid = do + lim <- input + internalGetTeamMembersWithLimitImpl tid (Just lim) + +-- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user +-- doesn't belong to a team. +getLHStatusImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + Maybe TeamId -> + UserId -> + Sem r UserLegalHoldStatus +getLHStatusImpl teamOfUser other = do + case teamOfUser of + Nothing -> pure defUserLegalHoldStatus + Just team -> do + mMember <- internalGetTeamMemberImpl other team + pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember + +-- | Add to every uid the legalhold status +getLHStatusForUsersImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + [UserId] -> + Sem r [(UserId, UserLegalHoldStatus)] +getLHStatusForUsersImpl uids = + mconcat + <$> for + (List.chunksOf 32 uids) + ( \uidsChunk -> do + teamsOfUsers <- TeamStore.getUsersTeams uidsChunk + for uidsChunk $ \uid -> do + (uid,) <$> getLHStatusImpl (Map.lookup uid teamsOfUsers) uid + ) diff --git a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs index f0bde2b2248..6946642238f 100644 --- a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs +++ b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs @@ -30,12 +30,36 @@ module Wire.UserClientIndexStore -- * Delete client deleteClient, deleteClients, + + -- * Helpers + internalGetClientIds, + rmClient, + getClientsId, ) where +import Data.Domain (Domain) import Data.Id +import Data.Proxy (Proxy (..)) +import Data.Qualified +import Data.Range import Galley.Types.Clients +import Imports +import Network.AMQP qualified as Q import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import System.Logger.Message +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error +import Wire.API.Routes.MultiTablePaging +import Wire.BackendNotificationQueueAccess +import Wire.BrigAPIAccess +import Wire.ConversationSubsystem qualified as ConversationSubsystem data UserClientIndexStore m a where GetClients :: [UserId] -> UserClientIndexStore m Clients @@ -44,3 +68,84 @@ data UserClientIndexStore m a where DeleteClients :: UserId -> UserClientIndexStore m () makeSem ''UserClientIndexStore + +internalGetClientIds :: + ( Member BrigAPIAccess r, + Member UserClientIndexStore r, + Member (Input ConversationSubsystemConfig) r + ) => + [UserId] -> + Sem r Clients +internalGetClientIds users = do + cfg <- input + let isInternal = cfg.listClientsUsingBrig + if isInternal + then fromUserClients <$> lookupClients users + else getClients users + +rmClient :: + forall r. + ( Member UserClientIndexStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (Input (Local ())) r, + Member P.TinyLog r + ) => + UserId -> + ClientId -> + Sem r () +rmClient usr cid = do + clients <- getClients [usr] + if (cid `elem` clientIds usr clients) + then do + lusr <- qualifyLocal usr + let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 + firstConvIds <- ConversationSubsystem.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + goConvs nRange1000 firstConvIds lusr + deleteClient usr cid + else + P.debug + ( field "user" (idToText usr) + . field "client" (clientToText cid) + . msg (val "rmClientH: client already gone") + ) + where + goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r () + goConvs range page lusr = do + let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) + for_ localConvs $ \convId -> do + mConv <- ConversationSubsystem.internalGetConversation convId + for_ mConv $ \conv -> do + lconv <- qualifyLocal conv + ConversationSubsystem.removeClient lconv (tUntagged lusr) cid + traverse_ removeRemoteMLSClients (rangedChunks remoteConvs) + when (mtpHasMore page) $ do + let nextState = mtpPagingState page + nextQuery = GetPaginatedConversationIds (Just nextState) range + newCids <- ConversationSubsystem.conversationIdsPageFrom lusr nextQuery + goConvs range newCids lusr + + removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r () + removeRemoteMLSClients convIds = do + for_ (bucketRemote (fromRange convIds)) $ \remoteConvs -> + let rpc = + fedQueueClient + @'OnClientRemovedTag + (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) + in enqueueNotification Q.Persistent remoteConvs rpc + +getClientsId :: + ( Member BrigAPIAccess r, + Member UserClientIndexStore r, + Member (Input ConversationSubsystemConfig) r + ) => + UserId -> + Sem r [ClientId] +getClientsId usr = clientIds usr <$> internalGetClientIds [usr] + +qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) +qualifyLocal a = toLocalUnsafe <$> fmap getDomain input <*> pure a + where + getDomain :: Local () -> Domain + getDomain = tDomain diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs similarity index 59% rename from services/galley/test/unit/Test/Galley/Mapping.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs index 575995457a1..69b7025e092 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs @@ -18,22 +18,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Galley.Mapping where +module Wire.ConversationSubsystem.MappingSpec where import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.API.Mapping import Galley.Types.Error (InternalError) import Imports import Polysemy (Sem) import Polysemy qualified as P import Polysemy.Error qualified as P import Polysemy.TinyLog qualified as P -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Arbitrary (..), Gen, listOf, (==>)) import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role @@ -41,63 +41,61 @@ import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), RemoteConversationV2 (..), ) +import Wire.ConversationSubsystem.Mapping import Wire.Sem.Logger qualified as P import Wire.StoredConversation run :: Sem '[P.TinyLog, P.Error InternalError] a -> Either InternalError a run = P.run . P.runError . P.discardLogs -tests :: TestTree -tests = - testGroup - "ConversationMapping" - [ testProperty "conversation view V9 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (conversationViewV9 luid c)), - testProperty "conversation view V10 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (pure $ conversationView (qualifyAs luid ()) (Just luid) c)), - testProperty "self user in conversation view is correct" $ - \(ConvWithLocalUser c luid) -> - fmap (memId . cmSelf . cnvMembers) (run (conversationViewV9 luid c)) - == Right (tUntagged luid), - testProperty "conversation view metadata is correct" $ - \(ConvWithLocalUser c luid) -> - fmap cnvMetadata (run (conversationViewV9 luid c)) - == Right c.metadata, - testProperty "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c luid) -> case run $ conversationViewV9 luid c of - Left _ -> False - Right cnv -> - tUntagged luid - `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)), - testProperty "conversation view contains all users" $ - \(ConvWithLocalUser c luid) -> - fmap (sort . cnvUids) (run (conversationViewV9 luid c)) - == Right (sort (convUids (tDomain luid) c)), - testProperty "conversation view for an invalid user is empty" $ - \(RandomConversation c) luid -> - notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> - isLeft (run (conversationViewV9 luid c)), - testProperty "remote conversation view for a valid user is non-empty" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - isJust (conversationToRemote dom ruid c), - testProperty "self user role in remote conversation view is correct" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (selfRole . (.members)) (conversationToRemote dom ruid c) - == Just roleNameWireMember, - testProperty "remote conversation view metadata is correct" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (.metadata) (conversationToRemote dom ruid c) - == Just c.metadata, - testProperty "remote conversation view does not contain self" $ - \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of - Nothing -> False - Just rcnv -> - tUntagged ruid - `notElem` map omQualifiedId rcnv.members.others - ] +spec :: Spec +spec = describe "ConversationMapping" do + prop "conversation view V9 for a valid user is non-empty" $ + \(ConvWithLocalUser c luid) -> isRight (run (conversationViewV9 luid c)) + prop "conversation view V10 for a valid user is non-empty" $ + \(ConvWithLocalUser c luid) -> isRight (run (pure $ conversationView (qualifyAs luid ()) (Just luid) c)) + prop "self user in conversation view is correct" $ + \(ConvWithLocalUser c luid) -> + fmap (memId . cmSelf . cnvMembers) (run (conversationViewV9 luid c)) + == Right (tUntagged luid) + prop "conversation view metadata is correct" $ + \(ConvWithLocalUser c luid) -> + fmap cnvMetadata (run (conversationViewV9 luid c)) + == Right c.metadata + prop "other members in conversation view do not contain self" $ + \(ConvWithLocalUser c luid) -> case run $ conversationViewV9 luid c of + Left _ -> False + Right cnv -> + tUntagged luid + `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)) + prop "conversation view contains all users" $ + \(ConvWithLocalUser c luid) -> + fmap (sort . cnvUids) (run (conversationViewV9 luid c)) + == Right (sort (convUids (tDomain luid) c)) + prop "conversation view for an invalid user is empty" $ + \(RandomConversation c) luid -> + notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> + isLeft (run (conversationViewV9 luid c)) + prop "remote conversation view for a valid user is non-empty" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) /= dom ==> + isJust (conversationToRemote dom ruid c) + prop "self user role in remote conversation view is correct" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) /= dom ==> + fmap (selfRole . (.members)) (conversationToRemote dom ruid c) + == Just roleNameWireMember + prop "remote conversation view metadata is correct" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) /= dom ==> + fmap (.metadata) (conversationToRemote dom ruid c) + == Just c.metadata + prop "remote conversation view does not contain self" $ + \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of + Nothing -> False + Just rcnv -> + tUntagged ruid + `notElem` map omQualifiedId rcnv.members.others cnvUids :: OwnConversation -> [Qualified UserId] cnvUids c = diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs similarity index 56% rename from services/galley/test/unit/Test/Galley/API/Message.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs index 18c9512c665..55e9b03d7c6 100644 --- a/services/galley/test/unit/Test/Galley/API/Message.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Galley.API.Message where +module Wire.ConversationSubsystem.MessageSpec where import Control.Lens import Data.Domain @@ -23,27 +23,23 @@ import Data.Id import Data.Map qualified as Map import Data.Set qualified as Set import Data.Set.Lens -import Data.UUID.Types -import Galley.API.Message +import Data.UUID qualified as UUID import Imports -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck ((===), (==>)) import Wire.API.Message import Wire.API.User.Client (QualifiedUserClients (..)) +import Wire.ConversationSubsystem.Message -tests :: TestTree -tests = - testGroup - "Galley.API.Message" - [ testGroup - "checkMessageClients" - [ checkMessageClientSuccess, - checkMessageClientEverythingReported, - checkMessageClientRedundantSender, - checkMessageClientMissingSubsetOfStrategy - ], - testBuildFailedToSend - ] +spec :: Spec +spec = describe "Galley.API.Message" do + describe "checkMessageClients" do + checkMessageClientSuccess + checkMessageClientEverythingReported + checkMessageClientRedundantSender + checkMessageClientMissingSubsetOfStrategy + testBuildFailedToSend flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) flatten = @@ -57,8 +53,8 @@ type QualifiedUserClient = (Domain, UserId, ClientId) recipientSetToMap :: Set QualifiedUserClient -> Map (Domain, UserId) (Set ClientId) recipientSetToMap = Set.foldr (\(d, u, c) m -> Map.insertWith Set.union (d, u) (Set.singleton c) m) mempty -checkMessageClientSuccess :: TestTree -checkMessageClientSuccess = testProperty "success" $ +checkMessageClientSuccess :: Spec +checkMessageClientSuccess = prop "success" $ \(sender :: QualifiedUserClient) (msg :: Map QualifiedUserClient ByteString) (strat :: ClientMismatchStrategy) -> let expectedRecipients = Map.keysSet msg expectedRecipientMap = recipientSetToMap expectedRecipients @@ -66,8 +62,8 @@ checkMessageClientSuccess = testProperty "success" $ checkMessageClients sender expectedRecipientMap msg strat === (True, msg, QualifiedMismatch mempty mempty mempty) -checkMessageClientRedundantSender :: TestTree -checkMessageClientRedundantSender = testProperty "sender should be part of redundant" $ +checkMessageClientRedundantSender :: Spec +checkMessageClientRedundantSender = prop "sender should be part of redundant" $ \(msg0 :: Map QualifiedUserClient ByteString) (sender :: QualifiedUserClient) (strat :: ClientMismatchStrategy) -> let msg = Map.insert sender "msg to self" msg0 expectedRecipients = Map.keysSet msg0 @@ -79,8 +75,8 @@ checkMessageClientRedundantSender = testProperty "sender should be part of redun -- expected'' are used along with msg to generate expected, this ensures that we -- don't always get a disjoint set between the intended recipietns and expected -- recipients. -checkMessageClientEverythingReported :: TestTree -checkMessageClientEverythingReported = testProperty "all intended and expected recipients should be part of valid and extras" $ +checkMessageClientEverythingReported :: Spec +checkMessageClientEverythingReported = prop "all intended and expected recipients should be part of valid and extras" $ \(sender :: QualifiedUserClient) (expected' :: Set QualifiedUserClient) (msg0 :: Map QualifiedUserClient ByteString) (msg' :: Map QualifiedUserClient ByteString) -> let expectedRecipients = Map.keysSet msg0 <> expected' expectedRecipientMap = recipientSetToMap expectedRecipients @@ -92,8 +88,8 @@ checkMessageClientEverythingReported = testProperty "all intended and expected r in validRecipients <> extraRecipients === intendedRecipients <> expectedRecipients -checkMessageClientMissingSubsetOfStrategy :: TestTree -checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should be a subset of the clients determined by the strategy" $ +checkMessageClientMissingSubsetOfStrategy :: Spec +checkMessageClientMissingSubsetOfStrategy = prop "missing clients should be a subset of the clients determined by the strategy" $ \(sender :: QualifiedUserClient) (expected' :: Set QualifiedUserClient) (msg0 :: Map QualifiedUserClient ByteString) (msg' :: Map QualifiedUserClient ByteString) (strat :: ClientMismatchStrategy) -> let expected = Map.keysSet msg0 <> expected' expectedMap = recipientSetToMap expected @@ -103,52 +99,38 @@ checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should missing = flatten . qualifiedUserClients $ qmMissing mismatch in Set.isSubsetOf missing stratClients -testBuildFailedToSend :: TestTree -testBuildFailedToSend = - testGroup - "build failed to send map for post message qualified" - [ testProperty - "Empty case - trivial" - $ collectFailedToSend [] - === mempty, - testProperty - "Empty case - single empty map" - $ collectFailedToSend [mempty] - === mempty, - testProperty - "Empty case - multiple empty maps" - $ collectFailedToSend [mempty, mempty] - === mempty, - testProperty - "Single domain" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty] - === Map.singleton (Domain "foo") mempty, - testProperty - "Single domain duplicated" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] - === Map.singleton (Domain "foo") mempty, - testProperty - "Mutliple domains in multiple maps" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] - === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], - testProperty - "Mutliple domains in single map" - $ collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] - === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], - testProperty - "Single domain duplicated with unique sub-maps" - $ collectFailedToSend - [ Map.singleton (Domain "foo") $ Map.singleton idA mempty, - Map.singleton (Domain "foo") $ Map.singleton idB mempty - ] - === Map.singleton - (Domain "foo") - ( Map.fromList - [ (idA, mempty), - (idB, mempty) - ] - ) - ] +testBuildFailedToSend :: Spec +testBuildFailedToSend = describe "build failed to send map for post message qualified" do + prop "Empty case - trivial" $ + collectFailedToSend [] === mempty + prop "Empty case - single empty map" $ + collectFailedToSend [mempty] === mempty + prop "Empty case - multiple empty maps" $ + collectFailedToSend [mempty, mempty] === mempty + prop "Single domain" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty + prop "Single domain duplicated" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty + prop "Mutliple domains in multiple maps" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)] + prop "Mutliple domains in single map" $ + collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)] + prop "Single domain duplicated with unique sub-maps" $ + collectFailedToSend + [ Map.singleton (Domain "foo") $ Map.singleton idA mempty, + Map.singleton (Domain "foo") $ Map.singleton idB mempty + ] + === Map.singleton + (Domain "foo") + ( Map.fromList + [ (idA, mempty), + (idB, mempty) + ] + ) where - idA = Id $ fromJust $ Data.UUID.Types.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa" - idB = Id $ fromJust $ Data.UUID.Types.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" + idA = Id $ fromJust $ UUID.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa" + idB = Id $ fromJust $ UUID.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs similarity index 80% rename from services/galley/test/unit/Test/Galley/API/One2One.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs index 88a0df0ff57..20c6658d77c 100644 --- a/services/galley/test/unit/Test/Galley/API/One2One.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs @@ -16,36 +16,33 @@ -- with this program. If not, see . -- | Tests for one-to-one conversations -module Test.Galley.API.One2One where +module Wire.ConversationSubsystem.One2OneSpec where import Data.Id import Data.List.Extra import Data.Qualified import Imports -import Test.Tasty -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck import Wire.API.User import Wire.ConversationSubsystem.One2One (one2OneConvId) -tests :: TestTree -tests = - testGroup - "one2OneConvId" - [ testProperty "symmetry" one2OneConvIdSymmetry, - testCase "non-collision" one2OneConvIdNonCollision - ] +spec :: Spec +spec = describe "one2OneConvId" do + prop "symmetry" one2OneConvIdSymmetry + it "non-collision" one2OneConvIdNonCollision one2OneConvIdSymmetry :: BaseProtocolTag -> Qualified UserId -> Qualified UserId -> Property one2OneConvIdSymmetry proto quid1 quid2 = one2OneConvId proto quid1 quid2 === one2OneConvId proto quid2 quid1 -- | Make sure that we never get the same conversation ID for a pair of -- (assumingly) distinct qualified user IDs -one2OneConvIdNonCollision :: Assertion +one2OneConvIdNonCollision :: IO () one2OneConvIdNonCollision = do let len = 10_000 -- A generator of lists of length 'len' of qualified user ID pairs let gen = vectorOf len arbitrary quids <- nubOrd <$> generate gen let hashes = nubOrd (fmap (uncurry (one2OneConvId BaseProtocolProteusTag)) quids) - length hashes @?= length quids + length hashes `shouldBe` length quids diff --git a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs index 5c45b433bc6..78ff882c602 100644 --- a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs @@ -25,6 +25,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range (checked, unsafeRange) import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock import Imports @@ -36,6 +37,8 @@ import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample, ioProperty, (.&&.), (===), (==>)) import Text.Email.Parser (unsafeEmailAddress) +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Meeting qualified as API import Wire.API.Team.Feature import Wire.API.Team.Member (TeamMember, mkTeamMember) @@ -68,6 +71,8 @@ type TestStack = State UTCTime, Random, State StdGen, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, Embed IO ] @@ -81,6 +86,11 @@ interpretFeaturesConfigSubsystemPure configs = interpret $ \case GetAllTeamFeaturesForTeamMember _luid _tid -> pure def GetAllTeamFeaturesForTeam _tid -> pure def GetAllTeamFeaturesForServer -> pure def + GuardSecondFactorDisabled _ _ -> error "not implemented" + FeatureEnabledForTeam _ _ -> error "not implemented" + GetAllTeamFeaturesForUser _ -> error "not implemented" + GetSingleFeatureForUser _ -> error "not implemented" + GetFeatureInternal _ -> error "not implemented" runTestStack :: UTCTime -> @@ -91,6 +101,9 @@ runTestStack :: IO (Either MeetingError a) runTestStack now gen teams configs = runM + . fmap (either (error . show) (either (error . show) Imports.id)) + . runError @(Tagged 'TeamNotFound ()) + . runError @(Tagged 'TeamMemberNotFound ()) . evalState gen . randomToStatefulStdGen . evalState now diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index d64f1e10b5b..88624c7019f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -59,6 +59,7 @@ import Data.Map.Lazy qualified as LM import Data.Map.Strict qualified as M import Data.Proxy import Data.Qualified +import Data.Tagged (Tagged) import Data.Time import Data.Type.Equality import Data.Vector qualified as Vector @@ -77,6 +78,9 @@ import System.Logger qualified as Log import Test.QuickCheck import Type.Reflection import Wire.API.Allowlists (AllowlistEmailDomains) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Federation.API import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -96,10 +100,13 @@ import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Config import Wire.AuthenticationSubsystem.Cookie.Limit import Wire.AuthenticationSubsystem.Interpreter +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BlockListStore +import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ClientStore import Wire.ClientSubsystem import Wire.ClientSubsystem.Interpreter +import Wire.ConversationSubsystem (ConversationSubsystem) import Wire.DeleteQueue import Wire.DeleteQueue.InMemory import Wire.DomainRegistrationStore qualified as DRS @@ -132,6 +139,7 @@ import Wire.TeamCollaboratorsSubsystem import Wire.TeamCollaboratorsSubsystem.Interpreter import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem.GalleyAPI +import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserGroupStore (UserGroupStore) import Wire.UserKeyStore import Wire.UserStore @@ -242,7 +250,8 @@ data MiniBackendParams r = MiniBackendParams teams :: Map TeamId [TeamMember], galleyConfigs :: AllTeamFeatures, usrCfg :: UserSubsystemConfig, - appCfg :: AppSubsystemConfig + appCfg :: AppSubsystemConfig, + conversationCfg :: ConversationSubsystemConfig } -- | `MiniBackendLowerEffects` is not a long, flat list, but a tree of effects. This way we @@ -253,7 +262,13 @@ data MiniBackendParams r = MiniBackendParams -- organize along effect types ("all `State`s"), but the domain ("everything about block -- lists"). type MiniBackendLowerEffects = - '[ TeamSubsystem, + '[ ClientSubsystem, + Input ConversationSubsystemConfig, + BrigAPIAccess, + UserClientIndexStore, + BackendNotificationQueueAccess, + ConversationSubsystem, + TeamSubsystem, EmailSubsystem, NotificationSubsystem, VerificationCodeSubsystem, @@ -281,7 +296,9 @@ type MiniBackendLowerEffects = Events, CryptoSign, Random, - Now + Now, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound ] `Append` InputEffects `Append` '[ Metrics @@ -305,6 +322,10 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . stateEffectsInterpreters mb . ignoreMetrics . inputEffectsInterpreters usrCfg appCfg localBackend.teamIdps + . fmap (either (error . show) Imports.id) + . runError @(Tagged 'TeamNotFound ()) + . fmap (either (error . show) Imports.id) + . runError @(Tagged 'TeamMemberNotFound ()) . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) . runRandomPure . runCryptoSignUnsafe @@ -334,6 +355,29 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . inMemoryNotificationSubsystemInterpreter . noopEmailSubsystemInterpreter . interpretTeamSubsystemToGalleyAPI + . mockConversationSubsystem + . mockBackendNotificationQueueAccess + . mockUserClientIndexStore + . mockBrigAPIAccess + . runInputConst conversationCfg + . runClientSubsystem undefined undefined + where + -- Mock BrigAPIAccess interpreter for tests + mockBrigAPIAccess :: forall r'. InterpreterFor BrigAPIAccess r' + mockBrigAPIAccess = interpret $ \case + _ -> error "Unimplemented BrigAPIAccess operation in mock" + -- Mock UserClientIndexStore interpreter for tests + mockUserClientIndexStore :: forall r'. InterpreterFor UserClientIndexStore r' + mockUserClientIndexStore = interpret $ \case + _ -> error "Unimplemented UserClientIndexStore operation in mock" + -- Mock BackendNotificationQueueAccess interpreter for tests + mockBackendNotificationQueueAccess :: forall r'. InterpreterFor BackendNotificationQueueAccess r' + mockBackendNotificationQueueAccess = interpret $ \case + _ -> error "Unimplemented BackendNotificationQueueAccess operation in mock" + -- Mock ConversationSubsystem interpreter for tests + mockConversationSubsystem :: forall r'. InterpreterFor ConversationSubsystem r' + mockConversationSubsystem = interpretH $ \case + _ -> error "Unimplemented ConversationSubsystem operation in mock" type StateEffects = '[ State [Push], @@ -643,6 +687,14 @@ interpretFederationStackState localBackend backends teams usrCfg = localBackend = localBackend, galleyConfigs = def, appCfg = def, + conversationCfg = + ConversationSubsystemConfig + { listClientsUsingBrig = False, + legalholdDefaults = def, + mlsKeys = Nothing, + maxConvSize = 10, + federationProtocols = Nothing + }, .. } @@ -705,6 +757,14 @@ interpretNoFederationStackState localBackend teams galleyConfigs usrCfg = localBackend = localBackend, galleyConfigs = galleyConfigs, appCfg = def, + conversationCfg = + ConversationSubsystemConfig + { listClientsUsingBrig = False, + legalholdDefaults = def, + mlsKeys = Nothing, + maxConvSize = 10, + federationProtocols = Nothing + }, .. } diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs index 74230077f5a..e0dfadc71cc 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs @@ -41,8 +41,8 @@ type ConversationMembers = Map ConvId (Set UserId) inMemoryConversationSubsystemInterpreter :: (Member (State (Map ConvId StoredConversation)) r, Member (State ConversationMembers) r, Member Random r) => InterpreterFor ConversationSubsystem r -inMemoryConversationSubsystemInterpreter = interpret $ \case - CreateGroupConversation lusr _mconn newConv -> do +inMemoryConversationSubsystemInterpreter = interpretH $ \case + InternalCreateGroupConversation lusr _mconn newConv -> do cid <- Random.newId let conv = StoredConversation @@ -71,8 +71,8 @@ inMemoryConversationSubsystemInterpreter = interpret $ \case } modify (Map.insert cid conv) modify (Map.insert cid (Set.singleton (tUnqualified lusr))) - pure conv + pureT conv InternalGetLocalMember cid uid -> do members <- gets (Map.lookup cid) - pure $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing + pureT $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing _ -> error "ConversationSubsystem: not implemented in mock" diff --git a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs index 31ebb431d53..fba4f321bd2 100644 --- a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs @@ -6,6 +6,7 @@ import Data.LegalHold (UserLegalHoldStatus (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.IO qualified as TL @@ -14,6 +15,7 @@ import Data.X509.CertificateStore qualified as X509 import Imports import Network.Mail.Mime (Address (..), Mail (..), Part (..), PartContent (..)) import Polysemy +import Polysemy.Error (runError) import Polysemy.State import SAML2.WebSSO import System.FilePath @@ -23,6 +25,8 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Email.Parser (unsafeEmailAddress) import URI.ByteString +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Locale import Wire.API.Password import Wire.API.Routes.Internal.Brig (IdpChangedNotification (..)) @@ -347,6 +351,8 @@ runInterpreters :: Logger (Logger.Msg -> Logger.Msg), EmailSending, State [Mail], + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, Embed IO ] a -> @@ -355,6 +361,9 @@ runInterpreters users teamMap teamTemplates branding action = do lr <- newLogRecorder (mails, res) <- runM + . fmap (either (error . show) (either (error . show) Imports.id)) + . runError @(Tagged 'TeamNotFound ()) + . runError @(Tagged 'TeamMemberNotFound ()) . runState @[Mail] [] -- Use runState to capture and return the Mail state . recordingEmailSendingInterpreter . recordLogs lr diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 3cdf8408a41..6861f097797 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -75,10 +75,10 @@ runDependenciesSafe :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UGS.UserGroupSubsystemError (Either ScimSubsystemError a) + Either UGS.LocalErrors (Either ScimSubsystemError a) runDependenciesSafe initialUsers initialTeams = run - . runError + . UGS.runLocalErrors . UGS.interpretDependencies initialUsers initialTeams . UGS.interpretUserGroupSubsystem . mockBrigAPIAccess initialUsers diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index dd2cf24f721..ce135460d02 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -26,6 +26,7 @@ import Data.Id import Data.LegalHold import Data.Map qualified as Map import Data.Qualified +import Data.Tagged (Tagged) import Data.Text.Encoding import Data.Time import Imports @@ -38,6 +39,8 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.EnterpriseLogin +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Team.Invitation import Wire.API.Team.Member import Wire.API.Team.Permission @@ -62,8 +65,7 @@ import Wire.UserSubsystem import Wire.Util type AllEffects = - [ Error TeamInvitationSubsystemError, - EnterpriseLoginSubsystem, + [ EnterpriseLoginSubsystem, TinyLog, TeamSubsystem, GalleyAPIAccess, @@ -75,6 +77,9 @@ type AllEffects = State (Map (InvitationCode) StoredInvitation), Now, State UTCTime, + Error TeamInvitationSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, EmailSubsystem, State (Map EmailAddress [SentMail]), UserSubsystem, @@ -89,7 +94,7 @@ data RunAllEffectsArgs = RunAllEffectsArgs } deriving (Eq, Show) -runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationSubsystemError a +runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either LocalErrors a runAllEffects args = run . runInMemoryUserKeyStoreIntepreterWithStoredUsers args.initialUsers @@ -97,6 +102,7 @@ runAllEffects args = . inMemoryUserSubsystemInterpreter . evalState mempty . noopEmailSubsystemInterpreter + . runLocalErrors . evalState defaultTime . interpretNowAsState . evalState mempty @@ -109,7 +115,26 @@ runAllEffects args = . interpretTeamSubsystemToGalleyAPI . discardTinyLogs . enterpriseLoginSubsystemTestInterpreter args.constGuardResult - . runError + +data LocalErrors + = ETeamMemberNotFound + | ETeamNotFound + | ESubsystem TeamInvitationSubsystemError + deriving stock (Eq, Show) + +runLocalErrors :: + Sem (Error TeamInvitationSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a -> + Sem r (Either LocalErrors a) +runLocalErrors = fmap toLocalErrors . runError . runError . runError + where + toLocalErrors :: + Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either TeamInvitationSubsystemError a)) -> + Either LocalErrors a + toLocalErrors = \case + Right (Right (Right a)) -> Right a + Right (Right (Left e)) -> Left (ESubsystem e) + Right (Left _) -> Left ETeamMemberNotFound + Left _ -> Left ETeamNotFound spec :: Spec spec = do @@ -192,7 +217,7 @@ spec = do -- run the test -- - outcome :: Either TeamInvitationSubsystemError () + outcome :: Either LocalErrors () outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do void $ inviteUser inviterLuid tid invReq @@ -201,11 +226,11 @@ spec = do teamNotAllowedOrWrongTeamIdFails = outcome === case domRegUpd.teamInvite of Allowed -> Right () - NotAllowed -> Left TeamInvitationNotAllowedForEmail + NotAllowed -> Left (ESubsystem TeamInvitationNotAllowedForEmail) Team allowedTid -> if allowedTid == tid then Right () - else Left TeamInvitationNotAllowedForEmail + else Left (ESubsystem TeamInvitationNotAllowedForEmail) backendRedirectOrNoRegistrationFails = case domRegUpd.domainRedirect of Backend _ _ -> @@ -213,7 +238,7 @@ spec = do teamNotAllowedOrWrongTeamIdFails NoRegistration -> if isJust preExistingPersonalAccount - then outcome === Left TeamInvitationNotAllowedForEmail + then outcome === Left (ESubsystem TeamInvitationNotAllowedForEmail) else teamNotAllowedOrWrongTeamIdFails _ -> teamNotAllowedOrWrongTeamIdFails @@ -283,7 +308,7 @@ spec = do constGuardResult = Nothing } - outcome :: Either TeamInvitationSubsystemError () + outcome :: Either LocalErrors () outcome = runAllEffects interpreterArgs . runTeamInvitationSubsystem config $ do void $ inviteUser inviterLuid tid invitationRequest - in pure $ outcome === Left TeamInvitationBlockedDomain + in pure $ outcome === Left (ESubsystem TeamInvitationBlockedDomain) diff --git a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs index c4288743fee..404c0931af3 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs @@ -33,6 +33,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.UUID qualified as UUID import Data.Vector qualified as V import Imports @@ -46,6 +47,8 @@ import System.Timeout (timeout) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Pagination import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll), Route (RouteAny)) import Wire.API.Team.Member as TM @@ -80,26 +83,34 @@ type AllDependencies = BackgroundJobsPublisher.BackgroundJobsPublisher, State [Push], Random.Random, - Error UserGroupSubsystemError + Error UserGroupSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound ] -runDependenciesFailOnError :: (HasCallStack) => [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies (IO ()) -> IO () -runDependenciesFailOnError usrs team = either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team +runDependenciesFailOnError :: + (HasCallStack) => + [StoredUser] -> + Map TeamId [TeamMember] -> + Sem AllDependencies (IO ()) -> + IO () +runDependenciesFailOnError usrs team = + either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team runDependencies :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UserGroupSubsystemError a + Either LocalErrors a runDependencies initialUsers initialTeams = - run . runError . interpretDependencies initialUsers initialTeams + run . runLocalErrors . interpretDependencies initialUsers initialTeams interpretDependencies :: forall r a. [StoredUser] -> Map TeamId [TeamMember] -> Sem (AllDependencies `Append` r) a -> - Sem ('[Error UserGroupSubsystemError] `Append` r) a + Sem ('[Error UserGroupSubsystemError, ErrorS 'TeamMemberNotFound, ErrorS 'TeamNotFound] `Append` r) a interpretDependencies initialUsers initialTeams = Random.randomToNull . evalState mempty @@ -116,10 +127,10 @@ runDependenciesWithReturnState :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UserGroupSubsystemError ([Push], a) + Either LocalErrors ([Push], a) runDependenciesWithReturnState initialUsers initialTeams = run - . runError + . runLocalErrors . Random.randomToNull . runState mempty . noopBackgroundJobsPublisher @@ -131,6 +142,26 @@ runDependenciesWithReturnState initialUsers initialTeams = . interpretTeamSubsystemToGalleyAPI . runInMemoryUserSubsytemInterpreter initialUsers mempty +data LocalErrors + = ETeamMemberNotFound + | ETeamNotFound + | ESubsystem UserGroupSubsystemError + deriving stock (Eq, Show) + +runLocalErrors :: + Sem (Error UserGroupSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a -> + Sem r (Either LocalErrors a) +runLocalErrors = fmap toLocalErrors . runError . runError . runError + where + toLocalErrors :: + Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either UserGroupSubsystemError a)) -> + Either LocalErrors a + toLocalErrors = \case + Right (Right (Right a)) -> Right a + Right (Right (Left e)) -> Left (ESubsystem e) + Right (Left _) -> Left ETeamMemberNotFound + Left _ -> Left ETeamNotFound + expectRight :: (Show err) => Either err Property -> Property expectRight = \case Left err -> counterexample ("Unexpected error: " <> show err) False @@ -231,7 +262,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins should be able to create a group" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -243,7 +274,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team members are allowed in the group" $ \team otherUsers newUserGroupName -> let othersWithoutTeamMembers = filter (\u -> u.teamId /= Just team.tid) otherUsers in notNull othersWithoutTeamMembers - ==> expectLeft UserGroupMemberIsNotInTheSameTeam + ==> expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam) . runDependencies (allUsers team <> otherUsers) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -535,7 +566,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins should be able to update a group" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName newUserGroupName2 -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -603,7 +634,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins can delete user groups" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) groupName -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -662,7 +693,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do newGroupName (team2 :: ArbitraryTeam) (addOrRemove :: Bool) -> - expectLeft UserGroupMemberIsNotInTheSameTeam + expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -675,7 +706,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do newGroupName (team2 :: ArbitraryTeam) (addOrRemove :: Bool) -> - expectLeft UserGroupNotFound + expectLeft (ESubsystem UserGroupNotFound) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 8ba7efffdaa..3d23daa74d6 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -104,6 +104,7 @@ common common-all , bytestring-conversion , case-insensitive , cassandra-util + , comonad , conduit , constraints , containers @@ -142,6 +143,7 @@ common common-all , imports , iproute , iso639 + , kan-extensions , lens , lens-aeson , lrucaching @@ -255,12 +257,47 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem + Wire.ConversationSubsystem.Action + Wire.ConversationSubsystem.Action.Kick + Wire.ConversationSubsystem.Action.Leave + Wire.ConversationSubsystem.Action.Notify + Wire.ConversationSubsystem.Action.Reset + Wire.ConversationSubsystem.Clients + Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.CreateInternal + Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Fetch Wire.ConversationSubsystem.Internal Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.LegalholdConflicts + Wire.ConversationSubsystem.Mapping + Wire.ConversationSubsystem.Message + Wire.ConversationSubsystem.MLS + Wire.ConversationSubsystem.MLS.CheckClients + Wire.ConversationSubsystem.MLS.Commit.Core + Wire.ConversationSubsystem.MLS.Commit.ExternalCommit + Wire.ConversationSubsystem.MLS.Commit.InternalCommit + Wire.ConversationSubsystem.MLS.Conversation + Wire.ConversationSubsystem.MLS.Enabled + Wire.ConversationSubsystem.MLS.GroupInfo + Wire.ConversationSubsystem.MLS.GroupInfoCheck + Wire.ConversationSubsystem.MLS.IncomingMessage + Wire.ConversationSubsystem.MLS.Keys + Wire.ConversationSubsystem.MLS.Message + Wire.ConversationSubsystem.MLS.Migration + Wire.ConversationSubsystem.MLS.One2One + Wire.ConversationSubsystem.MLS.OutOfSync + Wire.ConversationSubsystem.MLS.Propagate + Wire.ConversationSubsystem.MLS.Proposal + Wire.ConversationSubsystem.MLS.Removal + Wire.ConversationSubsystem.MLS.Reset + Wire.ConversationSubsystem.MLS.SubConversation + Wire.ConversationSubsystem.MLS.Util + Wire.ConversationSubsystem.MLS.Welcome Wire.ConversationSubsystem.Notify Wire.ConversationSubsystem.One2One + Wire.ConversationSubsystem.Query + Wire.ConversationSubsystem.Update Wire.ConversationSubsystem.Util Wire.CustomBackendStore Wire.CustomBackendStore.Cassandra @@ -536,6 +573,9 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec Wire.ClientSubsystem.InterpreterSpec + Wire.ConversationSubsystem.MappingSpec + Wire.ConversationSubsystem.MessageSpec + Wire.ConversationSubsystem.One2OneSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec Wire.FederationSubsystem.InternalsSpec Wire.HashPassword.InterpreterSpec diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 20dc97d1263..43059f7fd37 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -27,6 +27,7 @@ import Control.Monad.Catch import Control.Monad.Trans.Control import Data.Domain (Domain) import Data.Map.Strict qualified as Map +import Data.Misc (HttpsUrl) import HTTP2.Client.Manager import Hasql.Pool qualified as Hasql import Hasql.Pool.Extended @@ -46,6 +47,7 @@ import Util.Options import Wire.BackgroundWorker.Options import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (RateLimitEnv, newRateLimitEnv) type IsWorking = Bool @@ -87,7 +89,10 @@ data Env = Env gundeckEndpoint :: Endpoint, sparEndpoint :: Endpoint, galleyEndpoint :: Endpoint, - brigEndpoint :: Endpoint + brigEndpoint :: Endpoint, + settings :: Settings, + convCodeURI :: Either HttpsUrl (Map Text HttpsUrl), + passwordHashingRateLimitEnv :: RateLimitEnv } data BackendNotificationMetrics = BackendNotificationMetrics @@ -138,6 +143,14 @@ mkEnv opts galleyOpts = do galleyEndpoint = opts.galley gundeckEndpoint = opts.gundeck sparEndpoint = opts.spar + settings = opts.settings + let errMsg = "Either conversationCodeURI or multiIngress needs to be set." + convCodeURI <- case (settings.conversationCodeURI, settings.multiIngress) of + (Nothing, Nothing) -> error errMsg + (Nothing, Just mi) -> pure (Right mi) + (Just uri, Nothing) -> pure (Left uri) + (Just _, Just _) -> error errMsg + passwordHashingRateLimitEnv <- newRateLimitEnv settings.passwordHashingRateLimit workerRunningGauge <- mkWorkerRunningGauge hasqlPool <- initPostgresPool opts.postgresqlPool galleyOpts._postgresql galleyOpts._postgresqlPassword amqpJobsPublisherChannel <- diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 4c13bf2d047..d6a7e767079 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,6 +22,7 @@ where import Bilge qualified import Bilge.Retry +import Cassandra (ClientState) import Control.Monad.Catch import Control.Retry import Data.ByteString qualified as BS @@ -32,51 +33,67 @@ import Data.Qualified import Data.Tagged (Tagged) import Data.Text qualified as T import Data.Text.Lazy qualified as TL -import Galley.Types.Error (InternalError, InvalidInput, internalErrorDescription, legalHoldServiceUnavailable) +import Galley.Types.Error (InternalError, internalErrorDescription, legalHoldServiceUnavailable) import Hasql.Pool (UsageError) +import Hasql.Pool qualified as Hasql import Imports import Network.HTTP.Client qualified as Http +import Network.Wai.Utilities.JSONResponse (JSONResponse (..)) import OpenSSL.Session qualified as SSL import Polysemy import Polysemy.Async (asyncToIOFinal) import Polysemy.Conc import Polysemy.Error import Polysemy.Input +import Polysemy.Resource (resourceToIOFinal) import Polysemy.TinyLog qualified as P import Ssl.Util import System.Logger as Logger import System.Logger.Class qualified as Log import URI.ByteString (uriPath) import Wire.API.BackgroundJobs (Job (..)) -import Wire.API.Conversation.Config (ConversationSubsystemConfig) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Error (APIError (toResponse), DynError (..)) import Wire.API.Error.Galley import Wire.API.Federation.Error (FederationError) +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Team.Collaborator (TeamCollaboratorsError) -import Wire.API.Team.FeatureFlags (FeatureDefaults (FeatureLegalHoldDisabledPermanently)) +import Wire.API.Team.Feature (LegalholdConfig) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults (FeatureLegalHoldDisabledPermanently), currentFanoutLimit) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BackgroundJobsRunner (runJob) import Wire.BackgroundJobsRunner.Interpreter hiding (runJob) import Wire.BackgroundWorker.Env (AppT, Env (..)) +import Wire.BackgroundWorker.Options (Settings (..)) import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError) +import Wire.CodeStore.Cassandra (interpretCodeStoreToCassandra) +import Wire.CodeStore.DualWrite (interpretCodeStoreToCassandraAndPostgres) +import Wire.CodeStore.Postgres (interpretCodeStoreToPostgres) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (..), interpretConversationSubsystem) import Wire.ExternalAccess.External import Wire.FeaturesConfigSubsystem (getAllTeamFeaturesForServer) import Wire.FeaturesConfigSubsystem.Interpreter (runFeaturesConfigSubsystem) import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist (..)) import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) +import Wire.FederationSubsystem.Interpreter (runFederationSubsystem) import Wire.FireAndForget (interpretFireAndForget) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) import Wire.GundeckAPIAccess +import Wire.HashPassword.Interpreter (runHashPassword) import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.NotificationSubsystem.Interpreter +import Wire.Options.Galley (GuestLinkTTLSeconds) import Wire.ParseException import Wire.PostgresMigrationOpts +import Wire.ProposalStore.Cassandra (interpretProposalStoreToCassandra) +import Wire.RateLimit (RateLimitExceeded) +import Wire.RateLimit.Interpreter (interpretRateLimit) import Wire.Rpc import Wire.Sem.Concurrency (ConcurrencySafety (Unsafe)) import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) @@ -174,45 +191,53 @@ dispatchJob job = do let makeReq fpr url rb = makeVerifiedRequestIO env.logger extEnv fpr url rb makeReqFresh fpr url rb = makeVerifiedRequestFreshManagerIO env.logger fpr url rb in LegalHoldEnv {makeVerifiedRequest = makeReq, makeVerifiedRequestFreshManager = makeReqFresh} + convCodesStoreInterpreter = + case env.postgresMigration.conversationCodes of + CassandraStorage -> interpretCodeStoreToCassandra + MigrationToPostgresql -> interpretCodeStoreToCassandraAndPostgres + PostgresqlStorage -> interpretCodeStoreToPostgres runFinal @IO . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO . asyncToIOFinal . interpretRace . runDelay + . resourceToIOFinal . runError + . mapError @DynError (T.pack . show . (.eMessage)) + . mapError @JSONResponse (T.pack . show . (.value)) + . mapError @ConversationSubsystemError toResponse . mapError @ClientError (T.pack . displayException) . mapError @FederationError (T.pack . displayException) . mapError @UsageError (T.pack . show) . mapError @ParseException (T.pack . displayException) - . mapError (const ("Invalid input" :: Text) :: InvalidInput -> Text) . mapError @MigrationError (T.pack . show) . mapError @InternalError (TL.toStrict . internalErrorDescription) . mapError @UnreachableBackends (T.pack . show) . mapError @TeamCollaboratorsError (const ("Team collaborators error" :: Text)) . mapError @TeamFeatureStoreError (const ("Team feature store error" :: Text)) - . mapError @(Tagged HistoryNotSupported ()) (const ("History not supported" :: Text)) - . mapError @(Tagged OperationDenied ()) (const ("Operation denied" :: Text)) . mapError @(Tagged 'NotATeamMember ()) (const ("Not a team member" :: Text)) . mapError @(Tagged 'ConvAccessDenied ()) (const ("Conversation access denied" :: Text)) - . mapError @(Tagged 'NotConnected ()) (const ("Not connected" :: Text)) - . mapError @(Tagged 'MLSNotEnabled ()) (const ("MLS not enabled" :: Text)) - . mapError @(Tagged 'MLSNonEmptyMemberList ()) (const ("MLS non-empty member list" :: Text)) - . mapError @(Tagged 'MissingLegalholdConsent ()) (const ("Missing legalhold consent" :: Text)) - . mapError @(Tagged 'NonBindingTeam ()) (const ("Non-binding team" :: Text)) - . mapError @(Tagged 'NoBindingTeamMembers ()) (const ("No binding team members" :: Text)) . mapError @(Tagged 'TeamNotFound ()) (const ("Team not found" :: Text)) - . mapError @(Tagged 'InvalidOperation ()) (const ("Invalid operation" :: Text)) - . mapError @(Tagged 'ConvNotFound ()) (const ("Conversation not found" :: Text)) - . mapError @(Tagged 'ChannelsNotEnabled ()) (const ("Channels not enabled" :: Text)) - . mapError @(Tagged 'NotAnMlsConversation ()) (const ("Not an MLS conversation" :: Text)) + . mapError @(Tagged 'TeamMemberNotFound ()) (const ("Team member not found" :: Text)) + . mapError @(Tagged 'AccessDenied ()) (const ("Access denied" :: Text)) + . mapError @NonFederatingBackends (const ("Non federating backends" :: Text)) + . mapError @UnreachableBackendsLegacy (const ("Unreachable backends legacy" :: Text)) + . mapError @RateLimitExceeded (const ("Rate limit exceeded" :: Text)) . interpretTinyLog env job.requestId job.jobId - . runInputConst env.hasqlPool - . runInputConst (toLocalUnsafe env.federationDomain ()) - . runInputConst (FeatureLegalHoldDisabledPermanently) - . runInputConst env.cassandraGalley - . runInputConst legalHoldEnv - . runInputConst (ExposeInvitationURLsAllowlist []) + . runInputConst @Hasql.Pool env.hasqlPool + . runInputConst @(Local ()) (toLocalUnsafe env.federationDomain ()) + . runInputConst @(FeatureDefaults LegalholdConfig) FeatureLegalHoldDisabledPermanently + . runInputConst @ClientState env.cassandraGalley + . runInputConst @LegalHoldEnv legalHoldEnv + . runInputConst @ExposeInvitationURLsAllowlist (ExposeInvitationURLsAllowlist $ fromMaybe [] env.settings.exposeInvitationURLsTeamAllowlist) + . runInputConst @(Either HttpsUrl (Map Text HttpsUrl)) env.convCodeURI + . runInputConst @IntraListing (IntraListing env.settings.intraListing) + . runInputConst @(Maybe GroupInfoCheckEnabled) (GroupInfoCheckEnabled <$> env.settings.checkGroupInfo) + . runInputConst @(Maybe GuestLinkTTLSeconds) env.settings.guestLinkTTLSeconds + . runInputConst @FanoutLimit (currentFanoutLimit env.settings.maxTeamSize env.settings.maxFanoutSize) + . interpretMLSCommitLockStoreToCassandra env.cassandraGalley + . interpretProposalStoreToCassandra . interpretServiceStoreToCassandra env.cassandraBrig . interpretUserGroupStoreToPostgres . interpretTeamFeatureStoreToCassandra @@ -235,12 +260,20 @@ dispatchJob job = do . interpretBrigAccess env.brigEndpoint . interpretGalleyAPIAccessToRpc mempty env.galleyEndpoint . runInputSem getConversationSubsystemConfig + . runInputSem @(Maybe (MLSKeysByPurpose MLSPrivateKeys)) (inputs @ConversationSubsystemConfig (.mlsKeys)) . runInputSem getConfiguredFeatureFlags + . runHashPassword env.settings.passwordHashingOptions + . interpretRateLimit env.passwordHashingRateLimitEnv + . convCodesStoreInterpreter . interpretExternalAccess extEnv . interpretSparAPIAccessToRpc env.sparEndpoint . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) . interpretFederationAPIAccess federationAPIAccessConfig . interpretTeamSubsystem teamSubsystemConfig + . ( \m -> do + p <- inputs @ConversationSubsystemConfig (.federationProtocols) + runFederationSubsystem p m + ) . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer . interpretTeamCollaboratorsSubsystem @@ -252,6 +285,7 @@ dispatchJob job = do Sem r ConversationSubsystemConfig getConversationSubsystemConfig = getConversationConfig + backendQueueEnv :: Env -> BackendNotificationQueueAccess.Env backendQueueEnv env = BackendNotificationQueueAccess.Env { channelMVar = env.amqpBackendNotificationsChannel, diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index c616d1e5a4e..6109be3d1eb 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -18,16 +18,22 @@ module Wire.BackgroundWorker.Options where import Data.Aeson +import Data.Domain (Domain) +import Data.Id (TeamId) import Data.Misc import Data.Range (Range) import GHC.Generics import Hasql.Pool.Extended import Imports import Network.AMQP.Extended -import System.Logger.Extended +import System.Logger.Extended hiding (Settings) import Util.Options +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.Migration +import Wire.Options.Galley (GuestLinkTTLSeconds) import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (RateLimitConfig) data Opts = Opts { logLevel :: !Level, @@ -50,11 +56,30 @@ data Opts = Opts migrateConversationsOptions :: !MigrationOptions, migrateConversationCodes :: !Bool, migrateTeamFeatures :: !Bool, - backgroundJobs :: BackgroundJobsConfig + backgroundJobs :: BackgroundJobsConfig, + federationDomain :: Domain, + settings :: !Settings } deriving (Show, Generic) deriving (FromJSON) via Generically Opts +data Settings = Settings + { maxTeamSize :: !Word32, + maxFanoutSize :: !(Maybe FanoutLimit), + exposeInvitationURLsTeamAllowlist :: !(Maybe [TeamId]), + maxConvSize :: !Word16, + intraListing :: !Bool, + conversationCodeURI :: !(Maybe HttpsUrl), + multiIngress :: !(Maybe (Map Text HttpsUrl)), + federationProtocols :: !(Maybe [ProtocolTag]), + guestLinkTTLSeconds :: !(Maybe GuestLinkTTLSeconds), + passwordHashingOptions :: !PasswordHashingOptions, + passwordHashingRateLimit :: !RateLimitConfig, + checkGroupInfo :: !(Maybe Bool) + } + deriving (Show, Generic) + deriving (FromJSON) via Generically Settings + data BackendNotificationsConfig = BackendNotificationsConfig { -- | Minimum amount of time (in microseconds) to wait before doing the first -- retry in pushing a notification. Futher retries are done in a jittered diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 30a9c045733..122bd6964f6 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -70,6 +70,7 @@ import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Options import Wire.BackgroundWorker.Util import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (newRateLimitEnv) spec :: Spec spec = do @@ -371,7 +372,23 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined - + settings = + Settings + { maxTeamSize = 1000, + maxFanoutSize = Nothing, + exposeInvitationURLsTeamAllowlist = Nothing, + maxConvSize = 1000, + intraListing = True, + conversationCodeURI = Nothing, + multiIngress = Nothing, + federationProtocols = Nothing, + guestLinkTTLSeconds = Nothing, + passwordHashingOptions = undefined, + passwordHashingRateLimit = undefined, + checkGroupInfo = Nothing + } + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv undefined backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domains <- runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) @@ -412,6 +429,23 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined + settings = + Settings + { maxTeamSize = 1000, + maxFanoutSize = Nothing, + exposeInvitationURLsTeamAllowlist = Nothing, + maxConvSize = 1000, + intraListing = True, + conversationCodeURI = Nothing, + multiIngress = Nothing, + federationProtocols = Nothing, + guestLinkTTLSeconds = Nothing, + passwordHashingOptions = undefined, + passwordHashingRateLimit = undefined, + checkGroupInfo = Nothing + } + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv undefined backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domainsThread <- async $ runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 9810b9c2659..1d410317fe8 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -31,6 +31,7 @@ import Wire.BackgroundWorker.Env hiding (federatorInternal) import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (newRateLimitEnv) testEnv :: IO Env testEnv = do @@ -68,6 +69,23 @@ testEnv = do brigEndpoint = undefined sparEndpoint = Endpoint "localhost" 0 galleyEndpoint = undefined + settings = + Settings + { maxTeamSize = 1000, + maxFanoutSize = Nothing, + exposeInvitationURLsTeamAllowlist = Nothing, + maxConvSize = 1000, + intraListing = True, + conversationCodeURI = Nothing, + multiIngress = Nothing, + federationProtocols = Nothing, + guestLinkTTLSeconds = Nothing, + passwordHashingOptions = undefined, + passwordHashingRateLimit = undefined, + checkGroupInfo = Nothing + } + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv undefined pure Env {..} runTestAppT :: AppT IO a -> Int -> IO a diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index a5eb8d4f30b..2174a9a695b 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -42,6 +42,7 @@ import Data.ZAuth.CryptoSign (CryptoSign, runCryptoSign) import Hasql.Pool (UsageError) import Hasql.Pool qualified as Hasql import Imports +import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Async import Polysemy.Conc @@ -50,6 +51,8 @@ import Polysemy.Error (Error, errorToIOFinal, mapError, runError) import Polysemy.Input (Input, runInputConst) import Polysemy.Internal.Kind import Polysemy.TinyLog (TinyLog) +import Wire.API.Error (ErrorS, errorToWai) +import Wire.API.Error.Galley import Wire.API.Federation.Client qualified import Wire.API.Federation.Error import Wire.API.Team.Collaborator @@ -209,6 +212,10 @@ type BrigLowerLevelEffects = Error VerificationCodeSubsystemError, Error PropertySubsystemError, Error RateLimitExceeded, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, + Error Wai.Error, + Error HttpError, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, DomainVerificationChallengeStore, DomainRegistrationStore, @@ -437,6 +444,10 @@ runBrigToIO e (AppT ma) = do . interpretDomainRegistrationStoreToCassandra e.casClient . interpretDomainVerificationChallengeStoreToCassandra e.casClient e.settings.challengeTTL . interpretFederationAPIAccess federationApiAccessConfig + . rethrowHttpErrorIO + . mapError StdError -- Wai.Error + . mapError (const $ errorToWai @'TeamNotFound) -- ErrorS 'TeamNotFound + . mapError (const $ errorToWai @'TeamMemberNotFound) -- ErrorS 'TeamMemberNotFound . mapError rateLimitExceededToHttpError . mapError propertySubsystemErrorToHttpError . mapError verificationCodeSubsystemErrorToHttpError diff --git a/services/galley/default.nix b/services/galley/default.nix index 2aff9179654..716691efcad 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -18,7 +18,6 @@ , cassandra-util , cassava , cereal -, comonad , conduit , containers , cookie @@ -34,7 +33,6 @@ , galley-types , gitignoreSource , hasql-pool -, hex , hs-opentelemetry-instrumentation-wai , hs-opentelemetry-sdk , HsOpenSSL @@ -88,7 +86,6 @@ , tasty-ant-xml , tasty-cannon , tasty-hunit -, tasty-quickcheck , temporary , text , time @@ -103,8 +100,6 @@ , uri-bytestring , utf8-string , uuid -, uuid-types -, vector , wai , wai-extra , wai-middleware-gunzip @@ -134,16 +129,13 @@ mkDerivation { bytestring-conversion cassandra-util cassava - comonad containers data-default errors exceptions extended - extra galley-types hasql-pool - hex hs-opentelemetry-instrumentation-wai hs-opentelemetry-sdk HsOpenSSL @@ -169,11 +161,9 @@ mkDerivation { servant servant-server singletons - sop-core split ssl-util stm - tagged text time tinylog @@ -184,7 +174,6 @@ mkDerivation { uri-bytestring utf8-string uuid - vector wai wai-extra wai-middleware-gunzip @@ -277,24 +266,6 @@ mkDerivation { wire-subsystems yaml ]; - testHaskellDepends = [ - base - containers - extra - galley-types - imports - lens - polysemy - polysemy-wire-zoo - tasty - tasty-hunit - tasty-quickcheck - types-common - uuid-types - wire-api - wire-api-federation - wire-subsystems - ]; description = "Conversations"; license = lib.licenses.agpl3Only; } diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 8f706554d45..760d46ae5de 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -73,46 +73,12 @@ library -- cabal-fmt: expand src exposed-modules: - Galley.API.Action - Galley.API.Action.Kick - Galley.API.Action.Leave - Galley.API.Action.Notify - Galley.API.Action.Reset - Galley.API.Clients - Galley.API.Create Galley.API.CustomBackend Galley.API.Federation - Galley.API.Federation.Handlers Galley.API.Internal Galley.API.LegalHold - Galley.API.LegalHold.Conflicts - Galley.API.LegalHold.Get Galley.API.LegalHold.Team - Galley.API.Mapping Galley.API.Meetings - Galley.API.Message - Galley.API.MLS - Galley.API.MLS.CheckClients - Galley.API.MLS.Commit.Core - Galley.API.MLS.Commit.ExternalCommit - Galley.API.MLS.Commit.InternalCommit - Galley.API.MLS.Conversation - Galley.API.MLS.Enabled - Galley.API.MLS.GroupInfo - Galley.API.MLS.GroupInfoCheck - Galley.API.MLS.IncomingMessage - Galley.API.MLS.Keys - Galley.API.MLS.Message - Galley.API.MLS.Migration - Galley.API.MLS.One2One - Galley.API.MLS.OutOfSync - Galley.API.MLS.Propagate - Galley.API.MLS.Proposal - Galley.API.MLS.Removal - Galley.API.MLS.Reset - Galley.API.MLS.SubConversation - Galley.API.MLS.Util - Galley.API.MLS.Welcome Galley.API.Public.Bot Galley.API.Public.Conversation Galley.API.Public.CustomBackend @@ -126,13 +92,10 @@ library Galley.API.Public.TeamConversation Galley.API.Public.TeamMember Galley.API.Public.TeamNotification - Galley.API.Query Galley.API.Teams Galley.API.Teams.Export Galley.API.Teams.Features - Galley.API.Teams.Features.Get Galley.API.Teams.Notifications - Galley.API.Update Galley.App Galley.Cassandra Galley.Effects.Queue @@ -241,16 +204,13 @@ library , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 , cassava >=0.5.2 - , comonad , containers >=0.5 , data-default , errors >=2.0 , exceptions >=0.4 , extended - , extra >=1.3 , galley-types >=0.65.0 , hasql-pool - , hex , hs-opentelemetry-instrumentation-wai , hs-opentelemetry-sdk , HsOpenSSL >=0.11 @@ -276,11 +236,9 @@ library , servant , servant-server , singletons - , sop-core , split >=0.2 , ssl-util >=0.1 , stm >=2.4 - , tagged , text >=0.11 , time >=1.4 , tinylog >=0.10 @@ -291,7 +249,6 @@ library , uri-bytestring >=0.2 , utf8-string , uuid >=1.3 - , vector , wai >=3.0 , wai-extra >=3.0 , wai-middleware-gunzip >=0.0.2 @@ -520,35 +477,3 @@ executable galley-schema if flag(static) ld-options: -static - -test-suite galley-tests - import: common-all - type: exitcode-stdio-1.0 - main-is: ../unit.hs - other-modules: - Paths_galley - Run - Test.Galley.API.Message - Test.Galley.API.One2One - Test.Galley.Mapping - - ghc-options: -threaded -with-rtsopts=-N -Wno-x-partial - hs-source-dirs: test/unit - build-depends: - , base - , containers - , extra >=1.3 - , galley - , galley-types - , imports - , lens - , polysemy - , polysemy-wire-zoo - , tasty - , tasty-hunit - , tasty-quickcheck - , types-common - , uuid-types - , wire-api - , wire-api-federation - , wire-subsystems diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs deleted file mode 100644 index 638e2b56cfe..00000000000 --- a/services/galley/src/Galley/API/Create.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Galley.API.Create where - -import Data.Id -import Data.Qualified -import Data.Set qualified as Set -import Galley.API.Mapping -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import Wire.API.Conversation (CreateGroupConversation (..), CreateGroupOwnConversation (..), NewConv, NewOne2OneConv) -import Wire.API.Conversation qualified as Public -import Wire.API.Error.Galley (UnreachableBackendsLegacy (..)) -import Wire.API.Event.Conversation (Connect) -import Wire.API.FederationStatus (RemoteDomains (..)) -import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import Wire.API.User (baseProtocolToProtocol) -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) - ----------------------------------------------------------------------------- --- API Handlers - -createGroupConversationUpToV3 :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error UnreachableBackendsLegacy) r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - Created <$> conversationViewV9 lusr dbConv - -createGroupOwnConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member FederationSubsystem r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) - -createGroupConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member FederationSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - pure $ - CreateGroupConversation - { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, - failedToAdd = mempty - } - -createProteusSelfConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c - -createOne2OneConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - NewOne2OneConv -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversation lusr zcon j = do - (c, created) <- ConversationSubsystem.createOne2OneConversation lusr zcon j - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c - ----------------------------------------------------------------------------- --- Helpers - -createConnectConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Connect -> - Sem r (ConversationResponse Public.OwnConversation) -createConnectConversation lusr conn j = do - (c, created) <- ConversationSubsystem.createConnectConversation lusr conn j - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 560000626df..1b5ea3a958e 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -17,7 +17,6 @@ module Galley.API.Federation where -import Galley.API.Federation.Handlers import Galley.App import Polysemy import Servant (ServerT) @@ -26,6 +25,7 @@ import Wire.API.Federation.API import Wire.API.Federation.Endpoint import Wire.API.Federation.Version import Wire.API.Routes.Named +import Wire.ConversationSubsystem type FederationAPI = "federation" :> FedApi 'Galley @@ -33,26 +33,26 @@ type FederationAPI = "federation" :> FedApi 'Galley federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = - Named @"on-conversation-created" onConversationCreated - :<|> Named @"get-conversations@v1" getConversationsV1 - :<|> Named @"get-conversations" getConversations - :<|> Named @"leave-conversation" leaveConversation - :<|> Named @"send-message" sendMessage - :<|> Named @"update-conversation" updateConversation - :<|> Named @"mls-welcome" mlsSendWelcome - :<|> Named @"send-mls-message" sendMLSMessage - :<|> Named @"send-mls-commit-bundle" sendMLSCommitBundle - :<|> Named @"query-group-info" queryGroupInfo - :<|> Named @"update-typing-indicator" updateTypingIndicator - :<|> Named @"on-typing-indicator-updated" onTypingIndicatorUpdated - :<|> Named @"get-sub-conversation" getSubConversationForRemoteUser - :<|> Named @"delete-sub-conversation" deleteSubConversationForRemoteUser - :<|> Named @"leave-sub-conversation" leaveSubConversation - :<|> Named @"get-one2one-conversation@v1" getOne2OneConversationV1 - :<|> Named @"get-one2one-conversation" getOne2OneConversation - :<|> Named @"on-client-removed" onClientRemoved - :<|> Named @"on-message-sent" onMessageSent - :<|> Named @"on-mls-message-sent" onMLSMessageSent - :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 - :<|> Named @"on-conversation-updated" onConversationUpdated - :<|> Named @"on-user-deleted-conversations" onUserDeleted + Named @"on-conversation-created" federationOnConversationCreated + :<|> Named @"get-conversations@v1" federationGetConversationsV1 + :<|> Named @"get-conversations" federationGetConversations + :<|> Named @"leave-conversation" federationLeaveConversation + :<|> Named @"send-message" federationSendMessage + :<|> Named @"update-conversation" federationUpdateConversation + :<|> Named @"mls-welcome" federationMlsSendWelcome + :<|> Named @"send-mls-message" federationSendMLSMessage + :<|> Named @"send-mls-commit-bundle" federationSendMLSCommitBundle + :<|> Named @"query-group-info" federationQueryGroupInfo + :<|> Named @"update-typing-indicator" federationUpdateTypingIndicator + :<|> Named @"on-typing-indicator-updated" federationOnTypingIndicatorUpdated + :<|> Named @"get-sub-conversation" federationGetSubConversationForRemoteUser + :<|> Named @"delete-sub-conversation" federationDeleteSubConversationForRemoteUser + :<|> Named @"leave-sub-conversation" federationLeaveSubConversation + :<|> Named @"get-one2one-conversation@v1" federationGetOne2OneConversationV1 + :<|> Named @"get-one2one-conversation" federationGetOne2OneConversation + :<|> Named @"on-client-removed" federationOnClientRemoved + :<|> Named @"on-message-sent" federationOnMessageSent + :<|> Named @"on-mls-message-sent" federationOnMLSMessageSent + :<|> Named @(Versioned 'V0 "on-conversation-updated") federationOnConversationUpdatedV0 + :<|> Named @"on-conversation-updated" federationOnConversationUpdated + :<|> Named @"on-user-deleted-conversations" federationOnUserDeleted diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 280fc91d94b..9cc12832427 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -37,19 +37,11 @@ import Data.Qualified import Data.Range import Data.Singletons import Data.Time -import Galley.API.Action -import Galley.API.Clients qualified as Clients -import Galley.API.Create qualified as Create import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) -import Galley.API.LegalHold.Conflicts -import Galley.API.MLS.Removal import Galley.API.Public.Servant -import Galley.API.Query qualified as Query import Galley.API.Teams import Galley.API.Teams qualified as Teams import Galley.API.Teams.Features -import Galley.API.Teams.Features.Get -import Galley.API.Update qualified as Update import Galley.App import Galley.Monad import Galley.Queue qualified as Q @@ -73,7 +65,6 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig.EJPD @@ -82,31 +73,27 @@ import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiTablePaging qualified as MTP import Wire.API.Team.Feature -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FeatureFlags) import Wire.API.User (UserIds (cUsers)) import Wire.API.User.Client import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) -import Wire.ConversationStore +import Wire.ConversationStore hiding (getConversations) import Wire.ConversationStore qualified as ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.One2One -import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem as Conv +import Wire.ConversationSubsystem.LegalholdConflicts (LegalholdConflicts, LegalholdConflictsOldClients) import Wire.CustomBackendStore -import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem import Wire.FederationSubsystem (getFederationStatus) import Wire.LegalHoldStore as LegalHoldStore import Wire.ListItems import Wire.NotificationSubsystem -import Wire.Options.Galley hiding (brig) -import Wire.ProposalStore (ProposalStore) +import Wire.Options.Galley qualified import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -import Wire.Sem.Random (Random) import Wire.ServiceStore import Wire.StoredConversation import Wire.StoredConversation qualified as Data @@ -114,7 +101,7 @@ import Wire.TeamStore import Wire.TeamStore qualified as E import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -import Wire.UserClientIndexStore +import Wire.UserClientIndexStore as UserClientIndexStore import Wire.UserList import Wire.Util @@ -123,13 +110,13 @@ internalAPI = hoistAPI @InternalAPIBase Imports.id $ mkNamedAPI @"status" (pure ()) <@> mkNamedAPI @"delete-user" rmUser - <@> mkNamedAPI @"connect" Create.createConnectConversation + <@> mkNamedAPI @"connect" createConnectConversation <@> mkNamedAPI @"get-conversation-clients" iGetMLSClientListForConv <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH <@> legalholdWhitelistedTeamsAPI <@> iTeamsAPI <@> miscAPI - <@> mkNamedAPI @"upsert-one2one" iUpsertOne2OneConversation + <@> mkNamedAPI @"upsert-one2one" internalUpsertOne2OneConversation <@> featureAPI <@> federationAPI <@> conversationAPI @@ -145,23 +132,20 @@ getConversationConfigH = input iEJPDAPI :: API IEJPDAPI GalleyEffects iEJPDAPI = mkNamedAPI @"get-conversations-by-user" ejpdGetConvInfo --- | An unpaginated, internal http interface to `Query.conversationIdsPageFrom`. Used for +-- | An unpaginated, internal http interface to `conversationIdsPageFrom`. Used for -- EJPD reports. Called locally with very little data for each conv, so we don't expect -- pagination to ever be needed. ejpdGetConvInfo :: forall r. ( Member ConversationStore r, Member ConversationSubsystem r, - Member (Error InternalError) r, - Member (Input (Local ())) r, - Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member P.TinyLog r + Member (Input (Local ())) r ) => UserId -> Sem r [EJPDConvInfo] ejpdGetConvInfo uid = do luid <- qualifyLocal uid - firstPage <- Query.conversationIdsPageFrom luid initialPageRequest + firstPage <- conversationIdsPageFrom luid initialPageRequest getPages luid firstPage where initialPageRequest = mkPageRequest (MTP.MultiTablePagingState MTP.PagingLocals Nothing) @@ -184,7 +168,7 @@ ejpdGetConvInfo uid = do renderedPage <- mapMaybe mk <$> ConversationStore.getConversations (fst $ partitionQualified luid convids) if MTP.mtpHasMore page then do - newPage <- Query.conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) + newPage <- conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) morePages <- getPages luid newPage pure $ renderedPage <> morePages else pure renderedPage @@ -195,14 +179,14 @@ federationAPI = conversationAPI :: API IConversationAPI GalleyEffects conversationAPI = - mkNamedAPI @"conversation-get-member" Query.internalGetMember - <@> mkNamedAPI @"conversation-accept-v2" Update.acceptConv - <@> mkNamedAPI @"conversation-block" Update.blockConv - <@> mkNamedAPI @"conversation-unblock" Update.unblockConv - <@> mkNamedAPI @"conversation-meta" Query.getConversationMeta - <@> mkNamedAPI @"conversation-mls-one-to-one" Query.getMLSOne2OneConversationInternal - <@> mkNamedAPI @"conversation-mls-one-to-one-established" Query.isMLSOne2OneEstablished - <@> mkNamedAPI @"get-conversation-by-id" Query.getLocalConversationInternal + mkNamedAPI @"conversation-get-member" internalGetMember + <@> mkNamedAPI @"conversation-accept-v2" acceptConv + <@> mkNamedAPI @"conversation-block" blockConv + <@> mkNamedAPI @"conversation-unblock" unblockConv + <@> mkNamedAPI @"conversation-meta" getConversationMeta + <@> mkNamedAPI @"conversation-mls-one-to-one" getMLSOne2OneConversationInternal + <@> mkNamedAPI @"conversation-mls-one-to-one-established" isMLSOne2OneEstablished + <@> mkNamedAPI @"get-conversation-by-id" getLocalConversationInternal <@> mkNamedAPI @"is-conversation-out-of-sync" ConversationStore.isConversationOutOfSync legalholdWhitelistedTeamsAPI :: API ILegalholdWhitelistedTeamsAPI GalleyEffects @@ -244,20 +228,20 @@ iTeamsAPI = mkAPI $ \tid -> hoistAPIHandler Imports.id (base tid) <@> mkNamedAPI @"finalize-delete-team" (\lusr mconn -> TeamSubsystem.internalFinalizeDeleteTeam lusr mconn tid $> NoContent) <@> hoistAPISegment ( mkNamedAPI @"get-search-visibility-internal" (Teams.getSearchVisibilityInternal tid) - <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam @SearchVisibilityAvailableConfig) tid) + <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam (Proxy @SearchVisibilityAvailableConfig)) tid) ) miscAPI :: API IMiscAPI GalleyEffects miscAPI = mkNamedAPI @"get-team-members" Teams.getBindingTeamMembers <@> mkNamedAPI @"get-team-id" lookupBindingTeam - <@> mkNamedAPI @"test-get-clients" Clients.getClients + <@> mkNamedAPI @"test-get-clients" UserClientIndexStore.getClientsId <@> mkNamedAPI @"test-add-client" createClient - <@> mkNamedAPI @"test-delete-client" Clients.rmClient + <@> mkNamedAPI @"test-delete-client" rmClient <@> mkNamedAPI @"add-service" createService <@> mkNamedAPI @"delete-service" deleteService - <@> mkNamedAPI @"i-add-bot" Update.addBot - <@> mkNamedAPI @"delete-bot" Update.rmBot + <@> mkNamedAPI @"i-add-bot" addBot + <@> mkNamedAPI @"delete-bot" rmBot <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend @@ -341,7 +325,7 @@ featureAPI = <@> mkNamedAPI @"get-configured-feature-flags" getConfiguredFeatureFlags cellsAPI :: API ICellsAPI GalleyEffects -cellsAPI = mkNamedAPI @"set-cells-state" Update.updateCellsState +cellsAPI = mkNamedAPI @"set-cells-state" updateCellsState getConfiguredFeatureFlags :: forall r. @@ -360,20 +344,13 @@ rmUser :: Member ConversationStore r, Member (Error DynError) r, Member (Error FederationError) r, - Member (Error InternalError) r, - Member ExternalAccess r, Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member TeamSubsystem r, Member Now r, Member (ListItems p2 TeamId) r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, - Member (Input FanoutLimit) r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, Member FeaturesConfigSubsystem r ) => Local UserId -> @@ -383,7 +360,7 @@ rmUser lusr conn = do let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 tids <- listTeams (tUnqualified lusr) Nothing maxBound leaveTeams tids - allConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + allConvIds <- conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) goConvPages nRange1000 allConvIds deleteClients (tUnqualified lusr) @@ -396,7 +373,7 @@ rmUser lusr conn = do when (mtpHasMore page) $ do let nextState = mtpPagingState page nextQuery = GetPaginatedConversationIds (Just nextState) range - newCids <- Query.conversationIdsPageFrom lusr nextQuery + newCids <- conversationIdsPageFrom lusr nextQuery goConvPages range newCids leaveTeams page = for_ (pageItems page) $ \tid -> do @@ -405,7 +382,7 @@ rmUser lusr conn = do getFeatureForTeam @_ @LimitedEventFanoutConfig tid >>= ( \case FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid - FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid + FeatureStatusDisabled -> Right <$> TeamSubsystem.getTeamMembersForFanout tid ) . (.status) uncheckedDeleteTeamMember lusr conn tid (tUnqualified lusr) toNotify @@ -522,7 +499,7 @@ safeForever funName action = guardLegalholdPolicyConflictsH :: ( Member BrigAPIAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MissingLegalholdConsentOldClients) r, diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index c3e6abcfbe4..36a27385089 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -21,7 +21,6 @@ module Galley.API.LegalHold removeSettingsInternalPaging, removeSettings, removeSettings', - getUserStatus, grantConsent, requestDevice, approveDevice, @@ -40,10 +39,7 @@ import Data.Misc import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range (toRange) -import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team -import Galley.API.Query (iterateConversations) -import Galley.API.Update (removeMemberFromLocalConv) import Galley.External.LegalHoldService qualified as LHService import Galley.Types.Error import Imports @@ -54,12 +50,10 @@ import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class qualified as Log import Wire.API.Conversation (ConvType (..), ConversationMetadata (..)) -import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Federation.Error import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.LegalHold @@ -72,21 +66,13 @@ import Wire.API.Team.LegalHold.Internal import Wire.API.Team.Member import Wire.API.User hiding (userId) import Wire.API.User.Client.Prekey -import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess -import Wire.ConversationStore (ConversationStore) import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util -import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem import Wire.FireAndForget import Wire.LegalHoldStore qualified as LegalHoldData -import Wire.NotificationSubsystem -import Wire.ProposalStore (ProposalStore) -import Wire.Sem.Now (Now) import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamMemberStore @@ -97,11 +83,11 @@ import Wire.Util createSettings :: forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'LegalHoldNotEnabled) r, + ( Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceInvalidKey) r, Member (ErrorS 'LegalHoldServiceBadResponse) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member LegalHoldData.LegalHoldStore r, Member P.TinyLog r, Member (Input (FeatureDefaults LegalholdConfig)) r, @@ -120,7 +106,7 @@ createSettings lzusr tid newService = do -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.createSettings") - void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LegalHoldData.validateServiceKey newService.newLegalHoldServiceKey >>= noteS @'LegalHoldServiceInvalidKey @@ -153,37 +139,28 @@ getSettings lzusr tid = do removeSettingsInternalPaging :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldDisableUnimplemented) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member (TeamMemberStore InternalPaging) r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -197,35 +174,26 @@ removeSettings :: Bounded (PagingBounds p TeamMember), Member (TeamMemberStore p) r, Member TeamStore r, - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldDisableUnimplemented) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member LegalHoldData.LegalHoldStore r, + Member (Input (Local ())) r ) => UserId -> TeamId -> @@ -239,7 +207,7 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.removeSettings") - void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldTeamSettings zusrMembership ensureReAuthorised zusr mPassword Nothing Nothing removeSettings' @p tid where @@ -257,30 +225,21 @@ removeSettings' :: forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, - Member ExternalAccess r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, - Member (Input (Local ())) r, + Member TeamSubsystem r, Member LegalHoldData.LegalHoldStore r, Member (TeamMemberStore p) r, Member TeamStore r, - Member ProposalStore r, - Member Random r, Member P.TinyLog r, Member (Embed IO) r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input (Local ())) r ) => TeamId -> Sem r () @@ -308,26 +267,17 @@ removeSettings' tid = -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). grantConsent :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member TeamSubsystem r ) => Local UserId -> TeamId -> @@ -346,10 +296,7 @@ grantConsent lusr tid = do -- | Request to provision a device on the legal hold service for a user requestDevice :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -357,27 +304,21 @@ requestDevice :: Member (ErrorS 'LegalHoldServiceBadResponse) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'MLSLegalholdIncompatible) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'NoUserLegalHoldConsent) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'UserLegalHoldAlreadyEnabled) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -391,7 +332,7 @@ requestDevice lzusr tid uid = do Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.requestDevice") zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldUserSettings zusrMembership member <- noteS @'TeamMemberNotFound =<< TeamSubsystem.internalGetTeamMember uid tid case member ^. legalHoldStatus of UserLegalHoldEnabled -> throwS @'UserLegalHoldAlreadyEnabled @@ -406,7 +347,7 @@ requestDevice lzusr tid uid = do where disallowIfMLSUser :: Local UserId -> Sem r () disallowIfMLSUser luid = do - void $ iterateConversations luid (toRange (Proxy @500)) $ \convs -> do + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do throwS @'MLSLegalholdIncompatible @@ -440,11 +381,8 @@ requestDevice lzusr tid uid = do -- since they are replaced if needed when registering new LH devices. approveDevice :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, + ( Member BrigAPIAccess r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -452,25 +390,19 @@ approveDevice :: Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'NoLegalHoldDeviceAllocated) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'UserLegalHoldAlreadyEnabled) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member (ErrorS 'UserLegalHoldNotPending) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS 'NotATeamMember) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> ConnId -> @@ -486,7 +418,7 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.approveDevice") unless (zusr == tUnqualified luid) $ throwS @'AccessDenied - assertOnTeam (tUnqualified luid) tid + TeamSubsystem.assertOnTeam (tUnqualified luid) tid ensureReAuthorised zusr mPassword Nothing Nothing userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid @@ -521,31 +453,22 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw disableForUser :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -558,7 +481,7 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.disableForUser") zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lzusr) tid - void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldUserSettings zusrMembership userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid @@ -589,25 +512,16 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- enabled, or disabled, make sure the affected connections are screened for policy conflict -- (anybody with no-consent), and put those connections in the appropriate blocked state. changeLegalholdStatusAndHandlePolicyConflicts :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, + Member TeamSubsystem r, Member LegalHoldData.LegalHoldStore r, Member TeamStore r, - Member ProposalStore r, - Member Random r, - Member P.TinyLog r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member P.TinyLog r ) => TeamId -> Local UserId -> @@ -676,7 +590,7 @@ blockNonConsentingConnections uid = do -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do teamsOfUsers <- getUsersTeams others - filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others + filterM (fmap (== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.checkConsent teamsOfUsers) others blockConflicts :: UserId -> [UserId] -> Sem r [String] blockConflicts _ [] = pure [] @@ -708,61 +622,49 @@ unsetTeamLegalholdWhitelistedH tid = do -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. handleGroupConvPolicyConflicts :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, + ( Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, - Member ProposalStore r, - Member P.TinyLog r, - Member Random r, - Member TeamStore r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member TeamSubsystem r ) => Local UserId -> UserLegalHoldStatus -> Sem r () handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do - void $ - iterateConversations luid (toRange (Proxy @500)) $ \convs -> do - for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do - let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.remoteMembers + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do + for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do + let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.remoteMembers - membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do - let mems = conv.localMembers - uidsLHStatus <- getLHStatusForUsers ((.id_) <$> mems) - pure $ - zipWith - ( \mem (mid, status) -> - assert (mem.id_ == mid) $ - if mem.id_ == tUnqualified luid - then (mem, hypotheticalLHStatus) - else (mem, status) - ) - mems - uidsLHStatus + membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do + let mems = conv.localMembers + uidsLHStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> mems) + pure $ + zipWith + ( \mem (mid, status) -> + assert (mem.id_ == mid) $ + if mem.id_ == tUnqualified luid + then (mem, hypotheticalLHStatus) + else (mem, status) + ) + mems + uidsLHStatus - let lcnv = qualifyAs luid conv.id_ - -- we know that this is a group conversation, so invalid operation - -- and conversation not found errors cannot actually be thrown - mapToRuntimeError @'InvalidOperation - (InternalErrorWithDescription "expected group conversation while handling policy conflicts") - . mapToRuntimeError @'ConvNotFound - (InternalErrorWithDescription "conversation disappeared while iterating on a list of conversations") - . mapErrorS @('ActionDenied 'LeaveConversation) @('ActionDenied 'RemoveConversationMember) - $ if any - ((== ConsentGiven) . consentGiven . snd) - (filter ((== roleNameWireAdmin) . (.convRoleName) . fst) membersAndLHStatus) - then do - for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do - let lusr = qualifyAs luid memberNoConsent.id_ - removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) - else do - for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do - let lusr = qualifyAs luid legalholder.id_ - removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) + let lcnv = qualifyAs luid conv.id_ + -- we know that this is a group conversation, so invalid operation + -- and conversation not found errors cannot actually be thrown + mapToRuntimeError @'InvalidOperation + (InternalErrorWithDescription "expected group conversation while handling policy conflicts") + . mapToRuntimeError @'ConvNotFound + (InternalErrorWithDescription "conversation disappeared while iterating on a list of conversations") + . mapErrorS @('ActionDenied 'LeaveConversation) @('ActionDenied 'RemoveConversationMember) + $ if any + ((== TeamSubsystem.ConsentGiven) . TeamSubsystem.consentGiven . snd) + (filter ((== roleNameWireAdmin) . (.convRoleName) . fst) membersAndLHStatus) + then do + for_ (filter ((== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do + let lusr = qualifyAs luid memberNoConsent.id_ + removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) + else do + for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do + let lusr = qualifyAs luid legalholder.id_ + removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) diff --git a/services/galley/src/Galley/API/LegalHold/Get.hs b/services/galley/src/Galley/API/LegalHold/Get.hs deleted file mode 100644 index bc3c036beb7..00000000000 --- a/services/galley/src/Galley/API/LegalHold/Get.hs +++ /dev/null @@ -1,78 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Galley.API.LegalHold.Get (getUserStatus) where - -import Control.Lens (view) -import Data.ByteString.Conversion (toByteString') -import Data.Id -import Data.LegalHold (UserLegalHoldStatus (..)) -import Data.Qualified -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import System.Logger.Class qualified as Log -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Team.LegalHold -import Wire.API.Team.LegalHold qualified as Public -import Wire.API.Team.Member -import Wire.API.User.Client.Prekey -import Wire.LegalHoldStore qualified as LegalHoldData -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem - --- | Learn whether a user has LH enabled and fetch pre-keys. --- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatus :: - forall r. - ( Member (Error InternalError) r, - Member (ErrorS 'TeamMemberNotFound) r, - Member LegalHoldData.LegalHoldStore r, - Member P.TinyLog r, - Member TeamSubsystem r - ) => - Local UserId -> - TeamId -> - UserId -> - Sem r Public.UserLegalHoldStatusResponse -getUserStatus _lzusr tid uid = do - teamMember <- noteS @'TeamMemberNotFound =<< TeamSubsystem.internalGetTeamMember uid tid - let status = view legalHoldStatus teamMember - (mlk, lcid) <- case status of - UserLegalHoldNoConsent -> pure (Nothing, Nothing) - UserLegalHoldDisabled -> pure (Nothing, Nothing) - UserLegalHoldPending -> makeResponseDetails - UserLegalHoldEnabled -> makeResponseDetails - pure $ UserLegalHoldStatusResponse status mlk lcid - where - makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) - makeResponseDetails = do - mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid - lastKey <- case mLastKey of - Nothing -> do - P.err - . Log.msg - $ "expected to find a prekey for user: " - <> toByteString' uid - <> " but none was found" - throw NoPrekeyForUser - Just lstKey -> pure lstKey - let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey - pure (Just lastKey, Just clientId) diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index c7f511d4491..632dff0658d 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -21,19 +21,25 @@ module Galley.API.LegalHold.Team assertLegalHoldEnabledForTeam, ensureNotTooLargeToActivateLegalHold, teamSizeBelowLimit, + ensureReAuthorised, ) where +import Data.Code qualified as Code import Data.Id +import Data.Misc (PlainTextPassword6) import Data.Range import Imports import Polysemy +import Polysemy.Error import Polysemy.Input (Input, input) import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags as Team (FanoutLimit, FeatureDefaults (..)) import Wire.API.Team.Size +import Wire.API.User (VerificationAction) +import Wire.API.User.Auth.ReAuth import Wire.BrigAPIAccess import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) import Wire.LegalHold @@ -94,3 +100,15 @@ teamSizeBelowLimit teamSize = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' pure True + +ensureReAuthorised :: + ( Member BrigAPIAccess r, + Member (Error AuthenticationError) r + ) => + UserId -> + Maybe PlainTextPassword6 -> + Maybe Code.Value -> + Maybe VerificationAction -> + Sem r () +ensureReAuthorised u secret mbAction mbCode = + reauthUser u (ReAuthUser secret mbAction mbCode) >>= fromEither diff --git a/services/galley/src/Galley/API/Public/Bot.hs b/services/galley/src/Galley/API/Public/Bot.hs index ecb4f18eb38..ff47adc6254 100644 --- a/services/galley/src/Galley/API/Public/Bot.hs +++ b/services/galley/src/Galley/API/Public/Bot.hs @@ -18,42 +18,28 @@ module Galley.API.Public.Bot where import Data.Id -import Data.Qualified -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features qualified as Features -import Galley.API.Update import Galley.App import Polysemy -import Polysemy.Input -import Wire.API.Error -import Wire.API.Error.Galley import Wire.API.Event.Team qualified as Public () import Wire.API.Provider.Bot import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Bot -import Wire.ConversationStore (ConversationStore) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) -import Wire.TeamStore (TeamStore) -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.ConversationSubsystem +import Wire.FeaturesConfigSubsystem botAPI :: API BotAPI GalleyEffects botAPI = mkNamedAPI @"post-bot-message-unqualified" postBotMessageUnqualified - <@> mkNamedAPI @"get-bot-conversation" getBotConversation + <@> mkNamedAPI @"get-bot-conversation" getBotConversationH -getBotConversation :: +getBotConversationH :: forall r. - ( Member ConversationStore r, - Member (Input (Local ())) r, - Member (ErrorS 'AccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member TeamStore r, - Member TeamSubsystem r, + ( Member ConversationSubsystem r, Member FeaturesConfigSubsystem r ) => BotId -> ConvId -> Sem r BotConvView -getBotConversation bid cnv = do - Features.guardSecondFactorDisabled (botUserId bid) cnv - Query.getBotConversation bid cnv +getBotConversationH bid cnv = do + guardSecondFactorDisabled (botUserId bid) cnv + getBotConversation bid cnv diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index cbab0c5663a..a54e22548af 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -17,16 +17,12 @@ module Galley.API.Public.Conversation where -import Galley.API.Create -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.SubConversation -import Galley.API.Query -import Galley.API.Update import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = @@ -41,7 +37,7 @@ conversationAPI = <@> mkNamedAPI @"list-conversation-ids-unqualified" conversationIdsPageFromUnqualified <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPageFromV2 DoNotListGlobalSelf) <@> mkNamedAPI @"list-conversation-ids" conversationIdsPageFrom - <@> mkNamedAPI @"get-conversations" getConversations + <@> mkNamedAPI @"get-conversations" getPaginatedConversations <@> mkNamedAPI @"list-conversations@v1" listConversations <@> mkNamedAPI @"list-conversations@v2" listConversations <@> mkNamedAPI @"list-conversations@v5" listConversations diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 0c55a19471b..6fea67c5905 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -20,16 +20,16 @@ module Galley.API.Public.Feature where +import Data.Proxy (Proxy (..)) import Galley.API.Teams import Galley.API.Teams.Features -import Galley.API.Teams.Features.Get import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Feature import Wire.API.Routes.Version import Wire.API.Team.Feature -import Wire.FeaturesConfigSubsystem (getAllTeamFeaturesForTeamMember) +import Wire.FeaturesConfigSubsystem featureAPIGetPut :: forall cfg r. (_) => API (FeatureAPIGetPut cfg) r featureAPIGetPut = @@ -42,7 +42,7 @@ featureAPI = <@> featureAPIGetPut <@> featureAPIGetPut <@> mkNamedAPI @"get-search-visibility" getSearchVisibility - <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam @SearchVisibilityAvailableConfig)) + <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam (Proxy @SearchVisibilityAvailableConfig))) <@> mkNamedAPI @'("get", RequireExternalEmailVerificationConfig) getFeature <@> mkNamedAPI @'("get", DigitalSignaturesConfig) getFeature <@> featureAPIGetPut diff --git a/services/galley/src/Galley/API/Public/LegalHold.hs b/services/galley/src/Galley/API/Public/LegalHold.hs index 04afca327fb..33a5eeb8bb1 100644 --- a/services/galley/src/Galley/API/Public/LegalHold.hs +++ b/services/galley/src/Galley/API/Public/LegalHold.hs @@ -21,6 +21,7 @@ import Galley.API.LegalHold import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.LegalHold +import Wire.TeamSubsystem (getUserStatus) legalHoldAPI :: API LegalHoldAPI GalleyEffects legalHoldAPI = diff --git a/services/galley/src/Galley/API/Public/MLS.hs b/services/galley/src/Galley/API/Public/MLS.hs index 687d9e48276..dafde053b89 100644 --- a/services/galley/src/Galley/API/Public/MLS.hs +++ b/services/galley/src/Galley/API/Public/MLS.hs @@ -17,12 +17,11 @@ module Galley.API.Public.MLS where -import Galley.API.MLS -import Galley.API.MLS.Reset import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.MLS +import Wire.ConversationSubsystem mlsAPI :: API MLSAPI GalleyEffects mlsAPI = diff --git a/services/galley/src/Galley/API/Public/Messaging.hs b/services/galley/src/Galley/API/Public/Messaging.hs index 806484ae908..e96a78dd19c 100644 --- a/services/galley/src/Galley/API/Public/Messaging.hs +++ b/services/galley/src/Galley/API/Public/Messaging.hs @@ -17,10 +17,10 @@ module Galley.API.Public.Messaging where -import Galley.API.Update import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Messaging +import Wire.ConversationSubsystem messagingAPI :: API MessagingAPI GalleyEffects messagingAPI = diff --git a/services/galley/src/Galley/API/Public/Team.hs b/services/galley/src/Galley/API/Public/Team.hs index 7b8575c0e13..db27f6a176a 100644 --- a/services/galley/src/Galley/API/Public/Team.hs +++ b/services/galley/src/Galley/API/Public/Team.hs @@ -17,11 +17,11 @@ module Galley.API.Public.Team where -import Galley.API.Query import Galley.API.Teams import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Team +import Wire.ConversationSubsystem teamAPI :: API TeamAPI GalleyEffects teamAPI = diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index fbf7ed1b748..726a4651258 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -73,13 +73,9 @@ import Data.Proxy import Data.Qualified import Data.Range as Range import Data.Set qualified as Set -import Data.Singletons import Data.Time.Clock (UTCTime) -import Galley.API.Action import Galley.API.LegalHold.Team -import Galley.API.Teams.Features.Get import Galley.API.Teams.Notifications qualified as APITeamQueue -import Galley.API.Update qualified as API import Galley.App import Galley.Effects.Queue qualified as E import Galley.Types.Error as Galley @@ -91,13 +87,13 @@ import Polysemy.TinyLog qualified as P import System.Logger qualified as Log import Wire.API.Conversation (ConvType (..), ConversationRemoveMembers (..)) import Wire.API.Conversation qualified +import Wire.API.Conversation.Action (SConversationActionTag (SConversationRemoveMembersTag)) import Wire.API.Conversation.Role (wireConvRoles) import Wire.API.Conversation.Role qualified as Public import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.LeaveReason import Wire.API.Event.Team -import Wire.API.Federation.Error import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (MultiTablePage (..), MultiTablePagingState (..)) @@ -122,18 +118,15 @@ import Wire.API.User qualified as U import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.BrigAPIAccess qualified as E -import Wire.CodeStore import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.LegalHoldStore (LegalHoldStore) import Wire.ListItems import Wire.ListItems qualified as E import Wire.NotificationSubsystem -import Wire.Options.Galley -import Wire.ProposalStore (ProposalStore) +import Wire.Options.Galley (Opts, maxTeamSize, settings) import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.Sem.Paging.Cassandra @@ -152,7 +145,11 @@ import Wire.Util getTeamH :: forall r. - (Member (ErrorS 'TeamNotFound) r, Member (E.Queue DeleteItem) r, Member TeamStore r, Member TeamSubsystem r) => + ( Member (ErrorS 'TeamNotFound) r, + Member (E.Queue DeleteItem) r, + Member TeamStore r, + Member TeamSubsystem r + ) => UserId -> TeamId -> Sem r Public.Team @@ -262,11 +259,11 @@ createBindingTeam tid zusr body = do updateTeamStatus :: ( Member E.BrigAPIAccess r, - Member (ErrorS 'InvalidTeamStatusUpdate) r, Member (ErrorS 'TeamNotFound) r, Member Now r, Member TeamStore r, - Member TeamJournal r + Member TeamJournal r, + Member (ErrorS InvalidTeamStatusUpdate) r ) => TeamId -> TeamStatusUpdate -> @@ -301,12 +298,12 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (_, _) -> throwS @'InvalidTeamStatusUpdate updateTeamH :: - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS ('MissingPermission ('Just 'SetTeamData))) r, - Member NotificationSubsystem r, + ( Member NotificationSubsystem r, Member Now r, Member TeamStore r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (ErrorS (MissingPermission (Just SetTeamData))) r, + Member (ErrorS NotATeamMember) r ) => UserId -> ConnId -> @@ -315,7 +312,7 @@ updateTeamH :: Sem r () updateTeamH zusr zcon tid updateData = do zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - void $ permissionCheckS SSetTeamData zusrMembership + void $ TeamSubsystem.permissionCheckS SSetTeamData zusrMembership E.setTeamData tid updateData now <- Now.get admins <- E.getTeamAdmins tid @@ -333,15 +330,15 @@ updateTeamH zusr zcon tid updateData = do deleteTeam :: forall r. - ( Member E.BrigAPIAccess r, - Member (Error AuthenticationError) r, - Member (ErrorS 'DeleteQueueFull) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, + ( Member (ErrorS 'DeleteQueueFull) r, Member (ErrorS 'TeamNotFound) r, + Member (ErrorS OperationDenied) r, + Member (Error AuthenticationError) r, Member (E.Queue DeleteItem) r, + Member (ErrorS NotATeamMember) r, Member TeamStore r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member E.BrigAPIAccess r ) => UserId -> ConnId -> @@ -359,7 +356,7 @@ deleteTeam zusr zcon tid body = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< TeamSubsystem.internalGetTeamMember zusr tid + void $ TeamSubsystem.permissionCheck DeleteTeam =<< TeamSubsystem.internalGetTeamMember zusr tid when (tdTeam team ^. teamBinding == Binding) $ do ensureReAuthorised zusr (body ^. tdAuthPassword) (body ^. tdVerificationCode) (Just U.DeleteTeam) @@ -518,14 +515,14 @@ addTeamMember :: Member NotificationSubsystem r, Member (ErrorS 'InvalidPermissions) r, Member (ErrorS 'NoAddToBinding) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, Member (ErrorS 'UserBindingExists) r, Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'NotConnected) r, Member (Input Opts) r, Member Now r, Member LegalHoldStore r, @@ -551,12 +548,12 @@ addTeamMember lzusr zcon tid nmem = do -- verify permissions zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - >>= permissionCheck AddTeamMember + >>= TeamSubsystem.permissionCheck AddTeamMember let targetPermissions = nmem ^. nPermissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] - ensureConnectedToLocals zusr [uid] + E.ensureConnectedToLocals zusr [uid] (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem @@ -655,8 +652,8 @@ updateTeamMember :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TooManyTeamAdmins) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member NotificationSubsystem r, Member Now r, Member P.TinyLog r, @@ -681,7 +678,7 @@ updateTeamMember lzusr zcon tid newMem = do -- get the team and verify permissions user <- TeamSubsystem.internalGetTeamMember zusr tid - >>= permissionCheck SetMemberPermissions + >>= TeamSubsystem.permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user @@ -705,22 +702,21 @@ updateTeamMember lzusr zcon tid newMem = do deleteTeamMember :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member Now r ) => Local UserId -> ConnId -> @@ -733,22 +729,21 @@ deleteTeamMember lusr zcon tid remove body = deleteTeamMember' lusr zcon tid rem deleteNonBindingTeamMember :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member Now r ) => Local UserId -> ConnId -> @@ -761,22 +756,21 @@ deleteNonBindingTeamMember lusr zcon tid remove = deleteTeamMember' lusr zcon ti deleteTeamMember' :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member Now r ) => Local UserId -> ConnId -> @@ -790,7 +784,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do . Log.field "action" (Log.val "Teams.deleteTeamMember") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid targetMember <- TeamSubsystem.internalGetTeamMember remove tid - void $ permissionCheck RemoveTeamMember zusrMember + void $ TeamSubsystem.permissionCheck RemoveTeamMember zusrMember do dm <- noteS @'NotATeamMember zusrMember tm <- noteS @'TeamMemberNotFound targetMember @@ -820,7 +814,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do admins <- E.getTeamAdmins tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Left admins) FeatureStatusDisabled -> do - mems <- getTeamMembersForFanout tid + mems <- TeamSubsystem.getTeamMembersForFanout tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Right mems) pure TeamMemberDeleteCompleted @@ -915,7 +909,7 @@ removeFromConvsAndPushConvLeaveEvent lusr zcon tid remove = do (Set.fromList bots) void $ sendConversationActionNotifications - (sing @'ConversationRemoveMembersTag) + SConversationRemoveMembersTag (tUntagged lusr) True zcon @@ -965,17 +959,7 @@ getTeamConversation zusr tid cid = do pure $ newTeamConversation teamConv deleteTeamConversation :: - ( Member CodeStore r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS ('ActionDenied 'Public.DeleteConversation)) r, - Member ProposalStore r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => + (Member ConversationSubsystem r) => Local UserId -> ConnId -> TeamId -> @@ -983,12 +967,12 @@ deleteTeamConversation :: Sem r () deleteTeamConversation lusr zcon _tid cid = do let lconv = qualifyAs lusr cid - void $ API.deleteLocalConversation lusr zcon lconv + void $ deleteLocalConversation lusr zcon lconv getSearchVisibility :: - ( Member (ErrorS 'NotATeamMember) r, + ( Member TeamStore r, Member (ErrorS OperationDenied) r, - Member TeamStore r, + Member (ErrorS 'NotATeamMember) r, Member TeamSubsystem r ) => Local UserId -> @@ -996,15 +980,15 @@ getSearchVisibility :: Sem r TeamSearchVisibilityView getSearchVisibility luid tid = do zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid - void $ permissionCheck ViewTeamSearchVisibility zusrMembership + void $ TeamSubsystem.permissionCheck ViewTeamSearchVisibility zusrMembership getSearchVisibilityInternal tid setSearchVisibility :: forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, + ( Member TeamStore r, Member (ErrorS 'TeamSearchVisibilityNotEnabled) r, - Member TeamStore r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamSubsystem r ) => (TeamId -> Sem r Bool) -> @@ -1014,7 +998,7 @@ setSearchVisibility :: Sem r () setSearchVisibility availableForTeam luid tid req = do zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid - void $ permissionCheck ChangeTeamSearchVisibility zusrMembership + void $ TeamSubsystem.permissionCheck ChangeTeamSearchVisibility zusrMembership setSearchVisibilityInternal availableForTeam tid req -- Internal ----------------------------------------------------------------- @@ -1176,14 +1160,13 @@ getBindingTeamMembers :: ( Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, Member TeamStore r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => UserId -> Sem r TeamMemberList getBindingTeamMembers zusr = do tid <- E.lookupBindingTeam zusr - getTeamMembersForFanout tid + TeamSubsystem.getTeamMembersForFanout tid -- This could be extended for more checks, for now we test only legalhold -- @@ -1242,8 +1225,8 @@ userIsTeamOwner :: ( Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'NotATeamMember) r, - Member (Input (Local ())) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (Input (Local ())) r ) => TeamId -> UserId -> @@ -1275,9 +1258,9 @@ checkAdminLimit adminCount = updateTeamCollaborator :: forall r. ( Member ConversationStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS NotATeamMember) r, Member P.TinyLog r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamCollaboratorsSubsystem r, Member ConversationSubsystem r, Member TeamSubsystem r @@ -1292,7 +1275,7 @@ updateTeamCollaborator lusr tid rusr perms = do Log.field "targets" (toByteString rusr) . Log.field "action" (Log.val "Teams.updateTeamCollaborator") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - void $ permissionCheck UpdateTeamCollaborator zusrMember + void $ TeamSubsystem.permissionCheck UpdateTeamCollaborator zusrMember when (Set.null $ Set.intersection (Set.fromList [Collaborator.CreateTeamConversation, Collaborator.ImplicitConnection]) perms) $ removeFromConvsAndPushConvLeaveEvent lusr Nothing tid rusr internalUpdateTeamCollaborator rusr tid perms @@ -1301,16 +1284,15 @@ updateTeamCollaborator lusr tid rusr perms = do removeTeamCollaborator :: forall r. ( Member ConversationStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS NotATeamMember) r, Member NotificationSubsystem r, Member ConversationSubsystem r, Member Now r, Member P.TinyLog r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member TeamCollaboratorsSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => Local UserId -> @@ -1322,12 +1304,12 @@ removeTeamCollaborator lusr tid rusr = do Log.field "targets" (toByteString rusr) . Log.field "action" (Log.val "Teams.removeTeamCollaborator") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - void $ permissionCheck RemoveTeamCollaborator zusrMember + void $ TeamSubsystem.permissionCheck RemoveTeamCollaborator zusrMember toNotify <- (getFeatureForTeam @_ @LimitedEventFanoutConfig tid) >>= ( \case FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid - FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid + FeatureStatusDisabled -> Right <$> TeamSubsystem.getTeamMembersForFanout tid ) . (.status) uncheckedDeleteTeamMember lusr Nothing tid rusr toNotify diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index c113e394fa6..46709503d44 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -22,13 +22,9 @@ module Galley.API.Teams.Features ( setFeature, setFeatureInternal, patchFeatureInternal, - getAllTeamFeaturesForTeam, - getAllTeamFeaturesForUser, updateLockStatus, GetFeatureConfig (..), SetFeatureConfig (..), - guardSecondFactorDisabled, - featureEnabledForTeam, guardMlsE2EIdConfig, ) where @@ -43,7 +39,6 @@ import Data.Kind import Data.Qualified (Local) import Galley.API.LegalHold qualified as LegalHold import Galley.API.LegalHold.Team qualified as LegalHold -import Galley.API.Teams.Features.Get import Galley.App import Galley.Types.Error (InternalError) import Imports @@ -59,6 +54,7 @@ import Wire.API.Error.Galley import Wire.API.Event.FeatureConfig import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags import Wire.API.Team.Member @@ -68,10 +64,9 @@ import Wire.BrigAPIAccess (BrigAPIAccess, getAppIdsForTeam, setAccountStatus, up import Wire.CodeStore import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util (assertTeamExists, getTeamMembersForFanout, permissionCheck) import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) -import Wire.FeaturesConfigSubsystem.Types (GetFeatureConfigEffects) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal, getFeatureForTeam) +import Wire.FeaturesConfigSubsystem.Types import Wire.FeaturesConfigSubsystem.Utils (resolveServerFeature) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.FederationSubsystem (FederationSubsystem) @@ -100,12 +95,9 @@ patchFeatureInternal :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r, GetFeatureConfigEffects r ) => @@ -113,7 +105,7 @@ patchFeatureInternal :: LockableFeaturePatch cfg -> Sem r (LockableFeature cfg) patchFeatureInternal tid patch = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid dbFeature <- getDbFeatureRawInternal tid defFeature :: LockableFeature cfg <- resolveServerFeature let dbFeatureWithDefaults = dbFeature.applyDbFeature defFeature @@ -138,13 +130,12 @@ setFeature :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (Error TeamFeatureError) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => UserId -> @@ -153,7 +144,7 @@ setFeature :: Sem r (LockableFeature cfg) setFeature uid tid feat = do zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid - void $ permissionCheck ChangeTeamFeature zusrMembership + void $ TeamSubsystem.permissionCheck ChangeTeamFeature zusrMembership setFeatureUnchecked tid feat setFeatureInternal :: @@ -162,20 +153,17 @@ setFeatureInternal :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'TeamNotFound) r, Member (Error TeamFeatureError) r, - Member TeamStore r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> Feature cfg -> Sem r (LockableFeature cfg) setFeatureInternal tid feat = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid setFeatureUnchecked tid feat setFeatureUnchecked :: @@ -188,7 +176,6 @@ setFeatureUnchecked :: Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -203,14 +190,13 @@ updateLockStatus :: forall cfg r. ( IsFeatureConfig cfg, Member TeamFeatureStore r, - Member TeamStore r, - Member (ErrorS 'TeamNotFound) r + Member TeamSubsystem r ) => TeamId -> LockStatus -> Sem r LockStatusResponse updateLockStatus tid lockStatus = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid setFeatureLockStatus @cfg tid lockStatus pure $ LockStatusResponse lockStatus @@ -231,15 +217,14 @@ pushFeatureEvent :: forall cfg r. ( IsFeatureConfig cfg, Member NotificationSubsystem r, - Member P.TinyLog r, - Member (Input FanoutLimit) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member P.TinyLog r ) => TeamId -> Event -> Sem r () pushFeatureEvent tid event = do - memList <- getTeamMembersForFanout tid + memList <- TeamSubsystem.getTeamMembersForFanout tid if ((memList ^. teamMemberListType) == ListTruncated) then do P.warn $ @@ -270,7 +255,6 @@ setFeatureForTeam :: Member P.TinyLog r, Member NotificationSubsystem r, Member TeamFeatureStore r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -413,7 +397,7 @@ instance SetFeatureConfig SndFactorPasswordChallengeConfig instance SetFeatureConfig SearchVisibilityInboundConfig where type SetFeatureForTeamConstraints SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAPIAccess r) prepareFeature tid feat = do - updateSearchVisibilityInbound $ toTeamStatus tid feat + updateSearchVisibilityInbound $ Multi.TeamStatus tid feat.status instance SetFeatureConfig MLSConfig where type diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs deleted file mode 100644 index 231aa5d3c85..00000000000 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Galley.API.Teams.Features.Get - ( getFeature, - getFeatureInternal, - getAllTeamFeaturesForServer, - getAllTeamFeaturesForTeam, - getAllTeamFeaturesForUser, - getSingleFeatureForUser, - GetFeatureConfig (..), - getFeatureForTeam, - guardSecondFactorDisabled, - DoAuth (..), - featureEnabledForTeam, - toTeamStatus, - ) -where - -import Control.Error (hush) -import Data.Id -import Data.SOP -import Data.Tagged -import Imports -import Polysemy -import Polysemy.Error -import Wire.API.Conversation (cnvmTeam) -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi -import Wire.API.Team.Feature -import Wire.ConversationStore as ConversationStore -import Wire.ConversationSubsystem.Util -import Wire.FeaturesConfigSubsystem -import Wire.FeaturesConfigSubsystem.Types -import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem - --- FUTUREWORK: everything in this module should be moved to the FeatureConfigSubsystem -data DoAuth = DoAuth UserId | DontDoAuth - -getFeatureInternal :: - ( GetFeatureConfig cfg, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => - TeamId -> - Sem r (LockableFeature cfg) -getFeatureInternal tid = do - assertTeamExists tid - getFeatureForTeam tid - -toTeamStatus :: TeamId -> LockableFeature cfg -> Multi.TeamStatus cfg -toTeamStatus tid feat = Multi.TeamStatus tid feat.status - -getTeamAndCheckMembership :: - ( Member TeamStore.TeamStore r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamSubsystem r - ) => - UserId -> - Sem r (Maybe TeamId) -getTeamAndCheckMembership uid = do - mTid <- TeamStore.getOneUserTeam uid - for_ mTid $ \tid -> do - zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid - void $ maybe (throwS @'NotATeamMember) pure zusrMembership - assertTeamExists tid - pure mTid - -getAllTeamFeatures :: - forall r. - (Member FeaturesConfigSubsystem r) => - TeamId -> - Sem r AllTeamFeatures -getAllTeamFeatures tid = getAllTeamFeaturesForTeam tid - -getAllTeamFeaturesForUser :: - forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member TeamSubsystem r, - Member FeaturesConfigSubsystem r, - GetFeatureConfigEffects r - ) => - UserId -> - Sem r AllTeamFeatures -getAllTeamFeaturesForUser uid = do - mTid <- getTeamAndCheckMembership uid - case mTid of - Nothing -> hsequence' $ hcpure (Proxy @(GetAllTeamFeaturesForUserConstraints r)) $ Comp $ getFeatureForUser uid - Just tid -> getAllTeamFeatures tid - -getSingleFeatureForUser :: - forall cfg r. - ( GetFeatureConfig cfg, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member TeamSubsystem r, - Member FeaturesConfigSubsystem r - ) => - UserId -> - Sem r (LockableFeature cfg) -getSingleFeatureForUser uid = do - mTid <- getTeamAndCheckMembership uid - getFeatureForTeamUser @_ @cfg uid mTid - --- | If second factor auth is enabled, make sure that end-points that don't support it, but --- should, are blocked completely. (This is a workaround until we have 2FA for those --- end-points as well.) --- --- This function exists to resolve a cyclic dependency. -guardSecondFactorDisabled :: - forall r. - ( Member (ErrorS 'AccessDenied) r, - Member TeamStore.TeamStore r, - Member ConversationStore r, - Member FeaturesConfigSubsystem r - ) => - UserId -> - ConvId -> - Sem r () -guardSecondFactorDisabled uid cid = do - mTid <- fmap hush . runError @() $ do - convData <- ConversationStore.getConversationMetadata cid >>= note () - tid <- note () convData.cnvmTeam - mapError (unTagged @'TeamNotFound @()) $ assertTeamExists tid - pure tid - - tf <- getFeatureForTeamUser @_ @SndFactorPasswordChallengeConfig uid mTid - case tf.status of - FeatureStatusDisabled -> pure () - FeatureStatusEnabled -> throwS @'AccessDenied - -featureEnabledForTeam :: - forall cfg r. - ( GetFeatureConfig cfg, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => - TeamId -> - Sem r Bool -featureEnabledForTeam tid = - (==) FeatureStatusEnabled - . (.status) - <$> getFeatureInternal @cfg tid diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 8ee5e1e092b..ef8c2026fd8 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -52,7 +52,6 @@ import Data.Misc import Data.Qualified import Data.Range import Data.Text qualified as Text -import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled (GroupInfoCheckEnabled)) import Galley.Effects.Queue qualified as GE import Galley.Env import Galley.External.LegalHoldService.Internal qualified as LHInternal @@ -106,8 +105,8 @@ import Wire.CodeStore.Postgres import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres -import Wire.ConversationSubsystem (ConversationSubsystem) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (IntraListing), interpretConversationSubsystem) import Wire.CustomBackendStore import Wire.CustomBackendStore.Cassandra import Wire.Error @@ -233,6 +232,8 @@ type GalleyEffects = Input FanoutLimit, Input (FeatureDefaults LegalholdConfig), Input (Local ()), + Input IntraListing, + Input (Maybe GuestLinkTTLSeconds), Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)), Input (Maybe GroupInfoCheckEnabled), Input Opts, @@ -242,7 +243,10 @@ type GalleyEffects = Error Meeting.MeetingError, Error DynError, Error RateLimitExceeded, + Error ConversationSubsystemError, ErrorS OperationDenied, + ErrorS 'AccessDenied, + ErrorS 'TeamMemberNotFound, ErrorS 'HistoryNotSupported, ErrorS 'NotATeamMember, ErrorS 'ConvAccessDenied, @@ -292,7 +296,7 @@ type GalleyEffects = validateOptions :: Opts -> IO (Either HttpsUrl (Map Text HttpsUrl)) validateOptions o = do let settings' = view settings o - optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit o + optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit settings'._maxTeamSize settings'._maxFanoutSize when (settings'._maxConvSize > fromIntegral optFanoutLimit) $ error "setMaxConvSize cannot be > setTruncationLimit" when (settings' ^. maxTeamSize < optFanoutLimit) $ @@ -501,7 +505,10 @@ evalGalley e = . mapError toResponse -- ErrorS 'ConvAccessDenied . mapError toResponse -- ErrorS 'NotATeamMember . mapError toResponse -- ErrorS 'HistoryNotSupported + . mapError toResponse -- ErrorS 'TeamMemberNotFound + . mapError toResponse -- ErrorS 'AccessDenied . mapError toResponse -- ErrorS OperationDenied + . mapError toResponse -- Error ConversationSubsystemError, . mapError rateLimitExceededToHttpError . mapError toResponse -- DynError . mapError meetingError @@ -511,9 +518,11 @@ evalGalley e = . runInputConst (e ^. options) . runInputConst (GroupInfoCheckEnabled <$> e._options._settings._checkGroupInfo) . runInputConst e._mlsKeys + . runInputConst e._options._settings._guestLinkTTLSeconds + . runInputConst (IntraListing e._options._settings._intraListing) . runInputConst localUnit . interpretTeamFeatureSpecialContext e - . runInputConst (currentFanoutLimit (e ^. options)) + . runInputConst (currentFanoutLimitOpts (e ^. options)) . runInputSem (inputs @Opts $ view (O.settings . O.featureFlags)) . runInputSem (inputs @Opts $ ExposeInvitationURLsAllowlist . fromMaybe [] . view (O.settings . O.exposeInvitationURLsTeamAllowlist)) . interpretInternalTeamListToCassandra diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 80de4fb949c..009ac952546 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -18,13 +18,35 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Env where +module Galley.Env + ( Env (..), + DeleteItem (..), + reqId, + options, + applog, + manager, + http2Manager, + Galley.Env.federator, + Galley.Env.brig, + cstate, + hasqlPool, + deleteQueue, + extEnv, + aEnv, + mlsKeys, + rabbitmqChannel, + convCodeURI, + passwordHashingRateLimitEnv, + reqIdMsg, + notificationSubsystemConfig, + currentFanoutLimitOpts, + ) +where import Cassandra import Control.Lens hiding ((.=)) import Data.Id import Data.Misc (HttpsUrl) -import Data.Range import Data.Time.Clock.DiffTime (millisecondsToDiffTime) import Galley.Queue qualified as Q import HTTP2.Client.Manager (Http2Manager) @@ -36,6 +58,7 @@ import System.Logger import Util.Options import Wire.API.MLS.Keys import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags qualified as FeatureFlags import Wire.AWS qualified as Aws import Wire.ExternalAccess.External import Wire.NotificationSubsystem.Interpreter @@ -72,21 +95,19 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -currentFanoutLimit :: Opts -> FanoutLimit -currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit (o ^. (O.settings . maxFanoutSize)) - let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) - unsafeRange (min maxSize optFanoutLimit) - notificationSubsystemConfig :: Env -> NotificationSubsystemConfig notificationSubsystemConfig env = - NotificationSubsystemConfig - { chunkSize = defaultChunkSize, - fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = - maybe - defaultSlowPushDelay - (millisecondsToDiffTime . toInteger) - (env ^. options . O.settings . deleteConvThrottleMillis), - requestId = env ^. reqId - } + let settings' = env._options._settings + in NotificationSubsystemConfig + { chunkSize = defaultChunkSize, + fanoutLimit = FeatureFlags.currentFanoutLimit settings'._maxTeamSize settings'._maxFanoutSize, + slowPushDelay = + maybe + defaultSlowPushDelay + (millisecondsToDiffTime . toInteger) + (env ^. options . O.settings . deleteConvThrottleMillis), + requestId = env ^. reqId + } + +currentFanoutLimitOpts :: Opts -> FanoutLimit +currentFanoutLimitOpts opts = FeatureFlags.currentFanoutLimit opts._settings._maxTeamSize opts._settings._maxFanoutSize diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7ada3332644..699641b425b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -66,7 +66,6 @@ import Data.Text.Ascii qualified as Ascii import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer hiding (status) -import Galley.API.Mapping import Imports hiding (id) import Imports qualified as I import Network.HTTP.Types.Status qualified as HTTP @@ -104,6 +103,7 @@ import Wire.API.Team.Member qualified as Teams import Wire.API.User import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) +import Wire.ConversationSubsystem.Mapping import Wire.Options.Galley (federator, rabbitmq) import Wire.StoredConversation hiding (convName) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 04263221b24..472092c6741 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1280,7 +1280,7 @@ testBillingInLargeTeam = do refreshIndex opts <- view tsGConf galley <- viewGalley - let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts + let fanoutLimit = fromRange $ Galley.currentFanoutLimitOpts opts allOwnersBeforeFanoutLimit <- foldM ( \billingMembers n -> do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index f24abb8ada7..db9e3db7d0c 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -173,7 +173,7 @@ testRemoveLegalHoldFromTeam = do testAddTeamUserTooLargeWithLegalholdWhitelisted :: (HasCallStack) => TestM () testAddTeamUserTooLargeWithLegalholdWhitelisted = withTeam $ \owner tid -> do o <- view tsGConf - let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimitOpts o forM_ [2 .. (fanoutLimit + 5)] $ \_n -> do addUserToTeam' owner tid !!! do const 201 === statusCode diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 222c2af34bf..734af584d74 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -200,7 +200,7 @@ testRemoveLegalHoldFromTeam = do testEnablePerTeamTooLarge :: TestM () testEnablePerTeamTooLarge = do o <- view tsGConf - let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimitOpts o -- TODO: it is impossible in this test to create teams bigger than the fanout limit. -- Change the +1 to anything else and look at the logs (tid, _owner, _others) <- createBindingTeamWithMembers (fanoutLimit + 5) @@ -215,7 +215,7 @@ testEnablePerTeamTooLarge = do testAddTeamUserTooLargeWithLegalhold :: TestM () testAddTeamUserTooLargeWithLegalhold = do o <- view tsGConf - let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimitOpts o (tid, owner, _others) <- createBindingTeamWithMembers fanoutLimit feat :: Public.Feature Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid --- --- 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 Run - ( main, - ) -where - -import Imports -import Test.Galley.API.Message qualified -import Test.Galley.API.One2One qualified -import Test.Galley.Mapping qualified -import Test.Tasty - -main :: IO () -main = - defaultMain $ - testGroup - "Tests" - [ Test.Galley.API.Message.tests, - Test.Galley.API.One2One.tests, - Test.Galley.Mapping.tests - ] From d480408bfc00b63926ad2f1335f6a7db59990e59 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 20 Apr 2026 11:47:49 +0200 Subject: [PATCH 02/39] fix: use `galleyOpts` instead of add fields in background-worker options --- .../src/Wire/BackgroundWorker/Env.hs | 36 ++++++++++---- .../Wire/BackgroundWorker/Jobs/Registry.hs | 13 +++-- .../src/Wire/BackgroundWorker/Options.hs | 29 +---------- .../Wire/BackendNotificationPusherSpec.hs | 48 +++++++------------ .../background-worker/test/Test/Wire/Util.hs | 23 ++++----- 5 files changed, 61 insertions(+), 88 deletions(-) diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 43059f7fd37..fd30d31cd1e 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -26,6 +26,7 @@ import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control import Data.Domain (Domain) +import Data.Id (TeamId) import Data.Map.Strict qualified as Map import Data.Misc (HttpsUrl) import HTTP2.Client.Manager @@ -44,7 +45,10 @@ import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..)) import System.Logger.Extended qualified as Log import Util.Options +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.BackgroundWorker.Options +import Wire.Options.Galley (GuestLinkTTLSeconds) import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter (RateLimitEnv, newRateLimitEnv) @@ -90,7 +94,14 @@ data Env = Env sparEndpoint :: Endpoint, galleyEndpoint :: Endpoint, brigEndpoint :: Endpoint, - settings :: Settings, + maxTeamSize :: !Word32, + maxFanoutSize :: !(Maybe FanoutLimit), + exposeInvitationURLsTeamAllowlist :: !(Maybe [TeamId]), + intraListing :: !Bool, + federationProtocols :: !(Maybe [ProtocolTag]), + guestLinkTTLSeconds :: !(Maybe GuestLinkTTLSeconds), + passwordHashingOptions :: !PasswordHashingOptions, + checkGroupInfo :: !(Maybe Bool), convCodeURI :: Either HttpsUrl (Map Text HttpsUrl), passwordHashingRateLimitEnv :: RateLimitEnv } @@ -143,14 +154,14 @@ mkEnv opts galleyOpts = do galleyEndpoint = opts.galley gundeckEndpoint = opts.gundeck sparEndpoint = opts.spar - settings = opts.settings - let errMsg = "Either conversationCodeURI or multiIngress needs to be set." - convCodeURI <- case (settings.conversationCodeURI, settings.multiIngress) of - (Nothing, Nothing) -> error errMsg - (Nothing, Just mi) -> pure (Right mi) - (Just uri, Nothing) -> pure (Left uri) - (Just _, Just _) -> error errMsg - passwordHashingRateLimitEnv <- newRateLimitEnv settings.passwordHashingRateLimit + maxTeamSize = galleyOpts._settings._maxTeamSize + maxFanoutSize = galleyOpts._settings._maxFanoutSize + exposeInvitationURLsTeamAllowlist = galleyOpts._settings._exposeInvitationURLsTeamAllowlist + intraListing = galleyOpts._settings._intraListing + federationProtocols = galleyOpts._settings._federationProtocols + guestLinkTTLSeconds = galleyOpts._settings._guestLinkTTLSeconds + passwordHashingOptions = galleyOpts._settings._passwordHashingOptions + checkGroupInfo = galleyOpts._settings._checkGroupInfo workerRunningGauge <- mkWorkerRunningGauge hasqlPool <- initPostgresPool opts.postgresqlPool galleyOpts._postgresql galleyOpts._postgresqlPassword amqpJobsPublisherChannel <- @@ -159,6 +170,13 @@ mkEnv opts galleyOpts = do amqpBackendNotificationsChannel <- mkRabbitMqChannelMVar logger (Just "background-worker-backend-notifications") $ either id demoteOpts opts.rabbitmq.unRabbitMqOpts + let errMsg = "Either conversationCodeURI or multiIngress needs to be set." + convCodeURI <- case (galleyOpts._settings._conversationCodeURI, galleyOpts._settings._multiIngress) of + (Nothing, Nothing) -> error errMsg + (Nothing, Just mi) -> pure (Right mi) + (Just uri, Nothing) -> pure (Left uri) + (Just _, Just _) -> error errMsg + passwordHashingRateLimitEnv <- newRateLimitEnv galleyOpts._settings._passwordHashingRateLimit pure Env {..} initHttp2Manager :: IO Http2Manager diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index d6a7e767079..c670bea0f45 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -65,7 +65,6 @@ import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRa import Wire.BackgroundJobsRunner (runJob) import Wire.BackgroundJobsRunner.Interpreter hiding (runJob) import Wire.BackgroundWorker.Env (AppT, Env (..)) -import Wire.BackgroundWorker.Options (Settings (..)) import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError) import Wire.CodeStore.Cassandra (interpretCodeStoreToCassandra) @@ -230,12 +229,12 @@ dispatchJob job = do . runInputConst @(FeatureDefaults LegalholdConfig) FeatureLegalHoldDisabledPermanently . runInputConst @ClientState env.cassandraGalley . runInputConst @LegalHoldEnv legalHoldEnv - . runInputConst @ExposeInvitationURLsAllowlist (ExposeInvitationURLsAllowlist $ fromMaybe [] env.settings.exposeInvitationURLsTeamAllowlist) + . runInputConst @ExposeInvitationURLsAllowlist (ExposeInvitationURLsAllowlist $ fromMaybe [] env.exposeInvitationURLsTeamAllowlist) . runInputConst @(Either HttpsUrl (Map Text HttpsUrl)) env.convCodeURI - . runInputConst @IntraListing (IntraListing env.settings.intraListing) - . runInputConst @(Maybe GroupInfoCheckEnabled) (GroupInfoCheckEnabled <$> env.settings.checkGroupInfo) - . runInputConst @(Maybe GuestLinkTTLSeconds) env.settings.guestLinkTTLSeconds - . runInputConst @FanoutLimit (currentFanoutLimit env.settings.maxTeamSize env.settings.maxFanoutSize) + . runInputConst @IntraListing (IntraListing env.intraListing) + . runInputConst @(Maybe GroupInfoCheckEnabled) (GroupInfoCheckEnabled <$> env.checkGroupInfo) + . runInputConst @(Maybe GuestLinkTTLSeconds) env.guestLinkTTLSeconds + . runInputConst @FanoutLimit (currentFanoutLimit env.maxTeamSize env.maxFanoutSize) . interpretMLSCommitLockStoreToCassandra env.cassandraGalley . interpretProposalStoreToCassandra . interpretServiceStoreToCassandra env.cassandraBrig @@ -262,7 +261,7 @@ dispatchJob job = do . runInputSem getConversationSubsystemConfig . runInputSem @(Maybe (MLSKeysByPurpose MLSPrivateKeys)) (inputs @ConversationSubsystemConfig (.mlsKeys)) . runInputSem getConfiguredFeatureFlags - . runHashPassword env.settings.passwordHashingOptions + . runHashPassword env.passwordHashingOptions . interpretRateLimit env.passwordHashingRateLimitEnv . convCodesStoreInterpreter . interpretExternalAccess extEnv diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 6109be3d1eb..c616d1e5a4e 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -18,22 +18,16 @@ module Wire.BackgroundWorker.Options where import Data.Aeson -import Data.Domain (Domain) -import Data.Id (TeamId) import Data.Misc import Data.Range (Range) import GHC.Generics import Hasql.Pool.Extended import Imports import Network.AMQP.Extended -import System.Logger.Extended hiding (Settings) +import System.Logger.Extended import Util.Options -import Wire.API.Conversation.Protocol (ProtocolTag) -import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.Migration -import Wire.Options.Galley (GuestLinkTTLSeconds) import Wire.PostgresMigrationOpts -import Wire.RateLimit.Interpreter (RateLimitConfig) data Opts = Opts { logLevel :: !Level, @@ -56,30 +50,11 @@ data Opts = Opts migrateConversationsOptions :: !MigrationOptions, migrateConversationCodes :: !Bool, migrateTeamFeatures :: !Bool, - backgroundJobs :: BackgroundJobsConfig, - federationDomain :: Domain, - settings :: !Settings + backgroundJobs :: BackgroundJobsConfig } deriving (Show, Generic) deriving (FromJSON) via Generically Opts -data Settings = Settings - { maxTeamSize :: !Word32, - maxFanoutSize :: !(Maybe FanoutLimit), - exposeInvitationURLsTeamAllowlist :: !(Maybe [TeamId]), - maxConvSize :: !Word16, - intraListing :: !Bool, - conversationCodeURI :: !(Maybe HttpsUrl), - multiIngress :: !(Maybe (Map Text HttpsUrl)), - federationProtocols :: !(Maybe [ProtocolTag]), - guestLinkTTLSeconds :: !(Maybe GuestLinkTTLSeconds), - passwordHashingOptions :: !PasswordHashingOptions, - passwordHashingRateLimit :: !RateLimitConfig, - checkGroupInfo :: !(Maybe Bool) - } - deriving (Show, Generic) - deriving (FromJSON) via Generically Settings - data BackendNotificationsConfig = BackendNotificationsConfig { -- | Minimum amount of time (in microseconds) to wait before doing the first -- retry in pushing a notification. Futher retries are done in a jittered diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 122bd6964f6..d4c065f5079 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -372,22 +372,16 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined - settings = - Settings - { maxTeamSize = 1000, - maxFanoutSize = Nothing, - exposeInvitationURLsTeamAllowlist = Nothing, - maxConvSize = 1000, - intraListing = True, - conversationCodeURI = Nothing, - multiIngress = Nothing, - federationProtocols = Nothing, - guestLinkTTLSeconds = Nothing, - passwordHashingOptions = undefined, - passwordHashingRateLimit = undefined, - checkGroupInfo = Nothing - } + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = undefined + checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv undefined backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge @@ -429,22 +423,16 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined - settings = - Settings - { maxTeamSize = 1000, - maxFanoutSize = Nothing, - exposeInvitationURLsTeamAllowlist = Nothing, - maxConvSize = 1000, - intraListing = True, - conversationCodeURI = Nothing, - multiIngress = Nothing, - federationProtocols = Nothing, - guestLinkTTLSeconds = Nothing, - passwordHashingOptions = undefined, - passwordHashingRateLimit = undefined, - checkGroupInfo = Nothing - } + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = undefined + checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv undefined backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 1d410317fe8..424ee3d6248 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -69,21 +69,14 @@ testEnv = do brigEndpoint = undefined sparEndpoint = Endpoint "localhost" 0 galleyEndpoint = undefined - settings = - Settings - { maxTeamSize = 1000, - maxFanoutSize = Nothing, - exposeInvitationURLsTeamAllowlist = Nothing, - maxConvSize = 1000, - intraListing = True, - conversationCodeURI = Nothing, - multiIngress = Nothing, - federationProtocols = Nothing, - guestLinkTTLSeconds = Nothing, - passwordHashingOptions = undefined, - passwordHashingRateLimit = undefined, - checkGroupInfo = Nothing - } + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = undefined + checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") passwordHashingRateLimitEnv <- newRateLimitEnv undefined pure Env {..} From 6c8446e5e1bfbc8c1173b852e0cfe8c6d945f0e3 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 21 Apr 2026 09:03:55 +0200 Subject: [PATCH 03/39] Hello CI From 3d48ee0743aad65d69bd7d1255a4cf4d7026b7d0 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 21 Apr 2026 13:33:28 +0200 Subject: [PATCH 04/39] fix: test `Env` `undefined` breaks/hangs test-suits --- .../test/Test/Wire/BackendNotificationPusherSpec.hs | 6 +++--- services/background-worker/test/Test/Wire/Util.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index d4c065f5079..13b3561bd7c 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -57,7 +57,7 @@ import Test.Hspec import Test.QuickCheck import Test.Wire.Util import UnliftIO.Async -import Util.Options +import Util.Options (Endpoint (..), PasswordHashingOptions (..)) import Wire.API.Conversation.Action import Wire.API.Federation.API import Wire.API.Federation.API.Brig @@ -378,7 +378,7 @@ spec = do intraListing = True federationProtocols = Nothing guestLinkTTLSeconds = Nothing - passwordHashingOptions = undefined + passwordHashingOptions = PasswordHashingScrypt checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") @@ -429,7 +429,7 @@ spec = do intraListing = True federationProtocols = Nothing guestLinkTTLSeconds = Nothing - passwordHashingOptions = undefined + passwordHashingOptions = PasswordHashingScrypt checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 424ee3d6248..3d0578588df 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -26,7 +26,7 @@ import Data.Range import Imports import Network.HTTP.Client hiding (Proxy) import System.Logger.Class qualified as Logger -import Util.Options (Endpoint (..)) +import Util.Options (Endpoint (..), PasswordHashingOptions (..)) import Wire.BackgroundWorker.Env hiding (federatorInternal) import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options @@ -75,7 +75,7 @@ testEnv = do intraListing = True federationProtocols = Nothing guestLinkTTLSeconds = Nothing - passwordHashingOptions = undefined + passwordHashingOptions = PasswordHashingScrypt checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") passwordHashingRateLimitEnv <- newRateLimitEnv undefined From fa05624c0fc75d95269c8b597ed48952e7d4b2f8 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 21 Apr 2026 14:39:14 +0200 Subject: [PATCH 05/39] Hello CI From 36bd1d5be30bd17c90ff8aa4f5c064dc50e7874a Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 21 Apr 2026 16:30:23 +0200 Subject: [PATCH 06/39] Hello CI From 8d1af0592c91515961e818728b4c70729dc2e32e Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 21 Apr 2026 18:55:28 +0200 Subject: [PATCH 07/39] fix(leif): duplication and extra code --- changelog.d/5-internal/WPB-23789 | 4 - charts/wire-server/templates/_helpers.tpl | 174 ---------- .../src/Wire/ConversationSubsystem/Errors.hs | 325 ++++++++++++++++++ .../Wire/ConversationSubsystem/Interpreter.hs | 296 +--------------- .../src/Wire/Options/Galley.hs | 11 + .../src/Wire/TeamSubsystem/GalleyAPI.hs | 14 +- libs/wire-subsystems/wire-subsystems.cabal | 1 + .../src/Wire/BackgroundWorker/Env.hs | 9 +- .../brig/src/Brig/CanonicalInterpreter.hs | 2 - services/galley/src/Galley/App.hs | 7 +- 10 files changed, 348 insertions(+), 495 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs diff --git a/changelog.d/5-internal/WPB-23789 b/changelog.d/5-internal/WPB-23789 index 12ca52d1d09..30fc625fdb2 100644 --- a/changelog.d/5-internal/WPB-23789 +++ b/changelog.d/5-internal/WPB-23789 @@ -6,7 +6,3 @@ * Library updates: - Introduced dedicated error types for ConversationSubsystem to improve error handling - Consolidated conversation-related operations that were previously scattered across multiple stores and subsystems - -**Note:** The background-worker configuration now has a dependency on the shared global settings. -Deployments that previously set these values in both galley and background-worker sections -can consolidate them into the global.settings section. diff --git a/charts/wire-server/templates/_helpers.tpl b/charts/wire-server/templates/_helpers.tpl index fc74d3b41bc..5edb0251456 100644 --- a/charts/wire-server/templates/_helpers.tpl +++ b/charts/wire-server/templates/_helpers.tpl @@ -155,180 +155,6 @@ {{- end -}} {{- end -}} -{{/* SHARED SETTINGS */}} -{{- define "wire-server.settings.common" -}} -maxTeamSize: {{ .maxTeamSize }} -maxConvSize: {{ .maxConvSize }} -intraListing: {{ .intraListing }} -{{- if .maxFanoutSize }} -maxFanoutSize: {{ .maxFanoutSize }} -{{- end }} -{{- if .exposeInvitationURLsTeamAllowlist }} -exposeInvitationURLsTeamAllowlist: {{ toYaml .exposeInvitationURLsTeamAllowlist | nindent 8 }} -{{- end }} -{{- if .conversationCodeURI }} -conversationCodeURI: {{ .conversationCodeURI | quote }} -{{- else if .multiIngress }} -multiIngress: {{- toYaml .multiIngress | nindent 8 }} -{{- else }} -{{ fail "Either settings.conversationCodeURI or settings.multiIngress have to be set" }} -{{- end }} -{{- if (and .conversationCodeURI .multiIngress) }} -{{ fail "settings.conversationCodeURI and settings.multiIngress are mutually exclusive" }} -{{- end }} -{{- if hasKey . "httpPoolSize" }} -httpPoolSize: {{ .httpPoolSize }} -{{- end }} -{{- if hasKey . "federationDomain" }} -federationDomain: {{ .federationDomain }} -{{- end }} -{{- if .federationProtocols }} -federationProtocols: {{ .federationProtocols | toJson }} -{{- end }} -{{- if .mlsPrivateKeyPaths }} -mlsPrivateKeyPaths: {{- toYaml .mlsPrivateKeyPaths | nindent 8 }} -{{- end }} -{{- if .concurrentDeletionEvents }} -concurrentDeletionEvents: {{ .concurrentDeletionEvents }} -{{- end }} -{{- if .deleteConvThrottleMillis }} -deleteConvThrottleMillis: {{ .deleteConvThrottleMillis }} -{{- end }} -{{- if hasKey . "disabledAPIVersions" }} -disabledAPIVersions: {{ toJson .disabledAPIVersions }} -{{- end }} -{{- if .guestLinkTTLSeconds }} -guestLinkTTLSeconds: {{ .guestLinkTTLSeconds }} -{{- end }} -passwordHashingOptions: {{ toYaml .passwordHashingOptions | nindent 8 }} -passwordHashingRateLimit: {{ toYaml .passwordHashingRateLimit | nindent 8 }} -{{- if .checkGroupInfo }} -checkGroupInfo: {{ .checkGroupInfo }} -{{- end }} -{{- if hasKey . "meetings" }} -meetings: - {{- toYaml .meetings | nindent 8 }} -{{- end }} -{{- if .featureFlags }} -featureFlags: - sso: {{ .featureFlags.sso }} - legalhold: {{ .featureFlags.legalhold }} - teamSearchVisibility: {{ .featureFlags.teamSearchVisibility }} - classifiedDomains: - {{- toYaml .featureFlags.classifiedDomains | nindent 10 }} - {{- if .featureFlags.fileSharing }} - fileSharing: - {{- toYaml .featureFlags.fileSharing | nindent 10 }} - {{- end }} - {{- if .featureFlags.enforceFileDownloadLocation }} - enforceFileDownloadLocation: - {{- toYaml .featureFlags.enforceFileDownloadLocation | nindent 10 }} - {{- end }} - {{- if .featureFlags.sndFactorPasswordChallenge }} - sndFactorPasswordChallenge: - {{- toYaml .featureFlags.sndFactorPasswordChallenge | nindent 10 }} - {{- end }} - {{- if .featureFlags.searchVisibilityInbound }} - searchVisibilityInbound: - {{- toYaml .featureFlags.searchVisibilityInbound | nindent 10 }} - {{- end }} - {{- /* Accept the legacy typo in Helm values, but always render the canonical Galley key. */}} - {{- $validateSAMLemails := .featureFlags.validateSAMLemails | default .featureFlags.validateSAMLEmails }} - {{- if $validateSAMLemails }} - validateSAMLemails: - {{- toYaml $validateSAMLemails | nindent 10 }} - {{- end }} - {{- if .featureFlags.appLock }} - appLock: - {{- toYaml .featureFlags.appLock | nindent 10 }} - {{- end }} - {{- if .featureFlags.conferenceCalling }} - conferenceCalling: - {{- toYaml .featureFlags.conferenceCalling | nindent 10 }} - {{- end }} - {{- if .featureFlags.selfDeletingMessages }} - selfDeletingMessages: - {{- toYaml .featureFlags.selfDeletingMessages | nindent 10 }} - {{- end }} - {{- if .featureFlags.conversationGuestLinks }} - conversationGuestLinks: - {{- toYaml .featureFlags.conversationGuestLinks | nindent 10 }} - {{- end }} - {{- if .featureFlags.mls }} - mls: - {{- toYaml .featureFlags.mls | nindent 10 }} - {{- end }} - {{- if .featureFlags.outlookCalIntegration }} - outlookCalIntegration: - {{- toYaml .featureFlags.outlookCalIntegration | nindent 10 }} - {{- end }} - {{- if .featureFlags.mlsE2EId }} - mlsE2EId: - {{- toYaml .featureFlags.mlsE2EId | nindent 10 }} - {{- end }} - {{- if .featureFlags.mlsMigration }} - mlsMigration: - {{- toYaml .featureFlags.mlsMigration | nindent 10 }} - {{- end }} - {{- if .featureFlags.limitedEventFanout }} - limitedEventFanout: - {{- toYaml .featureFlags.limitedEventFanout | nindent 10 }} - {{- end }} - {{- if .featureFlags.domainRegistration }} - domainRegistration: - {{- toYaml .featureFlags.domainRegistration | nindent 10 }} - {{- end }} - {{- if .featureFlags.channels }} - channels: - {{- toYaml .featureFlags.channels | nindent 10 }} - {{- end }} - {{- if .featureFlags.cells }} - cells: - {{- toYaml .featureFlags.cells | nindent 10 }} - {{- end }} - {{- if .featureFlags.cellsInternal }} - cellsInternal: - {{- toYaml .featureFlags.cellsInternal | nindent 10 }} - {{- end }} - {{- if .featureFlags.allowedGlobalOperations }} - allowedGlobalOperations: - {{- toYaml .featureFlags.allowedGlobalOperations | nindent 10 }} - {{- end }} - {{- if .featureFlags.assetAuditLog }} - assetAuditLog: - {{- toYaml .featureFlags.assetAuditLog | nindent 10 }} - {{- end }} - {{- if .featureFlags.consumableNotifications }} - consumableNotifications: - {{- toYaml .featureFlags.consumableNotifications | nindent 10 }} - {{- end }} - {{- if .featureFlags.chatBubbles }} - chatBubbles: - {{- toYaml .featureFlags.chatBubbles | nindent 10 }} - {{- end }} - {{- if .featureFlags.apps }} - apps: - {{- toYaml .featureFlags.apps | nindent 10 }} - {{- end }} - {{- if .featureFlags.simplifiedUserConnectionRequestQRCode }} - simplifiedUserConnectionRequestQRCode: - {{- toYaml .featureFlags.simplifiedUserConnectionRequestQRCode | nindent 10 }} - {{- end }} - {{- if .featureFlags.stealthUsers }} - stealthUsers: - {{- toYaml .featureFlags.stealthUsers | nindent 10 }} - {{- end }} - {{- if .featureFlags.meetings }} - meetings: - {{- toYaml .featureFlags.meetings | nindent 10 }} - {{- end }} - {{- if .featureFlags.meetingsPremium }} - meetingsPremium: - {{- toYaml .featureFlags.meetingsPremium | nindent 10 }} - {{- end }} -{{- end }} -{{- end -}} - {{/* Compute the SCIM base URI The rules are: diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs new file mode 100644 index 00000000000..ec74e2b5267 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs @@ -0,0 +1,325 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- 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.ConversationSubsystem.Errors + ( mapErrors, + ConversationSubsystemError (..), + ) +where + +import Data.Tagged +import Galley.Types.Error (InternalError, InvalidInput (..)) +import Imports +import Network.Wai.Utilities.JSONResponse (JSONResponse) +import Polysemy +import Polysemy.Error +import Wire.API.Conversation.Role qualified as ConvRole +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Federation.Error +import Wire.API.Routes.API (ServerEffect (interpretServerEffect)) + +data ConversationSubsystemError + = ConversationSubsystemErrorConvAccessDenied + | ConversationSubsystemErrorNotATeamMember + | ConversationSubsystemErrorperationDenied + | ConversationSubsystemErrorNotConnected + | ConversationSubsystemErrorMLSNotEnabled + | ConversationSubsystemErrorMLSNonEmptyMemberList + | ConversationSubsystemErrorMissingLegalholdConsent + | ConversationSubsystemErrorNonBindingTeam + | ConversationSubsystemErrorNoBindingTeamMembers + | ConversationSubsystemErrorTeamNotFound + | ConversationSubsystemErrorInvalidOperation + | ConversationSubsystemErrorConvNotFound + | ConversationSubsystemErrorChannelsNotEnabled + | ConversationSubsystemErrorNotAnMlsConversation + | ConversationSubsystemErrorMLSLegalholdIncompatible + | ConversationSubsystemErrorMLSIdentityMismatch + | ConversationSubsystemErrorMLSUnsupportedMessage + | ConversationSubsystemErrorMLSStaleMessage + | ConversationSubsystemErrorMLSProposalNotFound + | ConversationSubsystemErrorMLSCommitMissingReferences + | ConversationSubsystemErrorMLSSelfRemovalNotAllowed + | ConversationSubsystemErrorMLSClientSenderUserMismatch + | ConversationSubsystemErrorMLSSubConvClientNotInParent + | ConversationSubsystemErrorMLSInvalidLeafNodeSignature + | ConversationSubsystemErrorMLSClientMismatch + | ConversationSubsystemErrorMLSInvalidLeafNodeIndex + | ConversationSubsystemErrorMLSUnsupportedProposal + | ConversationSubsystemErrorGroupIdVersionNotSupported + | ConversationSubsystemErrorConvMemberNotFound + | ConversationSubsystemErrorHistoryNotSupported + | ConversationSubsystemErrorLSGroupConversationMismatch + | ConversationSubsystemErrorActionDeniedLeaveConversation + | ConversationSubsystemErrorActionDeniedRemoveConversationMember + | ConversationSubsystemErrorActionDeniedDeleteConversation + | ConversationSubsystemErrorBroadcastLimitExceeded + | ConversationSubsystemErrorMLSFederatedResetNotSupported + | ConversationSubsystemErrorMLSSubConvUnsupportedConvType + | ConversationSubsystemErrorTeamMemberNotFound + | ConversationSubsystemErrorAccessDenied + | ConversationSubsystemErrorMLSMissingGroupInfo + | ConversationSubsystemErrorCodeNotFound + | ConversationSubsystemErrorInvalidConversationPassword + | ConversationSubsystemErrorGuestLinksDisabled + | ConversationSubsystemErrorMLSFederatedOne2OneNotSupported + | ConversationSubsystemErrorTooManyMembers + | ConversationSubsystemErrorCreateConversationCodeConflict + | ConversationSubsystemErrorInvalidTarget + | ConversationSubsystemErrorMLSReadReceiptsNotAllowed + | ConversationSubsystemErrorInvalidTargetAccess + | ConversationSubsystemErrorConvInvalidProtocolTransition + | ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied + | ConversationSubsystemErrorActionDeniedAddConversationMember + | ConversationSubsystemErrorActionDeniedModifyOtherConversationMember + | ConversationSubsystemErrorActionDeniedModifyConversationName + | ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer + | ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode + | ConversationSubsystemErrorActionDeniedModifyConversationAccess + | ConversationSubsystemErrorActionDeniedModifyAddPermission + | ConversationSubsystemErrorFederationError FederationError + | ConversationSubsystemErrorUnreachableBackends UnreachableBackends + | ConversationSubsystemErrorInternalError InternalError + | ConversationSubsystemErrorInvalidInput InvalidInput + | ConversationSubsystemErrorMLSProtocolError MLSProtocolError + | ConversationSubsystemErrorGroupInfoDiagnostics GroupInfoDiagnostics + | ConversationSubsystemErrorMLSOutOfSyncError MLSOutOfSyncError + | ConversationSubsystemErrorNonFederatingBackends NonFederatingBackends + | ConversationSubsystemErrorUnreachableBackendsLegacy UnreachableBackendsLegacy + +instance APIError ConversationSubsystemError where + toResponse = + \case + ConversationSubsystemErrorConvAccessDenied -> toResponse $ Tagged @'ConvAccessDenied () + ConversationSubsystemErrorNotATeamMember -> toResponse $ Tagged @'NotATeamMember () + ConversationSubsystemErrorperationDenied -> toResponse $ Tagged @OperationDenied () + ConversationSubsystemErrorNotConnected -> toResponse $ Tagged @'NotConnected () + ConversationSubsystemErrorMLSNotEnabled -> toResponse $ Tagged @'MLSNotEnabled () + ConversationSubsystemErrorMLSNonEmptyMemberList -> toResponse $ Tagged @'MLSNonEmptyMemberList () + ConversationSubsystemErrorMissingLegalholdConsent -> toResponse $ Tagged @'MissingLegalholdConsent () + ConversationSubsystemErrorNonBindingTeam -> toResponse $ Tagged @'NonBindingTeam () + ConversationSubsystemErrorNoBindingTeamMembers -> toResponse $ Tagged @'NoBindingTeamMembers () + ConversationSubsystemErrorTeamNotFound -> toResponse $ Tagged @'TeamNotFound () + ConversationSubsystemErrorInvalidOperation -> toResponse $ Tagged @'InvalidOperation () + ConversationSubsystemErrorConvNotFound -> toResponse $ Tagged @'ConvNotFound () + ConversationSubsystemErrorChannelsNotEnabled -> toResponse $ Tagged @'ChannelsNotEnabled () + ConversationSubsystemErrorNotAnMlsConversation -> toResponse $ Tagged @'NotAnMlsConversation () + ConversationSubsystemErrorMLSLegalholdIncompatible -> toResponse $ Tagged @'MLSLegalholdIncompatible () + ConversationSubsystemErrorMLSIdentityMismatch -> toResponse $ Tagged @'MLSIdentityMismatch () + ConversationSubsystemErrorMLSUnsupportedMessage -> toResponse $ Tagged @'MLSUnsupportedMessage () + ConversationSubsystemErrorMLSStaleMessage -> toResponse $ Tagged @'MLSStaleMessage () + ConversationSubsystemErrorMLSProposalNotFound -> toResponse $ Tagged @'MLSProposalNotFound () + ConversationSubsystemErrorMLSCommitMissingReferences -> toResponse $ Tagged @'MLSCommitMissingReferences () + ConversationSubsystemErrorMLSSelfRemovalNotAllowed -> toResponse $ Tagged @'MLSSelfRemovalNotAllowed () + ConversationSubsystemErrorMLSClientSenderUserMismatch -> toResponse $ Tagged @'MLSClientSenderUserMismatch () + ConversationSubsystemErrorMLSSubConvClientNotInParent -> toResponse $ Tagged @'MLSSubConvClientNotInParent () + ConversationSubsystemErrorMLSInvalidLeafNodeSignature -> toResponse $ Tagged @'MLSInvalidLeafNodeSignature () + ConversationSubsystemErrorMLSClientMismatch -> toResponse $ Tagged @'MLSClientMismatch () + ConversationSubsystemErrorMLSInvalidLeafNodeIndex -> toResponse $ Tagged @'MLSInvalidLeafNodeIndex () + ConversationSubsystemErrorMLSUnsupportedProposal -> toResponse $ Tagged @'MLSUnsupportedProposal () + ConversationSubsystemErrorGroupIdVersionNotSupported -> toResponse $ Tagged @'GroupIdVersionNotSupported () + ConversationSubsystemErrorConvMemberNotFound -> toResponse $ Tagged @'ConvMemberNotFound () + ConversationSubsystemErrorHistoryNotSupported -> toResponse $ Tagged @'HistoryNotSupported () + ConversationSubsystemErrorLSGroupConversationMismatch -> toResponse $ Tagged @MLSGroupConversationMismatch () + ConversationSubsystemErrorActionDeniedLeaveConversation -> toResponse $ Tagged @('ActionDenied ConvRole.LeaveConversation) () + ConversationSubsystemErrorActionDeniedRemoveConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.RemoveConversationMember) () + ConversationSubsystemErrorActionDeniedDeleteConversation -> toResponse $ Tagged @('ActionDenied ConvRole.DeleteConversation) () + ConversationSubsystemErrorBroadcastLimitExceeded -> toResponse $ Tagged @'BroadcastLimitExceeded () + ConversationSubsystemErrorMLSFederatedResetNotSupported -> toResponse $ Tagged @'MLSFederatedResetNotSupported () + ConversationSubsystemErrorMLSSubConvUnsupportedConvType -> toResponse $ Tagged @'MLSSubConvUnsupportedConvType () + ConversationSubsystemErrorTeamMemberNotFound -> toResponse $ Tagged @'TeamMemberNotFound () + ConversationSubsystemErrorAccessDenied -> toResponse $ Tagged @'AccessDenied () + ConversationSubsystemErrorMLSMissingGroupInfo -> toResponse $ Tagged @'MLSMissingGroupInfo () + ConversationSubsystemErrorCodeNotFound -> toResponse $ Tagged @'CodeNotFound () + ConversationSubsystemErrorInvalidConversationPassword -> toResponse $ Tagged @'InvalidConversationPassword () + ConversationSubsystemErrorGuestLinksDisabled -> toResponse $ Tagged @'GuestLinksDisabled () + ConversationSubsystemErrorMLSFederatedOne2OneNotSupported -> toResponse $ Tagged @'MLSFederatedOne2OneNotSupported () + ConversationSubsystemErrorTooManyMembers -> toResponse $ Tagged @'TooManyMembers () + ConversationSubsystemErrorCreateConversationCodeConflict -> toResponse $ Tagged @'CreateConversationCodeConflict () + ConversationSubsystemErrorInvalidTarget -> toResponse $ Tagged @'InvalidTarget () + ConversationSubsystemErrorMLSReadReceiptsNotAllowed -> toResponse $ Tagged @'MLSReadReceiptsNotAllowed () + ConversationSubsystemErrorInvalidTargetAccess -> toResponse $ Tagged @'InvalidTargetAccess () + ConversationSubsystemErrorConvInvalidProtocolTransition -> toResponse $ Tagged @'ConvInvalidProtocolTransition () + ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied -> toResponse $ Tagged @'MLSMigrationCriteriaNotSatisfied () + ConversationSubsystemErrorActionDeniedAddConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.AddConversationMember) () + ConversationSubsystemErrorActionDeniedModifyOtherConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyOtherConversationMember) () + ConversationSubsystemErrorActionDeniedModifyConversationName -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationName) () + ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationMessageTimer) () + ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationReceiptMode) () + ConversationSubsystemErrorActionDeniedModifyConversationAccess -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationAccess) () + ConversationSubsystemErrorActionDeniedModifyAddPermission -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyAddPermission) () + ConversationSubsystemErrorFederationError x -> toResponse x + ConversationSubsystemErrorUnreachableBackends x -> toResponse x + ConversationSubsystemErrorInternalError x -> toResponse x + ConversationSubsystemErrorInvalidInput x -> toResponse x + ConversationSubsystemErrorMLSProtocolError x -> toResponse $ (dynError @(MapError 'MLSProtocolErrorTag)) {eMessage = unTagged x} + ConversationSubsystemErrorGroupInfoDiagnostics x -> toResponse x + ConversationSubsystemErrorMLSOutOfSyncError x -> toResponse x + ConversationSubsystemErrorNonFederatingBackends x -> toResponse x + ConversationSubsystemErrorUnreachableBackendsLegacy x -> toResponse x + +type ConversationSubsystemErrorEffects = + '[ ErrorS 'ConvAccessDenied, + ErrorS 'NotATeamMember, + ErrorS OperationDenied, + ErrorS 'NotConnected, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSNonEmptyMemberList, + ErrorS 'MissingLegalholdConsent, + ErrorS 'NonBindingTeam, + ErrorS 'NoBindingTeamMembers, + ErrorS 'TeamNotFound, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ChannelsNotEnabled, + ErrorS 'NotAnMlsConversation, + ErrorS 'MLSLegalholdIncompatible, + ErrorS 'MLSIdentityMismatch, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MLSCommitMissingReferences, + ErrorS 'MLSSelfRemovalNotAllowed, + ErrorS 'MLSClientSenderUserMismatch, + ErrorS 'MLSSubConvClientNotInParent, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSClientMismatch, + ErrorS 'MLSInvalidLeafNodeIndex, + ErrorS 'MLSUnsupportedProposal, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'ConvMemberNotFound, + ErrorS 'HistoryNotSupported, + ErrorS MLSGroupConversationMismatch, + ErrorS ('ActionDenied ConvRole.LeaveConversation), + ErrorS ('ActionDenied ConvRole.RemoveConversationMember), + ErrorS ('ActionDenied ConvRole.DeleteConversation), + ErrorS 'BroadcastLimitExceeded, + ErrorS 'MLSFederatedResetNotSupported, + ErrorS 'MLSSubConvUnsupportedConvType, + ErrorS 'TeamMemberNotFound, + ErrorS 'AccessDenied, + ErrorS 'MLSMissingGroupInfo, + ErrorS 'CodeNotFound, + ErrorS 'InvalidConversationPassword, + ErrorS 'GuestLinksDisabled, + ErrorS 'MLSFederatedOne2OneNotSupported, + ErrorS 'TooManyMembers, + ErrorS 'CreateConversationCodeConflict, + ErrorS 'InvalidTarget, + ErrorS 'MLSReadReceiptsNotAllowed, + ErrorS 'InvalidTargetAccess, + ErrorS 'ConvInvalidProtocolTransition, + ErrorS 'MLSMigrationCriteriaNotSatisfied, + ErrorS ('ActionDenied ConvRole.AddConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyOtherConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyConversationName), + ErrorS ('ActionDenied ConvRole.ModifyConversationMessageTimer), + ErrorS ('ActionDenied ConvRole.ModifyConversationReceiptMode), + ErrorS ('ActionDenied ConvRole.ModifyConversationAccess), + ErrorS ('ActionDenied ConvRole.ModifyAddPermission), + Error FederationError, + Error UnreachableBackends, + Error InternalError, + Error InvalidInput, + Error AuthenticationError, + Error MLSProtocolError, + Error GroupInfoDiagnostics, + Error MLSOutOfSyncError, + Error MLSProposalFailure, + Error NonFederatingBackends, + Error UnreachableBackendsLegacy + ] + +mapErrors :: + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r + ) => + InterpretersFor ConversationSubsystemErrorEffects r +mapErrors = + mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) + . mapError (ConversationSubsystemErrorNonFederatingBackends) + . interpretServerEffect + . mapError (ConversationSubsystemErrorMLSOutOfSyncError) + . mapError (ConversationSubsystemErrorGroupInfoDiagnostics) + . mapError (ConversationSubsystemErrorMLSProtocolError) + . interpretServerEffect + . mapError (ConversationSubsystemErrorInvalidInput) + . mapError (ConversationSubsystemErrorInternalError) + . mapError (ConversationSubsystemErrorUnreachableBackends) + . mapError (ConversationSubsystemErrorFederationError) + . mapError (const ConversationSubsystemErrorActionDeniedModifyAddPermission) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationAccess) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationName) + . mapError (const ConversationSubsystemErrorActionDeniedModifyOtherConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedAddConversationMember) + . mapError (const ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied) + . mapError (const ConversationSubsystemErrorConvInvalidProtocolTransition) + . mapError (const ConversationSubsystemErrorInvalidTargetAccess) + . mapError (const ConversationSubsystemErrorMLSReadReceiptsNotAllowed) + . mapError (const ConversationSubsystemErrorInvalidTarget) + . mapError (const ConversationSubsystemErrorCreateConversationCodeConflict) + . mapError (const ConversationSubsystemErrorTooManyMembers) + . mapError (const ConversationSubsystemErrorMLSFederatedOne2OneNotSupported) + . mapError (const ConversationSubsystemErrorGuestLinksDisabled) + . mapError (const ConversationSubsystemErrorInvalidConversationPassword) + . mapError (const ConversationSubsystemErrorCodeNotFound) + . mapError (const ConversationSubsystemErrorMLSMissingGroupInfo) + . mapError (const ConversationSubsystemErrorAccessDenied) + . mapError (const ConversationSubsystemErrorTeamMemberNotFound) + . mapError (const ConversationSubsystemErrorMLSSubConvUnsupportedConvType) + . mapError (const ConversationSubsystemErrorMLSFederatedResetNotSupported) + . mapError (const ConversationSubsystemErrorBroadcastLimitExceeded) + . mapError (const ConversationSubsystemErrorActionDeniedDeleteConversation) + . mapError (const ConversationSubsystemErrorActionDeniedRemoveConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedLeaveConversation) + . mapError (const ConversationSubsystemErrorLSGroupConversationMismatch) + . mapError (const ConversationSubsystemErrorHistoryNotSupported) + . mapError (const ConversationSubsystemErrorConvMemberNotFound) + . mapError (const ConversationSubsystemErrorGroupIdVersionNotSupported) + . mapError (const ConversationSubsystemErrorMLSUnsupportedProposal) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeIndex) + . mapError (const ConversationSubsystemErrorMLSClientMismatch) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeSignature) + . mapError (const ConversationSubsystemErrorMLSSubConvClientNotInParent) + . mapError (const ConversationSubsystemErrorMLSClientSenderUserMismatch) + . mapError (const ConversationSubsystemErrorMLSSelfRemovalNotAllowed) + . mapError (const ConversationSubsystemErrorMLSCommitMissingReferences) + . mapError (const ConversationSubsystemErrorMLSProposalNotFound) + . mapError (const ConversationSubsystemErrorMLSStaleMessage) + . mapError (const ConversationSubsystemErrorMLSUnsupportedMessage) + . mapError (const ConversationSubsystemErrorMLSIdentityMismatch) + . mapError (const ConversationSubsystemErrorMLSLegalholdIncompatible) + . mapError (const ConversationSubsystemErrorNotAnMlsConversation) + . mapError (const ConversationSubsystemErrorChannelsNotEnabled) + . mapError (const ConversationSubsystemErrorConvNotFound) + . mapError (const ConversationSubsystemErrorInvalidOperation) + . mapError (const ConversationSubsystemErrorTeamNotFound) + . mapError (const ConversationSubsystemErrorNoBindingTeamMembers) + . mapError (const ConversationSubsystemErrorNonBindingTeam) + . mapError (const ConversationSubsystemErrorMissingLegalholdConsent) + . mapError (const ConversationSubsystemErrorMLSNonEmptyMemberList) + . mapError (const ConversationSubsystemErrorMLSNotEnabled) + . mapError (const ConversationSubsystemErrorNotConnected) + . mapError (const ConversationSubsystemErrorperationDenied) + . mapError (const ConversationSubsystemErrorNotATeamMember) + . mapError (const ConversationSubsystemErrorConvAccessDenied) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 3137f2e90bc..efbb6899621 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -26,8 +26,6 @@ module Wire.ConversationSubsystem.Interpreter where import Data.Qualified -import Data.Tagged -import Galley.Types.Error (InternalError, InvalidInput (..)) import Imports import Network.Wai.Utilities.JSONResponse (JSONResponse) import Polysemy @@ -37,13 +35,9 @@ import Polysemy.Internal.Tactics (liftT) import Polysemy.Resource (Resource) import Polysemy.TinyLog (TinyLog) import Wire.API.Conversation.Config -import Wire.API.Conversation.Role qualified as ConvRole import Wire.API.Error -import Wire.API.Error.Galley import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) -import Wire.API.Routes.API (ServerEffect (interpretServerEffect)) import Wire.API.Team.Feature (LegalholdConfig) import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults, FeatureFlags) import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) @@ -55,6 +49,7 @@ import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Action.Notify qualified as ActionNotify import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.CreateInternal qualified as CreateInternal +import Wire.ConversationSubsystem.Errors import Wire.ConversationSubsystem.Federation qualified as Federation import Wire.ConversationSubsystem.Fetch qualified as Fetch import Wire.ConversationSubsystem.MLS qualified as MLS @@ -373,292 +368,3 @@ interpretConversationSubsystem = interpretH $ \case liftT $ mapErrors $ Update.blockConv lusr qcnv UnblockConv lusr conn qcnv -> liftT $ mapErrors $ Update.unblockConv lusr conn qcnv - -data ConversationSubsystemError - = ConversationSubsystemErrorConvAccessDenied - | ConversationSubsystemErrorNotATeamMember - | ConversationSubsystemErrorperationDenied - | ConversationSubsystemErrorNotConnected - | ConversationSubsystemErrorMLSNotEnabled - | ConversationSubsystemErrorMLSNonEmptyMemberList - | ConversationSubsystemErrorMissingLegalholdConsent - | ConversationSubsystemErrorNonBindingTeam - | ConversationSubsystemErrorNoBindingTeamMembers - | ConversationSubsystemErrorTeamNotFound - | ConversationSubsystemErrorInvalidOperation - | ConversationSubsystemErrorConvNotFound - | ConversationSubsystemErrorChannelsNotEnabled - | ConversationSubsystemErrorNotAnMlsConversation - | ConversationSubsystemErrorMLSLegalholdIncompatible - | ConversationSubsystemErrorMLSIdentityMismatch - | ConversationSubsystemErrorMLSUnsupportedMessage - | ConversationSubsystemErrorMLSStaleMessage - | ConversationSubsystemErrorMLSProposalNotFound - | ConversationSubsystemErrorMLSCommitMissingReferences - | ConversationSubsystemErrorMLSSelfRemovalNotAllowed - | ConversationSubsystemErrorMLSClientSenderUserMismatch - | ConversationSubsystemErrorMLSSubConvClientNotInParent - | ConversationSubsystemErrorMLSInvalidLeafNodeSignature - | ConversationSubsystemErrorMLSClientMismatch - | ConversationSubsystemErrorMLSInvalidLeafNodeIndex - | ConversationSubsystemErrorMLSUnsupportedProposal - | ConversationSubsystemErrorGroupIdVersionNotSupported - | ConversationSubsystemErrorConvMemberNotFound - | ConversationSubsystemErrorHistoryNotSupported - | ConversationSubsystemErrorLSGroupConversationMismatch - | ConversationSubsystemErrorActionDeniedLeaveConversation - | ConversationSubsystemErrorActionDeniedRemoveConversationMember - | ConversationSubsystemErrorActionDeniedDeleteConversation - | ConversationSubsystemErrorBroadcastLimitExceeded - | ConversationSubsystemErrorMLSFederatedResetNotSupported - | ConversationSubsystemErrorMLSSubConvUnsupportedConvType - | ConversationSubsystemErrorTeamMemberNotFound - | ConversationSubsystemErrorAccessDenied - | ConversationSubsystemErrorMLSMissingGroupInfo - | ConversationSubsystemErrorCodeNotFound - | ConversationSubsystemErrorInvalidConversationPassword - | ConversationSubsystemErrorGuestLinksDisabled - | ConversationSubsystemErrorMLSFederatedOne2OneNotSupported - | ConversationSubsystemErrorTooManyMembers - | ConversationSubsystemErrorCreateConversationCodeConflict - | ConversationSubsystemErrorInvalidTarget - | ConversationSubsystemErrorMLSReadReceiptsNotAllowed - | ConversationSubsystemErrorInvalidTargetAccess - | ConversationSubsystemErrorConvInvalidProtocolTransition - | ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied - | ConversationSubsystemErrorActionDeniedAddConversationMember - | ConversationSubsystemErrorActionDeniedModifyOtherConversationMember - | ConversationSubsystemErrorActionDeniedModifyConversationName - | ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer - | ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode - | ConversationSubsystemErrorActionDeniedModifyConversationAccess - | ConversationSubsystemErrorActionDeniedModifyAddPermission - | ConversationSubsystemErrorFederationError FederationError - | ConversationSubsystemErrorUnreachableBackends UnreachableBackends - | ConversationSubsystemErrorInternalError InternalError - | ConversationSubsystemErrorInvalidInput InvalidInput - | ConversationSubsystemErrorMLSProtocolError MLSProtocolError - | ConversationSubsystemErrorGroupInfoDiagnostics GroupInfoDiagnostics - | ConversationSubsystemErrorMLSOutOfSyncError MLSOutOfSyncError - | ConversationSubsystemErrorNonFederatingBackends NonFederatingBackends - | ConversationSubsystemErrorUnreachableBackendsLegacy UnreachableBackendsLegacy - -instance APIError ConversationSubsystemError where - toResponse = - \case - ConversationSubsystemErrorConvAccessDenied -> toResponse $ Tagged @'ConvAccessDenied () - ConversationSubsystemErrorNotATeamMember -> toResponse $ Tagged @'NotATeamMember () - ConversationSubsystemErrorperationDenied -> toResponse $ Tagged @OperationDenied () - ConversationSubsystemErrorNotConnected -> toResponse $ Tagged @'NotConnected () - ConversationSubsystemErrorMLSNotEnabled -> toResponse $ Tagged @'MLSNotEnabled () - ConversationSubsystemErrorMLSNonEmptyMemberList -> toResponse $ Tagged @'MLSNonEmptyMemberList () - ConversationSubsystemErrorMissingLegalholdConsent -> toResponse $ Tagged @'MissingLegalholdConsent () - ConversationSubsystemErrorNonBindingTeam -> toResponse $ Tagged @'NonBindingTeam () - ConversationSubsystemErrorNoBindingTeamMembers -> toResponse $ Tagged @'NoBindingTeamMembers () - ConversationSubsystemErrorTeamNotFound -> toResponse $ Tagged @'TeamNotFound () - ConversationSubsystemErrorInvalidOperation -> toResponse $ Tagged @'InvalidOperation () - ConversationSubsystemErrorConvNotFound -> toResponse $ Tagged @'ConvNotFound () - ConversationSubsystemErrorChannelsNotEnabled -> toResponse $ Tagged @'ChannelsNotEnabled () - ConversationSubsystemErrorNotAnMlsConversation -> toResponse $ Tagged @'NotAnMlsConversation () - ConversationSubsystemErrorMLSLegalholdIncompatible -> toResponse $ Tagged @'MLSLegalholdIncompatible () - ConversationSubsystemErrorMLSIdentityMismatch -> toResponse $ Tagged @'MLSIdentityMismatch () - ConversationSubsystemErrorMLSUnsupportedMessage -> toResponse $ Tagged @'MLSUnsupportedMessage () - ConversationSubsystemErrorMLSStaleMessage -> toResponse $ Tagged @'MLSStaleMessage () - ConversationSubsystemErrorMLSProposalNotFound -> toResponse $ Tagged @'MLSProposalNotFound () - ConversationSubsystemErrorMLSCommitMissingReferences -> toResponse $ Tagged @'MLSCommitMissingReferences () - ConversationSubsystemErrorMLSSelfRemovalNotAllowed -> toResponse $ Tagged @'MLSSelfRemovalNotAllowed () - ConversationSubsystemErrorMLSClientSenderUserMismatch -> toResponse $ Tagged @'MLSClientSenderUserMismatch () - ConversationSubsystemErrorMLSSubConvClientNotInParent -> toResponse $ Tagged @'MLSSubConvClientNotInParent () - ConversationSubsystemErrorMLSInvalidLeafNodeSignature -> toResponse $ Tagged @'MLSInvalidLeafNodeSignature () - ConversationSubsystemErrorMLSClientMismatch -> toResponse $ Tagged @'MLSClientMismatch () - ConversationSubsystemErrorMLSInvalidLeafNodeIndex -> toResponse $ Tagged @'MLSInvalidLeafNodeIndex () - ConversationSubsystemErrorMLSUnsupportedProposal -> toResponse $ Tagged @'MLSUnsupportedProposal () - ConversationSubsystemErrorGroupIdVersionNotSupported -> toResponse $ Tagged @'GroupIdVersionNotSupported () - ConversationSubsystemErrorConvMemberNotFound -> toResponse $ Tagged @'ConvMemberNotFound () - ConversationSubsystemErrorHistoryNotSupported -> toResponse $ Tagged @'HistoryNotSupported () - ConversationSubsystemErrorLSGroupConversationMismatch -> toResponse $ Tagged @MLSGroupConversationMismatch () - ConversationSubsystemErrorActionDeniedLeaveConversation -> toResponse $ Tagged @('ActionDenied ConvRole.LeaveConversation) () - ConversationSubsystemErrorActionDeniedRemoveConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.RemoveConversationMember) () - ConversationSubsystemErrorActionDeniedDeleteConversation -> toResponse $ Tagged @('ActionDenied ConvRole.DeleteConversation) () - ConversationSubsystemErrorBroadcastLimitExceeded -> toResponse $ Tagged @'BroadcastLimitExceeded () - ConversationSubsystemErrorMLSFederatedResetNotSupported -> toResponse $ Tagged @'MLSFederatedResetNotSupported () - ConversationSubsystemErrorMLSSubConvUnsupportedConvType -> toResponse $ Tagged @'MLSSubConvUnsupportedConvType () - ConversationSubsystemErrorTeamMemberNotFound -> toResponse $ Tagged @'TeamMemberNotFound () - ConversationSubsystemErrorAccessDenied -> toResponse $ Tagged @'AccessDenied () - ConversationSubsystemErrorMLSMissingGroupInfo -> toResponse $ Tagged @'MLSMissingGroupInfo () - ConversationSubsystemErrorCodeNotFound -> toResponse $ Tagged @'CodeNotFound () - ConversationSubsystemErrorInvalidConversationPassword -> toResponse $ Tagged @'InvalidConversationPassword () - ConversationSubsystemErrorGuestLinksDisabled -> toResponse $ Tagged @'GuestLinksDisabled () - ConversationSubsystemErrorMLSFederatedOne2OneNotSupported -> toResponse $ Tagged @'MLSFederatedOne2OneNotSupported () - ConversationSubsystemErrorTooManyMembers -> toResponse $ Tagged @'TooManyMembers () - ConversationSubsystemErrorCreateConversationCodeConflict -> toResponse $ Tagged @'CreateConversationCodeConflict () - ConversationSubsystemErrorInvalidTarget -> toResponse $ Tagged @'InvalidTarget () - ConversationSubsystemErrorMLSReadReceiptsNotAllowed -> toResponse $ Tagged @'MLSReadReceiptsNotAllowed () - ConversationSubsystemErrorInvalidTargetAccess -> toResponse $ Tagged @'InvalidTargetAccess () - ConversationSubsystemErrorConvInvalidProtocolTransition -> toResponse $ Tagged @'ConvInvalidProtocolTransition () - ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied -> toResponse $ Tagged @'MLSMigrationCriteriaNotSatisfied () - ConversationSubsystemErrorActionDeniedAddConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.AddConversationMember) () - ConversationSubsystemErrorActionDeniedModifyOtherConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyOtherConversationMember) () - ConversationSubsystemErrorActionDeniedModifyConversationName -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationName) () - ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationMessageTimer) () - ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationReceiptMode) () - ConversationSubsystemErrorActionDeniedModifyConversationAccess -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationAccess) () - ConversationSubsystemErrorActionDeniedModifyAddPermission -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyAddPermission) () - ConversationSubsystemErrorFederationError x -> toResponse x - ConversationSubsystemErrorUnreachableBackends x -> toResponse x - ConversationSubsystemErrorInternalError x -> toResponse x - ConversationSubsystemErrorInvalidInput x -> toResponse x - ConversationSubsystemErrorMLSProtocolError x -> toResponse $ (dynError @(MapError 'MLSProtocolErrorTag)) {eMessage = unTagged x} - ConversationSubsystemErrorGroupInfoDiagnostics x -> toResponse x - ConversationSubsystemErrorMLSOutOfSyncError x -> toResponse x - ConversationSubsystemErrorNonFederatingBackends x -> toResponse x - ConversationSubsystemErrorUnreachableBackendsLegacy x -> toResponse x - -type ConversationSubsystemErrorEffects = - '[ ErrorS 'ConvAccessDenied, - ErrorS 'NotATeamMember, - ErrorS OperationDenied, - ErrorS 'NotConnected, - ErrorS 'MLSNotEnabled, - ErrorS 'MLSNonEmptyMemberList, - ErrorS 'MissingLegalholdConsent, - ErrorS 'NonBindingTeam, - ErrorS 'NoBindingTeamMembers, - ErrorS 'TeamNotFound, - ErrorS 'InvalidOperation, - ErrorS 'ConvNotFound, - ErrorS 'ChannelsNotEnabled, - ErrorS 'NotAnMlsConversation, - ErrorS 'MLSLegalholdIncompatible, - ErrorS 'MLSIdentityMismatch, - ErrorS 'MLSUnsupportedMessage, - ErrorS 'MLSStaleMessage, - ErrorS 'MLSProposalNotFound, - ErrorS 'MLSCommitMissingReferences, - ErrorS 'MLSSelfRemovalNotAllowed, - ErrorS 'MLSClientSenderUserMismatch, - ErrorS 'MLSSubConvClientNotInParent, - ErrorS 'MLSInvalidLeafNodeSignature, - ErrorS 'MLSClientMismatch, - ErrorS 'MLSInvalidLeafNodeIndex, - ErrorS 'MLSUnsupportedProposal, - ErrorS 'GroupIdVersionNotSupported, - ErrorS 'ConvMemberNotFound, - ErrorS 'HistoryNotSupported, - ErrorS MLSGroupConversationMismatch, - ErrorS ('ActionDenied ConvRole.LeaveConversation), - ErrorS ('ActionDenied ConvRole.RemoveConversationMember), - ErrorS ('ActionDenied ConvRole.DeleteConversation), - ErrorS 'BroadcastLimitExceeded, - ErrorS 'MLSFederatedResetNotSupported, - ErrorS 'MLSSubConvUnsupportedConvType, - ErrorS 'TeamMemberNotFound, - ErrorS 'AccessDenied, - ErrorS 'MLSMissingGroupInfo, - ErrorS 'CodeNotFound, - ErrorS 'InvalidConversationPassword, - ErrorS 'GuestLinksDisabled, - ErrorS 'MLSFederatedOne2OneNotSupported, - ErrorS 'TooManyMembers, - ErrorS 'CreateConversationCodeConflict, - ErrorS 'InvalidTarget, - ErrorS 'MLSReadReceiptsNotAllowed, - ErrorS 'InvalidTargetAccess, - ErrorS 'ConvInvalidProtocolTransition, - ErrorS 'MLSMigrationCriteriaNotSatisfied, - ErrorS ('ActionDenied ConvRole.AddConversationMember), - ErrorS ('ActionDenied ConvRole.ModifyOtherConversationMember), - ErrorS ('ActionDenied ConvRole.ModifyConversationName), - ErrorS ('ActionDenied ConvRole.ModifyConversationMessageTimer), - ErrorS ('ActionDenied ConvRole.ModifyConversationReceiptMode), - ErrorS ('ActionDenied ConvRole.ModifyConversationAccess), - ErrorS ('ActionDenied ConvRole.ModifyAddPermission), - Error FederationError, - Error UnreachableBackends, - Error InternalError, - Error InvalidInput, - Error AuthenticationError, - Error MLSProtocolError, - Error GroupInfoDiagnostics, - Error MLSOutOfSyncError, - Error MLSProposalFailure, - Error NonFederatingBackends, - Error UnreachableBackendsLegacy - ] - -mapErrors :: - ( Member (Error ConversationSubsystemError) r, - Member (Error JSONResponse) r, - Member (Error DynError) r - ) => - InterpretersFor ConversationSubsystemErrorEffects r -mapErrors = - mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) - . mapError (ConversationSubsystemErrorNonFederatingBackends) - . interpretServerEffect - . mapError (ConversationSubsystemErrorMLSOutOfSyncError) - . mapError (ConversationSubsystemErrorGroupInfoDiagnostics) - . mapError (ConversationSubsystemErrorMLSProtocolError) - . interpretServerEffect - . mapError (ConversationSubsystemErrorInvalidInput) - . mapError (ConversationSubsystemErrorInternalError) - . mapError (ConversationSubsystemErrorUnreachableBackends) - . mapError (ConversationSubsystemErrorFederationError) - . mapError (const ConversationSubsystemErrorActionDeniedModifyAddPermission) - . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationAccess) - . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode) - . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer) - . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationName) - . mapError (const ConversationSubsystemErrorActionDeniedModifyOtherConversationMember) - . mapError (const ConversationSubsystemErrorActionDeniedAddConversationMember) - . mapError (const ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied) - . mapError (const ConversationSubsystemErrorConvInvalidProtocolTransition) - . mapError (const ConversationSubsystemErrorInvalidTargetAccess) - . mapError (const ConversationSubsystemErrorMLSReadReceiptsNotAllowed) - . mapError (const ConversationSubsystemErrorInvalidTarget) - . mapError (const ConversationSubsystemErrorCreateConversationCodeConflict) - . mapError (const ConversationSubsystemErrorTooManyMembers) - . mapError (const ConversationSubsystemErrorMLSFederatedOne2OneNotSupported) - . mapError (const ConversationSubsystemErrorGuestLinksDisabled) - . mapError (const ConversationSubsystemErrorInvalidConversationPassword) - . mapError (const ConversationSubsystemErrorCodeNotFound) - . mapError (const ConversationSubsystemErrorMLSMissingGroupInfo) - . mapError (const ConversationSubsystemErrorAccessDenied) - . mapError (const ConversationSubsystemErrorTeamMemberNotFound) - . mapError (const ConversationSubsystemErrorMLSSubConvUnsupportedConvType) - . mapError (const ConversationSubsystemErrorMLSFederatedResetNotSupported) - . mapError (const ConversationSubsystemErrorBroadcastLimitExceeded) - . mapError (const ConversationSubsystemErrorActionDeniedDeleteConversation) - . mapError (const ConversationSubsystemErrorActionDeniedRemoveConversationMember) - . mapError (const ConversationSubsystemErrorActionDeniedLeaveConversation) - . mapError (const ConversationSubsystemErrorLSGroupConversationMismatch) - . mapError (const ConversationSubsystemErrorHistoryNotSupported) - . mapError (const ConversationSubsystemErrorConvMemberNotFound) - . mapError (const ConversationSubsystemErrorGroupIdVersionNotSupported) - . mapError (const ConversationSubsystemErrorMLSUnsupportedProposal) - . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeIndex) - . mapError (const ConversationSubsystemErrorMLSClientMismatch) - . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeSignature) - . mapError (const ConversationSubsystemErrorMLSSubConvClientNotInParent) - . mapError (const ConversationSubsystemErrorMLSClientSenderUserMismatch) - . mapError (const ConversationSubsystemErrorMLSSelfRemovalNotAllowed) - . mapError (const ConversationSubsystemErrorMLSCommitMissingReferences) - . mapError (const ConversationSubsystemErrorMLSProposalNotFound) - . mapError (const ConversationSubsystemErrorMLSStaleMessage) - . mapError (const ConversationSubsystemErrorMLSUnsupportedMessage) - . mapError (const ConversationSubsystemErrorMLSIdentityMismatch) - . mapError (const ConversationSubsystemErrorMLSLegalholdIncompatible) - . mapError (const ConversationSubsystemErrorNotAnMlsConversation) - . mapError (const ConversationSubsystemErrorChannelsNotEnabled) - . mapError (const ConversationSubsystemErrorConvNotFound) - . mapError (const ConversationSubsystemErrorInvalidOperation) - . mapError (const ConversationSubsystemErrorTeamNotFound) - . mapError (const ConversationSubsystemErrorNoBindingTeamMembers) - . mapError (const ConversationSubsystemErrorNonBindingTeam) - . mapError (const ConversationSubsystemErrorMissingLegalholdConsent) - . mapError (const ConversationSubsystemErrorMLSNonEmptyMemberList) - . mapError (const ConversationSubsystemErrorMLSNotEnabled) - . mapError (const ConversationSubsystemErrorNotConnected) - . mapError (const ConversationSubsystemErrorperationDenied) - . mapError (const ConversationSubsystemErrorNotATeamMember) - . mapError (const ConversationSubsystemErrorConvAccessDenied) diff --git a/libs/wire-subsystems/src/Wire/Options/Galley.hs b/libs/wire-subsystems/src/Wire/Options/Galley.hs index 47efc924ad7..6b30fff0976 100644 --- a/libs/wire-subsystems/src/Wire/Options/Galley.hs +++ b/libs/wire-subsystems/src/Wire/Options/Galley.hs @@ -66,6 +66,7 @@ module Wire.Options.Galley StorageLocation (..), GuestLinkTTLSeconds (..), defGuestLinkTTLSeconds, + conversationCodeURISettings, ) where @@ -241,3 +242,13 @@ data Opts = Opts deriveFromJSON toOptionFieldName ''Opts makeLenses ''Opts + +conversationCodeURISettings :: (Applicative m) => Opts -> m (Either HttpsUrl (Map Text HttpsUrl)) +conversationCodeURISettings opts = + case (opts._settings._conversationCodeURI, opts._settings._multiIngress) of + (Nothing, Nothing) -> error errMsg + (Nothing, Just mi) -> pure (Right mi) + (Just uri, Nothing) -> pure (Left uri) + (Just _, Just _) -> error errMsg + where + errMsg = "Either conversationCodeURI or multiIngress needs to be set." diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs index 52cfb0da574..93ca9a64101 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs @@ -17,7 +17,7 @@ module Wire.TeamSubsystem.GalleyAPI where -import Data.LegalHold (UserLegalHoldStatus (..)) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Imports import Polysemy import Wire.API.Error @@ -56,26 +56,26 @@ interpretTeamSubsystemToGalleyAPI = interpret $ \case for uids $ \uid -> do mteamId <- GalleyAPIAccess.getTeamId uid status <- case mteamId of - Nothing -> pure UserLegalHoldDisabled + Nothing -> pure defUserLegalHoldStatus Just tid -> do GalleyAPIAccess.getTeamMember uid tid >>= \case - Nothing -> pure UserLegalHoldDisabled + Nothing -> pure defUserLegalHoldStatus Just _ -> do LockableFeature {status} <- GalleyAPIAccess.getTeamLegalHoldStatus tid pure $ if status == FeatureStatusEnabled then UserLegalHoldEnabled - else UserLegalHoldDisabled + else defUserLegalHoldStatus pure (uid, status) GetLHStatus mtid uid -> do case mtid of - Nothing -> pure UserLegalHoldDisabled + Nothing -> pure defUserLegalHoldStatus Just tid -> do GalleyAPIAccess.getTeamMember uid tid >>= \case - Nothing -> pure UserLegalHoldDisabled + Nothing -> pure defUserLegalHoldStatus Just _ -> do LockableFeature {status} <- GalleyAPIAccess.getTeamLegalHoldStatus tid pure $ if status == FeatureStatusEnabled then UserLegalHoldEnabled - else UserLegalHoldDisabled + else defUserLegalHoldStatus diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 3d23daa74d6..bb6455c3e27 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -265,6 +265,7 @@ library Wire.ConversationSubsystem.Clients Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.CreateInternal + Wire.ConversationSubsystem.Errors Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Fetch Wire.ConversationSubsystem.Internal diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index fd30d31cd1e..981ae2139f6 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -48,7 +48,7 @@ import Util.Options import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.BackgroundWorker.Options -import Wire.Options.Galley (GuestLinkTTLSeconds) +import Wire.Options.Galley (GuestLinkTTLSeconds, conversationCodeURISettings) import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter (RateLimitEnv, newRateLimitEnv) @@ -170,12 +170,7 @@ mkEnv opts galleyOpts = do amqpBackendNotificationsChannel <- mkRabbitMqChannelMVar logger (Just "background-worker-backend-notifications") $ either id demoteOpts opts.rabbitmq.unRabbitMqOpts - let errMsg = "Either conversationCodeURI or multiIngress needs to be set." - convCodeURI <- case (galleyOpts._settings._conversationCodeURI, galleyOpts._settings._multiIngress) of - (Nothing, Nothing) -> error errMsg - (Nothing, Just mi) -> pure (Right mi) - (Just uri, Nothing) -> pure (Left uri) - (Just _, Just _) -> error errMsg + convCodeURI <- conversationCodeURISettings galleyOpts passwordHashingRateLimitEnv <- newRateLimitEnv galleyOpts._settings._passwordHashingRateLimit pure Env {..} diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 2174a9a695b..270f1a7affa 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -215,7 +215,6 @@ type BrigLowerLevelEffects = ErrorS 'TeamMemberNotFound, ErrorS 'TeamNotFound, Error Wai.Error, - Error HttpError, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, DomainVerificationChallengeStore, DomainRegistrationStore, @@ -444,7 +443,6 @@ runBrigToIO e (AppT ma) = do . interpretDomainRegistrationStoreToCassandra e.casClient . interpretDomainVerificationChallengeStoreToCassandra e.casClient e.settings.challengeTTL . interpretFederationAPIAccess federationApiAccessConfig - . rethrowHttpErrorIO . mapError StdError -- Wai.Error . mapError (const $ errorToWai @'TeamNotFound) -- ErrorS 'TeamNotFound . mapError (const $ errorToWai @'TeamMemberNotFound) -- ErrorS 'TeamMemberNotFound diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index ef8c2026fd8..e27c5e45ce0 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -312,12 +312,7 @@ validateOptions o = do error "For starting MLS migration, MLS must be included in the supportedProtocol list" unless (mlsDefaultProtocol mlsConfig `elem` mlsSupportedProtocols mlsConfig) $ error "The list 'settings.featureFlags.mls.supportedProtocols' must include the value in the field 'settings.featureFlags.mls.defaultProtocol'" - let errMsg = "Either conversationCodeURI or multiIngress needs to be set." - case (settings' ^. conversationCodeURI, settings' ^. multiIngress) of - (Nothing, Nothing) -> error errMsg - (Nothing, Just mi) -> pure (Right mi) - (Just uri, Nothing) -> pure (Left uri) - (Just _, Just _) -> error errMsg + conversationCodeURISettings o createEnv :: Opts -> Logger -> IO Env createEnv o l = do From a98d7d2b5cead40932d3e8fbf82889eeb836f621 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 22 Apr 2026 12:17:20 +0200 Subject: [PATCH 08/39] fix(leif): duplication --- libs/wire-subsystems/src/Wire/UserClientIndexStore.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs index 6946642238f..97e06f16696 100644 --- a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs +++ b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs @@ -38,7 +38,6 @@ module Wire.UserClientIndexStore ) where -import Data.Domain (Domain) import Data.Id import Data.Proxy (Proxy (..)) import Data.Qualified @@ -60,6 +59,7 @@ import Wire.API.Routes.MultiTablePaging import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.Util (qualifyLocal) data UserClientIndexStore m a where GetClients :: [UserId] -> UserClientIndexStore m Clients @@ -143,9 +143,3 @@ getClientsId :: UserId -> Sem r [ClientId] getClientsId usr = clientIds usr <$> internalGetClientIds [usr] - -qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) -qualifyLocal a = toLocalUnsafe <$> fmap getDomain input <*> pure a - where - getDomain :: Local () -> Domain - getDomain = tDomain From a57cb4c872ef6232d60e9cdcfb5f3f954e0877fe Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 22 Apr 2026 15:31:24 +0200 Subject: [PATCH 09/39] fix(leif): TeamSubsystem internal endpoints --- .../src/Wire/API/Routes/Internal/Galley.hs | 16 +++++++ .../src/Wire/GalleyAPIAccess.hs | 3 ++ .../src/Wire/GalleyAPIAccess/Rpc.hs | 47 +++++++++++++++++++ .../src/Wire/TeamSubsystem/GalleyAPI.hs | 31 +----------- .../Wire/MockInterpreters/GalleyAPIAccess.hs | 2 + services/galley/src/Galley/API/Internal.hs | 2 + 6 files changed, 72 insertions(+), 29 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index b46992e018f..8ac9a3b548a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -20,6 +20,7 @@ module Wire.API.Routes.Internal.Galley where import Control.Lens ((.~)) import Data.Domain import Data.Id as Id +import Data.LegalHold (UserLegalHoldStatus) import Data.OpenApi (OpenApi, info, title) import Data.Range import GHC.TypeLits (AppendSymbol) @@ -622,6 +623,21 @@ type IMiscAPI = :> Capture "domain" Domain :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 200 "OK") ) + :<|> Named + "get-user-lh-status" + ( "users" + :> Capture "uid" UserId + :> "lh-status" + :> QueryParam "team_id" TeamId + :> Get '[JSON] UserLegalHoldStatus + ) + :<|> Named + "get-users-lh-status" + ( "users" + :> "lh-status" + :> ReqBody '[JSON] UserIds + :> Post '[JSON] [(UserId, UserLegalHoldStatus)] + ) type IEJPDAPI = Named diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index f70fa3addf8..84f14322eb9 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -22,6 +22,7 @@ module Wire.GalleyAPIAccess where import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) +import Data.LegalHold (UserLegalHoldStatus) import Data.Qualified import Data.Range import Imports @@ -166,5 +167,7 @@ data GalleyAPIAccess m a where GetConversationConfig :: GalleyAPIAccess m ConversationSubsystemConfig GuardLegalHold :: LegalholdProtectee -> UserClients -> GalleyAPIAccess m () + GetUserLHStatus :: Maybe TeamId -> UserId -> GalleyAPIAccess m UserLegalHoldStatus + GetUsersLHStatus :: [UserId] -> GalleyAPIAccess m [(UserId, UserLegalHoldStatus)] makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 0aa2989693e..4b1f91ad7da 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -27,6 +27,7 @@ import Data.Coerce (coerce) import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) +import Data.LegalHold (UserLegalHoldStatus) import Data.Qualified import Data.Range import Imports @@ -109,6 +110,8 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamContacts uid -> getTeamContacts uid GetConversationConfig -> getConversationConfig GuardLegalHold protectee userClient -> guardLegalhold protectee userClient + GetUserLHStatus mtid uid -> getUserLHStatus mtid uid + GetUsersLHStatus uids -> getUsersLHStatus uids getUserLegalholdStatus :: ( Member (Error ParseException) r, @@ -748,3 +751,47 @@ guardLegalhold protectee userClients = do . paths ["i", "guard-legalhold-policy-conflicts"] . header "Content-Type" "application/json" . lbytes (encode $ GuardLegalholdPolicyConflicts protectee userClients) + +getUserLHStatus :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + Maybe TeamId -> + UserId -> + Sem r UserLegalHoldStatus +getUserLHStatus mtid uid = do + debug $ + remote "galley" + . field "user" (toByteString uid) + . msg (val "Get user legalhold status") + galleyRequest req >>= decodeBodyOrThrow "galley" + where + req = + method GET + . paths ["i", "users", toByteString' uid, "lh-status"] + . maybe id (queryItem "team_id" . toByteString') mtid + . expect2xx + +getUsersLHStatus :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + [UserId] -> + Sem r [(UserId, UserLegalHoldStatus)] +getUsersLHStatus uids = do + debug $ + remote "galley" + . msg (val "Get users legalhold status") + let bdy = UserIds uids + galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" + where + req bdy = + method POST + . paths ["i", "users", "lh-status"] + . header "Content-Type" "application/json" + . lbytes (encode bdy) + . expect2xx diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs index 93ca9a64101..83f5d77fe36 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs @@ -17,12 +17,10 @@ module Wire.TeamSubsystem.GalleyAPI where -import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Imports import Polysemy import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Team.Feature (FeatureStatus (FeatureStatusEnabled), LockableFeature (..)) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.TeamSubsystem @@ -52,30 +50,5 @@ interpretTeamSubsystemToGalleyAPI = interpret $ \case GalleyAPIAccess.getTeamMembersWithLimit tid Nothing AssertTeamExists tid -> do void $ GalleyAPIAccess.getTeam tid - GetLHStatusForUsers uids -> do - for uids $ \uid -> do - mteamId <- GalleyAPIAccess.getTeamId uid - status <- case mteamId of - Nothing -> pure defUserLegalHoldStatus - Just tid -> do - GalleyAPIAccess.getTeamMember uid tid >>= \case - Nothing -> pure defUserLegalHoldStatus - Just _ -> do - LockableFeature {status} <- GalleyAPIAccess.getTeamLegalHoldStatus tid - pure $ - if status == FeatureStatusEnabled - then UserLegalHoldEnabled - else defUserLegalHoldStatus - pure (uid, status) - GetLHStatus mtid uid -> do - case mtid of - Nothing -> pure defUserLegalHoldStatus - Just tid -> do - GalleyAPIAccess.getTeamMember uid tid >>= \case - Nothing -> pure defUserLegalHoldStatus - Just _ -> do - LockableFeature {status} <- GalleyAPIAccess.getTeamLegalHoldStatus tid - pure $ - if status == FeatureStatusEnabled - then UserLegalHoldEnabled - else defUserLegalHoldStatus + GetLHStatusForUsers uids -> GalleyAPIAccess.getUsersLHStatus uids + GetLHStatus mtid uid -> GalleyAPIAccess.getUserLHStatus mtid uid diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 2f08144ef81..485cb6454d9 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -92,6 +92,8 @@ miniGalleyAPIAccess teams configs = interpret $ \case maxConvSize = 500, listClientsUsingBrig = False } + GetUserLHStatus _ _ -> error "GetUserLHStatus not implemented in miniGalleyAPIAccess" + GetUsersLHStatus _ -> error "GetUsersLHStatus not implemented in miniGalleyAPIAccess" GuardLegalHold {} -> pure () -- this is called but the result is not needed in unit tests diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 9cc12832427..4a896607408 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -244,6 +244,8 @@ miscAPI = <@> mkNamedAPI @"delete-bot" rmBot <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend + <@> mkNamedAPI @"get-user-lh-status" (\uid mtid -> TeamSubsystem.getLHStatus mtid uid) + <@> mkNamedAPI @"get-users-lh-status" (\userIds -> TeamSubsystem.getLHStatusForUsers (cUsers userIds)) featureAPI1Full :: forall cfg r. From 3be701ffb66634d130762d9fbe78d9bae7929b87 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 23 Apr 2026 16:22:00 +0200 Subject: [PATCH 10/39] chore: rebase issue --- libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 4b1f91ad7da..e781f24bcea 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -39,6 +39,7 @@ import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog (TinyLog, debug) import Servant.API (toHeader) import System.Logger.Message import Util.Options @@ -67,7 +68,8 @@ import Wire.Rpc interpretGalleyAPIAccessToRpc :: ( Member (Error ParseException) r, Member Rpc r, - Member (Error ClientError) r + Member (Error ClientError) r, + Member TinyLog r ) => Set Version -> Endpoint -> From 20f8d774102347d64c789a30264f215132f096fd Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 23 Apr 2026 16:47:18 +0200 Subject: [PATCH 11/39] WIP: Remove higher order effect --- .../src/Wire/ConversationSubsystem.hs | 30 +++++++++++++++---- .../Wire/ConversationSubsystem/Interpreter.hs | 9 ++---- .../src/Wire/ConversationSubsystem/Query.hs | 1 + 3 files changed, 29 insertions(+), 11 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index cd10f465eca..6865e4be71a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -76,7 +76,7 @@ import Wire.ConversationSubsystem.MLS.IncomingMessage (IncomingBundle, IncomingM import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval import Wire.ConversationSubsystem.Util qualified as Util import Wire.NotificationSubsystem (LocalConversationUpdate) -import Wire.StoredConversation (BotMember, LocalMember, StoredConversation) +import Wire.StoredConversation data ConversationSubsystem m a where NotifyConversationAction :: @@ -213,11 +213,12 @@ data ConversationSubsystem m a where RawMLS Message -> ConversationSubsystem m MLSMessageSendingStatus IsMLSEnabled :: ConversationSubsystem m Bool - IterateConversations :: + GetConversationsInternal :: Local UserId -> - Range 1 500 Int32 -> - ([StoredConversation] -> m a) -> - ConversationSubsystem m () + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + ConversationSubsystem m (Public.ConversationList StoredConversation) RemoveMemberFromLocalConv :: Local ConvId -> Local UserId -> @@ -688,3 +689,22 @@ data ConversationSubsystem m a where ConversationSubsystem m () makeSem ''ConversationSubsystem + +iterateConversations :: + (Member ConversationSubsystem r) => + Local UserId -> + Range 1 500 Int32 -> + ([StoredConversation] -> Sem r a) -> + Sem r [a] +iterateConversations luid pageSize handleConvs = go Nothing + where + go mbConv = do + convResult <- getConversationsInternal luid Nothing mbConv (Just pageSize) + resultHead <- handleConvs (convList convResult) + resultTail <- case convList convResult of + (conv : rest) -> + if convHasMore convResult + then go (Just (maximum ((.id_) <$> (conv : rest)))) + else pure [] + _ -> pure [] + pure $ resultHead : resultTail diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index efbb6899621..9734ad7f256 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -45,7 +45,7 @@ import Wire.BrigAPIAccess import Wire.CodeStore (CodeStore) import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem (ConversationSubsystem (..)) import Wire.ConversationSubsystem.Action.Notify qualified as ActionNotify import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.CreateInternal qualified as CreateInternal @@ -159,11 +159,8 @@ interpretConversationSubsystem = interpretH $ \case liftT $ mapErrors $ MLSMessage.postMLSMessageFromLocalUser v lusr c conn smsg IsMLSEnabled -> liftT $ mapErrors $ MLSEnabled.isMLSEnabled - IterateConversations luid pageSize handleConvs -> do - handleConvsT <- bindT handleConvs - ins <- getInitialStateT - void $ raise $ interpretConversationSubsystem $ Query.iterateConversations luid pageSize $ handleConvsT . ($>) ins - pureT () + GetConversationsInternal luser mids mstart msize -> + liftT $ mapErrors $ getConversationsInternal luser mids mstart msize RemoveMemberFromLocalConv lcnv lusr con victim -> liftT $ mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim FederationOnConversationCreated domain rc -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index d64ec116e6f..ffb92913970 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -30,6 +30,7 @@ module Wire.ConversationSubsystem.Query conversationIdsPageFromV2, conversationIdsPageFrom, getConversations, + getConversationsInternal, listConversations, iterateConversations, getLocalSelf, From a578013a82377519951ff09280230141ab53fe00 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 23 Apr 2026 16:58:39 +0200 Subject: [PATCH 12/39] refactor: first order effect --- .../Wire/ConversationSubsystem/Interpreter.hs | 247 +++++++++--------- services/galley/src/Galley/API/LegalHold.hs | 78 +++--- 2 files changed, 161 insertions(+), 164 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9734ad7f256..25fd45d69f7 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -31,15 +31,13 @@ import Network.Wai.Utilities.JSONResponse (JSONResponse) import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.Internal.Tactics (liftT) import Polysemy.Resource (Resource) import Polysemy.TinyLog (TinyLog) import Wire.API.Conversation.Config import Wire.API.Error import Wire.API.Federation.Client (FederatorClient) import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) -import Wire.API.Team.Feature (LegalholdConfig) -import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults, FeatureFlags) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BrigAPIAccess import Wire.CodeStore (CodeStore) @@ -67,7 +65,6 @@ import Wire.ConversationSubsystem.Query qualified as Query import Wire.ConversationSubsystem.Update qualified as Update import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem -import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.FederationSubsystem (FederationSubsystem) import Wire.FireAndForget (FireAndForget) @@ -89,7 +86,6 @@ interpretConversationSubsystem :: ( Member (Error ConversationSubsystemError) r, Member (Error JSONResponse) r, Member (Error DynError) r, - Member (Input (FeatureDefaults LegalholdConfig)) r, Member UserGroupStore r, Member (Input (Maybe GuestLinkTTLSeconds)) r, Member HashPassword r, @@ -114,7 +110,6 @@ interpretConversationSubsystem :: Member (Input (Maybe GroupInfoCheckEnabled)) r, Member ProposalStore r, Member LegalHoldStore r, - Member (Input ExposeInvitationURLsAllowlist) r, Member TeamStore r, Member ConvStore.MLSCommitLockStore r, Member FederationSubsystem r, @@ -126,242 +121,242 @@ interpretConversationSubsystem :: ) => Sem (ConversationSubsystem : r) a -> Sem r a -interpretConversationSubsystem = interpretH $ \case +interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> - liftT $ mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData InternalCreateGroupConversation lusr conn newConv -> - liftT $ mapErrors $ CreateInternal.createGroupConversationGeneric lusr conn newConv + mapErrors $ CreateInternal.createGroupConversationGeneric lusr conn newConv CreateGroupConversationUpToV3 lusr conn newConv -> - liftT $ mapErrors $ Create.createGroupConversationUpToV3 lusr conn newConv + mapErrors $ Create.createGroupConversationUpToV3 lusr conn newConv CreateGroupOwnConversation lusr conn newConv -> - liftT $ mapErrors $ Create.createGroupOwnConversation lusr conn newConv + mapErrors $ Create.createGroupOwnConversation lusr conn newConv CreateGroupConversation lusr conn newConv -> - liftT $ mapErrors $ Create.createGroupConversation lusr conn newConv + mapErrors $ Create.createGroupConversation lusr conn newConv CreateProteusSelfConversation lusr -> - liftT $ mapErrors $ Create.createProteusSelfConversation lusr + mapErrors $ Create.createProteusSelfConversation lusr CreateOne2OneConversation lusr zcon j -> - liftT $ mapErrors $ Create.createOne2OneConversation lusr zcon j + mapErrors $ Create.createOne2OneConversation lusr zcon j CreateConnectConversation lusr conn j -> - liftT $ mapErrors $ Create.createConnectConversation lusr conn j + mapErrors $ Create.createConnectConversation lusr conn j GetConversations convIds -> - liftT $ mapErrors $ ConvStore.getConversations convIds + mapErrors $ ConvStore.getConversations convIds GetConversationIds lusr maxIds pagingState -> - liftT $ mapErrors $ Fetch.getConversationIdsImpl lusr maxIds pagingState + mapErrors $ Fetch.getConversationIdsImpl lusr maxIds pagingState InternalGetLocalMember cid uid -> - liftT $ mapErrors $ ConvStore.getLocalMember cid uid + mapErrors $ ConvStore.getLocalMember cid uid PostMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle -> - liftT $ mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle + mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle PostMLSCommitBundleFromLocalUser v lusr c conn bundle -> - liftT $ mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle + mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle PostMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg -> - liftT $ mapErrors $ MLSMessage.postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg + mapErrors $ MLSMessage.postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg PostMLSMessageFromLocalUser v lusr c conn smsg -> - liftT $ mapErrors $ MLSMessage.postMLSMessageFromLocalUser v lusr c conn smsg + mapErrors $ MLSMessage.postMLSMessageFromLocalUser v lusr c conn smsg IsMLSEnabled -> - liftT $ mapErrors $ MLSEnabled.isMLSEnabled + mapErrors $ MLSEnabled.isMLSEnabled GetConversationsInternal luser mids mstart msize -> - liftT $ mapErrors $ getConversationsInternal luser mids mstart msize + mapErrors $ Query.getConversationsInternal luser mids mstart msize RemoveMemberFromLocalConv lcnv lusr con victim -> - liftT $ mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim + mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim FederationOnConversationCreated domain rc -> - liftT $ mapErrors $ Federation.onConversationCreated domain rc + mapErrors $ Federation.onConversationCreated domain rc FederationGetConversationsV1 domain req -> - liftT $ mapErrors $ Federation.getConversationsV1 domain req + mapErrors $ Federation.getConversationsV1 domain req FederationGetConversations domain req -> - liftT $ mapErrors $ Federation.getConversations domain req + mapErrors $ Federation.getConversations domain req FederationLeaveConversation domain lc -> - liftT $ mapErrors $ Federation.leaveConversation domain lc + mapErrors $ Federation.leaveConversation domain lc FederationSendMessage domain msr -> - liftT $ mapErrors $ Federation.sendMessage domain msr + mapErrors $ Federation.sendMessage domain msr FederationUpdateConversation domain uc -> - liftT $ mapErrors $ Federation.updateConversation domain uc + mapErrors $ Federation.updateConversation domain uc FederationMlsSendWelcome domain req -> - liftT $ mapErrors $ Federation.mlsSendWelcome domain req + mapErrors $ Federation.mlsSendWelcome domain req FederationSendMLSMessage domain msr -> - liftT $ mapErrors $ Federation.sendMLSMessage domain msr + mapErrors $ Federation.sendMLSMessage domain msr FederationSendMLSCommitBundle domain msr -> - liftT $ mapErrors $ Federation.sendMLSCommitBundle domain msr + mapErrors $ Federation.sendMLSCommitBundle domain msr FederationQueryGroupInfo domain req -> - liftT $ mapErrors $ Federation.queryGroupInfo domain req + mapErrors $ Federation.queryGroupInfo domain req FederationUpdateTypingIndicator domain req -> - liftT $ mapErrors $ Federation.updateTypingIndicator domain req + mapErrors $ Federation.updateTypingIndicator domain req FederationOnTypingIndicatorUpdated domain td -> - liftT $ mapErrors $ Federation.onTypingIndicatorUpdated domain td + mapErrors $ Federation.onTypingIndicatorUpdated domain td FederationGetSubConversationForRemoteUser domain req -> - liftT $ mapErrors $ Federation.getSubConversationForRemoteUser domain req + mapErrors $ Federation.getSubConversationForRemoteUser domain req FederationDeleteSubConversationForRemoteUser domain req -> - liftT $ mapErrors $ Federation.deleteSubConversationForRemoteUser domain req + mapErrors $ Federation.deleteSubConversationForRemoteUser domain req FederationLeaveSubConversation domain lscr -> - liftT $ mapErrors $ Federation.leaveSubConversation domain lscr + mapErrors $ Federation.leaveSubConversation domain lscr FederationGetOne2OneConversationV1 domain req -> - liftT $ mapErrors $ Federation.getOne2OneConversationV1 domain req + mapErrors $ Federation.getOne2OneConversationV1 domain req FederationGetOne2OneConversation domain req -> - liftT $ mapErrors $ Federation.getOne2OneConversation domain req + mapErrors $ Federation.getOne2OneConversation domain req FederationOnClientRemoved domain req -> - liftT $ mapErrors $ Federation.onClientRemoved domain req + mapErrors $ Federation.onClientRemoved domain req FederationOnMessageSent domain rm -> - liftT $ mapErrors $ Federation.onMessageSent domain rm + mapErrors $ Federation.onMessageSent domain rm FederationOnMLSMessageSent domain rmm -> - liftT $ mapErrors $ Federation.onMLSMessageSent domain rmm + mapErrors $ Federation.onMLSMessageSent domain rmm FederationOnConversationUpdatedV0 domain cu -> - liftT $ mapErrors $ Federation.onConversationUpdatedV0 domain cu + mapErrors $ Federation.onConversationUpdatedV0 domain cu FederationOnConversationUpdated domain cu -> - liftT $ mapErrors $ Federation.onConversationUpdated domain cu + mapErrors $ Federation.onConversationUpdated domain cu FederationOnUserDeleted domain udcn -> - liftT $ mapErrors $ Federation.onUserDeleted domain udcn + mapErrors $ Federation.onUserDeleted domain udcn PostOtrMessageUnqualified lusr con cnv ignore report msg -> - liftT $ mapErrors $ Update.postOtrMessageUnqualified lusr con cnv ignore report msg + mapErrors $ Update.postOtrMessageUnqualified lusr con cnv ignore report msg PostOtrBroadcastUnqualified lusr con ignore report msg -> - liftT $ mapErrors $ Update.postOtrBroadcastUnqualified lusr con ignore report msg + mapErrors $ Update.postOtrBroadcastUnqualified lusr con ignore report msg PostProteusMessage lusr con cnv msg -> - liftT $ mapErrors $ Update.postProteusMessage lusr con cnv msg + mapErrors $ Update.postProteusMessage lusr con cnv msg PostProteusBroadcast lusr con msg -> - liftT $ mapErrors $ Update.postProteusBroadcast lusr con msg + mapErrors $ Update.postProteusBroadcast lusr con msg DeleteLocalConversation lusr con lcnv -> - liftT $ mapErrors $ Update.deleteLocalConversation lusr con lcnv + mapErrors $ Update.deleteLocalConversation lusr con lcnv GetMLSPublicKeys fmt -> - liftT $ mapErrors $ MLS.getMLSPublicKeys fmt + mapErrors $ MLS.getMLSPublicKeys fmt ResetMLSConversation lusr reset -> - liftT $ mapErrors $ MLSReset.resetMLSConversation lusr reset + mapErrors $ MLSReset.resetMLSConversation lusr reset GetSubConversation lusr cnv sub -> - liftT $ mapErrors $ MLSSubConversation.getSubConversation lusr cnv sub + mapErrors $ MLSSubConversation.getSubConversation lusr cnv sub GetBotConversation bid cnv -> - liftT $ mapErrors $ Query.getBotConversation bid cnv + mapErrors $ Query.getBotConversation bid cnv GetUnqualifiedOwnConversation lusr cnv -> - liftT $ mapErrors $ Query.getUnqualifiedOwnConversation lusr cnv + mapErrors $ Query.getUnqualifiedOwnConversation lusr cnv GetOwnConversation lusr qcnv -> - liftT $ mapErrors $ Query.getOwnConversation lusr qcnv + mapErrors $ Query.getOwnConversation lusr qcnv GetConversation lusr qcnv -> - liftT $ mapErrors $ Query.getConversation lusr qcnv + mapErrors $ Query.getConversation lusr qcnv InternalGetConversation cnv -> - liftT $ mapErrors $ ConvStore.getConversation cnv + mapErrors $ ConvStore.getConversation cnv GetConversationRoles lusr cnv -> - liftT $ mapErrors $ Query.getConversationRoles lusr cnv + mapErrors $ Query.getConversationRoles lusr cnv GetGroupInfo lusr qcnv -> - liftT $ mapErrors $ MLSGroupInfo.getGroupInfo lusr qcnv + mapErrors $ MLSGroupInfo.getGroupInfo lusr qcnv ConversationIdsPageFromUnqualified lusr mstart msize -> - liftT $ mapErrors $ Query.conversationIdsPageFromUnqualified lusr mstart msize + mapErrors $ Query.conversationIdsPageFromUnqualified lusr mstart msize ConversationIdsPageFromV2 listGlobalSelf lself req -> - liftT $ mapErrors $ Query.conversationIdsPageFromV2 listGlobalSelf lself req + mapErrors $ Query.conversationIdsPageFromV2 listGlobalSelf lself req ConversationIdsPageFrom lusr req -> - liftT $ mapErrors $ Query.conversationIdsPageFrom lusr req + mapErrors $ Query.conversationIdsPageFrom lusr req ListConversations luser req -> - liftT $ mapErrors $ Query.listConversations luser req + mapErrors $ Query.listConversations luser req GetConversationByReusableCode lusr key value -> - liftT $ mapErrors $ Query.getConversationByReusableCode lusr key value + mapErrors $ Query.getConversationByReusableCode lusr key value GetMLSSelfConversationWithError lusr -> - liftT $ mapErrors $ Query.getMLSSelfConversationWithError lusr + mapErrors $ Query.getMLSSelfConversationWithError lusr GetMLSOne2OneConversationV5 lself qother -> - liftT $ mapErrors $ Query.getMLSOne2OneConversationV5 lself qother + mapErrors $ Query.getMLSOne2OneConversationV5 lself qother GetMLSOne2OneConversationV6 lself qother -> - liftT $ mapErrors $ Query.getMLSOne2OneConversationV6 lself qother + mapErrors $ Query.getMLSOne2OneConversationV6 lself qother GetMLSOne2OneConversation lself qother fmt -> - liftT $ mapErrors $ Query.getMLSOne2OneConversation lself qother fmt + mapErrors $ Query.getMLSOne2OneConversation lself qother fmt GetLocalSelf lusr cnv -> - liftT $ mapErrors $ Query.getLocalSelf lusr cnv + mapErrors $ Query.getLocalSelf lusr cnv GetSelfMember lusr qcnv -> - liftT $ mapErrors $ Query.getSelfMember lusr qcnv + mapErrors $ Query.getSelfMember lusr qcnv GetConversationGuestLinksStatus uid cid -> - liftT $ mapErrors $ Query.getConversationGuestLinksStatus uid cid + mapErrors $ Query.getConversationGuestLinksStatus uid cid GetCode mcode lusr cnv -> - liftT $ mapErrors $ Update.getCode mcode lusr cnv + mapErrors $ Update.getCode mcode lusr cnv AddMembersUnqualified lusr con cnv invite -> - liftT $ mapErrors $ Update.addMembersUnqualified lusr con cnv invite + mapErrors $ Update.addMembersUnqualified lusr con cnv invite AddMembersUnqualifiedV2 lusr con cnv invite -> - liftT $ mapErrors $ Update.addMembersUnqualifiedV2 lusr con cnv invite + mapErrors $ Update.addMembersUnqualifiedV2 lusr con cnv invite AddMembers lusr zcon qcnv invite -> - liftT $ mapErrors $ Update.addMembers lusr zcon qcnv invite + mapErrors $ Update.addMembers lusr zcon qcnv invite ReplaceMembers lusr zcon qcnv invite -> - liftT $ mapErrors $ Update.replaceMembers lusr zcon qcnv invite + mapErrors $ Update.replaceMembers lusr zcon qcnv invite JoinConversationById lusr con cnv -> - liftT $ mapErrors $ Update.joinConversationById lusr con cnv + mapErrors $ Update.joinConversationById lusr con cnv JoinConversationByReusableCode lusr con req -> - liftT $ mapErrors $ Update.joinConversationByReusableCode lusr con req + mapErrors $ Update.joinConversationByReusableCode lusr con req CheckReusableCode addr code -> - liftT $ mapErrors $ Update.checkReusableCode addr code + mapErrors $ Update.checkReusableCode addr code AddCodeUnqualified mReq usr mbZHost mZcon cnv -> - liftT $ mapErrors $ Update.addCodeUnqualified mReq usr mbZHost mZcon cnv + mapErrors $ Update.addCodeUnqualified mReq usr mbZHost mZcon cnv AddCodeUnqualifiedWithReqBody lusr mname mconn cnv req -> - liftT $ mapErrors $ Update.addCodeUnqualifiedWithReqBody lusr mname mconn cnv req + mapErrors $ Update.addCodeUnqualifiedWithReqBody lusr mname mconn cnv req RmCodeUnqualified lusr con cnv -> - liftT $ mapErrors $ Update.rmCodeUnqualified lusr con cnv + mapErrors $ Update.rmCodeUnqualified lusr con cnv MemberTypingUnqualified lusr con cnv status -> - liftT $ mapErrors $ Update.memberTypingUnqualified lusr con cnv status + mapErrors $ Update.memberTypingUnqualified lusr con cnv status MemberTyping lusr con qcnv status -> - liftT $ mapErrors $ Update.memberTyping lusr con qcnv status + mapErrors $ Update.memberTyping lusr con qcnv status RemoveMemberUnqualified lusr con cnv uid -> - liftT $ mapErrors $ Update.removeMemberUnqualified lusr con cnv uid + mapErrors $ Update.removeMemberUnqualified lusr con cnv uid RemoveMemberQualified lusr con qcnv quid -> - liftT $ mapErrors $ Update.removeMemberQualified lusr con qcnv quid + mapErrors $ Update.removeMemberQualified lusr con qcnv quid UpdateOtherMemberUnqualified lusr con cnv uid update -> - liftT $ mapErrors $ Update.updateOtherMemberUnqualified lusr con cnv uid update + mapErrors $ Update.updateOtherMemberUnqualified lusr con cnv uid update UpdateOtherMember lusr con qcnv quid update -> - liftT $ mapErrors $ Update.updateOtherMember lusr con qcnv quid update + mapErrors $ Update.updateOtherMember lusr con qcnv quid update UpdateUnqualifiedConversationName lusr con cnv rename -> - liftT $ mapErrors $ Update.updateUnqualifiedConversationName lusr con cnv rename + mapErrors $ Update.updateUnqualifiedConversationName lusr con cnv rename UpdateConversationName lusr zcon qcnv rename -> - liftT $ mapErrors $ Update.updateConversationName lusr zcon qcnv rename + mapErrors $ Update.updateConversationName lusr zcon qcnv rename UpdateConversationMessageTimerUnqualified lusr con cnv update -> - liftT $ mapErrors $ Update.updateConversationMessageTimerUnqualified lusr con cnv update + mapErrors $ Update.updateConversationMessageTimerUnqualified lusr con cnv update UpdateConversationMessageTimer lusr zcon qcnv update -> - liftT $ mapErrors $ Update.updateConversationMessageTimer lusr zcon qcnv update + mapErrors $ Update.updateConversationMessageTimer lusr zcon qcnv update UpdateConversationReceiptModeUnqualified lusr con cnv update -> - liftT $ mapErrors $ Update.updateConversationReceiptModeUnqualified lusr con cnv update + mapErrors $ Update.updateConversationReceiptModeUnqualified lusr con cnv update UpdateConversationReceiptMode lusr zcon qcnv update -> - liftT $ mapErrors $ Update.updateConversationReceiptMode lusr zcon qcnv update + mapErrors $ Update.updateConversationReceiptMode lusr zcon qcnv update UpdateConversationAccessUnqualified lusr con cnv update -> - liftT $ mapErrors $ Update.updateConversationAccessUnqualified lusr con cnv update + mapErrors $ Update.updateConversationAccessUnqualified lusr con cnv update UpdateConversationAccess lusr zcon qcnv update -> - liftT $ mapErrors $ Update.updateConversationAccess lusr zcon qcnv update + mapErrors $ Update.updateConversationAccess lusr zcon qcnv update UpdateConversationHistory lusr zcon qcnv update -> - liftT $ mapErrors $ Update.updateConversationHistory lusr zcon qcnv update + mapErrors $ Update.updateConversationHistory lusr zcon qcnv update UpdateUnqualifiedSelfMember lusr con cnv update -> - liftT $ mapErrors $ Update.updateUnqualifiedSelfMember lusr con cnv update + mapErrors $ Update.updateUnqualifiedSelfMember lusr con cnv update UpdateSelfMember lusr zcon qcnv update -> - liftT $ mapErrors $ Update.updateSelfMember lusr zcon qcnv update + mapErrors $ Update.updateSelfMember lusr zcon qcnv update UpdateConversationProtocolWithLocalUser lusr conn qcnv update -> - liftT $ mapErrors $ Update.updateConversationProtocolWithLocalUser lusr conn qcnv update + mapErrors $ Update.updateConversationProtocolWithLocalUser lusr conn qcnv update UpdateChannelAddPermission lusr conn qcnv update -> - liftT $ mapErrors $ Update.updateChannelAddPermission lusr conn qcnv update + mapErrors $ Update.updateChannelAddPermission lusr conn qcnv update PostBotMessageUnqualified bid cnv ignore report msg -> - liftT $ mapErrors $ Update.postBotMessageUnqualified bid cnv ignore report msg + mapErrors $ Update.postBotMessageUnqualified bid cnv ignore report msg DeleteSubConversation lusr qcnv sub reset -> - liftT $ mapErrors $ MLSSubConversation.deleteSubConversation lusr qcnv sub reset + mapErrors $ MLSSubConversation.deleteSubConversation lusr qcnv sub reset GetSubConversationGroupInfo lusr qcnv sub -> - liftT $ mapErrors $ MLSSubConversation.getSubConversationGroupInfo lusr qcnv sub + mapErrors $ MLSSubConversation.getSubConversationGroupInfo lusr qcnv sub LeaveSubConversation lusr cli qcnv sub -> - liftT $ mapErrors $ MLSSubConversation.leaveSubConversation lusr cli qcnv sub + mapErrors $ MLSSubConversation.leaveSubConversation lusr cli qcnv sub SendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData -> - liftT $ mapErrors $ ActionNotify.sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData + mapErrors $ ActionNotify.sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData GetPaginatedConversations lusr mids mstart msize -> - liftT $ mapErrors $ Query.getConversations lusr mids mstart msize + mapErrors $ Query.getConversations lusr mids mstart msize SearchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable -> - liftT $ mapErrors $ Query.searchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable + mapErrors $ Query.searchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable InternalGetMember qcnv usr -> - liftT $ mapErrors $ Query.internalGetMember qcnv usr + mapErrors $ Query.internalGetMember qcnv usr GetConversationMeta cnv -> - liftT $ mapErrors $ Query.getConversationMeta cnv + mapErrors $ Query.getConversationMeta cnv GetMLSOne2OneConversationInternal lself qother -> - liftT $ mapErrors $ Query.getMLSOne2OneConversationInternal lself qother + mapErrors $ Query.getMLSOne2OneConversationInternal lself qother IsMLSOne2OneEstablished lself qother -> - liftT $ mapErrors $ Query.isMLSOne2OneEstablished lself qother + mapErrors $ Query.isMLSOne2OneEstablished lself qother GetLocalConversationInternal cid -> - liftT $ mapErrors $ Query.getLocalConversationInternal cid + mapErrors $ Query.getLocalConversationInternal cid RemoveClient lc qusr c -> - liftT $ mapErrors $ MLSRemoval.removeClient lc qusr c + mapErrors $ MLSRemoval.removeClient lc qusr c AddBot lusr zcon b -> - liftT $ mapErrors $ Update.addBot lusr zcon b + mapErrors $ Update.addBot lusr zcon b RmBot lusr zcon b -> - liftT $ mapErrors $ Update.rmBot lusr zcon b + mapErrors $ Update.rmBot lusr zcon b UpdateCellsState cnv state -> - liftT $ mapErrors $ Update.updateCellsState cnv state + mapErrors $ Update.updateCellsState cnv state RemoveUser lc includeMain qusr -> - liftT $ mapErrors $ MLSRemoval.removeUser lc includeMain qusr + mapErrors $ MLSRemoval.removeUser lc includeMain qusr InternalUpsertOne2OneConversation req -> - liftT $ mapErrors $ One2One.internalUpsertOne2OneConversation req + mapErrors $ One2One.internalUpsertOne2OneConversation req AcceptConv lusr conn cnv -> - liftT $ mapErrors $ Update.acceptConv lusr conn cnv + mapErrors $ Update.acceptConv lusr conn cnv BlockConv lusr qcnv -> - liftT $ mapErrors $ Update.blockConv lusr qcnv + mapErrors $ Update.blockConv lusr qcnv UnblockConv lusr conn qcnv -> - liftT $ mapErrors $ Update.unblockConv lusr conn qcnv + mapErrors $ Update.unblockConv lusr conn qcnv diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 36a27385089..9d45370cdee 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -347,9 +347,10 @@ requestDevice lzusr tid uid = do where disallowIfMLSUser :: Local UserId -> Sem r () disallowIfMLSUser luid = do - iterateConversations luid (toRange (Proxy @500)) $ \convs -> do - when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do - throwS @'MLSLegalholdIncompatible + void $ + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do + when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do + throwS @'MLSLegalholdIncompatible -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -631,40 +632,41 @@ handleGroupConvPolicyConflicts :: UserLegalHoldStatus -> Sem r () handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do - iterateConversations luid (toRange (Proxy @500)) $ \convs -> do - for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do - let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.remoteMembers + void $ + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do + for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do + let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.remoteMembers - membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do - let mems = conv.localMembers - uidsLHStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> mems) - pure $ - zipWith - ( \mem (mid, status) -> - assert (mem.id_ == mid) $ - if mem.id_ == tUnqualified luid - then (mem, hypotheticalLHStatus) - else (mem, status) - ) - mems - uidsLHStatus + membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do + let mems = conv.localMembers + uidsLHStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> mems) + pure $ + zipWith + ( \mem (mid, status) -> + assert (mem.id_ == mid) $ + if mem.id_ == tUnqualified luid + then (mem, hypotheticalLHStatus) + else (mem, status) + ) + mems + uidsLHStatus - let lcnv = qualifyAs luid conv.id_ - -- we know that this is a group conversation, so invalid operation - -- and conversation not found errors cannot actually be thrown - mapToRuntimeError @'InvalidOperation - (InternalErrorWithDescription "expected group conversation while handling policy conflicts") - . mapToRuntimeError @'ConvNotFound - (InternalErrorWithDescription "conversation disappeared while iterating on a list of conversations") - . mapErrorS @('ActionDenied 'LeaveConversation) @('ActionDenied 'RemoveConversationMember) - $ if any - ((== TeamSubsystem.ConsentGiven) . TeamSubsystem.consentGiven . snd) - (filter ((== roleNameWireAdmin) . (.convRoleName) . fst) membersAndLHStatus) - then do - for_ (filter ((== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do - let lusr = qualifyAs luid memberNoConsent.id_ - removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) - else do - for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do - let lusr = qualifyAs luid legalholder.id_ - removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) + let lcnv = qualifyAs luid conv.id_ + -- we know that this is a group conversation, so invalid operation + -- and conversation not found errors cannot actually be thrown + mapToRuntimeError @'InvalidOperation + (InternalErrorWithDescription "expected group conversation while handling policy conflicts") + . mapToRuntimeError @'ConvNotFound + (InternalErrorWithDescription "conversation disappeared while iterating on a list of conversations") + . mapErrorS @('ActionDenied 'LeaveConversation) @('ActionDenied 'RemoveConversationMember) + $ if any + ((== TeamSubsystem.ConsentGiven) . TeamSubsystem.consentGiven . snd) + (filter ((== roleNameWireAdmin) . (.convRoleName) . fst) membersAndLHStatus) + then do + for_ (filter ((== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do + let lusr = qualifyAs luid memberNoConsent.id_ + removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) + else do + for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do + let lusr = qualifyAs luid legalholder.id_ + removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) From 72b4d70c2d4d420b963e251011a84d026dbc2b29 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 23 Apr 2026 17:16:14 +0200 Subject: [PATCH 13/39] refactor: use InterpreterFor --- .../src/Wire/ConversationSubsystem/Interpreter.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 25fd45d69f7..a25bab74b48 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -119,8 +119,7 @@ interpretConversationSubsystem :: Member (Input FanoutLimit) r, Member TinyLog r ) => - Sem (ConversationSubsystem : r) a -> - Sem r a + InterpreterFor ConversationSubsystem r interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData From 4422cb9be84dbf089873dce38f0af0472589de23 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 09:22:28 +0000 Subject: [PATCH 14/39] rename conversationViewV9 --- .../src/Wire/ConversationSubsystem/Create.hs | 16 ++++++++-------- .../src/Wire/ConversationSubsystem/Mapping.hs | 6 +++--- .../src/Wire/ConversationSubsystem/Query.hs | 10 +++++----- .../src/Wire/ConversationSubsystem/Update.hs | 4 ++-- .../Wire/ConversationSubsystem/MappingSpec.hs | 12 ++++++------ 5 files changed, 24 insertions(+), 24 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs index 26c7fab9178..8a9a8b38a67 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -96,7 +96,7 @@ createGroupConversationUpToV3 :: Sem r (ConversationResponse Public.OwnConversation) createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do dbConv <- createGroupConversationGeneric lusr conn newConv - Created <$> conversationViewV9 lusr dbConv + Created <$> ownConversationView lusr dbConv createGroupOwnConversation :: ( Member BrigAPIAccess r, @@ -138,7 +138,7 @@ createGroupOwnConversation lusr conn newConv = do enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) dbConv <- createGroupConversationGeneric lusr conn newConv - GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) + GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> ownConversationView lusr dbConv <*> pure mempty) createGroupConversation :: ( Member BrigAPIAccess r, @@ -194,8 +194,8 @@ createProteusSelfConversation :: createProteusSelfConversation lusr = do (c, created) <- createProteusSelfConversationLogic lusr if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c createOne2OneConversation :: ( Member BrigAPIAccess r, @@ -227,8 +227,8 @@ createOne2OneConversation :: createOne2OneConversation lusr zcon j = do (c, created) <- createOne2OneConversationLogic lusr zcon j if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c ---------------------------------------------------------------------------- -- Helpers @@ -254,5 +254,5 @@ createConnectConversation :: createConnectConversation lusr conn j = do (c, created) <- createConnectConversationLogic lusr conn j if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs index c4cea7981d0..aaee83f03d7 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs @@ -16,7 +16,7 @@ -- with this program. If not, see . module Wire.ConversationSubsystem.Mapping - ( conversationViewV9, + ( ownConversationView, conversationView, conversationViewWithCachedOthers, remoteConversationView, @@ -41,14 +41,14 @@ import Wire.StoredConversation -- | View for a given user of a stored conversation. -- -- Throws @BadMemberState@ when the user is not part of the conversation. -conversationViewV9 :: +ownConversationView :: ( Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> StoredConversation -> Sem r OwnConversation -conversationViewV9 luid conv = do +ownConversationView luid conv = do let remoteOthers = map remoteMemberToOther $ conv.remoteMembers localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers conversationViewWithCachedOthers remoteOthers localOthers conv luid diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index ffb92913970..7c2ba3fbec8 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -162,7 +162,7 @@ getUnqualifiedOwnConversation :: Sem r Public.OwnConversation getUnqualifiedOwnConversation lusr cnv = do c <- getConversationAsMember (tUntagged lusr) (qualifyAs lusr cnv) - Mapping.conversationViewV9 lusr c + Mapping.ownConversationView lusr c getUnqualifiedConversation :: forall r. @@ -468,7 +468,7 @@ getConversations :: Sem r (Public.ConversationList Public.OwnConversation) getConversations luser mids mstart msize = do ConversationList cs more <- getConversationsInternal luser mids mstart msize - flip ConversationList more <$> mapM (Mapping.conversationViewV9 luser) cs + flip ConversationList more <$> mapM (Mapping.ownConversationView luser) cs getConversationsInternal :: (Member ConversationStore.ConversationStore r) => @@ -519,7 +519,7 @@ listConversations luser (Public.ListConversations ids) = do localInternalConversations <- ConversationStore.getConversations foundLocalIds >>= filterM (\c -> pure $ isMember (tUnqualified luser) c.localMembers) - localConversations <- mapM (Mapping.conversationViewV9 luser) localInternalConversations + localConversations <- mapM (Mapping.ownConversationView luser) localInternalConversations (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures @@ -739,7 +739,7 @@ getMLSSelfConversation lusr = do let selfConvId = mlsSelfConvId . tUnqualified $ lusr mconv <- ConversationStore.getConversation selfConvId cnv <- maybe (createMLSSelfConversation lusr) pure mconv - conversationViewV9 lusr cnv + ownConversationView lusr cnv createMLSSelfConversation :: (Member ConversationStore.ConversationStore r) => @@ -876,7 +876,7 @@ getLocalMLSOne2OneConversation lself lconv = do keys <- mlsKeysToPublic <$$> getMLSPrivateKeys conv <- case mconv of Nothing -> pure (localMLSOne2OneConversation lself lconv) - Just conv -> conversationViewV9 lself conv + Just conv -> ownConversationView lself conv pure $ MLSOne2OneConversation { conversation = conv, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 6aa276b8699..fe406107f84 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -177,7 +177,7 @@ acceptConv lusr conn cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound conv' <- acceptOne2One lusr conv conn - conversationViewV9 lusr conv' + ownConversationView lusr conv' blockConv :: ( Member ConversationStore r, @@ -259,7 +259,7 @@ unblockConvUnqualified lusr conn cnv = do unless (convType conv `elem` [ConnectConv, One2OneConv]) $ throwS @'InvalidOperation conv' <- acceptOne2One lusr conv conn - conversationViewV9 lusr conv' + ownConversationView lusr conv' unblockRemoteConv :: (Member ConversationStore r) => diff --git a/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs index 69b7025e092..025e97a4b59 100644 --- a/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs @@ -51,31 +51,31 @@ run = P.run . P.runError . P.discardLogs spec :: Spec spec = describe "ConversationMapping" do prop "conversation view V9 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (conversationViewV9 luid c)) + \(ConvWithLocalUser c luid) -> isRight (run (ownConversationView luid c)) prop "conversation view V10 for a valid user is non-empty" $ \(ConvWithLocalUser c luid) -> isRight (run (pure $ conversationView (qualifyAs luid ()) (Just luid) c)) prop "self user in conversation view is correct" $ \(ConvWithLocalUser c luid) -> - fmap (memId . cmSelf . cnvMembers) (run (conversationViewV9 luid c)) + fmap (memId . cmSelf . cnvMembers) (run (ownConversationView luid c)) == Right (tUntagged luid) prop "conversation view metadata is correct" $ \(ConvWithLocalUser c luid) -> - fmap cnvMetadata (run (conversationViewV9 luid c)) + fmap cnvMetadata (run (ownConversationView luid c)) == Right c.metadata prop "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c luid) -> case run $ conversationViewV9 luid c of + \(ConvWithLocalUser c luid) -> case run $ ownConversationView luid c of Left _ -> False Right cnv -> tUntagged luid `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)) prop "conversation view contains all users" $ \(ConvWithLocalUser c luid) -> - fmap (sort . cnvUids) (run (conversationViewV9 luid c)) + fmap (sort . cnvUids) (run (ownConversationView luid c)) == Right (sort (convUids (tDomain luid) c)) prop "conversation view for an invalid user is empty" $ \(RandomConversation c) luid -> notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> - isLeft (run (conversationViewV9 luid c)) + isLeft (run (ownConversationView luid c)) prop "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom ==> From 242a541bde84b960197ffcf516ccc600fcaa3c50 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 09:39:19 +0000 Subject: [PATCH 15/39] rename RemoteConversationV2 and helpers --- .../src/Wire/API/Federation/API/Galley.hs | 26 +++++++++---------- .../Golden/GetOne2OneConversationResponse.hs | 4 +-- .../Wire/ConversationSubsystem/MLS/One2One.hs | 4 +-- .../src/Wire/ConversationSubsystem/Mapping.hs | 6 ++--- .../src/Wire/ConversationSubsystem/Query.hs | 4 +-- .../Wire/ConversationSubsystem/MappingSpec.hs | 2 +- services/galley/test/integration/API/Util.hs | 4 +-- 7 files changed, 25 insertions(+), 25 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 0f4afc600a0..92f39cce5bb 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -236,7 +236,7 @@ instance ToSchema RemoteConversation -- information as a 'Conversation', with the exception that conversation status -- fields (muted\/archived\/hidden) are omitted, since they are not known by the -- remote backend. -data RemoteConversationV2 = RemoteConversationV2 +data RemoteConversationView = RemoteConversationView { -- | Id of the conversation, implicitly qualified with the domain of the -- backend that created this value. id :: ConvId, @@ -245,13 +245,13 @@ data RemoteConversationV2 = RemoteConversationV2 protocol :: Protocol } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform RemoteConversationV2) - deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConversationV2) + deriving (Arbitrary) via (GenericUniform RemoteConversationView) + deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConversationView) -instance ToSchema RemoteConversationV2 +instance ToSchema RemoteConversationView -remoteConversationFromV2 :: RemoteConversationV2 -> RemoteConversation -remoteConversationFromV2 rc = +remoteConversationFromView :: RemoteConversationView -> RemoteConversation +remoteConversationFromView rc = RemoteConversation { id = rc.id, metadata = rc.metadata, @@ -259,9 +259,9 @@ remoteConversationFromV2 rc = protocol = ClientAPI.Versioned rc.protocol } -remoteConversationToV2 :: RemoteConversation -> RemoteConversationV2 -remoteConversationToV2 rc = - RemoteConversationV2 +remoteConversationToView :: RemoteConversation -> RemoteConversationView +remoteConversationToView rc = + RemoteConversationView { id = rc.id, metadata = rc.metadata, members = rc.members, @@ -278,7 +278,7 @@ newtype GetConversationsResponse = GetConversationsResponse instance ToSchema GetConversationsResponse newtype GetConversationsResponseV2 = GetConversationsResponseV2 - { convs :: [RemoteConversationV2] + { convs :: [RemoteConversationView] } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform GetConversationsResponseV2) @@ -287,10 +287,10 @@ newtype GetConversationsResponseV2 = GetConversationsResponseV2 instance ToSchema GetConversationsResponseV2 getConversationsResponseToV2 :: GetConversationsResponse -> GetConversationsResponseV2 -getConversationsResponseToV2 res = GetConversationsResponseV2 (map remoteConversationToV2 res.convs) +getConversationsResponseToV2 res = GetConversationsResponseV2 (map remoteConversationToView res.convs) getConversationsResponseFromV2 :: GetConversationsResponseV2 -> GetConversationsResponse -getConversationsResponseFromV2 res = GetConversationsResponse (map remoteConversationFromV2 res.convs) +getConversationsResponseFromV2 res = GetConversationsResponse (map remoteConversationFromView res.convs) data GetOne2OneConversationResponse = GetOne2OneConversationOk RemoteConversation @@ -321,7 +321,7 @@ data GetOne2OneConversationResponseV2 instance ToSchema GetOne2OneConversationResponseV2 data RemoteMLSOne2OneConversation = RemoteMLSOne2OneConversation - { conversation :: RemoteConversationV2, + { conversation :: RemoteConversationView, publicKeys :: MLSKeysByPurpose MLSPublicKeys } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs index 25cd3f9025e..5e95cdd713b 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs @@ -116,9 +116,9 @@ remoteConversation = } } -remoteConversationV2 :: RemoteConversationV2 +remoteConversationV2 :: RemoteConversationView remoteConversationV2 = - RemoteConversationV2 + RemoteConversationView { id = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200040001"))), metadata = ConversationMetadata diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs index 3082a3dc257..2db148d7aae 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs @@ -65,7 +65,7 @@ localMLSOne2OneConversation lself (tUntagged -> convId) = -- conversation to be returned to a remote backend. localMLSOne2OneConversationAsRemote :: Local ConvId -> - RemoteConversationV2 + RemoteConversationView localMLSOne2OneConversationAsRemote lcnv = let members = RemoteConvMembers @@ -73,7 +73,7 @@ localMLSOne2OneConversationAsRemote lcnv = others = [] } (metadata, mlsData) = localMLSOne2OneConversationMetadata (tUntagged lcnv) - in RemoteConversationV2 + in RemoteConversationView { id = tUnqualified lcnv, metadata = metadata, members = members, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs index aaee83f03d7..a06b910e76e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs @@ -114,7 +114,7 @@ conversationViewMaybe luid remoteOthers localOthers conv = do remoteConversationView :: Local UserId -> MemberStatus -> - Remote RemoteConversationV2 -> + Remote RemoteConversationView -> OwnConversation remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = let mems = rconv.members @@ -142,7 +142,7 @@ conversationToRemote :: Domain -> Remote UserId -> StoredConversation -> - Maybe RemoteConversationV2 + Maybe RemoteConversationView conversationToRemote localDomain ruid conv = do let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) lothers = conv.localMembers @@ -151,7 +151,7 @@ conversationToRemote localDomain ruid conv = do map (localMemberToOther localDomain) lothers <> map remoteMemberToOther rothers pure $ - RemoteConversationV2 + RemoteConversationView { id = conv.id_, metadata = conv.metadata, members = diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 7c2ba3fbec8..19b75815177 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -318,7 +318,7 @@ getRemoteConversationsWithFailures :: getRemoteConversationsWithFailures lusr convs = do -- get self member statuses from the database statusMap <- ConversationStore.getRemoteConversationStatus (tUnqualified lusr) convs - let remoteView :: Remote RemoteConversationV2 -> OwnConversation + let remoteView :: Remote RemoteConversationView -> OwnConversation remoteView rconv = Mapping.remoteConversationView lusr @@ -353,7 +353,7 @@ getRemoteConversationsWithFailures lusr convs = do handleFailure :: (Member P.TinyLog r) => Either (Remote [ConvId], FederationError) (Remote GetConversationsResponseV2) -> - Sem r (Either FailedGetConversation [Remote RemoteConversationV2]) + Sem r (Either FailedGetConversation [Remote RemoteConversationView]) handleFailure (Left (rcids, e)) = do P.warn $ Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) diff --git a/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs index 025e97a4b59..90771e04aa0 100644 --- a/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs @@ -39,7 +39,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), - RemoteConversationV2 (..), + RemoteConversationView (..), ) import Wire.ConversationSubsystem.Mapping import Wire.Sem.Logger qualified as P diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 5198b210061..e2e624fa0b7 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2449,9 +2449,9 @@ mkProteusConv :: UserId -> RoleName -> [OtherMember] -> - RemoteConversationV2 + RemoteConversationView mkProteusConv cnvId creator selfRole otherMembers = - RemoteConversationV2 + RemoteConversationView cnvId ( ConversationMetadata RegularConv From 8aae25d0ca16acdaa3467a6883bd5e0ce7c42692 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 09:49:15 +0000 Subject: [PATCH 16/39] renamed addMemberUnqualifiedV2 --- libs/wire-subsystems/src/Wire/ConversationSubsystem.hs | 2 +- .../src/Wire/ConversationSubsystem/Interpreter.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Update.hs | 6 +++--- services/galley/src/Galley/API/Public/Conversation.hs | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 6865e4be71a..f7eb140ad0a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -467,7 +467,7 @@ data ConversationSubsystem m a where ConvId -> Invite -> ConversationSubsystem m (UpdateResult Event) - AddMembersUnqualifiedV2 :: + AddQualifiedMembersUnqualified :: Local UserId -> ConnId -> ConvId -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index a25bab74b48..be426bc1b91 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -261,8 +261,8 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Update.getCode mcode lusr cnv AddMembersUnqualified lusr con cnv invite -> mapErrors $ Update.addMembersUnqualified lusr con cnv invite - AddMembersUnqualifiedV2 lusr con cnv invite -> - mapErrors $ Update.addMembersUnqualifiedV2 lusr con cnv invite + AddQualifiedMembersUnqualified lusr con cnv invite -> + mapErrors $ Update.addQualifiedMembersUnqualified lusr con cnv invite AddMembers lusr zcon qcnv invite -> mapErrors $ Update.addMembers lusr zcon qcnv invite ReplaceMembers lusr zcon qcnv invite -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index fe406107f84..1feb573c153 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -50,7 +50,7 @@ module Wire.ConversationSubsystem.Update -- * Managing Members addMembersUnqualified, - addMembersUnqualifiedV2, + addQualifiedMembersUnqualified, addMembers, replaceMembers, updateUnqualifiedSelfMember, @@ -982,7 +982,7 @@ addMembers lusr zcon qcnv (InviteQualified users role) = do getUpdateResult . fmap lcuEvent $ updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) action -addMembersUnqualifiedV2 :: +addQualifiedMembersUnqualified :: ( Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, Member ConversationStore r, @@ -1016,7 +1016,7 @@ addMembersUnqualifiedV2 :: ConvId -> InviteQualified -> Sem r (UpdateResult Event) -addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do +addQualifiedMembersUnqualified lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv getUpdateResult . fmap lcuEvent $ updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) $ diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index a54e22548af..789451968e2 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -64,7 +64,7 @@ conversationAPI = <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneConversationV6 <@> mkNamedAPI @"get-one-to-one-mls-conversation" getMLSOne2OneConversation <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified - <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addMembersUnqualifiedV2 + <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addQualifiedMembersUnqualified <@> mkNamedAPI @"add-members-to-conversation" addMembers <@> mkNamedAPI @"replace-members-in-conversation" replaceMembers <@> mkNamedAPI @"join-conversation-by-id-unqualified" joinConversationById From ab3f3a2abdea78f0dd3880108ac020552b4a95f4 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 09:56:14 +0000 Subject: [PATCH 17/39] rename GetConversationResponseV2 --- .../src/Wire/API/Federation/API/Galley.hs | 18 +++++++++--------- .../src/Wire/ConversationSubsystem.hs | 2 +- .../Wire/ConversationSubsystem/Federation.hs | 6 +++--- .../src/Wire/ConversationSubsystem/Query.hs | 6 +++--- services/galley/test/integration/API.hs | 10 +++++----- .../galley/test/integration/API/Federation.hs | 4 ++-- 6 files changed, 23 insertions(+), 23 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 92f39cce5bb..b2ae91b06e4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -83,7 +83,7 @@ type GalleyApi = '[From 'V2] "get-conversations" GetConversationsRequest - GetConversationsResponseV2 + GetRemoteConversationViewsResponse :<|> FedEndpoint "leave-conversation" LeaveConversationRequest @@ -277,20 +277,20 @@ newtype GetConversationsResponse = GetConversationsResponse instance ToSchema GetConversationsResponse -newtype GetConversationsResponseV2 = GetConversationsResponseV2 +newtype GetRemoteConversationViewsResponse = GetRemoteConversationViewsResponse { convs :: [RemoteConversationView] } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform GetConversationsResponseV2) - deriving (ToJSON, FromJSON) via (CustomEncoded GetConversationsResponseV2) + deriving (Arbitrary) via (GenericUniform GetRemoteConversationViewsResponse) + deriving (ToJSON, FromJSON) via (CustomEncoded GetRemoteConversationViewsResponse) -instance ToSchema GetConversationsResponseV2 +instance ToSchema GetRemoteConversationViewsResponse -getConversationsResponseToV2 :: GetConversationsResponse -> GetConversationsResponseV2 -getConversationsResponseToV2 res = GetConversationsResponseV2 (map remoteConversationToView res.convs) +getConversationsResponseToView :: GetConversationsResponse -> GetRemoteConversationViewsResponse +getConversationsResponseToView res = GetRemoteConversationViewsResponse (map remoteConversationToView res.convs) -getConversationsResponseFromV2 :: GetConversationsResponseV2 -> GetConversationsResponse -getConversationsResponseFromV2 res = GetConversationsResponse (map remoteConversationFromView res.convs) +getConversationsResponseFromView :: GetRemoteConversationViewsResponse -> GetConversationsResponse +getConversationsResponseFromView res = GetConversationsResponse (map remoteConversationFromView res.convs) data GetOne2OneConversationResponse = GetOne2OneConversationOk RemoteConversation diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index f7eb140ad0a..da99b9704e0 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -236,7 +236,7 @@ data ConversationSubsystem m a where FederationGetConversations :: Domain -> GetConversationsRequest -> - ConversationSubsystem m GetConversationsResponseV2 + ConversationSubsystem m GetRemoteConversationViewsResponse FederationLeaveConversation :: Domain -> LeaveConversationRequest -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index ee1f24f0de7..cfaeac0c7a7 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -191,7 +191,7 @@ getConversationsV1 :: GetConversationsRequest -> Sem r GetConversationsResponse getConversationsV1 domain req = - getConversationsResponseFromV2 <$> getConversations domain req + getConversationsResponseFromView <$> getConversations domain req getConversations :: ( Member E.ConversationStore r, @@ -199,11 +199,11 @@ getConversations :: ) => Domain -> GetConversationsRequest -> - Sem r GetConversationsResponseV2 + Sem r GetRemoteConversationViewsResponse getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid loc <- qualifyLocal () - GetConversationsResponseV2 + GetRemoteConversationViewsResponse . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) <$> E.getConversations cids diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 19b75815177..f08325a6a82 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -334,14 +334,14 @@ getRemoteConversationsWithFailures lusr convs = do | otherwise = [failedGetConversationLocally (map tUntagged locallyNotFound)] -- request conversations from remote backends - let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetConversationsResponseV2 + let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetRemoteConversationViewsResponse rpc req = do mFedVersion <- getNegotiatedVersion case mFedVersion of Nothing -> error "impossible" Just fedVersion -> if fedVersion < Federation.V2 - then getConversationsResponseToV2 <$> fedClient @'Galley @"get-conversations@v1" req + then getConversationsResponseToView <$> fedClient @'Galley @"get-conversations@v1" req else fedClient @'Galley @"get-conversations" req resp <- E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> @@ -352,7 +352,7 @@ getRemoteConversationsWithFailures lusr convs = do where handleFailure :: (Member P.TinyLog r) => - Either (Remote [ConvId], FederationError) (Remote GetConversationsResponseV2) -> + Either (Remote [ConvId], FederationError) (Remote GetRemoteConversationViewsResponse) -> Sem r (Either FailedGetConversation [Remote RemoteConversationView]) handleFailure (Left (rcids, e)) = do P.warn $ diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 699641b425b..003a1fb6f94 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2375,8 +2375,8 @@ testBulkGetQualifiedConvs = do let mock = do d <- frTargetDomain <$> getRequest asum - [ guard (d == remoteDomainA) *> mockReply (GetConversationsResponseV2 [mockConversationA]), - guard (d == remoteDomainB) *> mockReply (GetConversationsResponseV2 [mockConversationB]), + [ guard (d == remoteDomainA) *> mockReply (GetRemoteConversationViewsResponse [mockConversationA]), + guard (d == remoteDomainB) *> mockReply (GetRemoteConversationViewsResponse [mockConversationB]), guard (d == remoteDomainC) *> liftIO (throw (DiscoveryFailureSrvNotAvailable "domainC")), do r <- getRequest @@ -3056,7 +3056,7 @@ putRemoteConvMemberOk update = do (qUnqualified qbob) roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] - remoteConversationResponse = GetConversationsResponseV2 [mockConversation] + remoteConversationResponse = GetRemoteConversationViewsResponse [mockConversation] (rs, _) <- withTempMockFederator' (mockReply remoteConversationResponse) @@ -3381,7 +3381,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do pure . map omQualifiedId . cmOthers . cnvMembers $ conv RemoteActor -> do fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient (tDomain bob) $ GetConversationsRequest { userId = tUnqualified bob, @@ -3400,7 +3400,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do found <- do let rconv = mkProteusConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] (resp, _) <- - withTempMockFederator' (mockReply (GetConversationsResponseV2 [rconv])) $ + withTempMockFederator' (mockReply (GetRemoteConversationViewsResponse [rconv])) $ getConvQualified (tUnqualified alice) convId pure $ statusCode resp == 200 liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 01c5b35d9e0..3d4c74398a5 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -153,7 +153,7 @@ getConversationsAllFound = do fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient (qDomain aliceQ) $ GetConversationsRequest (qUnqualified aliceQ) @@ -198,7 +198,7 @@ getConversationsNotPartOf = do fedGalleyClient <- view tsFedGalleyClient rando <- Id <$> liftIO nextRandom - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient localDomain $ GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs From 1c4f511256a9f46d5d308de5eb238514fc63dcd9 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 10:08:09 +0000 Subject: [PATCH 18/39] rename CreateGroupConversationUpToV3 --- libs/wire-subsystems/src/Wire/ConversationSubsystem.hs | 2 +- libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Interpreter.hs | 4 ++-- services/galley/src/Galley/API/Public/Conversation.hs | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index da99b9704e0..8c61ab1bdc4 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -96,7 +96,7 @@ data ConversationSubsystem m a where Maybe ConnId -> NewConv -> ConversationSubsystem m StoredConversation - CreateGroupConversationUpToV3 :: + CreateLegacyGroupConversation :: Local UserId -> Maybe ConnId -> NewConv -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs index 8a9a8b38a67..2458b1355b9 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -60,7 +60,7 @@ import Wire.TeamSubsystem (TeamSubsystem) ---------------------------------------------------------------------------- -- API Handlers -createGroupConversationUpToV3 :: +createLegacyGroupConversation :: ( Member BrigAPIAccess r, Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r, @@ -94,7 +94,7 @@ createGroupConversationUpToV3 :: Maybe ConnId -> NewConv -> Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do +createLegacyGroupConversation lusr conn newConv = mapError UnreachableBackendsLegacy $ do dbConv <- createGroupConversationGeneric lusr conn newConv Created <$> ownConversationView lusr dbConv diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index be426bc1b91..cfefaeb3dba 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -125,8 +125,8 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData InternalCreateGroupConversation lusr conn newConv -> mapErrors $ CreateInternal.createGroupConversationGeneric lusr conn newConv - CreateGroupConversationUpToV3 lusr conn newConv -> - mapErrors $ Create.createGroupConversationUpToV3 lusr conn newConv + CreateLegacyGroupConversation lusr conn newConv -> + mapErrors $ Create.createLegacyGroupConversation lusr conn newConv CreateGroupOwnConversation lusr conn newConv -> mapErrors $ Create.createGroupOwnConversation lusr conn newConv CreateGroupConversation lusr conn newConv -> diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 789451968e2..f0a00492836 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -43,8 +43,8 @@ conversationAPI = <@> mkNamedAPI @"list-conversations@v5" listConversations <@> mkNamedAPI @"list-conversations" listConversations <@> mkNamedAPI @"get-conversation-by-reusable-code" getConversationByReusableCode - <@> mkNamedAPI @"create-group-conversation@v2" createGroupConversationUpToV3 - <@> mkNamedAPI @"create-group-conversation@v3" createGroupConversationUpToV3 + <@> mkNamedAPI @"create-group-conversation@v2" createLegacyGroupConversation + <@> mkNamedAPI @"create-group-conversation@v3" createLegacyGroupConversation <@> mkNamedAPI @"create-group-conversation@v5" createGroupOwnConversation <@> mkNamedAPI @"create-group-conversation@v9" createGroupOwnConversation <@> mkNamedAPI @"create-group-conversation" createGroupConversation From f4ee1477d8d954ba999b507abeab206da8e55106 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 10:12:34 +0000 Subject: [PATCH 19/39] renamed FederationGetConversationsV1 --- libs/wire-subsystems/src/Wire/ConversationSubsystem.hs | 2 +- .../src/Wire/ConversationSubsystem/Federation.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Interpreter.hs | 4 ++-- services/galley/src/Galley/API/Federation.hs | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 8c61ab1bdc4..180e060b97b 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -229,7 +229,7 @@ data ConversationSubsystem m a where Domain -> ConversationCreated ConvId -> ConversationSubsystem m EmptyResponse - FederationGetConversationsV1 :: + FederationGetLegacyConversations :: Domain -> GetConversationsRequest -> ConversationSubsystem m GetConversationsResponse diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index cfaeac0c7a7..0c88b670b45 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -183,14 +183,14 @@ onConversationCreated domain rc = do pushConversationEvent Nothing () event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] pure EmptyResponse -getConversationsV1 :: +getLegacyConversations :: ( Member E.ConversationStore r, Member (Input (Local ())) r ) => Domain -> GetConversationsRequest -> Sem r GetConversationsResponse -getConversationsV1 domain req = +getLegacyConversations domain req = getConversationsResponseFromView <$> getConversations domain req getConversations :: diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index cfefaeb3dba..d82cb812a7d 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -159,8 +159,8 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim FederationOnConversationCreated domain rc -> mapErrors $ Federation.onConversationCreated domain rc - FederationGetConversationsV1 domain req -> - mapErrors $ Federation.getConversationsV1 domain req + FederationGetLegacyConversations domain req -> + mapErrors $ Federation.getLegacyConversations domain req FederationGetConversations domain req -> mapErrors $ Federation.getConversations domain req FederationLeaveConversation domain lc -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 1b5ea3a958e..ba0cb531276 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -34,7 +34,7 @@ federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = Named @"on-conversation-created" federationOnConversationCreated - :<|> Named @"get-conversations@v1" federationGetConversationsV1 + :<|> Named @"get-conversations@v1" federationGetLegacyConversations :<|> Named @"get-conversations" federationGetConversations :<|> Named @"leave-conversation" federationLeaveConversation :<|> Named @"send-message" federationSendMessage From 061503d00d8208f6f3d36824c826c845dac1fc1d Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 10:16:16 +0000 Subject: [PATCH 20/39] renamed FederationGetOne2OneConversationV1 --- libs/wire-subsystems/src/Wire/ConversationSubsystem.hs | 2 +- .../src/Wire/ConversationSubsystem/Federation.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Interpreter.hs | 4 ++-- services/galley/src/Galley/API/Federation.hs | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 180e060b97b..13ff9383303 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -285,7 +285,7 @@ data ConversationSubsystem m a where Domain -> LeaveSubConversationRequest -> ConversationSubsystem m LeaveSubConversationResponse - FederationGetOne2OneConversationV1 :: + FederationGetLegacyOne2OneConversation :: Domain -> GetOne2OneConversationRequest -> ConversationSubsystem m GetOne2OneConversationResponse diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index 0c88b670b45..bbc60268d5f 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -772,7 +772,7 @@ deleteSubConversationForRemoteUser domain DeleteSubConversationFedRequest {..} = lconv <- qualifyLocal dscreqConv resetLocalSubConversation qusr lconv dscreqSubConv dsc -getOne2OneConversationV1 :: +getLegacyOne2OneConversation :: ( Member (Input (Local ())) r, Member BrigAPIAccess r, Member (Error InvalidInput) r @@ -780,7 +780,7 @@ getOne2OneConversationV1 :: Domain -> GetOne2OneConversationRequest -> Sem r GetOne2OneConversationResponse -getOne2OneConversationV1 domain (GetOne2OneConversationRequest self other) = +getLegacyOne2OneConversation domain (GetOne2OneConversationRequest self other) = fmap (Imports.fromRight GetOne2OneConversationNotConnected) . runError @(Tagged 'NotConnected ()) $ do diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index d82cb812a7d..9b0f3727441 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -187,8 +187,8 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Federation.deleteSubConversationForRemoteUser domain req FederationLeaveSubConversation domain lscr -> mapErrors $ Federation.leaveSubConversation domain lscr - FederationGetOne2OneConversationV1 domain req -> - mapErrors $ Federation.getOne2OneConversationV1 domain req + FederationGetLegacyOne2OneConversation domain req -> + mapErrors $ Federation.getLegacyOne2OneConversation domain req FederationGetOne2OneConversation domain req -> mapErrors $ Federation.getOne2OneConversation domain req FederationOnClientRemoved domain req -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index ba0cb531276..2aa9dde39f1 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -48,7 +48,7 @@ federationSitemap = :<|> Named @"get-sub-conversation" federationGetSubConversationForRemoteUser :<|> Named @"delete-sub-conversation" federationDeleteSubConversationForRemoteUser :<|> Named @"leave-sub-conversation" federationLeaveSubConversation - :<|> Named @"get-one2one-conversation@v1" federationGetOne2OneConversationV1 + :<|> Named @"get-one2one-conversation@v1" federationGetLegacyOne2OneConversation :<|> Named @"get-one2one-conversation" federationGetOne2OneConversation :<|> Named @"on-client-removed" federationOnClientRemoved :<|> Named @"on-message-sent" federationOnMessageSent From 47150531b9ba72050b7f46591ce0cf4e31df377d Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 12:39:04 +0200 Subject: [PATCH 21/39] refactor: rename conversationIdsPageFromV2 to conversationIdsPaginated --- libs/wire-subsystems/src/Wire/ConversationSubsystem.hs | 2 +- .../src/Wire/ConversationSubsystem/Interpreter.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Query.hs | 8 ++++---- services/galley/src/Galley/API/Public/Conversation.hs | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 13ff9383303..aa6d5f3b5cb 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -409,7 +409,7 @@ data ConversationSubsystem m a where Maybe ConvId -> Maybe (Range 1 1000 Int32) -> ConversationSubsystem m (ConversationList ConvId) - ConversationIdsPageFromV2 :: + ConversationIdsPaginated :: ListGlobalSelfConvs -> Local UserId -> Public.GetPaginatedConversationIds -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9b0f3727441..3fe15696bd7 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -235,8 +235,8 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ MLSGroupInfo.getGroupInfo lusr qcnv ConversationIdsPageFromUnqualified lusr mstart msize -> mapErrors $ Query.conversationIdsPageFromUnqualified lusr mstart msize - ConversationIdsPageFromV2 listGlobalSelf lself req -> - mapErrors $ Query.conversationIdsPageFromV2 listGlobalSelf lself req + ConversationIdsPaginated listGlobalSelf lself req -> + mapErrors $ Query.conversationIdsPaginated listGlobalSelf lself req ConversationIdsPageFrom lusr req -> mapErrors $ Query.conversationIdsPageFrom lusr req ListConversations luser req -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index f08325a6a82..664cf496fa5 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -27,7 +27,7 @@ module Wire.ConversationSubsystem.Query getLocalConversationInternal, getConversationRoles, conversationIdsPageFromUnqualified, - conversationIdsPageFromV2, + conversationIdsPaginated, conversationIdsPageFrom, getConversations, getConversationsInternal, @@ -401,13 +401,13 @@ conversationIdsPageFromUnqualified lusr start msize = do -- -- FUTUREWORK: Move the body of this function to 'conversationIdsPageFrom' once -- support for V2 is dropped. -conversationIdsPageFromV2 :: +conversationIdsPaginated :: (Member ConversationStore.ConversationStore r) => ListGlobalSelfConvs -> Local UserId -> Public.GetPaginatedConversationIds -> Sem r Public.ConvIdsPage -conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do +conversationIdsPaginated listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do filterOut <$> getConversationIdsImpl lusr gmtprSize gmtprState where -- MLS self-conversation of this user @@ -454,7 +454,7 @@ conversationIdsPageFrom lusr state = do -- returned or attempted to be created; in that case we skip anything related -- to it. whenM isMLSEnabled $ void $ getMLSSelfConversation lusr - conversationIdsPageFromV2 ListGlobalSelf lusr state + conversationIdsPaginated ListGlobalSelf lusr state getConversations :: ( Member (Error InternalError) r, diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index f0a00492836..0e14a8a2d8b 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -35,7 +35,7 @@ conversationAPI = <@> mkNamedAPI @"get-conversation-roles" getConversationRoles <@> mkNamedAPI @"get-group-info" getGroupInfo <@> mkNamedAPI @"list-conversation-ids-unqualified" conversationIdsPageFromUnqualified - <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPageFromV2 DoNotListGlobalSelf) + <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPaginated DoNotListGlobalSelf) <@> mkNamedAPI @"list-conversation-ids" conversationIdsPageFrom <@> mkNamedAPI @"get-conversations" getPaginatedConversations <@> mkNamedAPI @"list-conversations@v1" listConversations From 00f22b61d50ae6da814308b89ae1e37c34ea9c48 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 12:59:07 +0200 Subject: [PATCH 22/39] refactor: move FederationOnConversationUpdatedV0 to Galley --- .../src/Wire/ConversationSubsystem.hs | 4 ---- .../src/Wire/ConversationSubsystem/Federation.hs | 14 -------------- .../src/Wire/ConversationSubsystem/Interpreter.hs | 2 -- services/galley/src/Galley/API/Federation.hs | 13 ++++++++++++- 4 files changed, 12 insertions(+), 21 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index aa6d5f3b5cb..be1e5260d72 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -305,10 +305,6 @@ data ConversationSubsystem m a where Domain -> RemoteMLSMessage -> ConversationSubsystem m EmptyResponse - FederationOnConversationUpdatedV0 :: - Domain -> - ConversationUpdateV0 -> - ConversationSubsystem m EmptyResponse FederationOnConversationUpdated :: Domain -> ConversationUpdate -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index bbc60268d5f..563ca98ea8c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -225,20 +225,6 @@ onConversationUpdated requestingDomain cu = do void $ updateLocalStateOfRemoteConv rcu Nothing pure EmptyResponse -onConversationUpdatedV0 :: - ( Member BrigAPIAccess r, - Member NotificationSubsystem r, - Member ExternalAccess r, - Member (Input (Local ())) r, - Member E.ConversationStore r, - Member P.TinyLog r - ) => - Domain -> - ConversationUpdateV0 -> - Sem r EmptyResponse -onConversationUpdatedV0 domain cu = - onConversationUpdated domain (conversationUpdateFromV0 cu) - -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: ( Member BackendNotificationQueueAccess r, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 3fe15696bd7..30e27926dcb 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -197,8 +197,6 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Federation.onMessageSent domain rm FederationOnMLSMessageSent domain rmm -> mapErrors $ Federation.onMLSMessageSent domain rmm - FederationOnConversationUpdatedV0 domain cu -> - mapErrors $ Federation.onConversationUpdatedV0 domain cu FederationOnConversationUpdated domain cu -> mapErrors $ Federation.onConversationUpdated domain cu FederationOnUserDeleted domain udcn -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 2aa9dde39f1..2c76eed02b2 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -17,11 +17,14 @@ module Galley.API.Federation where +import Data.Domain (Domain) import Galley.App import Polysemy import Servant (ServerT) import Servant.API import Wire.API.Federation.API +import Wire.API.Federation.API.Common (EmptyResponse (..)) +import Wire.API.Federation.API.Galley hiding (id) import Wire.API.Federation.Endpoint import Wire.API.Federation.Version import Wire.API.Routes.Named @@ -53,6 +56,14 @@ federationSitemap = :<|> Named @"on-client-removed" federationOnClientRemoved :<|> Named @"on-message-sent" federationOnMessageSent :<|> Named @"on-mls-message-sent" federationOnMLSMessageSent - :<|> Named @(Versioned 'V0 "on-conversation-updated") federationOnConversationUpdatedV0 + :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0H :<|> Named @"on-conversation-updated" federationOnConversationUpdated :<|> Named @"on-user-deleted-conversations" federationOnUserDeleted + +onConversationUpdatedV0H :: + (Member ConversationSubsystem r) => + Domain -> + ConversationUpdateV0 -> + Sem r EmptyResponse +onConversationUpdatedV0H domain cu = + federationOnConversationUpdated domain (conversationUpdateFromV0 cu) From f5ecd58ee2eb0c1269677dda5162eae6229341f7 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 13:34:43 +0200 Subject: [PATCH 23/39] refactor: rename getMLSOne2OneConversationV5/getMLSOne2OneConversationV6 --- .../src/Wire/ConversationSubsystem.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Interpreter.hs | 8 ++++---- .../src/Wire/ConversationSubsystem/Query.hs | 14 +++++++------- .../galley/src/Galley/API/Public/Conversation.hs | 4 ++-- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index be1e5260d72..00afc9b19b8 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -426,11 +426,11 @@ data ConversationSubsystem m a where GetMLSSelfConversationWithError :: Local UserId -> ConversationSubsystem m Public.OwnConversation - GetMLSOne2OneConversationV5 :: + GetMLSOne2OneOwnConversation :: Local UserId -> Qualified UserId -> ConversationSubsystem m Public.OwnConversation - GetMLSOne2OneConversationV6 :: + GetMLSOne2OneMLSConversation :: Local UserId -> Qualified UserId -> ConversationSubsystem m (MLSOne2OneConversation MLSPublicKey) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 30e27926dcb..23bd4a6cc4e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -243,10 +243,10 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Query.getConversationByReusableCode lusr key value GetMLSSelfConversationWithError lusr -> mapErrors $ Query.getMLSSelfConversationWithError lusr - GetMLSOne2OneConversationV5 lself qother -> - mapErrors $ Query.getMLSOne2OneConversationV5 lself qother - GetMLSOne2OneConversationV6 lself qother -> - mapErrors $ Query.getMLSOne2OneConversationV6 lself qother + GetMLSOne2OneOwnConversation lself qother -> + mapErrors $ Query.getMLSOne2OneOwnConversation lself qother + GetMLSOne2OneMLSConversation lself qother -> + mapErrors $ Query.getMLSOne2OneMLSConversation lself qother GetMLSOne2OneConversation lself qother fmt -> mapErrors $ Query.getMLSOne2OneConversation lself qother fmt GetLocalSelf lusr cnv -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 664cf496fa5..648623e066b 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -43,8 +43,8 @@ module Wire.ConversationSubsystem.Query ensureConvAdmin, getMLSSelfConversation, getMLSSelfConversationWithError, - getMLSOne2OneConversationV5, - getMLSOne2OneConversationV6, + getMLSOne2OneOwnConversation, + getMLSOne2OneMLSConversation, getMLSOne2OneConversationInternal, getMLSOne2OneConversation, isMLSOne2OneEstablished, @@ -766,7 +766,7 @@ createMLSSelfConversation lusr = do -- uses the same function to calculate the conversation ID and corresponding -- group ID, however we /do/ assume that the two backends agree on which of the -- two is responsible for hosting the conversation. -getMLSOne2OneConversationV5 :: +getMLSOne2OneOwnConversation :: ( Member BrigAPIAccess r, Member ConversationStore.ConversationStore r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, @@ -784,7 +784,7 @@ getMLSOne2OneConversationV5 :: Local UserId -> Qualified UserId -> Sem r OwnConversation -getMLSOne2OneConversationV5 lself qother = do +getMLSOne2OneOwnConversation lself qother = do if isLocal lself qother then getMLSOne2OneConversationInternal lself qother else throwS @MLSFederatedOne2OneNotSupported @@ -810,7 +810,7 @@ getMLSOne2OneConversationInternal :: getMLSOne2OneConversationInternal lself qother = (.conversation) <$> getMLSOne2OneConversation lself qother Nothing -getMLSOne2OneConversationV6 :: +getMLSOne2OneMLSConversation :: forall r. ( Member BrigAPIAccess r, Member ConversationStore.ConversationStore r, @@ -828,7 +828,7 @@ getMLSOne2OneConversationV6 :: Local UserId -> Qualified UserId -> Sem r (MLSOne2OneConversation MLSPublicKey) -getMLSOne2OneConversationV6 lself qother = do +getMLSOne2OneMLSConversation lself qother = do assertMLSEnabled ensureConnectedOrSameTeam lself [qother] let convId = one2OneConvId BaseProtocolMLSTag (tUntagged lself) qother @@ -857,7 +857,7 @@ getMLSOne2OneConversation :: Maybe MLSPublicKeyFormat -> Sem r (MLSOne2OneConversation SomeKey) getMLSOne2OneConversation lself qother fmt = do - convWithUnformattedKeys <- getMLSOne2OneConversationV6 lself qother + convWithUnformattedKeys <- getMLSOne2OneMLSConversation lself qother MLSOne2OneConversation convWithUnformattedKeys.conversation <$> formatPublicKeys fmt convWithUnformattedKeys.publicKeys diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 0e14a8a2d8b..9c07e85b3ff 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -60,8 +60,8 @@ conversationAPI = <@> mkNamedAPI @"create-one-to-one-conversation@v2" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation@v6" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation" createOne2OneConversation - <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneConversationV5 - <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneConversationV6 + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneOwnConversation + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneMLSConversation <@> mkNamedAPI @"get-one-to-one-mls-conversation" getMLSOne2OneConversation <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addQualifiedMembersUnqualified From 0701fd79f9bd8a7d06006cae1d369a2d5829fb46 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 11:09:58 +0000 Subject: [PATCH 24/39] move legacy handler to galley --- .../src/Wire/ConversationSubsystem.hs | 4 ---- .../Wire/ConversationSubsystem/Federation.hs | 10 --------- .../Wire/ConversationSubsystem/Interpreter.hs | 2 -- services/galley/src/Galley/API/Federation.hs | 21 +++++++++++++------ 4 files changed, 15 insertions(+), 22 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 00afc9b19b8..498b9926282 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -229,10 +229,6 @@ data ConversationSubsystem m a where Domain -> ConversationCreated ConvId -> ConversationSubsystem m EmptyResponse - FederationGetLegacyConversations :: - Domain -> - GetConversationsRequest -> - ConversationSubsystem m GetConversationsResponse FederationGetConversations :: Domain -> GetConversationsRequest -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index 563ca98ea8c..4ed61983854 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -183,16 +183,6 @@ onConversationCreated domain rc = do pushConversationEvent Nothing () event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] pure EmptyResponse -getLegacyConversations :: - ( Member E.ConversationStore r, - Member (Input (Local ())) r - ) => - Domain -> - GetConversationsRequest -> - Sem r GetConversationsResponse -getLegacyConversations domain req = - getConversationsResponseFromView <$> getConversations domain req - getConversations :: ( Member E.ConversationStore r, Member (Input (Local ())) r diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 23bd4a6cc4e..70b78c3c15a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -159,8 +159,6 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim FederationOnConversationCreated domain rc -> mapErrors $ Federation.onConversationCreated domain rc - FederationGetLegacyConversations domain req -> - mapErrors $ Federation.getLegacyConversations domain req FederationGetConversations domain req -> mapErrors $ Federation.getConversations domain req FederationLeaveConversation domain lc -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 2c76eed02b2..d1e47cae92a 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -17,18 +17,19 @@ module Galley.API.Federation where -import Data.Domain (Domain) +import Data.Domain import Galley.App +import Imports import Polysemy import Servant (ServerT) import Servant.API import Wire.API.Federation.API import Wire.API.Federation.API.Common (EmptyResponse (..)) -import Wire.API.Federation.API.Galley hiding (id) +import Wire.API.Federation.API.Galley import Wire.API.Federation.Endpoint import Wire.API.Federation.Version import Wire.API.Routes.Named -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem as ConversationSubsystem type FederationAPI = "federation" :> FedApi 'Galley @@ -56,14 +57,22 @@ federationSitemap = :<|> Named @"on-client-removed" federationOnClientRemoved :<|> Named @"on-message-sent" federationOnMessageSent :<|> Named @"on-mls-message-sent" federationOnMLSMessageSent - :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0H + :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 :<|> Named @"on-conversation-updated" federationOnConversationUpdated :<|> Named @"on-user-deleted-conversations" federationOnUserDeleted -onConversationUpdatedV0H :: +onConversationUpdatedV0 :: (Member ConversationSubsystem r) => Domain -> ConversationUpdateV0 -> Sem r EmptyResponse -onConversationUpdatedV0H domain cu = +onConversationUpdatedV0 domain cu = federationOnConversationUpdated domain (conversationUpdateFromV0 cu) + +federationGetLegacyConversations :: + (Member ConversationSubsystem r) => + Domain -> + GetConversationsRequest -> + Sem r GetConversationsResponse +federationGetLegacyConversations domain req = + getConversationsResponseFromView <$> ConversationSubsystem.federationGetConversations domain req From b10a1e9455b6ba476b413f18e2b6644ebf4198fd Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 24 Apr 2026 14:18:07 +0000 Subject: [PATCH 25/39] make mapping pure --- .../src/Wire/ConversationSubsystem/Create.hs | 32 ++-- .../Wire/ConversationSubsystem/Federation.hs | 4 +- .../src/Wire/ConversationSubsystem/Mapping.hs | 163 ------------------ .../src/Wire/ConversationSubsystem/Query.hs | 20 ++- .../src/Wire/ConversationSubsystem/Update.hs | 5 +- .../src/Wire/ConversationSubsystem/Util.hs | 47 ++--- .../src/Wire/StoredConversation.hs | 131 ++++++++++++++ ...ppingSpec.hs => StoredConversationSpec.hs} | 51 +++--- libs/wire-subsystems/wire-subsystems.cabal | 3 +- services/galley/test/integration/API.hs | 1 - 10 files changed, 201 insertions(+), 256 deletions(-) delete mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs rename libs/wire-subsystems/test/unit/Wire/{ConversationSubsystem/MappingSpec.hs => StoredConversationSpec.hs} (79%) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs index 2458b1355b9..0c76bf359da 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -45,7 +45,7 @@ import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationSubsystem.CreateInternal -import Wire.ConversationSubsystem.Mapping +import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) @@ -53,6 +53,7 @@ import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Random (Random) +import Wire.StoredConversation import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamSubsystem (TeamSubsystem) @@ -96,7 +97,7 @@ createLegacyGroupConversation :: Sem r (ConversationResponse Public.OwnConversation) createLegacyGroupConversation lusr conn newConv = mapError UnreachableBackendsLegacy $ do dbConv <- createGroupConversationGeneric lusr conn newConv - Created <$> ownConversationView lusr dbConv + maybe (throwWhenMemberNotFound lusr dbConv.id_) (pure . Created) $ ownConversationView lusr dbConv createGroupOwnConversation :: ( Member BrigAPIAccess r, @@ -138,7 +139,8 @@ createGroupOwnConversation lusr conn newConv = do enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) dbConv <- createGroupConversationGeneric lusr conn newConv - GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> ownConversationView lusr dbConv <*> pure mempty) + maybe (throwWhenMemberNotFound lusr dbConv.id_) (pure . GroupConversationCreatedV9) $ + (CreateGroupOwnConversation <$> ownConversationView lusr dbConv <*> pure mempty) createGroupConversation :: ( Member BrigAPIAccess r, @@ -193,9 +195,11 @@ createProteusSelfConversation :: Sem r (ConversationResponse Public.OwnConversation) createProteusSelfConversation lusr = do (c, created) <- createProteusSelfConversationLogic lusr - if created - then Created <$> ownConversationView lusr c - else Existed <$> ownConversationView lusr c + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwWhenMemberNotFound lusr c.id_) pure mConv createOne2OneConversation :: ( Member BrigAPIAccess r, @@ -226,9 +230,11 @@ createOne2OneConversation :: Sem r (ConversationResponse Public.OwnConversation) createOne2OneConversation lusr zcon j = do (c, created) <- createOne2OneConversationLogic lusr zcon j - if created - then Created <$> ownConversationView lusr c - else Existed <$> ownConversationView lusr c + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwWhenMemberNotFound lusr c.id_) pure mConv ---------------------------------------------------------------------------- -- Helpers @@ -253,6 +259,8 @@ createConnectConversation :: Sem r (ConversationResponse Public.OwnConversation) createConnectConversation lusr conn j = do (c, created) <- createConnectConversationLogic lusr conn j - if created - then Created <$> ownConversationView lusr c - else Existed <$> ownConversationView lusr c + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwWhenMemberNotFound lusr c.id_) pure mConv diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index 4ed61983854..34a22f5dd4f 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -86,8 +86,6 @@ import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.MLS.SubConversation hiding (leaveSubConversation) import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.MLS.Welcome -import Wire.ConversationSubsystem.Mapping -import Wire.ConversationSubsystem.Mapping qualified as Mapping import Wire.ConversationSubsystem.Message import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) @@ -194,7 +192,7 @@ getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid loc <- qualifyLocal () GetRemoteConversationViewsResponse - . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) + . mapMaybe (conversationToRemote (tDomain loc) ruid) <$> E.getConversations cids -- | Update the local database with information on conversation members joining diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs deleted file mode 100644 index a06b910e76e..00000000000 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Mapping.hs +++ /dev/null @@ -1,163 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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.ConversationSubsystem.Mapping - ( ownConversationView, - conversationView, - conversationViewWithCachedOthers, - remoteConversationView, - conversationToRemote, - ) -where - -import Data.Domain (Domain) -import Data.Id (UserId, idToText) -import Data.Qualified -import Galley.Types.Error (InternalError (BadMemberState)) -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation hiding (Member) -import Wire.API.Federation.API.Galley -import Wire.ConversationSubsystem.Util (localMemberToPublic) -import Wire.StoredConversation - --- | View for a given user of a stored conversation. --- --- Throws @BadMemberState@ when the user is not part of the conversation. -ownConversationView :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r OwnConversation -ownConversationView luid conv = do - let remoteOthers = map remoteMemberToOther $ conv.remoteMembers - localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers - conversationViewWithCachedOthers remoteOthers localOthers conv luid - -conversationView :: - Local x -> - Maybe (Local UserId) -> - StoredConversation -> - Conversation -conversationView l luid conv = - let remoteMembers = map remoteMemberToOther $ conv.remoteMembers - localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers - selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) - mSelf = localMemberToPublic l <$> listToMaybe selfs - others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers - in Conversation - { members = ConvMembers mSelf others, - qualifiedId = (tUntagged . qualifyAs l $ conv.id_), - metadata = conv.metadata, - protocol = conv.protocol - } - --- | Like 'conversationView' but optimized for situations which could benefit --- from pre-computing the list of @OtherMember@s in the conversation. For --- instance, creating @ConversationView@ for more than 1 member of the same conversation. -conversationViewWithCachedOthers :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - [OtherMember] -> - [OtherMember] -> - StoredConversation -> - Local UserId -> - Sem r OwnConversation -conversationViewWithCachedOthers remoteOthers localOthers conv luid = do - let mbConv = conversationViewMaybe luid remoteOthers localOthers conv - maybe memberNotFound pure mbConv - where - memberNotFound = do - P.err . msg $ - val "User " - +++ idToText (tUnqualified luid) - +++ val " is not a member of conv " - +++ idToText conv.id_ - throw BadMemberState - --- | View for a given user of a stored conversation. --- --- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation -conversationViewMaybe luid remoteOthers localOthers conv = do - let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers - self <- localMemberToPublic luid <$> listToMaybe selfs - let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - OwnConversation - (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata - (OwnConvMembers self others) - conv.protocol - --- | View for a local user of a remote conversation. -remoteConversationView :: - Local UserId -> - MemberStatus -> - Remote RemoteConversationView -> - OwnConversation -remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = - let mems = rconv.members - others = mems.others - self = - localMemberToPublic - uid - LocalMember - { id_ = tUnqualified uid, - service = Nothing, - status = status, - convRoleName = mems.selfRole - } - in OwnConversation - (Qualified rconv.id rDomain) - rconv.metadata - (OwnConvMembers self others) - rconv.protocol - --- | Convert a local conversation to a structure to be returned to a remote --- backend. --- --- This returns 'Nothing' if the given remote user is not part of the conversation. -conversationToRemote :: - Domain -> - Remote UserId -> - StoredConversation -> - Maybe RemoteConversationView -conversationToRemote localDomain ruid conv = do - let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) - lothers = conv.localMembers - selfRole' <- (.convRoleName) <$> listToMaybe selfs - let others' = - map (localMemberToOther localDomain) lothers - <> map remoteMemberToOther rothers - pure $ - RemoteConversationView - { id = conv.id_, - metadata = conv.metadata, - members = - RemoteConvMembers - { selfRole = selfRole', - others = others' - }, - protocol = conv.protocol - } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 648623e066b..4f48eee9a1e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -106,8 +106,6 @@ import Wire.ConversationSubsystem.Fetch (getConversationIdsImpl) import Wire.ConversationSubsystem.MLS import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled, getMLSPrivateKeys, isMLSEnabled) import Wire.ConversationSubsystem.MLS.One2One (localMLSOne2OneConversation, remoteMLSOne2OneConversation) -import Wire.ConversationSubsystem.Mapping -import Wire.ConversationSubsystem.Mapping qualified as Mapping import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem @@ -162,7 +160,7 @@ getUnqualifiedOwnConversation :: Sem r Public.OwnConversation getUnqualifiedOwnConversation lusr cnv = do c <- getConversationAsMember (tUntagged lusr) (qualifyAs lusr cnv) - Mapping.ownConversationView lusr c + maybe (throwWhenMemberNotFound lusr cnv) pure $ ownConversationView lusr c getUnqualifiedConversation :: forall r. @@ -175,7 +173,7 @@ getUnqualifiedConversation :: ConvId -> Sem r Public.Conversation getUnqualifiedConversation lusr cnv = - Mapping.conversationView (qualifyAs lusr ()) (Just lusr) . (.conv) + conversationView (qualifyAs lusr ()) (Just lusr) . (.conv) <$> getConversationAsViewer (tUntagged lusr) (qualifyAs lusr cnv) getConversation :: @@ -320,7 +318,7 @@ getRemoteConversationsWithFailures lusr convs = do statusMap <- ConversationStore.getRemoteConversationStatus (tUnqualified lusr) convs let remoteView :: Remote RemoteConversationView -> OwnConversation remoteView rconv = - Mapping.remoteConversationView + remoteConversationView lusr ( Map.findWithDefault defMemberStatus @@ -468,7 +466,8 @@ getConversations :: Sem r (Public.ConversationList Public.OwnConversation) getConversations luser mids mstart msize = do ConversationList cs more <- getConversationsInternal luser mids mstart msize - flip ConversationList more <$> mapM (Mapping.ownConversationView luser) cs + ownConvs <- for cs (\c -> maybe (throwWhenMemberNotFound luser c.id_) pure $ ownConversationView luser c) + pure $ ConversationList ownConvs more getConversationsInternal :: (Member ConversationStore.ConversationStore r) => @@ -519,7 +518,10 @@ listConversations luser (Public.ListConversations ids) = do localInternalConversations <- ConversationStore.getConversations foundLocalIds >>= filterM (\c -> pure $ isMember (tUnqualified luser) c.localMembers) - localConversations <- mapM (Mapping.ownConversationView luser) localInternalConversations + localConversations <- + mapM + (\c -> maybe (throwWhenMemberNotFound luser c.id_) pure (ownConversationView luser c)) + localInternalConversations (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures @@ -739,7 +741,7 @@ getMLSSelfConversation lusr = do let selfConvId = mlsSelfConvId . tUnqualified $ lusr mconv <- ConversationStore.getConversation selfConvId cnv <- maybe (createMLSSelfConversation lusr) pure mconv - ownConversationView lusr cnv + maybe (throwWhenMemberNotFound lusr cnv.id_) pure $ ownConversationView lusr cnv createMLSSelfConversation :: (Member ConversationStore.ConversationStore r) => @@ -876,7 +878,7 @@ getLocalMLSOne2OneConversation lself lconv = do keys <- mlsKeysToPublic <$$> getMLSPrivateKeys conv <- case mconv of Nothing -> pure (localMLSOne2OneConversation lself lconv) - Just conv -> ownConversationView lself conv + Just conv -> maybe (throwWhenMemberNotFound lself conv.id_) pure $ ownConversationView lself conv pure $ MLSOne2OneConversation { conversation = conv, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 1feb573c153..220a6ae784a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -132,7 +132,6 @@ import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem.Action import Wire.ConversationSubsystem.Action.Kick (kickMember) -import Wire.ConversationSubsystem.Mapping import Wire.ConversationSubsystem.Message import Wire.ConversationSubsystem.Query qualified as Query import Wire.ConversationSubsystem.Util @@ -177,7 +176,7 @@ acceptConv lusr conn cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound conv' <- acceptOne2One lusr conv conn - ownConversationView lusr conv' + maybe (throwWhenMemberNotFound lusr cnv) pure $ ownConversationView lusr conv' blockConv :: ( Member ConversationStore r, @@ -259,7 +258,7 @@ unblockConvUnqualified lusr conn cnv = do unless (convType conv `elem` [ConnectConv, One2OneConv]) $ throwS @'InvalidOperation conv' <- acceptOne2One lusr conv conn - ownConversationView lusr conv' + maybe (throwWhenMemberNotFound lusr cnv) pure $ ownConversationView lusr conv' unblockRemoteConv :: (Member ConversationStore r) => diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index e61b1c4505a..b351613f24a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -41,11 +41,14 @@ import Data.Text qualified as T import Data.Time import Galley.Types.Conversations.Roles import Galley.Types.Error -import Imports hiding (forkIO) +import Imports import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -95,6 +98,15 @@ import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven, getLH import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList +throwWhenMemberNotFound :: (Member TinyLog r, Member (Error InternalError) r) => Local UserId -> ConvId -> Sem r a +throwWhenMemberNotFound luid cid = do + P.err . msg $ + val "User " + +++ idToText (tUnqualified luid) + +++ val " is not a member of conv " + +++ idToText cid + throw BadMemberState + data NoChanges = NoChanges ensureAccessRole :: @@ -1021,39 +1033,6 @@ notifyConversationUpdated lusr conn j conv = do } ] --- | Convert a local conversation member (as stored in the DB) to a publicly --- facing 'Member' structure. -localMemberToPublic :: Local x -> LocalMember -> Public.Member -localMemberToPublic loc lm = - Public.Member - { memId = tUntagged . qualifyAs loc $ lm.id_, - memService = lm.service, - memOtrMutedStatus = msOtrMutedStatus st, - memOtrMutedRef = msOtrMutedRef st, - memOtrArchived = msOtrArchived st, - memOtrArchivedRef = msOtrArchivedRef st, - memHidden = msHidden st, - memHiddenRef = msHiddenRef st, - memConvRoleName = lm.convRoleName - } - where - st = lm.status - --- | View for a given user of a stored conversation. --- --- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe Public.OwnConversation -conversationViewMaybe luid remoteOthers localOthers conv = do - let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers - self <- localMemberToPublic luid <$> listToMaybe selfs - let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - Public.OwnConversation - (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata - (OwnConvMembers self others) - conv.protocol - notifyConversationCreated :: ( Member NotificationSubsystem r, Member ConversationStore r, diff --git a/libs/wire-subsystems/src/Wire/StoredConversation.hs b/libs/wire-subsystems/src/Wire/StoredConversation.hs index 5af3bb2bac0..1fdbe37284e 100644 --- a/libs/wire-subsystems/src/Wire/StoredConversation.hs +++ b/libs/wire-subsystems/src/Wire/StoredConversation.hs @@ -30,9 +30,11 @@ import Data.Time (UTCTime) import Data.UUID.Tagged qualified as U import Imports import Wire.API.Conversation +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.CellsState import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role +import Wire.API.Federation.API.Galley import Wire.API.History import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group.Serialisation qualified as MLS @@ -352,6 +354,135 @@ defAccess One2OneConv (Just []) = [PrivateAccess] defAccess RegularConv (Just []) = defRegularConvAccess defAccess _ (Just xs@(_ : _)) = xs +-- MAPPING ------------------------------------------------------------------- + +-- | View for a given user of a stored conversation. +-- +-- Throws @BadMemberState@ when the user is not part of the conversation. +ownConversationView :: + Local UserId -> + StoredConversation -> + Maybe OwnConversation +ownConversationView luid conv = do + let remoteOthers = map remoteMemberToOther $ conv.remoteMembers + localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers + conversationViewWithCachedOthers remoteOthers localOthers conv luid + +conversationView :: + Local x -> + Maybe (Local UserId) -> + StoredConversation -> + Conversation +conversationView l luid conv = + let remoteMembers = map remoteMemberToOther $ conv.remoteMembers + localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers + selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) + mSelf = localMemberToPublic l <$> listToMaybe selfs + others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers + in Conversation + { members = ConvMembers mSelf others, + qualifiedId = (tUntagged . qualifyAs l $ conv.id_), + metadata = conv.metadata, + protocol = conv.protocol + } + +-- | Like 'conversationView' but optimized for situations which could benefit +-- from pre-computing the list of @OtherMember@s in the conversation. For +-- instance, creating @ConversationView@ for more than 1 member of the same conversation. +conversationViewWithCachedOthers :: + [OtherMember] -> + [OtherMember] -> + StoredConversation -> + Local UserId -> + Maybe OwnConversation +conversationViewWithCachedOthers remoteOthers localOthers conv luid = do + conversationViewMaybe luid remoteOthers localOthers conv + +-- | View for a given user of a stored conversation. +-- +-- Returns 'Nothing' if the user is not part of the conversation. +conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation +conversationViewMaybe luid remoteOthers localOthers conv = do + let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers + self <- localMemberToPublic luid <$> listToMaybe selfs + let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers + pure $ + OwnConversation + (tUntagged . qualifyAs luid $ conv.id_) + conv.metadata + (OwnConvMembers self others) + conv.protocol + +-- | View for a local user of a remote conversation. +remoteConversationView :: + Local UserId -> + MemberStatus -> + Remote RemoteConversationView -> + OwnConversation +remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = + let mems = rconv.members + others = mems.others + self = + localMemberToPublic + uid + LocalMember + { id_ = tUnqualified uid, + service = Nothing, + status = status, + convRoleName = mems.selfRole + } + in OwnConversation + (Qualified rconv.id rDomain) + rconv.metadata + (OwnConvMembers self others) + rconv.protocol + +-- | Convert a local conversation member (as stored in the DB) to a publicly +-- facing 'Member' structure. +localMemberToPublic :: Local x -> LocalMember -> Public.Member +localMemberToPublic loc lm = + Public.Member + { memId = tUntagged . qualifyAs loc $ lm.id_, + memService = lm.service, + memOtrMutedStatus = msOtrMutedStatus st, + memOtrMutedRef = msOtrMutedRef st, + memOtrArchived = msOtrArchived st, + memOtrArchivedRef = msOtrArchivedRef st, + memHidden = msHidden st, + memHiddenRef = msHiddenRef st, + memConvRoleName = lm.convRoleName + } + where + st = lm.status + +-- | Convert a local conversation to a structure to be returned to a remote +-- backend. +-- +-- This returns 'Nothing' if the given remote user is not part of the conversation. +conversationToRemote :: + Domain -> + Remote UserId -> + StoredConversation -> + Maybe RemoteConversationView +conversationToRemote localDomain ruid conv = do + let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) + lothers = conv.localMembers + selfRole' <- (.convRoleName) <$> listToMaybe selfs + let others' = + map (localMemberToOther localDomain) lothers + <> map remoteMemberToOther rothers + pure $ + RemoteConversationView + { id = conv.id_, + metadata = conv.metadata, + members = + RemoteConvMembers + { selfRole = selfRole', + others = others' + }, + protocol = conv.protocol + } + -- BotMember ------------------------------------------------------------------ -- | For now we assume bots to always be local diff --git a/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs similarity index 79% rename from libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs rename to libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs index 90771e04aa0..693354abbc3 100644 --- a/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MappingSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs @@ -18,19 +18,14 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem.MappingSpec where +module Wire.StoredConversationSpec where import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.Types.Error (InternalError) import Imports -import Polysemy (Sem) -import Polysemy qualified as P -import Polysemy.Error qualified as P -import Polysemy.TinyLog qualified as P import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck (Arbitrary (..), Gen, listOf, (==>)) @@ -41,54 +36,52 @@ import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), RemoteConversationView (..), ) -import Wire.ConversationSubsystem.Mapping -import Wire.Sem.Logger qualified as P import Wire.StoredConversation -run :: Sem '[P.TinyLog, P.Error InternalError] a -> Either InternalError a -run = P.run . P.runError . P.discardLogs - spec :: Spec spec = describe "ConversationMapping" do prop "conversation view V9 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (ownConversationView luid c)) + \(ConvWithLocalUser c luid) -> isJust (ownConversationView luid c) prop "conversation view V10 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (pure $ conversationView (qualifyAs luid ()) (Just luid) c)) + \(ConvWithLocalUser c luid) -> isJust (pure $ conversationView (qualifyAs luid ()) (Just luid) c) prop "self user in conversation view is correct" $ \(ConvWithLocalUser c luid) -> - fmap (memId . cmSelf . cnvMembers) (run (ownConversationView luid c)) - == Right (tUntagged luid) + fmap (memId . cmSelf . cnvMembers) (ownConversationView luid c) + == Just (tUntagged luid) prop "conversation view metadata is correct" $ \(ConvWithLocalUser c luid) -> - fmap cnvMetadata (run (ownConversationView luid c)) - == Right c.metadata + fmap cnvMetadata (ownConversationView luid c) + == Just c.metadata prop "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c luid) -> case run $ ownConversationView luid c of - Left _ -> False - Right cnv -> + \(ConvWithLocalUser c luid) -> case ownConversationView luid c of + Nothing -> False + Just cnv -> tUntagged luid `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)) prop "conversation view contains all users" $ \(ConvWithLocalUser c luid) -> - fmap (sort . cnvUids) (run (ownConversationView luid c)) - == Right (sort (convUids (tDomain luid) c)) + fmap (sort . cnvUids) (ownConversationView luid c) + == Just (sort (convUids (tDomain luid) c)) prop "conversation view for an invalid user is empty" $ \(RandomConversation c) luid -> notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> - isLeft (run (ownConversationView luid c)) + isJust (ownConversationView luid c) prop "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - isJust (conversationToRemote dom ruid c) + qDomain (tUntagged ruid) + /= dom + ==> isJust (conversationToRemote dom ruid c) prop "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (selfRole . (.members)) (conversationToRemote dom ruid c) + qDomain (tUntagged ruid) + /= dom + ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) == Just roleNameWireMember prop "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (.metadata) (conversationToRemote dom ruid c) + qDomain (tUntagged ruid) + /= dom + ==> fmap (.metadata) (conversationToRemote dom ruid c) == Just c.metadata prop "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index bb6455c3e27..dd2e897a6c3 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -271,7 +271,6 @@ library Wire.ConversationSubsystem.Internal Wire.ConversationSubsystem.Interpreter Wire.ConversationSubsystem.LegalholdConflicts - Wire.ConversationSubsystem.Mapping Wire.ConversationSubsystem.Message Wire.ConversationSubsystem.MLS Wire.ConversationSubsystem.MLS.CheckClients @@ -574,7 +573,6 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec Wire.ClientSubsystem.InterpreterSpec - Wire.ConversationSubsystem.MappingSpec Wire.ConversationSubsystem.MessageSpec Wire.ConversationSubsystem.One2OneSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec @@ -626,6 +624,7 @@ test-suite wire-subsystems-tests Wire.RateLimited.InterpreterSpec Wire.SAMLEmailSubsystem.InterpreterSpec Wire.ScimSubsystem.InterpreterSpec + Wire.StoredConversationSpec Wire.TeamCollaboratorsSubsystem.InterpreterSpec Wire.TeamInvitationSubsystem.InterpreterSpec Wire.UserGroupSubsystem.InterpreterSpec diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 003a1fb6f94..5f9475e034b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -103,7 +103,6 @@ import Wire.API.Team.Member qualified as Teams import Wire.API.User import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) -import Wire.ConversationSubsystem.Mapping import Wire.Options.Galley (federator, rabbitmq) import Wire.StoredConversation hiding (convName) From 9bed12fe27f63edcb7e40cf7a5c03a2a8d408d89 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 17:04:39 +0200 Subject: [PATCH 26/39] fix: test --- .../test/unit/Wire/StoredConversationSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs index 693354abbc3..6f496276fc1 100644 --- a/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs @@ -64,25 +64,25 @@ spec = describe "ConversationMapping" do == Just (sort (convUids (tDomain luid) c)) prop "conversation view for an invalid user is empty" $ \(RandomConversation c) luid -> - notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> - isJust (ownConversationView luid c) + notElem (tUnqualified luid) (map (.id_) c.localMembers) + ==> isNothing (ownConversationView luid c) prop "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom - ==> isJust (conversationToRemote dom ruid c) + ==> isJust (conversationToRemote dom ruid c) prop "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom - ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) - == Just roleNameWireMember + ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) + == Just roleNameWireMember prop "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom - ==> fmap (.metadata) (conversationToRemote dom ruid c) - == Just c.metadata + ==> fmap (.metadata) (conversationToRemote dom ruid c) + == Just c.metadata prop "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of Nothing -> False From 68c78f4209190207c9e49d9c9ef3094c7a14bed5 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 19:43:50 +0200 Subject: [PATCH 27/39] fix: test Swagger --- .../src/Wire/API/Routes/Internal/Galley.hs | 5 +++-- libs/wire-api/src/Wire/API/Team/LegalHold.hs | 19 +++++++++++++++++++ .../src/Wire/GalleyAPIAccess/Rpc.hs | 3 ++- services/galley/src/Galley/API/Internal.hs | 3 ++- 4 files changed, 26 insertions(+), 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index 8ac9a3b548a..9888175f906 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -24,7 +24,7 @@ import Data.LegalHold (UserLegalHoldStatus) import Data.OpenApi (OpenApi, info, title) import Data.Range import GHC.TypeLits (AppendSymbol) -import Imports hiding (head) +import Imports import Servant import Servant.OpenApi import Wire.API.Bot @@ -53,6 +53,7 @@ import Wire.API.Routes.QualifiedCapture import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Feature +import Wire.API.Team.LegalHold qualified as LegalHold import Wire.API.Team.Member import Wire.API.Team.Member.Info import Wire.API.Team.SearchVisibility @@ -636,7 +637,7 @@ type IMiscAPI = ( "users" :> "lh-status" :> ReqBody '[JSON] UserIds - :> Post '[JSON] [(UserId, UserLegalHoldStatus)] + :> Post '[JSON] [LegalHold.UserLegalHoldStatusEntry] ) type IEJPDAPI = diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index a7c65addd22..492229be234 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -22,6 +22,7 @@ module Wire.API.Team.LegalHold ViewLegalHoldService (..), ViewLegalHoldServiceInfo (..), UserLegalHoldStatusResponse (..), + UserLegalHoldStatusEntry (..), RemoveLegalHoldSettingsRequest (..), DisableLegalHoldForUserRequest (..), ApproveLegalHoldForUserRequest (..), @@ -162,6 +163,24 @@ instance ToSchema UserLegalHoldStatusResponse where <*> ulhsrLastPrekey .= maybe_ (optField "last_prekey" schema) <*> (fmap IdObject . ulhsrClientId) .= maybe_ (optField "client" (fromIdObject <$> schema)) +-------------------------------------------------------------------------------- +-- UserLegalHoldStatusEntry + +data UserLegalHoldStatusEntry = UserLegalHoldStatusEntry + { ulhseUser :: UserId, + ulhseStatus :: UserLegalHoldStatus + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserLegalHoldStatusEntry) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserLegalHoldStatusEntry) + +instance ToSchema UserLegalHoldStatusEntry where + schema = + object $ + UserLegalHoldStatusEntry + <$> ulhseUser .= field "user" schema + <*> ulhseStatus .= field "status" schema + -------------------------------------------------------------------------------- -- RemoveLegalHoldSettingsRequest diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index e781f24bcea..f495ea7c611 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -789,7 +789,8 @@ getUsersLHStatus uids = do remote "galley" . msg (val "Get users legalhold status") let bdy = UserIds uids - galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" + entries :: [UserLegalHoldStatusEntry] <- galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" + pure $ map (\e -> (e.ulhseUser, e.ulhseStatus)) entries where req bdy = method POST diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 4a896607408..bfde82b11b2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -74,6 +74,7 @@ import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiTablePaging qualified as MTP import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags (FeatureFlags) +import Wire.API.Team.LegalHold (UserLegalHoldStatusEntry (..)) import Wire.API.User (UserIds (cUsers)) import Wire.API.User.Client import Wire.BackendNotificationQueueAccess @@ -245,7 +246,7 @@ miscAPI = <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend <@> mkNamedAPI @"get-user-lh-status" (\uid mtid -> TeamSubsystem.getLHStatus mtid uid) - <@> mkNamedAPI @"get-users-lh-status" (\userIds -> TeamSubsystem.getLHStatusForUsers (cUsers userIds)) + <@> mkNamedAPI @"get-users-lh-status" (\userIds -> map (uncurry UserLegalHoldStatusEntry) <$> TeamSubsystem.getLHStatusForUsers (cUsers userIds)) featureAPI1Full :: forall cfg r. From d0203d7d16614862ebf9e4f9dc2b778a965708de Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 20:52:12 +0200 Subject: [PATCH 28/39] refactor: more back moves --- .../src/Wire/ConversationSubsystem.hs | 56 +---- .../Wire/ConversationSubsystem/Interpreter.hs | 18 -- .../src/Wire/ConversationSubsystem/Update.hs | 218 ------------------ .../src/Galley/API/Public/Conversation.hs | 22 +- 4 files changed, 13 insertions(+), 301 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 498b9926282..68f548da6f3 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -453,12 +453,7 @@ data ConversationSubsystem m a where ConvId -> ConversationSubsystem m ConversationCodeInfo -- Update functions - AddMembersUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - Invite -> - ConversationSubsystem m (UpdateResult Event) + AddQualifiedMembersUnqualified :: Local UserId -> ConnId -> @@ -510,37 +505,18 @@ data ConversationSubsystem m a where ConnId -> ConvId -> ConversationSubsystem m Event - MemberTypingUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - TypingStatus -> - ConversationSubsystem m () MemberTyping :: Local UserId -> ConnId -> Qualified ConvId -> TypingStatus -> ConversationSubsystem m () - RemoveMemberUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - UserId -> - ConversationSubsystem m (Maybe Event) RemoveMemberQualified :: Local UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> ConversationSubsystem m (Maybe Event) - UpdateOtherMemberUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - UserId -> - OtherMemberUpdate -> - ConversationSubsystem m () UpdateOtherMember :: Local UserId -> ConnId -> @@ -548,48 +524,24 @@ data ConversationSubsystem m a where Qualified UserId -> OtherMemberUpdate -> ConversationSubsystem m () - UpdateUnqualifiedConversationName :: - Local UserId -> - ConnId -> - ConvId -> - ConversationRename -> - ConversationSubsystem m (UpdateResult Event) UpdateConversationName :: Local UserId -> ConnId -> Qualified ConvId -> ConversationRename -> ConversationSubsystem m (UpdateResult Event) - UpdateConversationMessageTimerUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - ConversationMessageTimerUpdate -> - ConversationSubsystem m (UpdateResult Event) UpdateConversationMessageTimer :: Local UserId -> ConnId -> Qualified ConvId -> ConversationMessageTimerUpdate -> ConversationSubsystem m (UpdateResult Event) - UpdateConversationReceiptModeUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - ConversationReceiptModeUpdate -> - ConversationSubsystem m (UpdateResult Event) UpdateConversationReceiptMode :: Local UserId -> ConnId -> Qualified ConvId -> ConversationReceiptModeUpdate -> ConversationSubsystem m (UpdateResult Event) - UpdateConversationAccessUnqualified :: - Local UserId -> - ConnId -> - ConvId -> - ConversationAccessData -> - ConversationSubsystem m (UpdateResult Event) UpdateConversationAccess :: Local UserId -> ConnId -> @@ -602,12 +554,6 @@ data ConversationSubsystem m a where Qualified ConvId -> ConversationHistoryUpdate -> ConversationSubsystem m (UpdateResult Event) - UpdateUnqualifiedSelfMember :: - Local UserId -> - ConnId -> - ConvId -> - MemberUpdate -> - ConversationSubsystem m () UpdateSelfMember :: Local UserId -> ConnId -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 70b78c3c15a..29b4f93b8fc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -255,8 +255,6 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Query.getConversationGuestLinksStatus uid cid GetCode mcode lusr cnv -> mapErrors $ Update.getCode mcode lusr cnv - AddMembersUnqualified lusr con cnv invite -> - mapErrors $ Update.addMembersUnqualified lusr con cnv invite AddQualifiedMembersUnqualified lusr con cnv invite -> mapErrors $ Update.addQualifiedMembersUnqualified lusr con cnv invite AddMembers lusr zcon qcnv invite -> @@ -275,38 +273,22 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Update.addCodeUnqualifiedWithReqBody lusr mname mconn cnv req RmCodeUnqualified lusr con cnv -> mapErrors $ Update.rmCodeUnqualified lusr con cnv - MemberTypingUnqualified lusr con cnv status -> - mapErrors $ Update.memberTypingUnqualified lusr con cnv status MemberTyping lusr con qcnv status -> mapErrors $ Update.memberTyping lusr con qcnv status - RemoveMemberUnqualified lusr con cnv uid -> - mapErrors $ Update.removeMemberUnqualified lusr con cnv uid RemoveMemberQualified lusr con qcnv quid -> mapErrors $ Update.removeMemberQualified lusr con qcnv quid - UpdateOtherMemberUnqualified lusr con cnv uid update -> - mapErrors $ Update.updateOtherMemberUnqualified lusr con cnv uid update UpdateOtherMember lusr con qcnv quid update -> mapErrors $ Update.updateOtherMember lusr con qcnv quid update - UpdateUnqualifiedConversationName lusr con cnv rename -> - mapErrors $ Update.updateUnqualifiedConversationName lusr con cnv rename UpdateConversationName lusr zcon qcnv rename -> mapErrors $ Update.updateConversationName lusr zcon qcnv rename - UpdateConversationMessageTimerUnqualified lusr con cnv update -> - mapErrors $ Update.updateConversationMessageTimerUnqualified lusr con cnv update UpdateConversationMessageTimer lusr zcon qcnv update -> mapErrors $ Update.updateConversationMessageTimer lusr zcon qcnv update - UpdateConversationReceiptModeUnqualified lusr con cnv update -> - mapErrors $ Update.updateConversationReceiptModeUnqualified lusr con cnv update UpdateConversationReceiptMode lusr zcon qcnv update -> mapErrors $ Update.updateConversationReceiptMode lusr zcon qcnv update - UpdateConversationAccessUnqualified lusr con cnv update -> - mapErrors $ Update.updateConversationAccessUnqualified lusr con cnv update UpdateConversationAccess lusr zcon qcnv update -> mapErrors $ Update.updateConversationAccess lusr zcon qcnv update UpdateConversationHistory lusr zcon qcnv update -> mapErrors $ Update.updateConversationHistory lusr zcon qcnv update - UpdateUnqualifiedSelfMember lusr con cnv update -> - mapErrors $ Update.updateUnqualifiedSelfMember lusr con cnv update UpdateSelfMember lusr zcon qcnv update -> mapErrors $ Update.updateSelfMember lusr zcon qcnv update UpdateConversationProtocolWithLocalUser lusr conn qcnv update -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 220a6ae784a..9c3edf1868a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -32,13 +32,9 @@ module Wire.ConversationSubsystem.Update addCodeUnqualifiedWithReqBody, rmCodeUnqualified, getCode, - updateUnqualifiedConversationName, updateConversationName, - updateConversationReceiptModeUnqualified, updateConversationReceiptMode, - updateConversationMessageTimerUnqualified, updateConversationMessageTimer, - updateConversationAccessUnqualified, updateConversationAccess, updateConversationHistory, updateChannelAddPermission, @@ -49,16 +45,12 @@ module Wire.ConversationSubsystem.Update updateCellsState, -- * Managing Members - addMembersUnqualified, addQualifiedMembersUnqualified, addMembers, replaceMembers, - updateUnqualifiedSelfMember, updateSelfMember, updateOtherMember, - updateOtherMemberUnqualified, removeMemberQualified, - removeMemberUnqualified, removeMemberFromLocalConv, removeMemberFromRemoteConv, @@ -67,7 +59,6 @@ module Wire.ConversationSubsystem.Update postOtrMessageUnqualified, postProteusBroadcast, postOtrBroadcastUnqualified, - memberTypingUnqualified, memberTyping, -- * External Services @@ -336,24 +327,6 @@ updateConversationHistory lusr con qcnv update = do (Just con) update.history -updateConversationAccessUnqualified :: - ( Members UpdateConversationAccessEffects r, - Member Now r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationAccessData -> - Sem r (UpdateResult Event) -updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap lcuEvent $ - updateLocalConversationAccessData - (qualifyAs lusr cnv) - (tUntagged lusr) - (Just con) - update - updateConversationReceiptMode :: ( Member BrigAPIAccess r, Member ConversationStore r, @@ -432,31 +405,6 @@ updateRemoteConversation rcnv lusr mconn action = getUpdateResult $ do ConversationUpdateResponseUnreachableBackends e -> throw e updateLocalStateOfRemoteConv (qualifyAs rcnv convUpdate) mconn >>= note NoChanges -updateConversationReceiptModeUnqualified :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (ErrorS ('ActionDenied 'ModifyConversationReceiptMode)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'MLSReadReceiptsNotAllowed) r, - Member E.ExternalAccess r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member TinyLog r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationReceiptModeUpdate -> - Sem r (UpdateResult Event) -updateConversationReceiptModeUnqualified lusr zcon cnv = updateConversationReceiptMode lusr zcon (tUntagged (qualifyAs lusr cnv)) - updateConversationMessageTimer :: ( Member ConversationStore r, Member (ErrorS ('ActionDenied 'ModifyConversationMessageTimer)) r, @@ -489,25 +437,6 @@ updateConversationMessageTimer lusr zcon qcnv update = (\_ -> throw FederationNotImplemented) qcnv -updateConversationMessageTimerUnqualified :: - ( Member ConversationStore r, - Member (ErrorS ('ActionDenied 'ModifyConversationMessageTimer)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (Error FederationError) r, - Member NotificationSubsystem r, - Member E.ExternalAccess r, - Member Now r, - Member BackendNotificationQueueAccess r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationMessageTimerUpdate -> - Sem r (UpdateResult Event) -updateConversationMessageTimerUnqualified lusr zcon cnv = updateConversationMessageTimer lusr zcon (tUntagged (qualifyAs lusr cnv)) - deleteLocalConversation :: ( Member CodeStore r, Member ConversationStore r, @@ -1021,44 +950,6 @@ addQualifiedMembersUnqualified lusr zcon cnv (InviteQualified users role) = do updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role def -addMembersUnqualified :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'AddConversationMember)) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TooManyMembers) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'GroupIdVersionNotSupported) r, - Member (Error UnreachableBackends) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, - Member LegalHoldStore r, - Member ProposalStore r, - Member Random r, - Member TeamStore r, - Member TinyLog r, - Member TeamCollaboratorsSubsystem r, - Member FederationSubsystem r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - ConnId -> - ConvId -> - Invite -> - Sem r (UpdateResult Event) -addMembersUnqualified lusr zcon cnv (Invite users role) = do - let qusers = fmap (tUntagged . qualifyAs lusr) users - addMembers lusr zcon (tUntagged (qualifyAs lusr cnv)) (InviteQualified qusers role) - -- | Replace conversation members by computing the difference between desired and -- current members, then executing removals followed by additions within a commit -- lock. @@ -1193,22 +1084,6 @@ updateSelfMember lusr zcon qcnv update = do misConvRoleName = Nothing } -updateUnqualifiedSelfMember :: - ( Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r, - Member E.ExternalAccess r, - Member NotificationSubsystem r, - Member Now r - ) => - Local UserId -> - ConnId -> - ConvId -> - MemberUpdate -> - Sem r () -updateUnqualifiedSelfMember lusr zcon cnv update = do - let lcnv = qualifyAs lusr cnv - updateSelfMember lusr zcon (tUntagged lcnv) update - updateOtherMemberLocalConv :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1235,31 +1110,6 @@ updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult updateLocalConversationMemberUpdate lcnv (tUntagged lusr) (Just con) $ ConversationMemberUpdate qvictim update -updateOtherMemberUnqualified :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, - Member (ErrorS 'InvalidTarget) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'ConvMemberNotFound) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member E.ExternalAccess r, - Member Now r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - UserId -> - OtherMemberUpdate -> - Sem r () -updateOtherMemberUnqualified lusr zcon cnv victim update = do - let lcnv = qualifyAs lusr cnv - let lvictim = qualifyAs lusr victim - updateOtherMemberLocalConv lcnv lusr zcon (tUntagged lvictim) update - updateOtherMember :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1294,33 +1144,6 @@ updateOtherMemberRemoteConv :: Sem r () updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented -removeMemberUnqualified :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, - Member ProposalStore r, - Member Random r, - Member TinyLog r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - ConnId -> - ConvId -> - UserId -> - Sem r (Maybe Event) -removeMemberUnqualified lusr con cnv victim = do - let lvictim = qualifyAs lusr victim - lcnv = qualifyAs lusr cnv - removeMemberQualified lusr con (tUntagged lcnv) (tUntagged lvictim) - removeMemberQualified :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, @@ -1665,28 +1488,6 @@ updateConversationName lusr zcon qcnv convRename = do qcnv convRename -updateUnqualifiedConversationName :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InvalidInput) r, - Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member E.ExternalAccess r, - Member Now r, - Member BackendNotificationQueueAccess r, - Member NotificationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationRename -> - Sem r (UpdateResult Event) -updateUnqualifiedConversationName lusr zcon cnv rename = do - let lcnv = qualifyAs lusr cnv - updateLocalConversationName lusr zcon lcnv rename - updateLocalConversationName :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1748,25 +1549,6 @@ memberTyping lusr zcon qcnv ts = do ) qcnv -memberTypingUnqualified :: - ( Member NotificationSubsystem r, - Member (ErrorS 'ConvNotFound) r, - Member (Input (Local ())) r, - Member Now r, - Member ConversationStore r, - Member (E.FederationAPIAccess FederatorClient) r, - Member (Error FederationError) r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - TypingStatus -> - Sem r () -memberTypingUnqualified lusr zcon cnv ts = do - lcnv <- qualifyLocal cnv - memberTyping lusr zcon (tUntagged lcnv) ts - addBot :: forall r. ( Member E.UserClientIndexStore r, diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 9c07e85b3ff..6b2d287cb28 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -17,8 +17,10 @@ module Galley.API.Public.Conversation where +import Data.Qualified import Galley.App import Imports +import Wire.API.Conversation import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types @@ -63,7 +65,7 @@ conversationAPI = <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneOwnConversation <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneMLSConversation <@> mkNamedAPI @"get-one-to-one-mls-conversation" getMLSOne2OneConversation - <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified + <@> mkNamedAPI @"add-members-to-conversation-unqualified" (\lusr con cnv invite -> addMembers lusr con (tUntagged (qualifyAs lusr cnv)) (InviteQualified (fmap (tUntagged . qualifyAs lusr) (invUsers invite)) (invRoleName invite))) <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addQualifiedMembersUnqualified <@> mkNamedAPI @"add-members-to-conversation" addMembers <@> mkNamedAPI @"replace-members-in-conversation" replaceMembers @@ -75,25 +77,25 @@ conversationAPI = <@> mkNamedAPI @"get-conversation-guest-links-status" getConversationGuestLinksStatus <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified <@> mkNamedAPI @"get-code" getCode - <@> mkNamedAPI @"member-typing-unqualified" memberTypingUnqualified + <@> mkNamedAPI @"member-typing-unqualified" (\lusr con cnv status -> memberTyping lusr con (tUntagged (qualifyAs lusr cnv)) status) <@> mkNamedAPI @"member-typing-qualified" memberTyping - <@> mkNamedAPI @"remove-member-unqualified" removeMemberUnqualified + <@> mkNamedAPI @"remove-member-unqualified" (\lusr con cnv victim -> removeMemberQualified lusr con (tUntagged (qualifyAs lusr cnv)) (tUntagged (qualifyAs lusr victim))) <@> mkNamedAPI @"remove-member" removeMemberQualified - <@> mkNamedAPI @"update-other-member-unqualified" updateOtherMemberUnqualified + <@> mkNamedAPI @"update-other-member-unqualified" (\lusr con cnv victim update -> updateOtherMember lusr con (tUntagged (qualifyAs lusr cnv)) (tUntagged (qualifyAs lusr victim)) update) <@> mkNamedAPI @"update-other-member" updateOtherMember - <@> mkNamedAPI @"update-conversation-name-deprecated" updateUnqualifiedConversationName - <@> mkNamedAPI @"update-conversation-name-unqualified" updateUnqualifiedConversationName + <@> mkNamedAPI @"update-conversation-name-deprecated" (\lusr con cnv rename -> updateConversationName lusr con (tUntagged (qualifyAs lusr cnv)) rename) + <@> mkNamedAPI @"update-conversation-name-unqualified" (\lusr con cnv rename -> updateConversationName lusr con (tUntagged (qualifyAs lusr cnv)) rename) <@> mkNamedAPI @"update-conversation-name" updateConversationName - <@> mkNamedAPI @"update-conversation-message-timer-unqualified" updateConversationMessageTimerUnqualified + <@> mkNamedAPI @"update-conversation-message-timer-unqualified" (\lusr con cnv update -> updateConversationMessageTimer lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-message-timer" updateConversationMessageTimer - <@> mkNamedAPI @"update-conversation-receipt-mode-unqualified" updateConversationReceiptModeUnqualified + <@> mkNamedAPI @"update-conversation-receipt-mode-unqualified" (\lusr con cnv update -> updateConversationReceiptMode lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-receipt-mode" updateConversationReceiptMode - <@> mkNamedAPI @"update-conversation-access-unqualified" updateConversationAccessUnqualified + <@> mkNamedAPI @"update-conversation-access-unqualified" (\lusr con cnv update -> updateConversationAccess lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-access@v2" updateConversationAccess <@> mkNamedAPI @"update-conversation-access" updateConversationAccess <@> mkNamedAPI @"update-conversation-history" updateConversationHistory <@> mkNamedAPI @"get-conversation-self-unqualified" getLocalSelf - <@> mkNamedAPI @"update-conversation-self-unqualified" updateUnqualifiedSelfMember + <@> mkNamedAPI @"update-conversation-self-unqualified" (\lusr con cnv update -> updateSelfMember lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"get-conversation-self" getSelfMember <@> mkNamedAPI @"update-conversation-self" updateSelfMember <@> mkNamedAPI @"update-conversation-protocol" updateConversationProtocolWithLocalUser From 9877e2c9d376195f4686c6d40f571f7ae681b4d4 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 21:06:32 +0200 Subject: [PATCH 29/39] fix: formatting --- .../test/unit/Wire/StoredConversationSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs index 6f496276fc1..eaee1a974f4 100644 --- a/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs @@ -64,25 +64,25 @@ spec = describe "ConversationMapping" do == Just (sort (convUids (tDomain luid) c)) prop "conversation view for an invalid user is empty" $ \(RandomConversation c) luid -> - notElem (tUnqualified luid) (map (.id_) c.localMembers) - ==> isNothing (ownConversationView luid c) + notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> + isNothing (ownConversationView luid c) prop "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom - ==> isJust (conversationToRemote dom ruid c) + ==> isJust (conversationToRemote dom ruid c) prop "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom - ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) - == Just roleNameWireMember + ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) + == Just roleNameWireMember prop "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> qDomain (tUntagged ruid) /= dom - ==> fmap (.metadata) (conversationToRemote dom ruid c) - == Just c.metadata + ==> fmap (.metadata) (conversationToRemote dom ruid c) + == Just c.metadata prop "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of Nothing -> False From 5ce904063d343eccbab6038a6b9e6e3bdef8c41d Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 24 Apr 2026 23:48:47 +0200 Subject: [PATCH 30/39] Hello CI From 33d62e99131c0f502ff88a75020785712b904c5f Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 27 Apr 2026 11:39:07 +0200 Subject: [PATCH 31/39] refactor: inline addCodeUnqualifiedWithReqBody --- .../src/Wire/ConversationSubsystem.hs | 7 ----- .../Wire/ConversationSubsystem/Interpreter.hs | 2 -- .../src/Wire/ConversationSubsystem/Update.hs | 27 ------------------- .../src/Galley/API/Public/Conversation.hs | 2 +- 4 files changed, 1 insertion(+), 37 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 68f548da6f3..bff912ef6b1 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -493,13 +493,6 @@ data ConversationSubsystem m a where Maybe ConnId -> ConvId -> ConversationSubsystem m AddCodeResult - AddCodeUnqualifiedWithReqBody :: - UserId -> - Maybe Text -> - Maybe ConnId -> - ConvId -> - CreateConversationCodeRequest -> - ConversationSubsystem m AddCodeResult RmCodeUnqualified :: Local UserId -> ConnId -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 29b4f93b8fc..1fe0a3ddec1 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -269,8 +269,6 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Update.checkReusableCode addr code AddCodeUnqualified mReq usr mbZHost mZcon cnv -> mapErrors $ Update.addCodeUnqualified mReq usr mbZHost mZcon cnv - AddCodeUnqualifiedWithReqBody lusr mname mconn cnv req -> - mapErrors $ Update.addCodeUnqualifiedWithReqBody lusr mname mconn cnv req RmCodeUnqualified lusr con cnv -> mapErrors $ Update.rmCodeUnqualified lusr con cnv MemberTyping lusr con qcnv status -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 9c3edf1868a..8d94d2aaddf 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -29,7 +29,6 @@ module Wire.ConversationSubsystem.Update joinConversationByReusableCode, joinConversationById, addCodeUnqualified, - addCodeUnqualifiedWithReqBody, rmCodeUnqualified, getCode, updateConversationName, @@ -460,32 +459,6 @@ deleteLocalConversation lusr con lcnv = getUpdateResult . fmap lcuEvent $ updateLocalConversationDelete lcnv (tUntagged lusr) (Just con) -addCodeUnqualifiedWithReqBody :: - forall r. - ( Member CodeStore r, - Member ConversationStore r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'GuestLinksDisabled) r, - Member (ErrorS 'CreateConversationCodeConflict) r, - Member E.ExternalAccess r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member HashPassword r, - Member (Input (Maybe GuestLinkTTLSeconds)) r, - Member FeaturesConfigSubsystem r, - Member RateLimit r, - Member TeamSubsystem r - ) => - UserId -> - Maybe Text -> - Maybe ConnId -> - ConvId -> - CreateConversationCodeRequest -> - Sem r AddCodeResult -addCodeUnqualifiedWithReqBody usr mbZHost mZcon cnv req = addCodeUnqualified (Just req) usr mbZHost mZcon cnv - addCodeUnqualified :: forall r. ( Member CodeStore r, diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 6b2d287cb28..6e470a60c76 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -73,7 +73,7 @@ conversationAPI = <@> mkNamedAPI @"join-conversation-by-code-unqualified" joinConversationByReusableCode <@> mkNamedAPI @"code-check" checkReusableCode <@> mkNamedAPI @"create-conversation-code-unqualified@v3" (addCodeUnqualified Nothing) - <@> mkNamedAPI @"create-conversation-code-unqualified" addCodeUnqualifiedWithReqBody + <@> mkNamedAPI @"create-conversation-code-unqualified" (\req -> addCodeUnqualified (Just req)) <@> mkNamedAPI @"get-conversation-guest-links-status" getConversationGuestLinksStatus <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified <@> mkNamedAPI @"get-code" getCode From 50b8d50ae82c3db63a61698777102e4317afada1 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 27 Apr 2026 14:00:58 +0000 Subject: [PATCH 32/39] fix galley --- services/galley/src/Galley/API/Public/Conversation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 6e470a60c76..23598b787cf 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -73,7 +73,7 @@ conversationAPI = <@> mkNamedAPI @"join-conversation-by-code-unqualified" joinConversationByReusableCode <@> mkNamedAPI @"code-check" checkReusableCode <@> mkNamedAPI @"create-conversation-code-unqualified@v3" (addCodeUnqualified Nothing) - <@> mkNamedAPI @"create-conversation-code-unqualified" (\req -> addCodeUnqualified (Just req)) + <@> mkNamedAPI @"create-conversation-code-unqualified" (\uid zhost conn conv req -> addCodeUnqualified (Just req) uid zhost conn conv) <@> mkNamedAPI @"get-conversation-guest-links-status" getConversationGuestLinksStatus <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified <@> mkNamedAPI @"get-code" getCode From cf5a880fc0ce93eccdc74ccf20e844ce75fcfacd Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 27 Apr 2026 15:11:29 +0000 Subject: [PATCH 33/39] update changelog --- changelog.d/5-internal/WPB-23789 | 8 -------- changelog.d/5-internal/WPB-24072 | 1 + 2 files changed, 1 insertion(+), 8 deletions(-) delete mode 100644 changelog.d/5-internal/WPB-23789 create mode 100644 changelog.d/5-internal/WPB-24072 diff --git a/changelog.d/5-internal/WPB-23789 b/changelog.d/5-internal/WPB-23789 deleted file mode 100644 index 30fc625fdb2..00000000000 --- a/changelog.d/5-internal/WPB-23789 +++ /dev/null @@ -1,8 +0,0 @@ -### ConversationSubsystem Migration - -* Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. - This consolidation improves code organization and separation of concerns for conversation logic. - -* Library updates: - - Introduced dedicated error types for ConversationSubsystem to improve error handling - - Consolidated conversation-related operations that were previously scattered across multiple stores and subsystems diff --git a/changelog.d/5-internal/WPB-24072 b/changelog.d/5-internal/WPB-24072 new file mode 100644 index 00000000000..61a31439bf8 --- /dev/null +++ b/changelog.d/5-internal/WPB-24072 @@ -0,0 +1 @@ +Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. From 97c7ae8018f16255fabc71c725eb61b06be15979 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 27 Apr 2026 15:11:50 +0000 Subject: [PATCH 34/39] remove redundant converstion to text --- .../src/Wire/BackgroundWorker/Jobs/Registry.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index c670bea0f45..842dec6ec80 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -203,7 +203,7 @@ dispatchJob job = do . runDelay . resourceToIOFinal . runError - . mapError @DynError (T.pack . show . (.eMessage)) + . mapError @DynError (.eMessage) . mapError @JSONResponse (T.pack . show . (.value)) . mapError @ConversationSubsystemError toResponse . mapError @ClientError (T.pack . displayException) From 6d26ab59510ce9c06b2213563a114bd0a5c924cc Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 27 Apr 2026 15:12:08 +0000 Subject: [PATCH 35/39] remove unused code --- .../src/Wire/UserClientIndexStore.hs | 115 +----------------- 1 file changed, 1 insertion(+), 114 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs index 97e06f16696..1ba2898ecaa 100644 --- a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs +++ b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs @@ -17,49 +17,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.UserClientIndexStore - ( -- * UserClientIndexStore Effect - UserClientIndexStore (..), - - -- * Create client - createClient, - - -- * Get client - getClients, - - -- * Delete client - deleteClient, - deleteClients, - - -- * Helpers - internalGetClientIds, - rmClient, - getClientsId, - ) -where +module Wire.UserClientIndexStore where import Data.Id -import Data.Proxy (Proxy (..)) -import Data.Qualified -import Data.Range import Galley.Types.Clients -import Imports -import Network.AMQP qualified as Q import Polysemy -import Polysemy.Error -import Polysemy.Input -import Polysemy.TinyLog qualified as P -import System.Logger.Message -import Wire.API.Conversation hiding (Member) -import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) -import Wire.API.Federation.API -import Wire.API.Federation.API.Galley -import Wire.API.Federation.Error -import Wire.API.Routes.MultiTablePaging -import Wire.BackendNotificationQueueAccess -import Wire.BrigAPIAccess -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.Util (qualifyLocal) data UserClientIndexStore m a where GetClients :: [UserId] -> UserClientIndexStore m Clients @@ -68,78 +30,3 @@ data UserClientIndexStore m a where DeleteClients :: UserId -> UserClientIndexStore m () makeSem ''UserClientIndexStore - -internalGetClientIds :: - ( Member BrigAPIAccess r, - Member UserClientIndexStore r, - Member (Input ConversationSubsystemConfig) r - ) => - [UserId] -> - Sem r Clients -internalGetClientIds users = do - cfg <- input - let isInternal = cfg.listClientsUsingBrig - if isInternal - then fromUserClients <$> lookupClients users - else getClients users - -rmClient :: - forall r. - ( Member UserClientIndexStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error FederationError) r, - Member BackendNotificationQueueAccess r, - Member (Input (Local ())) r, - Member P.TinyLog r - ) => - UserId -> - ClientId -> - Sem r () -rmClient usr cid = do - clients <- getClients [usr] - if (cid `elem` clientIds usr clients) - then do - lusr <- qualifyLocal usr - let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 - firstConvIds <- ConversationSubsystem.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) - goConvs nRange1000 firstConvIds lusr - deleteClient usr cid - else - P.debug - ( field "user" (idToText usr) - . field "client" (clientToText cid) - . msg (val "rmClientH: client already gone") - ) - where - goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r () - goConvs range page lusr = do - let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) - for_ localConvs $ \convId -> do - mConv <- ConversationSubsystem.internalGetConversation convId - for_ mConv $ \conv -> do - lconv <- qualifyLocal conv - ConversationSubsystem.removeClient lconv (tUntagged lusr) cid - traverse_ removeRemoteMLSClients (rangedChunks remoteConvs) - when (mtpHasMore page) $ do - let nextState = mtpPagingState page - nextQuery = GetPaginatedConversationIds (Just nextState) range - newCids <- ConversationSubsystem.conversationIdsPageFrom lusr nextQuery - goConvs range newCids lusr - - removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r () - removeRemoteMLSClients convIds = do - for_ (bucketRemote (fromRange convIds)) $ \remoteConvs -> - let rpc = - fedQueueClient - @'OnClientRemovedTag - (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) - in enqueueNotification Q.Persistent remoteConvs rpc - -getClientsId :: - ( Member BrigAPIAccess r, - Member UserClientIndexStore r, - Member (Input ConversationSubsystemConfig) r - ) => - UserId -> - Sem r [ClientId] -getClientsId usr = clientIds usr <$> internalGetClientIds [usr] From 4f0d3648642e0a60b40f5e98925fdee43c74a7ca Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 27 Apr 2026 15:15:32 +0000 Subject: [PATCH 36/39] renaming --- .../src/Wire/ConversationSubsystem/Create.hs | 10 +++++----- .../src/Wire/ConversationSubsystem/Query.hs | 10 +++++----- .../src/Wire/ConversationSubsystem/Update.hs | 4 ++-- .../src/Wire/ConversationSubsystem/Util.hs | 4 ++-- 4 files changed, 14 insertions(+), 14 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs index 0c76bf359da..983fd7f0af2 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -97,7 +97,7 @@ createLegacyGroupConversation :: Sem r (ConversationResponse Public.OwnConversation) createLegacyGroupConversation lusr conn newConv = mapError UnreachableBackendsLegacy $ do dbConv <- createGroupConversationGeneric lusr conn newConv - maybe (throwWhenMemberNotFound lusr dbConv.id_) (pure . Created) $ ownConversationView lusr dbConv + maybe (throwIfNotOwnConversation lusr dbConv.id_) (pure . Created) $ ownConversationView lusr dbConv createGroupOwnConversation :: ( Member BrigAPIAccess r, @@ -139,7 +139,7 @@ createGroupOwnConversation lusr conn newConv = do enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) dbConv <- createGroupConversationGeneric lusr conn newConv - maybe (throwWhenMemberNotFound lusr dbConv.id_) (pure . GroupConversationCreatedV9) $ + maybe (throwIfNotOwnConversation lusr dbConv.id_) (pure . GroupConversationCreatedV9) $ (CreateGroupOwnConversation <$> ownConversationView lusr dbConv <*> pure mempty) createGroupConversation :: @@ -199,7 +199,7 @@ createProteusSelfConversation lusr = do if created then Created <$> ownConversationView lusr c else Existed <$> ownConversationView lusr c - maybe (throwWhenMemberNotFound lusr c.id_) pure mConv + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv createOne2OneConversation :: ( Member BrigAPIAccess r, @@ -234,7 +234,7 @@ createOne2OneConversation lusr zcon j = do if created then Created <$> ownConversationView lusr c else Existed <$> ownConversationView lusr c - maybe (throwWhenMemberNotFound lusr c.id_) pure mConv + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv ---------------------------------------------------------------------------- -- Helpers @@ -263,4 +263,4 @@ createConnectConversation lusr conn j = do if created then Created <$> ownConversationView lusr c else Existed <$> ownConversationView lusr c - maybe (throwWhenMemberNotFound lusr c.id_) pure mConv + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 4f48eee9a1e..ce8009d45bd 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -160,7 +160,7 @@ getUnqualifiedOwnConversation :: Sem r Public.OwnConversation getUnqualifiedOwnConversation lusr cnv = do c <- getConversationAsMember (tUntagged lusr) (qualifyAs lusr cnv) - maybe (throwWhenMemberNotFound lusr cnv) pure $ ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr c getUnqualifiedConversation :: forall r. @@ -466,7 +466,7 @@ getConversations :: Sem r (Public.ConversationList Public.OwnConversation) getConversations luser mids mstart msize = do ConversationList cs more <- getConversationsInternal luser mids mstart msize - ownConvs <- for cs (\c -> maybe (throwWhenMemberNotFound luser c.id_) pure $ ownConversationView luser c) + ownConvs <- for cs (\c -> maybe (throwIfNotOwnConversation luser c.id_) pure $ ownConversationView luser c) pure $ ConversationList ownConvs more getConversationsInternal :: @@ -520,7 +520,7 @@ listConversations luser (Public.ListConversations ids) = do >>= filterM (\c -> pure $ isMember (tUnqualified luser) c.localMembers) localConversations <- mapM - (\c -> maybe (throwWhenMemberNotFound luser c.id_) pure (ownConversationView luser c)) + (\c -> maybe (throwIfNotOwnConversation luser c.id_) pure (ownConversationView luser c)) localInternalConversations (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds @@ -741,7 +741,7 @@ getMLSSelfConversation lusr = do let selfConvId = mlsSelfConvId . tUnqualified $ lusr mconv <- ConversationStore.getConversation selfConvId cnv <- maybe (createMLSSelfConversation lusr) pure mconv - maybe (throwWhenMemberNotFound lusr cnv.id_) pure $ ownConversationView lusr cnv + maybe (throwIfNotOwnConversation lusr cnv.id_) pure $ ownConversationView lusr cnv createMLSSelfConversation :: (Member ConversationStore.ConversationStore r) => @@ -878,7 +878,7 @@ getLocalMLSOne2OneConversation lself lconv = do keys <- mlsKeysToPublic <$$> getMLSPrivateKeys conv <- case mconv of Nothing -> pure (localMLSOne2OneConversation lself lconv) - Just conv -> maybe (throwWhenMemberNotFound lself conv.id_) pure $ ownConversationView lself conv + Just conv -> maybe (throwIfNotOwnConversation lself conv.id_) pure $ ownConversationView lself conv pure $ MLSOne2OneConversation { conversation = conv, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 8d94d2aaddf..96a798aeca3 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -166,7 +166,7 @@ acceptConv lusr conn cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound conv' <- acceptOne2One lusr conv conn - maybe (throwWhenMemberNotFound lusr cnv) pure $ ownConversationView lusr conv' + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr conv' blockConv :: ( Member ConversationStore r, @@ -248,7 +248,7 @@ unblockConvUnqualified lusr conn cnv = do unless (convType conv `elem` [ConnectConv, One2OneConv]) $ throwS @'InvalidOperation conv' <- acceptOne2One lusr conv conn - maybe (throwWhenMemberNotFound lusr cnv) pure $ ownConversationView lusr conv' + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr conv' unblockRemoteConv :: (Member ConversationStore r) => diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index b351613f24a..78d70193979 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -98,8 +98,8 @@ import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven, getLH import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList -throwWhenMemberNotFound :: (Member TinyLog r, Member (Error InternalError) r) => Local UserId -> ConvId -> Sem r a -throwWhenMemberNotFound luid cid = do +throwIfNotOwnConversation :: (Member TinyLog r, Member (Error InternalError) r) => Local UserId -> ConvId -> Sem r a +throwIfNotOwnConversation luid cid = do P.err . msg $ val "User " +++ idToText (tUnqualified luid) From 29d3dac77bfaf49b14a5e02bd96e12a847365640 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 27 Apr 2026 15:53:41 +0000 Subject: [PATCH 37/39] fix internal remove client handler --- libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs | 2 +- libs/wire-subsystems/src/Wire/ConversationSubsystem.hs | 3 +-- .../src/Wire/ConversationSubsystem/Interpreter.hs | 5 +++-- services/galley/src/Galley/API/Internal.hs | 5 +++-- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index 9888175f906..a254f170483 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -552,7 +552,7 @@ type IMiscAPI = (RespondEmpty 200 "OK") ) :<|> Named - "test-delete-client" + "remove-client" ( "clients" :> ZUser :> Capture "cid" ClientId diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index bff912ef6b1..44605b64467 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -155,8 +155,7 @@ data ConversationSubsystem m a where ConvId -> ConversationSubsystem m Conversation RemoveClient :: - Local StoredConversation -> - Qualified UserId -> + UserId -> ClientId -> ConversationSubsystem m () AddBot :: diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 1fe0a3ddec1..672372cf8bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -45,6 +45,7 @@ import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem (ConversationSubsystem (..)) import Wire.ConversationSubsystem.Action.Notify qualified as ActionNotify +import Wire.ConversationSubsystem.Clients as Clients import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.CreateInternal qualified as CreateInternal import Wire.ConversationSubsystem.Errors @@ -317,8 +318,8 @@ interpretConversationSubsystem = interpret $ \case mapErrors $ Query.isMLSOne2OneEstablished lself qother GetLocalConversationInternal cid -> mapErrors $ Query.getLocalConversationInternal cid - RemoveClient lc qusr c -> - mapErrors $ MLSRemoval.removeClient lc qusr c + RemoveClient uid cid -> + mapErrors $ Clients.rmClient uid cid AddBot lusr zcon b -> mapErrors $ Update.addBot lusr zcon b RmBot lusr zcon b -> diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index bfde82b11b2..221da66c5b2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -45,6 +45,7 @@ import Galley.API.Teams.Features import Galley.App import Galley.Monad import Galley.Queue qualified as Q +import Galley.Types.Clients import Galley.Types.Error import Imports hiding (head) import Network.AMQP qualified as Q @@ -236,9 +237,9 @@ miscAPI :: API IMiscAPI GalleyEffects miscAPI = mkNamedAPI @"get-team-members" Teams.getBindingTeamMembers <@> mkNamedAPI @"get-team-id" lookupBindingTeam - <@> mkNamedAPI @"test-get-clients" UserClientIndexStore.getClientsId + <@> mkNamedAPI @"test-get-clients" (\uid -> clientIds uid <$> getClients [uid]) <@> mkNamedAPI @"test-add-client" createClient - <@> mkNamedAPI @"test-delete-client" rmClient + <@> mkNamedAPI @"remove-client" removeClient <@> mkNamedAPI @"add-service" createService <@> mkNamedAPI @"delete-service" deleteService <@> mkNamedAPI @"i-add-bot" addBot From 541dc44b3ce7a297d50f723fa97d2912411ed7da Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 27 Apr 2026 18:59:33 +0200 Subject: [PATCH 38/39] fix: copilot review --- .../src/Wire/GalleyAPIAccess.hs | 3 +++ .../src/Wire/GalleyAPIAccess/Rpc.hs | 20 +++++++++++++++++++ .../src/Wire/TeamSubsystem/GalleyAPI.hs | 7 ++++--- .../Wire/MockInterpreters/GalleyAPIAccess.hs | 1 + .../Wire/BackendNotificationPusherSpec.hs | 4 ++-- .../background-worker/test/Test/Wire/Util.hs | 16 +++++++++++++-- 6 files changed, 44 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 84f14322eb9..e3fa6bc3bc4 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -105,6 +105,9 @@ data GalleyAPIAccess m a where GetTeam :: TeamId -> GalleyAPIAccess m Team.TeamData + FindTeam :: + TeamId -> + GalleyAPIAccess m (Maybe Team.TeamData) GetTeamName :: TeamId -> GalleyAPIAccess m Team.TeamName diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index f495ea7c611..ae8f54d772d 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -92,6 +92,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = SelectTeamMembers tid uids -> selectTeamMembers tid uids GetTeamId id' -> getTeamId id' GetTeam id' -> getTeam id' + FindTeam id' -> findTeam id' GetTeamName id' -> getTeamName id' GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' GetTeamSearchVisibility id' -> getTeamSearchVisibility id' @@ -433,6 +434,25 @@ getTeam tid = do . paths ["i", "teams", toByteString' tid] . expect2xx +-- | Like 'getTeam' but returns 'Nothing' on 404 instead of throwing. +findTeam :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r + ) => + TeamId -> + Sem r (Maybe Team.TeamData) +findTeam tid = do + rs <- galleyRequest req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBodyOrThrow "galley" rs + _ -> pure Nothing + where + req = + method GET + . paths ["i", "teams", toByteString' tid] + . expect [status200, status404] + -- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeamName :: ( Member (Error ParseException) r, diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs index 83f5d77fe36..31ff34a8863 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs @@ -27,8 +27,8 @@ import Wire.TeamSubsystem interpretTeamSubsystemToGalleyAPI :: ( Member GalleyAPIAccess r, - Member (ErrorS TeamMemberNotFound) r, - Member (ErrorS TeamNotFound) r + Member (ErrorS 'TeamMemberNotFound) r, + Member (ErrorS 'TeamNotFound) r ) => InterpreterFor TeamSubsystem r interpretTeamSubsystemToGalleyAPI = interpret $ \case @@ -49,6 +49,7 @@ interpretTeamSubsystemToGalleyAPI = interpret $ \case GetTeamMembersForFanout tid -> GalleyAPIAccess.getTeamMembersWithLimit tid Nothing AssertTeamExists tid -> do - void $ GalleyAPIAccess.getTeam tid + found <- isJust <$> GalleyAPIAccess.findTeam tid + unless found $ throwS @'TeamNotFound GetLHStatusForUsers uids -> GalleyAPIAccess.getUsersLHStatus uids GetLHStatus mtid uid -> GalleyAPIAccess.getUserLHStatus mtid uid diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 485cb6454d9..4d79967500b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -56,6 +56,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case (\members -> any (\member -> member ^. userId == uid) members) teams GetTeam _ -> error "GetTeam not implemented in miniGalleyAPIAccess" + FindTeam _ -> error "FindTeam not implemented in miniGalleyAPIAccess" GetTeamName _ -> error "GetTeamName not implemented in miniGalleyAPIAccess" GetTeamLegalHoldStatus _ -> error "GetTeamLegalHoldStatus not implemented in miniGalleyAPIAccess" GetUserLegalholdStatus _ _ -> error "GetUserLegalholdStatus not implemented in miniGalleyAPIAccess" diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 13b3561bd7c..a3730bdaf27 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -382,7 +382,7 @@ spec = do checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") - passwordHashingRateLimitEnv <- newRateLimitEnv undefined + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domains <- runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) @@ -433,7 +433,7 @@ spec = do checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") - passwordHashingRateLimitEnv <- newRateLimitEnv undefined + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domainsThread <- async $ runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 3d0578588df..6aa6afa8c91 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -31,7 +31,7 @@ import Wire.BackgroundWorker.Env hiding (federatorInternal) import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options import Wire.PostgresMigrationOpts -import Wire.RateLimit.Interpreter (newRateLimitEnv) +import Wire.RateLimit.Interpreter (RateLimitConfig (..), TokenBucketConfig (..), newRateLimitEnv) testEnv :: IO Env testEnv = do @@ -78,9 +78,21 @@ testEnv = do passwordHashingOptions = PasswordHashingScrypt checkGroupInfo = Nothing convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") - passwordHashingRateLimitEnv <- newRateLimitEnv undefined + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig pure Env {..} +defTestRateLimitConfig :: RateLimitConfig +defTestRateLimitConfig = + RateLimitConfig + { ipv4CidrBlock = 32, + ipv6CidrBlock = 128, + ipAddressExceptions = [], + maxRateLimitedKeys = 1000, + ipAddrLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000}, + userLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000}, + internalLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000} + } + runTestAppT :: AppT IO a -> Int -> IO a runTestAppT app port = do baseEnv <- testEnv From 1f027c49db5eef77d97cc2f44ff63319c6fdfb42 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 27 Apr 2026 20:01:20 +0200 Subject: [PATCH 39/39] Hello CI