From 186fd42a4c7bf5de773a47e9dceee698dd29649c Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 22 Jan 2026 17:59:47 +0100 Subject: [PATCH 01/11] WPB-21964: move conversation creation to wire-subsystems --- .../templates/configmap.yaml | 8 +- charts/background-worker/values.yaml | 3 + libs/galley-types/default.nix | 4 + libs/galley-types/galley-types.cabal | 3 + .../galley-types/src/Galley/Types}/Error.hs | 2 +- .../src/Wire/ConversationSubsystem.hs | 5 + .../Wire/ConversationSubsystem/Interpreter.hs | 348 +++++++++++++++++- .../ConversationSubsystem/Notification.hs | 264 +++++++++++++ .../src/Wire/ConversationSubsystem/View.hs | 143 +++++++ libs/wire-subsystems/wire-subsystems.cabal | 2 + .../background-worker/background-worker.cabal | 1 + services/background-worker/default.nix | 2 + .../src/Wire/BackgroundWorker/Env.hs | 4 +- .../Wire/BackgroundWorker/Jobs/Registry.hs | 15 + .../src/Wire/BackgroundWorker/Options.hs | 1 + .../Wire/BackendNotificationPusherSpec.hs | 2 + .../background-worker/test/Test/Wire/Util.hs | 1 + services/galley/default.nix | 1 + services/galley/galley.cabal | 2 +- services/galley/src/Galley/API/Action.hs | 2 +- services/galley/src/Galley/API/Clients.hs | 2 +- services/galley/src/Galley/API/Create.hs | 199 +++------- services/galley/src/Galley/API/Federation.hs | 2 +- services/galley/src/Galley/API/Internal.hs | 2 +- services/galley/src/Galley/API/LegalHold.hs | 2 +- .../galley/src/Galley/API/LegalHold/Get.hs | 2 +- services/galley/src/Galley/API/MLS.hs | 2 +- .../galley/src/Galley/API/MLS/Commit/Core.hs | 2 +- .../Galley/API/MLS/Commit/InternalCommit.hs | 2 +- services/galley/src/Galley/API/MLS/Message.hs | 2 +- .../galley/src/Galley/API/MLS/Proposal.hs | 2 +- services/galley/src/Galley/API/MLS/Reset.hs | 2 +- services/galley/src/Galley/API/Mapping.hs | 2 +- services/galley/src/Galley/API/Query.hs | 2 +- services/galley/src/Galley/API/Teams.hs | 2 +- .../galley/src/Galley/API/Teams/Features.hs | 2 +- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/src/Galley/API/Util.hs | 29 +- services/galley/src/Galley/App.hs | 2 +- .../External/LegalHoldService/Internal.hs | 2 +- services/galley/src/Galley/Validation.hs | 2 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 42 files changed, 884 insertions(+), 197 deletions(-) rename {services/galley/src/Galley/API => libs/galley-types/src/Galley/Types}/Error.hs (99%) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs diff --git a/charts/background-worker/templates/configmap.yaml b/charts/background-worker/templates/configmap.yaml index 6c84d808767..fbcdd9dd702 100644 --- a/charts/background-worker/templates/configmap.yaml +++ b/charts/background-worker/templates/configmap.yaml @@ -25,6 +25,12 @@ data: host: brig port: 8080 + {{- if .enableFederation }} + federator: + host: {{ .federator.host }} + port: {{ .federator.port }} + {{- end }} + gundeck: host: gundeck port: 8080 @@ -103,4 +109,4 @@ data: {{- if .postgresMigration }} postgresMigration: {{- toYaml .postgresMigration | nindent 6 }} {{- end }} - {{- end }} + {{- end }} \ No newline at end of file diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index 2896d749e89..37f6c30d9dc 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -19,6 +19,9 @@ config: logLevel: Info logFormat: StructuredJSON enableFederation: false # keep in sync with brig, cargohold and galley charts' config.enableFederation as well as wire-server chart's tags.federation + federator: + host: federator + port: 8080 rabbitmq: host: rabbitmq port: 5672 diff --git a/libs/galley-types/default.nix b/libs/galley-types/default.nix index 4edd7e398d8..ff5a59d4968 100644 --- a/libs/galley-types/default.nix +++ b/libs/galley-types/default.nix @@ -12,6 +12,7 @@ , data-default , errors , gitignoreSource +, http-types , imports , lens , lib @@ -21,6 +22,7 @@ , types-common , utf8-string , uuid +, wai-utilities , wire-api }: mkDerivation { @@ -36,6 +38,7 @@ mkDerivation { crypton data-default errors + http-types imports lens memory @@ -44,6 +47,7 @@ mkDerivation { types-common utf8-string uuid + wai-utilities wire-api ]; license = lib.licenses.agpl3Only; diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 3405710cad3..249cb27489e 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -16,6 +16,7 @@ library Galley.Types Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles + Galley.Types.Error Galley.Types.Teams other-modules: Paths_galley_types @@ -76,6 +77,7 @@ library , crypton , data-default , errors + , http-types , imports , lens >=4.12 , memory @@ -84,6 +86,7 @@ library , types-common >=0.16 , utf8-string , uuid + , wai-utilities , wire-api default-language: GHC2021 diff --git a/services/galley/src/Galley/API/Error.hs b/libs/galley-types/src/Galley/Types/Error.hs similarity index 99% rename from services/galley/src/Galley/API/Error.hs rename to libs/galley-types/src/Galley/Types/Error.hs index a8241afa1c4..51a7223c868 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/libs/galley-types/src/Galley/Types/Error.hs @@ -18,7 +18,7 @@ -- | Most of the errors thrown by galley are defined as static errors in -- 'Wire.API.Error.Galley' and declared as part of the API. Errors defined here -- are dynamic, and mostly internal. -module Galley.API.Error +module Galley.Types.Error ( -- * Internal errors InvalidInput (..), InternalError (..), diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index ca068239bde..a84b8a2a98a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -43,5 +43,10 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate + CreateConversation :: + Local ConvId -> + Local UserId -> + NewConversation -> + ConversationSubsystem m StoredConversation makeSem ''ConversationSubsystem diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 089e6d14c76..2b364a6b184 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -1,3 +1,17 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -17,33 +31,58 @@ module Wire.ConversationSubsystem.Interpreter where +import Data.Bifunctor (second) import Data.Default import Data.Id -import Data.Json.Util (ToJSONObject (toJSONObject)) +import Data.Json.Util +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Qualified -import Data.Singletons (Sing) +import Data.Set qualified as Set +import Data.Singletons (Sing, sing) +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Time (UTCTime) +import Galley.Types.Error qualified as GalleyError import Galley.Types.Teams (FeatureDefaults) import Imports import Network.AMQP qualified as Q import Polysemy import Polysemy.Error -import Wire.API.Conversation hiding (Member) +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) +import Wire.API.Component (Component (Brig, Galley)) +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action -import Wire.API.Conversation.CellsState (CellsState (..)) -import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Conversation.CellsState +import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus), ProtocolTag) +import Wire.API.Conversation.Role +import Wire.API.Error.Galley import Wire.API.Event.Conversation -import Wire.API.Federation.API (makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API.Galley (ConversationCreated (..), ccRemoteOrigUserId) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) -import Wire.API.Federation.Error (FederationError) +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) -import Wire.API.Team.Feature (LegalholdConfig) -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently) +import Wire.API.Push.V2 qualified as PushV2 +import Wire.API.Team.Feature +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently, enqueueNotificationsConcurrentlyBuckets) +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.View (ViewError, conversationViewWithCachedOthers) import Wire.ExternalAccess (ExternalAccess, deliverAsync) +import Wire.FederationAPIAccess (FederationAPIAccess, runFederatedConcurrentlyEither) +import Wire.FederationAPIAccess qualified as E import Wire.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now -import Wire.StoredConversation +import Wire.StoredConversation hiding (convTeam, id_, localOne2OneConvId) +import Wire.StoredConversation as Data (LocalMember (..), NewConversation (..), RemoteMember (..), convType) +import Wire.StoredConversation qualified as Data data ConversationSubsystemConfig = ConversationSubsystemConfig { mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), @@ -54,16 +93,72 @@ data ConversationSubsystemConfig = ConversationSubsystemConfig interpretConversationSubsystem :: ( Member (Error FederationError) r, + Member (Error GalleyError.InternalError) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, - Member Now r + Member Now r, + Member (Embed IO) r, + Member ConversationStore r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog r ) => Sem (ConversationSubsystem : r) a -> Sem r a interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + CreateConversation lconv lusr newConv -> do + res <- runError @UnreachableBackends $ runError @ViewError $ createConversationImpl lconv lusr newConv + case res of + Left (unreachable :: UnreachableBackends) -> throw $ FederationUnexpectedError (T.pack $ show unreachable) + Right (Left (viewErr :: ViewError)) -> throw $ GalleyError.InternalErrorWithDescription (LT.pack $ show viewErr) + Right (Right val') -> pure val' + +createConversationImpl :: + ( Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error ViewError) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member Now r, + Member (Embed IO) r, + Member ConversationStore r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog r + ) => + Local ConvId -> + Local UserId -> + Data.NewConversation -> + Sem r StoredConversation +createConversationImpl lconv lusr newConv = do + storedConv <- ConvStore.upsertConversation lconv newConv + notifyCreatedConversation lusr Nothing storedConv def + sendCellsNotification lusr Nothing storedConv + pure storedConv + +sendCellsNotification :: + ( Member NotificationSubsystem r, + Member Now r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + Sem r () +sendCellsNotification lusr conn conv = do + now <- Now.get + let lconv = qualifyAs lusr conv.id_ + event = CellsEvent (tUntagged lconv) (tUntagged lusr) now CellsConvCreateNoData + when (conv.metadata.cnvmCellsState /= CellsDisabled) $ do + let push = + def + { origin = Just (tUnqualified lusr), + json = toJSONObject event, + isCellsEvent = True, + route = PushV2.RouteAny, + conn + } + NS.pushNotifications [push] notifyConversationActionImpl :: forall tag r. @@ -82,7 +177,7 @@ notifyConversationActionImpl :: Set (Remote UserId) -> Set BotMember -> ConversationAction (tag :: ConversationActionTag) -> - ExtraConversationData -> + Public.ExtraConversationData -> Sem r LocalConversationUpdate notifyConversationActionImpl tag eventFrom notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData = do now <- Now.get @@ -127,7 +222,7 @@ pushConversationEvent :: f BotMember -> Sem r () pushConversationEvent conn st e lusers bots = do - pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] + NS.pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] deliverAsync (map (,e) (toList bots)) where newConversationEventPush :: Local [UserId] -> Push @@ -137,6 +232,231 @@ pushConversationEvent conn st e lusers bots = do in def { origin = musr, json = toJSONObject e, - recipients = map userRecipient (tUnqualified users), + recipients = map NS.userRecipient (tUnqualified users), isCellsEvent = shouldPushToCells st e } + +toConversationCreated :: + UTCTime -> + Local UserId -> + StoredConversation -> + ConversationCreated ConvId +toConversationCreated now lusr StoredConversation {metadata = Public.ConversationMetadata {..}, ..} = + ConversationCreated + { time = now, + origUserId = tUnqualified lusr, + cnvId = id_, + cnvType = cnvmType, + cnvAccess = cnvmAccess, + cnvAccessRoles = cnvmAccessRoles, + cnvName = cnvmName, + nonCreatorMembers = Set.empty, + messageTimer = cnvmMessageTimer, + receiptMode = cnvmReceiptMode, + protocol = protocol, + groupConvType = cnvmGroupConvType, + channelAddPermission = cnvmChannelAddPermission + } + +fromConversationCreated :: + Local x -> + ConversationCreated (Remote ConvId) -> + [(Public.Member, Public.OwnConversation)] +fromConversationCreated loc rc@ConversationCreated {..} = + let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers + creatorOther = + Public.OtherMember + (tUntagged (ccRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin + in foldMap + ( \(me, others) -> + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) + ) + membersView + where + inDomain :: Public.OtherMember -> Bool + inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId + setHoles :: (Ord a) => Set a -> [(a, Set a)] + setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s + toMember :: Public.OtherMember -> Public.Member + toMember m = + Public.Member + { memId = Public.omQualifiedId m, + memService = Public.omService m, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = False, + memHiddenRef = Nothing, + memConvRoleName = Public.omConvRoleName m + } + conv :: Public.Member -> [Public.OtherMember] -> Public.OwnConversation + conv this others = + Public.OwnConversation + (tUntagged cnvId) + Public.ConversationMetadata + { cnvmType = cnvType, + cnvmCreator = Just origUserId, + cnvmAccess = cnvAccess, + cnvmAccessRoles = cnvAccessRoles, + cnvmName = cnvName, + cnvmTeam = Nothing, + cnvmMessageTimer = messageTimer, + cnvmReceiptMode = receiptMode, + cnvmGroupConvType = groupConvType, + cnvmChannelAddPermission = channelAddPermission, + cnvmCellsState = def, + cnvmParent = Nothing + } + (Public.OwnConvMembers this others) + ProtocolProteus + +ensureNoUnreachableBackends :: + (Member (Error UnreachableBackends) r) => + [Either (Remote e, b) a] -> + Sem r [a] +ensureNoUnreachableBackends results = do + let (errors, values) = partitionEithers results + unless (null errors) $ + throw (UnreachableBackends (map (tDomain . fst) errors)) + pure values + +registerRemoteConversationMemberships :: + ( Member ConvStore.ConversationStore r, + Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog r + ) => + UTCTime -> + Local UserId -> + Local StoredConversation -> + JoinType -> + Sem r () +registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do + let c = tUnqualified lc + rc = toConversationCreated now lusr c + allRemoteMembers = nubOrd c.remoteMembers + allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers + allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> + void $ fedClient @'Brig @"api-version" () + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ + \rrms -> + fedClient @'Galley @"on-conversation-created" + ( rc + { nonCreatorMembers = + toMembers (tUnqualified rrms) + } + ) + + let joined :: [Remote [RemoteMember]] = allRemoteBuckets + joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] + joinedCoupled = + foldMap + ( \ruids -> + let nj = + foldMap (fmap (.id_) . tUnqualified) $ + filter (\r -> tDomain r /= tDomain ruids) joined + in case NE.nonEmpty nj of + Nothing -> [] + Just v -> [fmap (,v) ruids] + ) + joined + + void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle + where + creator :: Maybe UserId + creator = Public.cnvmCreator . (.metadata) . tUnqualified $ lc + + localNonCreators :: [Public.OtherMember] + localNonCreators = + fmap (localMemberToOther . tDomain $ lc) + . filter (\lm -> lm.id_ `notElem` creator) + . (.localMembers) + . tUnqualified + $ lc + + toMembers :: [RemoteMember] -> Set Public.OtherMember + toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs + + convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate + convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = + ConversationUpdate + { time = now, + origUserId = tUntagged lusr, + convId = (tUnqualified lc).id_, + alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, + action = + SomeConversationAction + (sing @'ConversationJoinTag) + (Public.ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), + extraConversationData = def + } + + deleteOnUnreachable :: + ( Member ConvStore.ConversationStore r, + Member (Error UnreachableBackends) r, + Member TinyLog r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + P.err . msg $ + val "Unreachable backend when notifying" + +++ val "error" + +++ (LT.pack . show $ e) + ConvStore.deleteConversation (tUnqualified lc).id_ + throw e + +notifyCreatedConversation :: + ( Member ConvStore.ConversationStore r, + Member (Error FederationError) r, + Member (Error ViewError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + NS.pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == Public.RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [localMemberToRecipient m], + isCellsEvent = False, + route, + conn + } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs new file mode 100644 index 00000000000..831fb213e0e --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Wire.ConversationSubsystem.Notification where + +import Data.Bifunctor +import Data.Default +import Data.Id +import Data.Json.Util +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Qualified +import Data.Set qualified as Set +import Data.Singletons +import Data.Time +import Imports +import Network.AMQP qualified as Q +import Polysemy +import Polysemy.Error +import Polysemy.TinyLog qualified as P +import Wire.API.Component (Component (..)) +import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.Action +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role +import Wire.API.Error.Galley (UnreachableBackends (..)) +import Wire.API.Event.Conversation +import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as PushV2 +import Wire.BackendNotificationQueueAccess +import Wire.ConversationStore +import Wire.ConversationSubsystem.View +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess qualified as E +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredConversation as Data + +toConversationCreated :: + UTCTime -> + Local UserId -> + StoredConversation -> + ConversationCreated ConvId +toConversationCreated now lusr StoredConversation {metadata = ConversationMetadata {..}, ..} = + ConversationCreated + { time = now, + origUserId = tUnqualified lusr, + cnvId = id_, + cnvType = cnvmType, + cnvAccess = cnvmAccess, + cnvAccessRoles = cnvmAccessRoles, + cnvName = cnvmName, + nonCreatorMembers = Set.empty, + messageTimer = cnvmMessageTimer, + receiptMode = cnvmReceiptMode, + protocol = protocol, + groupConvType = cnvmGroupConvType, + channelAddPermission = cnvmChannelAddPermission + } + +fromConversationCreated :: + Local x -> + ConversationCreated (Remote ConvId) -> + [(Public.Member, Public.OwnConversation)] +fromConversationCreated loc rc@ConversationCreated {..} = + let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers + creatorOther = + OtherMember + (tUntagged (ccRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin + in foldMap + ( \(me, others) -> + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) + ) + membersView + where + inDomain :: OtherMember -> Bool + inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId + setHoles :: (Ord a) => Set a -> [(a, Set a)] + setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s + toMember :: OtherMember -> Public.Member + toMember m = + Public.Member + { memId = Public.omQualifiedId m, + memService = Public.omService m, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = False, + memHiddenRef = Nothing, + memConvRoleName = Public.omConvRoleName m + } + conv :: Public.Member -> [OtherMember] -> Public.OwnConversation + conv this others = + Public.OwnConversation + (tUntagged cnvId) + ConversationMetadata + { cnvmType = cnvType, + cnvmCreator = Just origUserId, + cnvmAccess = cnvAccess, + cnvmAccessRoles = cnvAccessRoles, + cnvmName = cnvName, + cnvmTeam = Nothing, + cnvmMessageTimer = messageTimer, + cnvmReceiptMode = receiptMode, + cnvmGroupConvType = groupConvType, + cnvmChannelAddPermission = channelAddPermission, + cnvmCellsState = def, + cnvmParent = Nothing + } + (OwnConvMembers this others) + ProtocolProteus + +ensureNoUnreachableBackends :: + (Member (Error UnreachableBackends) r) => + [Either (Remote e, b) a] -> + Sem r [a] +ensureNoUnreachableBackends results = do + let (errors, values) = partitionEithers results + unless (null errors) $ + throw (UnreachableBackends (map (tDomain . fst) errors)) + pure values + +registerRemoteConversationMemberships :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r + ) => + UTCTime -> + Local UserId -> + Local StoredConversation -> + JoinType -> + Sem r () +registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do + let c = tUnqualified lc + rc = toConversationCreated now lusr c + allRemoteMembers = nubOrd c.remoteMembers + allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers + allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> + void $ fedClient @'Brig @"api-version" () + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ + \rrms -> + fedClient @'Galley @"on-conversation-created" + ( rc + { nonCreatorMembers = + toMembers (tUnqualified rrms) + } + ) + + let joined :: [Remote [RemoteMember]] = allRemoteBuckets + joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] + joinedCoupled = + foldMap + ( \ruids -> + let nj = + foldMap (fmap (.id_) . tUnqualified) $ + filter (\r -> tDomain r /= tDomain ruids) joined + in case NE.nonEmpty nj of + Nothing -> [] + Just v -> [fmap (,v) ruids] + ) + joined + + void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle + where + creator :: Maybe UserId + creator = cnvmCreator . (.metadata) . tUnqualified $ lc + + localNonCreators :: [OtherMember] + localNonCreators = + fmap (localMemberToOther . tDomain $ lc) + . filter (\lm -> lm.id_ `notElem` creator) + . (.localMembers) + . tUnqualified + $ lc + + toMembers :: [RemoteMember] -> Set OtherMember + toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs + + convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate + convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = + ConversationUpdate + { time = now, + origUserId = tUntagged lusr, + convId = (tUnqualified lc).id_, + alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, + action = + SomeConversationAction + (sing @'ConversationJoinTag) + (ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), + extraConversationData = def + } + + deleteOnUnreachable :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + deleteConversation (tUnqualified lc).id_ + throw e + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error ViewError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [localMemberToRecipient m], + isCellsEvent = False, + route, + conn + } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs new file mode 100644 index 00000000000..9141e495535 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -0,0 +1,143 @@ +module Wire.ConversationSubsystem.View where + +import Data.Domain (Domain) +import Data.Id (UserId, idToText) +import Data.Qualified +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.Conversation qualified as Conversation +import Wire.API.Federation.API.Galley +import Wire.StoredConversation + +data ViewError = BadMemberState + deriving (Show, Eq) + +conversationViewV9 :: + ( Member (Error ViewError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r OwnConversation +conversationViewV9 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 = localMemberToSelf 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 + } + +conversationViewWithCachedOthers :: + ( Member (Error ViewError) 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 + +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 <- localMemberToSelf 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 + +remoteConversationView :: + Local UserId -> + MemberStatus -> + Remote RemoteConversationV2 -> + OwnConversation +remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = + let mems = rconv.members + others = mems.others + self = + localMemberToSelf + 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 + +conversationToRemote :: + Domain -> + Remote UserId -> + StoredConversation -> + Maybe RemoteConversationV2 +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 $ + RemoteConversationV2 + { id = conv.id_, + metadata = conv.metadata, + members = + RemoteConvMembers + { selfRole = selfRole', + others = others' + }, + protocol = conv.protocol + } + +localMemberToSelf :: Local x -> LocalMember -> Conversation.Member +localMemberToSelf loc lm = + Conversation.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 diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 5dc5e19c770..c69927a38e6 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -244,6 +244,8 @@ library Wire.ConversationStore.Postgres Wire.ConversationSubsystem Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.Notification + Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 595e3d01eac..2b73310cbc5 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -42,6 +42,7 @@ library , exceptions , extended , extra + , galley-types , hasql-pool , HsOpenSSL , http-client diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 011bc91bea0..58beb333294 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -16,6 +16,7 @@ , extended , extra , federator +, galley-types , gitignoreSource , hasql-pool , HsOpenSSL @@ -68,6 +69,7 @@ mkDerivation { exceptions extended extra + galley-types hasql-pool HsOpenSSL http-client diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 11787f105c6..5e2774106d5 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -84,7 +84,8 @@ data Env = Env federationDomain :: Domain, postgresMigration :: PostgresMigrationOpts, gundeckEndpoint :: Endpoint, - brigEndpoint :: Endpoint + brigEndpoint :: Endpoint, + federator :: Maybe Endpoint } data BackendNotificationMetrics = BackendNotificationMetrics @@ -133,6 +134,7 @@ mkEnv opts = do postgresMigration = opts.postgresMigration brigEndpoint = opts.brig gundeckEndpoint = opts.gundeck + federator = opts.federator workerRunningGauge <- mkWorkerRunningGauge hasqlPool <- initPostgresPool opts.postgresqlPool opts.postgresql opts.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 1c9b3416bd5..324e5d8f9ce 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -23,6 +23,8 @@ where import Data.Id import Data.Qualified import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Galley.Types.Error (InternalError, internalErrorDescription) import Hasql.Pool (UsageError) import Imports import Polysemy @@ -45,11 +47,14 @@ import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) import Wire.ExternalAccess.External +import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) import Wire.FireAndForget (interpretFireAndForget) import Wire.GundeckAPIAccess import Wire.NotificationSubsystem.Interpreter import Wire.ParseException import Wire.Rpc +import Wire.Sem.Concurrency (ConcurrencySafety (Unsafe)) +import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) import Wire.Sem.Delay (runDelay) import Wire.Sem.Logger (mapLogger) import Wire.Sem.Logger.TinyLog (loggerToTinyLog) @@ -72,7 +77,15 @@ dispatchJob job = do MigrationToPostgresql -> interpretConversationStoreToCassandraAndPostgres env.cassandraGalley PostgresqlStorage -> interpretConversationStoreToPostgres runInterpreters env extEnv = do + let federationAPIAccessConfig = + FederationAPIAccessConfig + { ownDomain = env.federationDomain, + federatorEndpoint = env.federator, + http2Manager = env.http2Manager, + requestId = job.requestId + } runFinal @IO + . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO . asyncToIOFinal . interpretRace @@ -82,6 +95,7 @@ dispatchJob job = do . mapError @UsageError (T.pack . show) . mapError @ParseException (T.pack . displayException) . mapError @MigrationError (T.pack . show) + . mapError @InternalError (TL.toStrict . internalErrorDescription) . interpretTinyLog env job.requestId job.jobId . runInputConst env.hasqlPool . runInputConst (toLocalUnsafe env.federationDomain ()) @@ -102,6 +116,7 @@ dispatchJob job = do . interpretBrigAccess env.brigEndpoint . interpretExternalAccess extEnv . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) + . interpretFederationAPIAccess federationAPIAccessConfig . interpretConversationSubsystem . interpretBackgroundJobsRunner diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 6dc18f03a2b..35ee518c306 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -37,6 +37,7 @@ data Opts = Opts federatorInternal :: !Endpoint, brig :: Endpoint, gundeck :: Endpoint, + federator :: Maybe Endpoint, rabbitmq :: !RabbitMqOpts, -- | Seconds, Nothing for no timeout defederationTimeout :: Maybe Int, diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index e10ab43123d..0b6196284be 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -368,6 +368,7 @@ spec = do } gundeckEndpoint = undefined brigEndpoint = undefined + federator = Nothing backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge @@ -406,6 +407,7 @@ spec = do } gundeckEndpoint = undefined brigEndpoint = undefined + federator = Nothing 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 cdb020a2223..014c3b50383 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -65,6 +65,7 @@ testEnv = do federationDomain = Domain "local" gundeckEndpoint = undefined brigEndpoint = undefined + federator = Nothing pure Env {..} runTestAppT :: AppT IO a -> Int -> IO a diff --git a/services/galley/default.nix b/services/galley/default.nix index 988d5378dc7..d6684de242c 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -296,6 +296,7 @@ mkDerivation { base containers extra + galley-types imports lens polysemy diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f1d6b4f299c..4fdb78797f9 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -81,7 +81,6 @@ library Galley.API.Clients Galley.API.Create Galley.API.CustomBackend - Galley.API.Error Galley.API.Federation Galley.API.Internal Galley.API.LegalHold @@ -571,6 +570,7 @@ test-suite galley-tests , containers , extra >=1.3 , galley + , galley-types , imports , lens , polysemy diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 10474662d9a..e65841a77ec 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -69,7 +69,6 @@ import Galley.API.Action.Kick import Galley.API.Action.Leave import Galley.API.Action.Notify import Galley.API.Action.Reset -import Galley.API.Error import Galley.API.MLS.Conversation import Galley.API.MLS.Migration import Galley.API.MLS.Removal @@ -78,6 +77,7 @@ import Galley.API.Util import Galley.Effects import Galley.Env (Env) import Galley.Options (Opts) +import Galley.Types.Error import Galley.Validation import Imports hiding ((\\)) import Polysemy diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 60dae17eaaf..e260c25e5d0 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -25,7 +25,6 @@ import Data.Id import Data.Proxy import Data.Qualified import Data.Range -import Galley.API.Error import Galley.API.MLS.Removal import Galley.API.Query qualified as Query import Galley.API.Util @@ -33,6 +32,7 @@ import Galley.Effects import Galley.Effects.ClientStore qualified as E import Galley.Env import Galley.Types.Clients (clientIds) +import Galley.Types.Error import Imports import Network.AMQP qualified as Q import Polysemy diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index d22b336ea75..f69f41e9923 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -43,14 +43,14 @@ import Data.Range import Data.Set qualified as Set import Data.UUID.Tagged qualified as U import Galley.API.Action -import Galley.API.Error import Galley.API.MLS import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util import Galley.App (Env) import Galley.Effects -import Galley.Options (Opts) +import Galley.Options +import Galley.Types.Error import Galley.Types.Teams (notTeamMember) import Galley.Validation import Imports hiding ((\\)) @@ -81,9 +81,9 @@ import Wire.API.Team.Permission hiding (self) import Wire.API.User import Wire.BrigAPIAccess import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem qualified as ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.FeaturesConfigSubsystem -import Wire.FederationAPIAccess qualified as E import Wire.NotificationSubsystem import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -102,11 +102,10 @@ import Wire.UserList -- | The public-facing endpoint for creating group conversations in the client -- API up to and including version 3. createGroupConversationUpToV3 :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r, @@ -118,7 +117,6 @@ createGroupConversationUpToV3 :: Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, Member (Error UnreachableBackendsLegacy) r, - Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, @@ -136,22 +134,17 @@ createGroupConversationUpToV3 :: Maybe ConnId -> NewConv -> Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ - do - conv <- - createGroupConversationGeneric - lusr - conn - newConv - def - conversationCreated lusr conv +createGroupConversationUpToV3 lusr conn newConv = + mapError UnreachableBackendsLegacy $ + createGroupConversationGeneric lusr conn newConv + >>= conversationCreated lusr -- | The public-facing endpoint for creating group conversations in the client -- API in from version 4 to 8 createGroupOwnConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -197,9 +190,9 @@ createGroupOwnConversation lusr conn newConv = do -- | The public-facing endpoint for creating group conversations in the client -- API in version 9 and above. createGroupConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -222,7 +215,6 @@ createGroupConversation :: Member Now r, Member LegalHoldStore r, Member TeamStore r, - Member P.TinyLog r, Member FeaturesConfigSubsystem r, Member TeamCollaboratorsSubsystem r, Member Random r, @@ -263,11 +255,10 @@ createGroupConvAndMkResponse :: Member (Error NonFederatingBackends) r, Member (Error InternalError) r, Member (Error InvalidInput) r, - Member P.TinyLog r, Member (FederationAPIAccess FederatorClient) r, - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member NotificationSubsystem r, Member LegalHoldStore r, Member TeamStore r, @@ -286,16 +277,15 @@ createGroupConvAndMkResponse lusr conn newConv mkResponse = do let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- createGroupConversationGeneric lusr conn newConv def + dbConv <- createGroupConversationGeneric lusr conn newConv mkResponse dbConv createGroupConversationGeneric :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r, @@ -306,8 +296,6 @@ createGroupConversationGeneric :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, @@ -315,7 +303,6 @@ createGroupConversationGeneric :: Member Now r, Member LegalHoldStore r, Member TeamStore r, - Member P.TinyLog r, Member FeaturesConfigSubsystem r, Member TeamCollaboratorsSubsystem r, Member Random r, @@ -324,9 +311,8 @@ createGroupConversationGeneric :: Local UserId -> Maybe ConnId -> NewConv -> - JoinType -> Sem r StoredConversation -createGroupConversationGeneric lusr conn newConv joinType = do +createGroupConversationGeneric lusr conn newConv = do (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers ensureNoLegalholdConflicts allUsers @@ -336,12 +322,11 @@ createGroupConversationGeneric lusr conn newConv joinType = do assertMLSEnabled lcnv <- traverse (const $ Id <$> Random.uuid) lusr - conv <- E.upsertConversation lcnv nc + conv <- ConversationSubsystem.createConversation lcnv lusr nc -- NOTE: We only send (conversation) events to members of the conversation - notifyCreatedConversation lusr conn conv joinType sendCellsNotification conv - E.getConversation (tUnqualified lcnv) - >>= note (BadConvState (tUnqualified lcnv)) + E.getConversation conv.id_ + >>= note (BadConvState conv.id_) where sendCellsNotification :: StoredConversation -> Sem r () sendCellsNotification conv = do @@ -468,6 +453,7 @@ getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) createProteusSelfConversation :: forall r. ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, Member P.TinyLog r ) => @@ -487,13 +473,13 @@ createProteusSelfConversation lusr = do protocol = BaseProtocolProteusTag, groupId = Nothing } - c <- E.upsertConversation lcnv nc - conversationCreated lusr c + ConversationSubsystem.createConversation lcnv lusr nc + >>= conversationCreated lusr createOne2OneConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, @@ -505,9 +491,6 @@ createOne2OneConversation :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotConnected) r, Member (Error UnreachableBackendsLegacy) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member TeamStore r, Member P.TinyLog r, Member TeamCollaboratorsSubsystem r, @@ -587,14 +570,10 @@ createOne2OneConversation lusr zcon j = else throwS @OperationDenied createLegacyOne2OneConversationUnchecked :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, Member (Error InvalidInput) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member P.TinyLog r ) => Local UserId -> @@ -603,7 +582,7 @@ createLegacyOne2OneConversationUnchecked :: Maybe TeamId -> Local UserId -> Sem r (ConversationResponse Public.OwnConversation) -createLegacyOne2OneConversationUnchecked self zcon name mtid other = do +createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do lcnv <- localOne2OneConvId self other let meta = (defConversationMetadata (Just (tUnqualified self))) @@ -622,23 +601,14 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do case mc of Just c -> conversationExisted self c Nothing -> do - c <- E.upsertConversation lcnv nc - runError @UnreachableBackends (notifyCreatedConversation self (Just zcon) c def) - >>= \case - Left _ -> do - throw . InternalErrorWithDescription $ - "A one-to-one conversation on one backend cannot involve unreachable backends" - Right () -> conversationCreated self c + ConversationSubsystem.createConversation lcnv self nc + >>= conversationCreated self createOne2OneConversationUnchecked :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member P.TinyLog r ) => Local UserId -> @@ -656,14 +626,9 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member P.TinyLog r ) => Local ConvId -> @@ -673,7 +638,7 @@ createOne2OneConversationLocally :: Maybe TeamId -> Qualified UserId -> Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationLocally lcnv self zcon name mtid other = do +createOne2OneConversationLocally lcnv self _zcon name mtid other = do mc <- E.getConversation (tUnqualified lcnv) case mc of Just c -> conversationExisted self c @@ -691,9 +656,8 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do protocol = BaseProtocolProteusTag, groupId = Nothing } - c <- E.upsertConversation lcnv nc - notifyCreatedConversation self (Just zcon) c def - conversationCreated self c + ConversationSubsystem.createConversation lcnv self nc + >>= conversationCreated self createOne2OneConversationRemotely :: (Member (Error FederationError) r) => @@ -708,15 +672,13 @@ createOne2OneConversationRemotely _ _ _ _ _ _ = throw FederationNotImplemented createConnectConversation :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvNotFound) r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'InvalidOperation) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, Member Now r, Member P.TinyLog r @@ -747,20 +709,7 @@ createConnectConversation lusr conn j = do >>= maybe (create lcnv nc) (update n) where create lcnv nc = do - c <- E.upsertConversation lcnv nc - now <- Now.get - let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) now Nothing (EdConnect j) - notifyCreatedConversation lusr conn c def - pushNotifications - [ def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = map localMemberToRecipient c.localMembers, - isCellsEvent = shouldPushToCells c.metadata e, - route = PushV2.RouteDirect, - conn - } - ] + c <- ConversationSubsystem.createConversation lcnv lusr nc conversationCreated lusr c update n conv = do let mems = conv.localMembers @@ -787,24 +736,12 @@ createConnectConversation lusr conn j = do else pure conv'' connect n conv | Data.convType conv == ConnectConv = do - let lcnv = qualifyAs lusr conv.id_ n' <- case n of Just x -> do E.setConversationName conv.id_ x pure . Just $ fromRange x Nothing -> pure $ Data.convName conv - t <- Now.get - let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConnect j) - pushNotifications - [ def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = map localMemberToRecipient conv.localMembers, - isCellsEvent = shouldPushToCells conv.metadata e, - route = PushV2.RouteDirect, - conn - } - ] + notifyConversationUpdated lusr conn j conv pure $ Data.convSetName n' conv | otherwise = pure conv @@ -879,58 +816,6 @@ conversationCreated :: Sem r (ConversationResponse Public.OwnConversation) conversationCreated lusr cnv = Created <$> conversationViewV9 lusr cnv --- | The return set contains all the remote users that could not be contacted. --- Consequently, the unreachable users are not added to the member list. This --- behavior might be changed later on when a message/event queue per remote --- backend is implemented. -notifyCreatedConversation :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - -- Ask remote servers to store conversation membership and notify remote users - -- of being added to a conversation - registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - -- Notify local users - pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = [localMemberToRecipient m], - -- on conversation creation we send the cells event separately to make sure it is sent exactly once - isCellsEvent = False, - route, - conn - } - localOne2OneConvId :: (Member (Error InvalidInput) r) => Local UserId -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 725117fe7f6..f476a7ff6ee 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -37,7 +37,6 @@ import Data.Singletons (SingI (..), demote, sing) import Data.Tagged import Data.Text.Lazy qualified as LT import Galley.API.Action -import Galley.API.Error import Galley.API.MLS import Galley.API.MLS.Enabled import Galley.API.MLS.GroupInfo @@ -56,6 +55,7 @@ import Galley.App import Galley.Effects import Galley.Options import Galley.Types.Conversations.One2One +import Galley.Types.Error import Imports import Network.Wai.Utilities.Exception import Polysemy diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 7c50cd9d5ee..9a21fd3c3f2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -39,7 +39,6 @@ import Data.Time import Galley.API.Action import Galley.API.Clients qualified as Clients import Galley.API.Create qualified as Create -import Galley.API.Error import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts import Galley.API.MLS.Removal @@ -60,6 +59,7 @@ import Galley.Env (FanoutLimit) import Galley.Monad import Galley.Options hiding (brig) import Galley.Queue qualified as Q +import Galley.Types.Error import Imports hiding (head) import Network.AMQP qualified as Q import Polysemy diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 2aa4a480886..9007a8c8111 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -41,7 +41,6 @@ import Data.Misc import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range (toRange) -import Galley.API.Error import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team import Galley.API.Query (iterateConversations) @@ -51,6 +50,7 @@ import Galley.App import Galley.Effects import Galley.Effects.TeamMemberStore import Galley.External.LegalHoldService qualified as LHService +import Galley.Types.Error import Galley.Types.Teams as Team import Imports import Network.HTTP.Types.Status (status200) diff --git a/services/galley/src/Galley/API/LegalHold/Get.hs b/services/galley/src/Galley/API/LegalHold/Get.hs index e6ac3379fac..37c90544250 100644 --- a/services/galley/src/Galley/API/LegalHold/Get.hs +++ b/services/galley/src/Galley/API/LegalHold/Get.hs @@ -22,8 +22,8 @@ import Data.ByteString.Conversion (toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..)) import Data.Qualified -import Galley.API.Error import Galley.Effects +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS.hs b/services/galley/src/Galley/API/MLS.hs index 7a83ac92146..0d0d5abe601 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/services/galley/src/Galley/API/MLS.hs @@ -27,10 +27,10 @@ module Galley.API.MLS where import Data.Default -import Galley.API.Error import Galley.API.MLS.Enabled import Galley.API.MLS.Message import Galley.Env +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs index 966693c5940..6b3a49b4779 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/services/galley/src/Galley/API/MLS/Commit/Core.hs @@ -31,13 +31,13 @@ where import Control.Comonad import Data.Id import Data.Qualified -import Galley.API.Error import Galley.API.MLS.Conversation import Galley.API.MLS.IncomingMessage import Galley.API.MLS.Proposal import Galley.Effects import Galley.Env import Galley.Options +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index ac15b43399f..e5d234ac33d 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -30,7 +30,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra import Galley.API.Action -import Galley.API.Error import Galley.API.MLS.CheckClients import Galley.API.MLS.Commit.Core import Galley.API.MLS.Conversation @@ -40,6 +39,7 @@ import Galley.API.MLS.Proposal import Galley.API.MLS.Util import Galley.API.Util import Galley.Effects +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 8ca29cac361..aeef15f5a48 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -41,7 +41,6 @@ import Data.Tagged import Data.Text.Lazy qualified as LT import Data.Tuple.Extra import Galley.API.Action -import Galley.API.Error import Galley.API.LegalHold.Get (getUserStatus) import Galley.API.MLS.Commit.Core (getCommitData) import Galley.API.MLS.Commit.ExternalCommit @@ -58,6 +57,7 @@ import Galley.API.MLS.Util import Galley.API.MLS.Welcome (sendWelcomes) import Galley.API.Util import Galley.Effects +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 68dc6a0a7a4..e7c3704a482 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -38,12 +38,12 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.Error import Galley.API.MLS.IncomingMessage import Galley.API.Util import Galley.Effects import Galley.Env import Galley.Options +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Reset.hs b/services/galley/src/Galley/API/MLS/Reset.hs index 5d9515c9722..d9b6abc0674 100644 --- a/services/galley/src/Galley/API/MLS/Reset.hs +++ b/services/galley/src/Galley/API/MLS/Reset.hs @@ -20,12 +20,12 @@ module Galley.API.MLS.Reset (resetMLSConversation) where import Data.Id import Data.Qualified import Galley.API.Action -import Galley.API.Error import Galley.API.MLS.Enabled import Galley.API.MLS.Util import Galley.API.Update import Galley.Effects import Galley.Env +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 91d2c338c7b..d4b66ede388 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -28,7 +28,7 @@ where import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified -import Galley.API.Error +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index ee61bf748a4..4595cb9ee00 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -66,7 +66,6 @@ import Data.Qualified import Data.Range import Data.Set qualified as Set import Data.Tagged -import Galley.API.Error import Galley.API.MLS import Galley.API.MLS.Enabled import Galley.API.MLS.One2One @@ -77,6 +76,7 @@ import Galley.API.Teams.Features.Get import Galley.API.Util import Galley.Effects import Galley.Env +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 2ac49386349..22deafd2e01 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -77,7 +77,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Time.Clock (UTCTime) import Galley.API.Action -import Galley.API.Error as Galley import Galley.API.LegalHold.Team import Galley.API.Teams.Features.Get import Galley.API.Teams.Notifications qualified as APITeamQueue @@ -90,6 +89,7 @@ import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData import Galley.Effects.TeamMemberStore qualified as E import Galley.Env import Galley.Options +import Galley.Types.Error as Galley import Galley.Types.Teams import Imports hiding (forkIO) import Polysemy diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 4c9bf4b9797..349d6d56326 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -41,7 +41,6 @@ import Data.Id import Data.Json.Util import Data.Kind import Data.Qualified (Local) -import Galley.API.Error (InternalError) import Galley.API.LegalHold qualified as LegalHold import Galley.API.LegalHold.Team qualified as LegalHold import Galley.API.Teams.Features.Get @@ -51,6 +50,7 @@ import Galley.Effects import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData import Galley.Env (FanoutLimit) import Galley.Options +import Galley.Types.Error (InternalError) import Galley.Types.Teams import Imports import Polysemy diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index fd4e4606b8a..cbd948dd391 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,7 +91,6 @@ import Data.Singletons import Data.Vector qualified as V import Galley.API.Action import Galley.API.Action.Kick (kickMember) -import Galley.API.Error import Galley.API.Mapping import Galley.API.Message import Galley.API.Query qualified as Query @@ -102,6 +101,7 @@ import Galley.Effects import Galley.Effects.ClientStore qualified as E import Galley.Env import Galley.Options +import Galley.Types.Error import Imports hiding (forkIO) import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index d8a1143b9ef..beabe54bb34 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -40,13 +40,14 @@ import Data.Set qualified as Set import Data.Singletons import Data.Text qualified as T import Data.Time -import Galley.API.Error import Galley.API.Mapping import Galley.Effects import Galley.Effects.ClientStore import Galley.Env +import Galley.Options () import Galley.Types.Clients (Clients, fromUserClients) import Galley.Types.Conversations.Roles +import Galley.Types.Error import Galley.Types.Teams import Imports hiding (forkIO) import Network.AMQP qualified as Q @@ -1187,3 +1188,29 @@ instance if err' == demote @e then throwS @e else rethrowErrors @effs @r err' + +---------------------------------------------------------------------------- +-- Notifications +notifyConversationUpdated :: + ( Member NotificationSubsystem r, + Member Now r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + StoredConversation -> + Sem r () +notifyConversationUpdated lusr conn j conv = do + let lcnv = qualifyAs lusr conv.id_ + t <- Now.get + let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConnect j) + pushNotifications + [ def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = map localMemberToRecipient conv.localMembers, + isCellsEvent = shouldPushToCells conv.metadata e, + route = PushV2.RouteDirect, + conn + } + ] diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 2035a64c1cf..611814c3563 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.Error import Galley.Cassandra.Client import Galley.Cassandra.CustomBackend import Galley.Cassandra.SearchVisibility @@ -72,6 +71,7 @@ import Galley.Options hiding (brig, endpoint, federator) import Galley.Options qualified as O import Galley.Queue import Galley.Queue qualified as Q +import Galley.Types.Error import Galley.Types.Teams import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Hasql.Pool qualified as Hasql diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index eac3a0d0100..6834a6426ab 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -29,9 +29,9 @@ import Control.Retry import Data.ByteString qualified as BS import Data.ByteString.Lazy.Char8 qualified as LC8 import Data.Misc -import Galley.API.Error import Galley.Env import Galley.Monad +import Galley.Types.Error import Imports import Network.HTTP.Client qualified as Http import OpenSSL.Session qualified as SSL diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 7d045d21026..6c43091116f 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -29,8 +29,8 @@ where import Control.Lens import Data.Range import GHC.TypeNats -import Galley.API.Error import Galley.Options +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index d8e36e1ad91..b73a27c17b4 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,8 +25,8 @@ import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.API.Error (InternalError) import Galley.API.Mapping +import Galley.Types.Error (InternalError) import Imports import Polysemy (Sem) import Polysemy qualified as P From 78fb9da657acea21f2af4ee3ff5a675a7369de6b Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 23 Jan 2026 13:31:11 +0100 Subject: [PATCH 02/11] refactor: move `Galley.Types.Clients` to `galley-types`, partially `Galley.API.Action`, `Galley.API.One2One`, `Galley.API.Util`, partially `Galley.API.Mappings`, partially `Galley.API.Create` to `wire-subsystems` --- libs/galley-types/galley-types.cabal | 1 + .../galley-types}/src/Galley/Types/Clients.hs | 0 libs/galley-types/src/Galley/Types/Teams.hs | 4 + .../src/Wire/API/Routes/Public/Brig.hs | 2 +- .../src/Wire/ConversationSubsystem}/Create.hs | 84 +++++--- .../Wire/ConversationSubsystem/Federation.hs | 112 +++++++++++ .../Wire/ConversationSubsystem/Interpreter.hs | 49 +++-- .../ConversationSubsystem/Notification.hs | 14 +- .../Wire/ConversationSubsystem}/One2One.hs | 2 +- .../src/Wire/ConversationSubsystem/Types.hs | 31 +++ .../src/Wire/ConversationSubsystem}/Util.hs | 22 +-- .../src/Wire/ConversationSubsystem/View.hs | 8 +- .../src/Wire}/Effects/ClientStore.hs | 2 +- libs/wire-subsystems/wire-subsystems.cabal | 6 + services/brig/src/Brig/IO/Intra.hs | 2 +- services/galley/default.nix | 1 - services/galley/galley.cabal | 7 - services/galley/src/Galley/API/Action.hs | 62 +----- services/galley/src/Galley/API/Action/Kick.hs | 2 +- .../galley/src/Galley/API/Action/Leave.hs | 2 +- .../galley/src/Galley/API/Action/Notify.hs | 2 +- .../galley/src/Galley/API/Action/Reset.hs | 2 +- services/galley/src/Galley/API/Clients.hs | 4 +- services/galley/src/Galley/API/Federation.hs | 6 +- services/galley/src/Galley/API/Internal.hs | 10 +- services/galley/src/Galley/API/LegalHold.hs | 2 +- .../src/Galley/API/LegalHold/Conflicts.hs | 2 +- .../galley/src/Galley/API/LegalHold/Team.hs | 3 +- .../Galley/API/MLS/Commit/InternalCommit.hs | 2 +- .../galley/src/Galley/API/MLS/GroupInfo.hs | 2 +- services/galley/src/Galley/API/MLS/Message.hs | 2 +- .../galley/src/Galley/API/MLS/Proposal.hs | 2 +- .../src/Galley/API/MLS/SubConversation.hs | 2 +- services/galley/src/Galley/API/Mapping.hs | 182 ------------------ services/galley/src/Galley/API/Message.hs | 6 +- .../src/Galley/API/Public/Conversation.hs | 2 +- services/galley/src/Galley/API/Query.hs | 10 +- services/galley/src/Galley/API/Teams.hs | 3 +- .../galley/src/Galley/API/Teams/Features.hs | 3 +- .../src/Galley/API/Teams/Features/Get.hs | 2 +- services/galley/src/Galley/API/Update.hs | 8 +- .../galley/src/Galley/Cassandra/Client.hs | 2 +- services/galley/src/Galley/Effects.hs | 2 +- services/galley/src/Galley/Env.hs | 4 +- services/galley/test/integration/API.hs | 2 +- .../galley/test/integration/Federation.hs | 2 +- .../test/unit/Test/Galley/API/One2One.hs | 2 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 48 files changed, 298 insertions(+), 388 deletions(-) rename {services/galley => libs/galley-types}/src/Galley/Types/Clients.hs (100%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Create.hs (93%) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/One2One.hs (98%) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Types.hs rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Util.hs (98%) rename {services/galley/src/Galley => libs/wire-subsystems/src/Wire}/Effects/ClientStore.hs (97%) delete mode 100644 services/galley/src/Galley/API/Mapping.hs diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 249cb27489e..f17b6cc285f 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -14,6 +14,7 @@ library -- cabal-fmt: expand src exposed-modules: Galley.Types + Galley.Types.Clients Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles Galley.Types.Error diff --git a/services/galley/src/Galley/Types/Clients.hs b/libs/galley-types/src/Galley/Types/Clients.hs similarity index 100% rename from services/galley/src/Galley/Types/Clients.hs rename to libs/galley-types/src/Galley/Types/Clients.hs diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 6177db2ef4e..65e91eeaf37 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -23,6 +23,7 @@ module Galley.Types.Teams ( GetFeatureDefaults (..), FeatureDefaults (..), FeatureFlags, + FanoutLimit, featureDefaults, notTeamMember, findTeamMember, @@ -40,6 +41,7 @@ import Data.ByteString (toStrict) import Data.ByteString.UTF8 qualified as UTF8 import Data.Default import Data.Id (UserId) +import Data.Range (Range) import Data.SOP import Data.Set qualified as Set import Imports @@ -47,6 +49,8 @@ import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.API.Team.Permission +type FanoutLimit = Range 1 HardTruncationLimit Int32 + -- | Used to extract the feature config type out of 'FeatureDefaults' or -- related types. type family ConfigOf a diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 80ae80db1b4..65ee2f97a61 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -1289,7 +1289,7 @@ type ClientAPI = -- - MemberJoin event to self and other, if joining an existing connect conversation (via galley) -- - ConvCreate event to self, if creating a connect conversation (via galley) -- - ConvConnect event to self, in some cases (via galley), --- for details see 'Galley.API.Create.createConnectConversation' +-- for details see 'Wire.ConversationSubsystem.Create.createConnectConversation' type ConnectionAPI = Named "create-connection-unqualified" diff --git a/services/galley/src/Galley/API/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs similarity index 93% rename from services/galley/src/Galley/API/Create.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs index f69f41e9923..f3b01f05a98 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -22,7 +22,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Create +module Wire.ConversationSubsystem.Create ( createGroupConversationUpToV3, createGroupOwnConversation, createProteusSelfConversation, @@ -42,17 +42,9 @@ import Data.Qualified import Data.Range import Data.Set qualified as Set import Data.UUID.Tagged qualified as U -import Galley.API.Action -import Galley.API.MLS -import Galley.API.Mapping -import Galley.API.One2One -import Galley.API.Util -import Galley.App (Env) -import Galley.Effects -import Galley.Options +import GHC.TypeNats import Galley.Types.Error import Galley.Types.Teams (notTeamMember) -import Galley.Validation import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -80,17 +72,26 @@ import Wire.API.Team.Member import Wire.API.Team.Permission hiding (self) import Wire.API.User import Wire.BrigAPIAccess +import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Federation +import Wire.ConversationSubsystem.One2One +import Wire.ConversationSubsystem.Types +import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now +import Wire.Sem.Random (Random) import Wire.Sem.Random qualified as Random import Wire.StoredConversation hiding (convTeam, localOne2OneConvId) 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 qualified as TeamSubsystem @@ -118,8 +119,6 @@ createGroupConversationUpToV3 :: Member (ErrorS NotAnMlsConversation) r, Member (Error UnreachableBackendsLegacy) r, Member NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, Member Now r, Member LegalHoldStore r, Member TeamStore r, @@ -161,8 +160,6 @@ createGroupOwnConversation :: Member (Error UnreachableBackends) r, Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, Member (Input ConversationSubsystemConfig) r, Member Now r, Member LegalHoldStore r, @@ -209,8 +206,6 @@ createGroupConversation :: Member (Error UnreachableBackends) r, Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, Member (Input ConversationSubsystemConfig) r, Member Now r, Member LegalHoldStore r, @@ -238,9 +233,7 @@ createGroupConversation lusr conn newConv = do ) createGroupConvAndMkResponse :: - ( Member (Input Opts) r, - Member (Input Env) r, - Member Now r, + ( Member Now r, Member (ErrorS OperationDenied) r, Member (ErrorS ConvAccessDenied) r, Member (ErrorS NotATeamMember) r, @@ -297,8 +290,6 @@ createGroupConversationGeneric :: Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, Member NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, Member (Input ConversationSubsystemConfig) r, Member Now r, Member LegalHoldStore r, @@ -753,21 +744,21 @@ newRegularConversation :: ( Member (ErrorS 'MLSNonEmptyMemberList) r, Member (ErrorS OperationDenied) r, Member (Error InvalidInput) r, - Member (Input Opts) r, + Member (Input ConversationSubsystemConfig) r, Member ConversationStore r ) => Local UserId -> NewConv -> Sem r (NewConversation, ConvSizeChecked UserList UserId) newRegularConversation lusr newConv = do - o <- input + cfg <- input let uncheckedUsers = newConvMembers lusr newConv forM_ newConv.newConvParent $ \parent -> do mMembership <- E.getLocalMember parent (tUnqualified lusr) when (isNothing mMembership) $ throwS @OperationDenied users <- case newConvProtocol newConv of - BaseProtocolProteusTag -> checkedConvSize o uncheckedUsers + BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers BaseProtocolMLSTag -> do unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList pure mempty @@ -856,3 +847,46 @@ newOne2OneConvMembers loc body = ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a ensureOne [x] = pure x ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") + +-------------------------------------------------------------------------------- +-- Validation and MLS Helpers + +assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () +assertMLSEnabled = do + cfg <- input + when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled + +-- Between 0 and (setMaxConvSize - 1) +newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} + deriving (Functor, Foldable, Traversable) + +deriving newtype instance (Semigroup (f a)) => Semigroup (ConvSizeChecked f a) + +deriving newtype instance (Monoid (f a)) => Monoid (ConvSizeChecked f a) + +checkedConvSize :: + (Member (Error InvalidInput) r, Foldable f) => + ConversationSubsystemConfig -> + f a -> + Sem r (ConvSizeChecked f a) +checkedConvSize cfg x = do + let minV :: Integer = 0 + limit = cfg.maxConvSize - 1 + if length x <= fromIntegral limit + then pure (ConvSizeChecked x) + else throwErr (errorMsg minV limit "") + +rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) +rangeChecked = either throwErr pure . checkedEither +{-# INLINE rangeChecked #-} + +rangeCheckedMaybe :: + (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => + Maybe a -> + Sem r (Maybe (Range n m a)) +rangeCheckedMaybe Nothing = pure Nothing +rangeCheckedMaybe (Just a) = Just <$> rangeChecked a +{-# INLINE rangeCheckedMaybe #-} + +throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a +throwErr = throw . InvalidRange . fromString diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs new file mode 100644 index 00000000000..ec073a3c62f --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConversationSubsystem.Federation where + +import Control.Error (headMay) +import Data.Domain (Domain) +import Data.Qualified +import Data.Set qualified as Set +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Wire.API.Component (Component (..)) +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Error.Galley (NonFederatingBackends (..), UnreachableBackends (..)) +import Wire.API.Federation.API (fedClient) +import Wire.API.Federation.API.Brig (DomainSet (..), NonConnectedBackends (..)) +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.FederationStatus +import Wire.ConversationSubsystem.Types +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationAPIAccess qualified as E + +enforceFederationProtocol :: + ( Member (Error FederationError) r, + Member (Input ConversationSubsystemConfig) r + ) => + ProtocolTag -> + [Remote ()] -> + Sem r () +enforceFederationProtocol proto domains = do + unless (null domains) $ do + mAllowedProtos <- federationProtocols <$> input + unless (maybe True (elem proto) mAllowedProtos) $ + throw FederationDisabledForProtocol + +checkFederationStatus :: + ( Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member (FederationAPIAccess FederatorClient) r + ) => + RemoteDomains -> + Sem r () +checkFederationStatus req = do + status <- getFederationStatus req + case status of + FullyConnected -> pure () + NotConnectedDomains dom1 dom2 -> throw (NonFederatingBackends dom1 dom2) + +getFederationStatus :: + ( Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r + ) => + RemoteDomains -> + Sem r FederationStatus +getFederationStatus req = do + fmap firstConflictOrFullyConnected + . (ensureNoUnreachableBackends =<<) + $ E.runFederatedConcurrentlyEither + (Set.toList req.rdDomains) + ( \qds -> + fedClient @'Brig @"get-not-fully-connected-backends" + (DomainSet . Set.map tDomain $ void qds `Set.delete` req.rdDomains) + ) + +-- | "conflict" here means two remote domains that we are connected to +-- but are not connected to each other. +firstConflictOrFullyConnected :: [Remote NonConnectedBackends] -> FederationStatus +firstConflictOrFullyConnected = + maybe + FullyConnected + (uncurry NotConnectedDomains) + . headMay + . mapMaybe toMaybeConflict + where + toMaybeConflict :: Remote NonConnectedBackends -> Maybe (Domain, Domain) + toMaybeConflict r = + headMay (Set.toList (nonConnectedBackends (tUnqualified r))) <&> (tDomain r,) + +ensureNoUnreachableBackends :: + (Member (Error UnreachableBackends) r) => + [Either (Remote e, b) a] -> + Sem r [a] +ensureNoUnreachableBackends results = do + let (errors, values) = partitionEithers results + unless (null errors) $ + throw (UnreachableBackends (map (tDomain . fst) errors)) + pure values diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 2b364a6b184..b66ba8bf678 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -29,7 +29,19 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem.Interpreter where +module Wire.ConversationSubsystem.Interpreter + ( module X, + interpretConversationSubsystem, + createConversationImpl, + sendCellsNotification, + notifyConversationActionImpl, + pushConversationEvent, + toConversationCreated, + fromConversationCreated, + registerRemoteConversationMemberships, + notifyCreatedConversation, + ) +where import Data.Bifunctor (second) import Data.Default @@ -44,8 +56,8 @@ import Data.Singletons (Sing, sing) import Data.Text qualified as T import Data.Text.Lazy qualified as LT import Data.Time (UTCTime) +import Galley.Types.Error (InternalError) import Galley.Types.Error qualified as GalleyError -import Galley.Types.Teams (FeatureDefaults) import Imports import Network.AMQP qualified as Q import Polysemy @@ -57,7 +69,7 @@ import Wire.API.Component (Component (Brig, Galley)) import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action import Wire.API.Conversation.CellsState -import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus), ProtocolTag) +import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus)) import Wire.API.Conversation.Role import Wire.API.Error.Galley import Wire.API.Event.Conversation @@ -66,14 +78,14 @@ import Wire.API.Federation.API.Galley (ConversationCreated (..), ccRemoteOrigUse import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error -import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Push.V2 qualified as PushV2 -import Wire.API.Team.Feature import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently, enqueueNotificationsConcurrentlyBuckets) import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.View (ViewError, conversationViewWithCachedOthers) +import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) +import Wire.ConversationSubsystem.Types as X +import Wire.ConversationSubsystem.View (conversationViewWithCachedOthers) import Wire.ExternalAccess (ExternalAccess, deliverAsync) import Wire.FederationAPIAccess (FederationAPIAccess, runFederatedConcurrentlyEither) import Wire.FederationAPIAccess qualified as E @@ -84,13 +96,6 @@ import Wire.StoredConversation hiding (convTeam, id_, localOne2OneConvId) import Wire.StoredConversation as Data (LocalMember (..), NewConversation (..), RemoteMember (..), convType) import Wire.StoredConversation qualified as Data -data ConversationSubsystemConfig = ConversationSubsystemConfig - { mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), - federationProtocols :: Maybe [ProtocolTag], - legalholdDefaults :: FeatureDefaults LegalholdConfig, - maxConvSize :: Word16 - } - interpretConversationSubsystem :: ( Member (Error FederationError) r, Member (Error GalleyError.InternalError) r, @@ -109,16 +114,16 @@ interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData CreateConversation lconv lusr newConv -> do - res <- runError @UnreachableBackends $ runError @ViewError $ createConversationImpl lconv lusr newConv + res <- runError @UnreachableBackends $ runError @InternalError $ createConversationImpl lconv lusr newConv case res of Left (unreachable :: UnreachableBackends) -> throw $ FederationUnexpectedError (T.pack $ show unreachable) - Right (Left (viewErr :: ViewError)) -> throw $ GalleyError.InternalErrorWithDescription (LT.pack $ show viewErr) + Right (Left (err :: InternalError)) -> throw err Right (Right val') -> pure val' createConversationImpl :: ( Member (Error FederationError) r, Member (Error UnreachableBackends) r, - Member (Error ViewError) r, + Member (Error InternalError) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member Now r, @@ -313,16 +318,6 @@ fromConversationCreated loc rc@ConversationCreated {..} = (Public.OwnConvMembers this others) ProtocolProteus -ensureNoUnreachableBackends :: - (Member (Error UnreachableBackends) r) => - [Either (Remote e, b) a] -> - Sem r [a] -ensureNoUnreachableBackends results = do - let (errors, values) = partitionEithers results - unless (null errors) $ - throw (UnreachableBackends (map (tDomain . fst) errors)) - pure values - registerRemoteConversationMemberships :: ( Member ConvStore.ConversationStore r, Member (Error UnreachableBackends) r, @@ -420,7 +415,7 @@ registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable notifyCreatedConversation :: ( Member ConvStore.ConversationStore r, Member (Error FederationError) r, - Member (Error ViewError) r, + Member (Error InternalError) r, Member (Error UnreachableBackends) r, Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs index 831fb213e0e..cf4837fb6b8 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs @@ -16,6 +16,7 @@ import Data.Qualified import Data.Set qualified as Set import Data.Singletons import Data.Time +import Galley.Types.Error (InternalError) import Imports import Network.AMQP qualified as Q import Polysemy @@ -36,6 +37,7 @@ import Wire.API.Federation.Error import Wire.API.Push.V2 qualified as PushV2 import Wire.BackendNotificationQueueAccess import Wire.ConversationStore +import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) import Wire.ConversationSubsystem.View import Wire.FederationAPIAccess import Wire.FederationAPIAccess qualified as E @@ -121,16 +123,6 @@ fromConversationCreated loc rc@ConversationCreated {..} = (OwnConvMembers this others) ProtocolProteus -ensureNoUnreachableBackends :: - (Member (Error UnreachableBackends) r) => - [Either (Remote e, b) a] -> - Sem r [a] -ensureNoUnreachableBackends results = do - let (errors, values) = partitionEithers results - unless (null errors) $ - throw (UnreachableBackends (map (tDomain . fst) errors)) - pure values - registerRemoteConversationMemberships :: ( Member ConversationStore r, Member (Error UnreachableBackends) r, @@ -222,7 +214,7 @@ registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable notifyCreatedConversation :: ( Member ConversationStore r, Member (Error FederationError) r, - Member (Error ViewError) r, + Member (Error InternalError) r, Member (Error UnreachableBackends) r, Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, diff --git a/services/galley/src/Galley/API/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs similarity index 98% rename from services/galley/src/Galley/API/One2One.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs index acbd3c17f2e..afe039381b8 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.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.One2One +module Wire.ConversationSubsystem.One2One ( one2OneConvId, iUpsertOne2OneConversation, ) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Types.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Types.hs new file mode 100644 index 00000000000..b37ba673093 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Types.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConversationSubsystem.Types where + +import Galley.Types.Teams (FeatureDefaults) +import Imports +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) +import Wire.API.Team.Feature (LegalholdConfig) + +data ConversationSubsystemConfig = ConversationSubsystemConfig + { mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), + federationProtocols :: Maybe [ProtocolTag], + legalholdDefaults :: FeatureDefaults LegalholdConfig, + maxConvSize :: Word16 + } diff --git a/services/galley/src/Galley/API/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs similarity index 98% rename from services/galley/src/Galley/API/Util.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index beabe54bb34..63370a7223e 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.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.Util where +module Wire.ConversationSubsystem.Util where import Control.Lens (view, (^.)) import Control.Monad.Extra (allM, anyM) @@ -40,11 +40,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Text qualified as T import Data.Time -import Galley.API.Mapping -import Galley.Effects -import Galley.Effects.ClientStore -import Galley.Env -import Galley.Options () import Galley.Types.Clients (Clients, fromUserClients) import Galley.Types.Conversations.Roles import Galley.Types.Error @@ -88,7 +83,10 @@ import Wire.BrigAPIAccess import Wire.CodeStore import Wire.CodeStore.Code as DataTypes import Wire.ConversationStore -import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..)) +import Wire.ConversationSubsystem.Federation +import Wire.ConversationSubsystem.Types +import Wire.ConversationSubsystem.View +import Wire.Effects.ClientStore import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.HashPassword (HashPassword) @@ -903,16 +901,6 @@ fromConversationCreated loc rc@ConversationCreated {..} = (OwnConvMembers this others) ProtocolProteus -ensureNoUnreachableBackends :: - (Member (Error UnreachableBackends) r) => - [Either (Remote e, b) a] -> - Sem r [a] -ensureNoUnreachableBackends results = do - let (errors, values) = partitionEithers results - unless (null errors) $ - throw (UnreachableBackends (map (tDomain . fst) errors)) - pure values - -- | Notify remote users of being added to a new conversation. registerRemoteConversationMemberships :: ( Member ConversationStore r, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs index 9141e495535..e6a71cf0d95 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -3,6 +3,7 @@ module Wire.ConversationSubsystem.View 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 @@ -13,11 +14,8 @@ import Wire.API.Conversation qualified as Conversation import Wire.API.Federation.API.Galley import Wire.StoredConversation -data ViewError = BadMemberState - deriving (Show, Eq) - conversationViewV9 :: - ( Member (Error ViewError) r, + ( Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -47,7 +45,7 @@ conversationView l luid conv = } conversationViewWithCachedOthers :: - ( Member (Error ViewError) r, + ( Member (Error InternalError) r, Member P.TinyLog r ) => [OtherMember] -> diff --git a/services/galley/src/Galley/Effects/ClientStore.hs b/libs/wire-subsystems/src/Wire/Effects/ClientStore.hs similarity index 97% rename from services/galley/src/Galley/Effects/ClientStore.hs rename to libs/wire-subsystems/src/Wire/Effects/ClientStore.hs index 4697dc12b12..d38a67b9c04 100644 --- a/services/galley/src/Galley/Effects/ClientStore.hs +++ b/libs/wire-subsystems/src/Wire/Effects/ClientStore.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.Effects.ClientStore +module Wire.Effects.ClientStore ( -- * ClientStore Effect ClientStore (..), diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index c69927a38e6..80cfd1d87e9 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -243,8 +243,13 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem + Wire.ConversationSubsystem.Create + Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Interpreter Wire.ConversationSubsystem.Notification + Wire.ConversationSubsystem.One2One + Wire.ConversationSubsystem.Types + Wire.ConversationSubsystem.Util Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory @@ -252,6 +257,7 @@ library Wire.DomainRegistrationStore.Cassandra Wire.DomainVerificationChallengeStore Wire.DomainVerificationChallengeStore.Cassandra + Wire.Effects.ClientStore Wire.EmailSending Wire.EmailSending.SES Wire.EmailSending.SMTP diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index d0368962072..2cc16a9bac6 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -439,7 +439,7 @@ toApsData _ = Nothing ------------------------------------------------------------------------------- -- Conversation Management --- | Calls 'Galley.API.Create.createConnectConversation'. +-- | Calls 'Wire.ConversationSubsystem.Create.createConnectConversation'. createLocalConnectConv :: ( Member (Embed HttpClientIO) r, Member TinyLog r diff --git a/services/galley/default.nix b/services/galley/default.nix index d6684de242c..dde0afe0b97 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -190,7 +190,6 @@ mkDerivation { text time tinylog - transformers types-common types-common-aws unliftio diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 4fdb78797f9..d558569b23b 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -79,7 +79,6 @@ library Galley.API.Action.Notify Galley.API.Action.Reset Galley.API.Clients - Galley.API.Create Galley.API.CustomBackend Galley.API.Federation Galley.API.Internal @@ -87,7 +86,6 @@ library Galley.API.LegalHold.Conflicts Galley.API.LegalHold.Get Galley.API.LegalHold.Team - Galley.API.Mapping Galley.API.Message Galley.API.MLS Galley.API.MLS.CheckClients @@ -112,7 +110,6 @@ library Galley.API.MLS.SubConversation Galley.API.MLS.Util Galley.API.MLS.Welcome - Galley.API.One2One Galley.API.Public.Bot Galley.API.Public.Conversation Galley.API.Public.CustomBackend @@ -133,7 +130,6 @@ library Galley.API.Teams.Features.Get Galley.API.Teams.Notifications Galley.API.Update - Galley.API.Util Galley.App Galley.Cassandra Galley.Cassandra.Client @@ -146,7 +142,6 @@ library Galley.Cassandra.Util Galley.Data.TeamNotifications Galley.Effects - Galley.Effects.ClientStore Galley.Effects.CustomBackendStore Galley.Effects.Queue Galley.Effects.SearchVisibilityStore @@ -244,7 +239,6 @@ library Galley.Schema.V97_CellsConversation Galley.Schema.V98_ChannelAddPermission Galley.Schema.V99_ConversationAddParent - Galley.Types.Clients Galley.Validation ghc-options: -fplugin=Polysemy.Plugin @@ -312,7 +306,6 @@ library , text >=0.11 , time >=1.4 , tinylog >=0.10 - , transformers , types-common >=0.16 , types-common-aws , unliftio >=0.2 diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index e65841a77ec..6707774641a 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -46,11 +46,9 @@ module Galley.API.Action where import Control.Arrow ((&&&)) -import Control.Error (headMay) import Control.Lens import Data.ByteString.Conversion (toByteString') import Data.Default -import Data.Domain (Domain (..)) import Data.Id import Data.Json.Util import Data.Kind @@ -73,7 +71,6 @@ import Galley.API.MLS.Conversation import Galley.API.MLS.Migration import Galley.API.MLS.Removal import Galley.API.Teams.Features.Get -import Galley.API.Util import Galley.Effects import Galley.Env (Env) import Galley.Options (Opts) @@ -98,7 +95,6 @@ import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API -import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as F import Wire.API.Federation.Client (FederatorClient) @@ -117,7 +113,9 @@ import Wire.CodeStore import Wire.CodeStore qualified as E import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Federation import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..)) +import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess qualified as E import Wire.FireAndForget qualified as E @@ -367,62 +365,6 @@ type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) :: ErrorS ConvNotFound ] -enforceFederationProtocol :: - ( Member (Error FederationError) r, - Member (Input ConversationSubsystemConfig) r - ) => - ProtocolTag -> - [Remote ()] -> - Sem r () -enforceFederationProtocol proto domains = do - unless (null domains) $ do - mAllowedProtos <- federationProtocols <$> input - unless (maybe True (elem proto) mAllowedProtos) $ - throw FederationDisabledForProtocol - -checkFederationStatus :: - ( Member (Error UnreachableBackends) r, - Member (Error NonFederatingBackends) r, - Member (FederationAPIAccess FederatorClient) r - ) => - RemoteDomains -> - Sem r () -checkFederationStatus req = do - status <- getFederationStatus req - case status of - FullyConnected -> pure () - NotConnectedDomains dom1 dom2 -> throw (NonFederatingBackends dom1 dom2) - -getFederationStatus :: - ( Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r - ) => - RemoteDomains -> - Sem r FederationStatus -getFederationStatus req = do - fmap firstConflictOrFullyConnected - . (ensureNoUnreachableBackends =<<) - $ E.runFederatedConcurrentlyEither - (Set.toList req.rdDomains) - ( \qds -> - fedClient @'Brig @"get-not-fully-connected-backends" - (DomainSet . Set.map tDomain $ void qds `Set.delete` req.rdDomains) - ) - --- | "conflict" here means two remote domains that we are connected to --- but are not connected to each other. -firstConflictOrFullyConnected :: [Remote NonConnectedBackends] -> FederationStatus -firstConflictOrFullyConnected = - maybe - FullyConnected - (uncurry NotConnectedDomains) - . headMay - . mapMaybe toMaybeConflict - where - toMaybeConflict :: Remote NonConnectedBackends -> Maybe (Domain, Domain) - toMaybeConflict r = - headMay (Set.toList (nonConnectedBackends (tUnqualified r))) <&> (tDomain r,) - noChanges :: (Member (Error NoChanges) r) => Sem r a noChanges = throw NoChanges diff --git a/services/galley/src/Galley/API/Action/Kick.hs b/services/galley/src/Galley/API/Action/Kick.hs index 4224dfe4a02..520a6dfb493 100644 --- a/services/galley/src/Galley/API/Action/Kick.hs +++ b/services/galley/src/Galley/API/Action/Kick.hs @@ -23,7 +23,6 @@ import Data.Qualified import Data.Singletons import Galley.API.Action.Leave import Galley.API.Action.Notify -import Galley.API.Util import Galley.Effects import Imports hiding ((\\)) import Polysemy @@ -36,6 +35,7 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.Error import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.NotificationSubsystem import Wire.Sem.Now (Now) import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/Action/Leave.hs b/services/galley/src/Galley/API/Action/Leave.hs index 8d717b9cccf..7d8f83cf2a0 100644 --- a/services/galley/src/Galley/API/Action/Leave.hs +++ b/services/galley/src/Galley/API/Action/Leave.hs @@ -21,7 +21,6 @@ import Control.Lens import Data.Id import Data.Qualified import Galley.API.MLS.Removal -import Galley.API.Util import Galley.Effects import Imports hiding ((\\)) import Polysemy @@ -30,6 +29,7 @@ import Polysemy.Input import Polysemy.TinyLog import Wire.API.Federation.Error import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.NotificationSubsystem import Wire.Sem.Now (Now) import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/Action/Notify.hs b/services/galley/src/Galley/API/Action/Notify.hs index 2e65778f8bf..6ede2e2cc22 100644 --- a/services/galley/src/Galley/API/Action/Notify.hs +++ b/services/galley/src/Galley/API/Action/Notify.hs @@ -20,7 +20,6 @@ module Galley.API.Action.Notify where import Data.Id import Data.Qualified import Data.Singletons -import Galley.API.Util import Galley.Effects import Imports hiding ((\\)) import Polysemy @@ -28,6 +27,7 @@ import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Event.Conversation import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Util import Wire.NotificationSubsystem import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/Action/Reset.hs b/services/galley/src/Galley/API/Action/Reset.hs index b483f293044..fd95b0cc16a 100644 --- a/services/galley/src/Galley/API/Action/Reset.hs +++ b/services/galley/src/Galley/API/Action/Reset.hs @@ -24,7 +24,6 @@ import Data.Id import Data.Qualified import Galley.API.Action.Kick import Galley.API.MLS.Util -import Galley.API.Util import Galley.Effects import Imports import Polysemy @@ -49,6 +48,7 @@ import Wire.API.VersionInfo import Wire.ConversationStore import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.FederationAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Now (Now) diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index e260c25e5d0..2a402c0f40b 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -27,9 +27,7 @@ import Data.Qualified import Data.Range import Galley.API.MLS.Removal import Galley.API.Query qualified as Query -import Galley.API.Util import Galley.Effects -import Galley.Effects.ClientStore qualified as E import Galley.Env import Galley.Types.Clients (clientIds) import Galley.Types.Error @@ -48,6 +46,8 @@ import Wire.API.Routes.MultiTablePaging import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (getConversation) import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util +import Wire.Effects.ClientStore qualified as E import Wire.NotificationSubsystem import Wire.Sem.Now (Now) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f476a7ff6ee..b47da28fcb6 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -46,11 +46,8 @@ 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.API.Push -import Galley.API.Util import Galley.App import Galley.Effects import Galley.Options @@ -97,6 +94,9 @@ import Wire.CodeStore import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View +import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FireAndForget qualified as E import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 9a21fd3c3f2..9e090d3e5e2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,11 +38,9 @@ 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.One2One import Galley.API.Public.Servant import Galley.API.Query qualified as Query import Galley.API.Teams @@ -50,16 +48,14 @@ 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.API.Util import Galley.App import Galley.Effects -import Galley.Effects.ClientStore import Galley.Effects.CustomBackendStore -import Galley.Env (FanoutLimit) import Galley.Monad import Galley.Options hiding (brig) import Galley.Queue qualified as Q import Galley.Types.Error +import Galley.Types.Teams (FanoutLimit) import Imports hiding (head) import Network.AMQP qualified as Q import Polysemy @@ -93,7 +89,11 @@ import Wire.ConversationStore import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.One2One +import Wire.ConversationSubsystem.Util +import Wire.Effects.ClientStore import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) import Wire.LegalHoldStore as LegalHoldStore import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 9007a8c8111..60ffdfb2041 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -45,7 +45,6 @@ import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) -import Galley.API.Util import Galley.App import Galley.Effects import Galley.Effects.TeamMemberStore @@ -80,6 +79,7 @@ import Wire.BrigAPIAccess import Wire.ConversationStore import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.FireAndForget import Wire.LegalHoldStore qualified as LegalHoldData import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 705d3b2f28a..59eea597008 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -33,7 +33,6 @@ import Data.Map qualified as Map import Data.Misc import Data.Qualified import Data.Set qualified as Set -import Galley.API.Util import Galley.Effects import Galley.Options import Galley.Types.Teams @@ -49,6 +48,7 @@ import Wire.API.Team.Member import Wire.API.User import Wire.API.User.Client as Client import Wire.BrigAPIAccess +import Wire.ConversationSubsystem.Util import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index 977fcfb2918..aaaacd6296e 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -27,8 +27,7 @@ where import Data.Id import Data.Range import Galley.Effects -import Galley.Env -import Galley.Types.Teams as Team +import Galley.Types.Teams as Team (FanoutLimit, FeatureDefaults (..)) import Imports import Polysemy import Polysemy.Input (Input, input) diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index e5d234ac33d..06d8270ac78 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -37,7 +37,6 @@ import Galley.API.MLS.IncomingMessage import Galley.API.MLS.One2One import Galley.API.MLS.Proposal import Galley.API.MLS.Util -import Galley.API.Util import Galley.Effects import Galley.Types.Error import Imports @@ -62,6 +61,7 @@ import Wire.ConversationStore import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.ProposalStore import Wire.StoredConversation import Wire.TeamSubsystem (TeamSubsystem) diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/services/galley/src/Galley/API/MLS/GroupInfo.hs index a10870a306e..f09a21db861 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/services/galley/src/Galley/API/MLS/GroupInfo.hs @@ -22,7 +22,6 @@ import Data.Json.Util import Data.Qualified import Galley.API.MLS.Enabled import Galley.API.MLS.Util -import Galley.API.Util import Galley.Effects import Galley.Env import Imports @@ -38,6 +37,7 @@ import Wire.API.Federation.Error import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem.Util import Wire.FederationAPIAccess qualified as E type MLSGroupInfoStaticErrors = diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index aeef15f5a48..074e6d4d9c3 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -55,7 +55,6 @@ import Galley.API.MLS.Propagate import Galley.API.MLS.Proposal import Galley.API.MLS.Util import Galley.API.MLS.Welcome (sendWelcomes) -import Galley.API.Util import Galley.Effects import Galley.Types.Error import Imports @@ -89,6 +88,7 @@ import Wire.ConversationStore import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index e7c3704a482..302a962338d 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -39,7 +39,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Galley.API.MLS.IncomingMessage -import Galley.API.Util import Galley.Effects import Galley.Env import Galley.Options @@ -69,6 +68,7 @@ import Wire.API.MLS.Validation.Error (toText) import Wire.API.Message import Wire.BrigAPIAccess import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.Util import Wire.NotificationSubsystem import Wire.ProposalStore import Wire.Sem.Now (Now) diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 8d45dfc410c..c066a009af2 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -40,7 +40,6 @@ import Galley.API.MLS.Conversation import Galley.API.MLS.GroupInfo import Galley.API.MLS.Removal import Galley.API.MLS.Util -import Galley.API.Util import Galley.App (Env) import Galley.Effects import Imports @@ -66,6 +65,7 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.ConversationStore qualified as Eff import Wire.ConversationStore.MLS.Types as Eff import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.FederationAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Now (Now) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs deleted file mode 100644 index d4b66ede388..00000000000 --- a/services/galley/src/Galley/API/Mapping.hs +++ /dev/null @@ -1,182 +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.Mapping - ( conversationViewV9, - conversationView, - conversationViewWithCachedOthers, - remoteConversationView, - conversationToRemote, - localMemberToSelf, - ) -where - -import Data.Domain (Domain) -import Data.Id (UserId, idToText) -import Data.Qualified -import Galley.Types.Error -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.Conversation qualified as Conversation -import Wire.API.Federation.API.Galley -import Wire.StoredConversation - --- | View for a given user of a stored conversation. --- --- Throws @BadMemberState@ when the user is not part of the conversation. -conversationViewV9 :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r OwnConversation -conversationViewV9 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 = localMemberToSelf 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 <- localMemberToSelf 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 RemoteConversationV2 -> - OwnConversation -remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = - let mems = rconv.members - others = mems.others - self = - localMemberToSelf - 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 RemoteConversationV2 -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 $ - RemoteConversationV2 - { id = conv.id_, - metadata = conv.metadata, - members = - RemoteConvMembers - { selfRole = selfRole', - others = others' - }, - protocol = conv.protocol - } - --- | Convert a local conversation member (as stored in the DB) to a publicly --- facing 'Member' structure. -localMemberToSelf :: Local x -> LocalMember -> Conversation.Member -localMemberToSelf loc lm = - Conversation.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 diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 6ca08e514d0..4fd9135e4ca 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -51,12 +51,10 @@ import Data.Set.Lens import Data.Time.Clock (UTCTime) import Galley.API.LegalHold.Conflicts import Galley.API.Push -import Galley.API.Util import Galley.Effects -import Galley.Effects.ClientStore -import Galley.Env import Galley.Options import Galley.Types.Clients qualified as Clients +import Galley.Types.Teams (FanoutLimit) import Imports hiding (forkIO) import Network.AMQP qualified as Q import Polysemy hiding (send) @@ -82,6 +80,8 @@ import Wire.API.UserMap (UserMap (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore +import Wire.ConversationSubsystem.Util +import Wire.Effects.ClientStore import Wire.FederationAPIAccess import Wire.NotificationSubsystem (NotificationSubsystem) import Wire.Sem.Now (Now) diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 724dd81c240..aa05d3bc25a 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -17,7 +17,6 @@ module Galley.API.Public.Conversation where -import Galley.API.Create import Galley.API.MLS.GroupInfo import Galley.API.MLS.SubConversation import Galley.API.Query @@ -27,6 +26,7 @@ import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.Create conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 4595cb9ee00..94ecae59804 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -69,11 +69,7 @@ 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.One2One import Galley.API.Teams.Features.Get -import Galley.API.Util import Galley.Effects import Galley.Env import Galley.Types.Error @@ -110,6 +106,10 @@ import Wire.CodeStore.Code (Code (codeConversation)) import Wire.CodeStore.Code qualified as Data import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.One2One +import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View +import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess qualified as E import Wire.HashPassword (HashPassword) @@ -788,6 +788,7 @@ getMLSOne2OneConversationV5 lself qother = do else throwS @MLSFederatedOne2OneNotSupported getMLSOne2OneConversationInternal :: + forall r. ( Member BrigAPIAccess r, Member ConversationStore r, Member (Input Env) r, @@ -808,6 +809,7 @@ getMLSOne2OneConversationInternal lself qother = (.conversation) <$> getMLSOne2OneConversation lself qother Nothing getMLSOne2OneConversationV6 :: + forall r. ( Member BrigAPIAccess r, Member ConversationStore r, Member (Input Env) r, diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 22deafd2e01..35a1ea18cf8 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -81,13 +81,11 @@ 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.API.Util import Galley.App import Galley.Effects import Galley.Effects.Queue qualified as E import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData import Galley.Effects.TeamMemberStore qualified as E -import Galley.Env import Galley.Options import Galley.Types.Error as Galley import Galley.Types.Teams @@ -132,6 +130,7 @@ import Wire.CodeStore import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.ListItems qualified as E import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 349d6d56326..23e9c3016e7 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -44,11 +44,9 @@ 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.API.Util (assertTeamExists, getTeamMembersForFanout, permissionCheck) import Galley.App import Galley.Effects import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData -import Galley.Env (FanoutLimit) import Galley.Options import Galley.Types.Error (InternalError) import Galley.Types.Teams @@ -71,6 +69,7 @@ import Wire.CodeStore import Wire.ConversationStore (MLSCommitLockStore) import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util (assertTeamExists, getTeamMembersForFanout, permissionCheck) import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) import Wire.FeaturesConfigSubsystem.Types (GetFeatureConfigEffects) import Wire.FeaturesConfigSubsystem.Utils (resolveServerFeature) diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index ece1922543c..88892545f81 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -37,7 +37,6 @@ import Control.Error (hush) import Data.Id import Data.SOP import Data.Tagged -import Galley.API.Util import Galley.Effects import Imports import Polysemy @@ -48,6 +47,7 @@ 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.TeamFeatureStore diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index cbd948dd391..f0d8bb0826d 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,17 +91,14 @@ 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.API.Util import Galley.App import Galley.Effects -import Galley.Effects.ClientStore qualified as E -import Galley.Env import Galley.Options import Galley.Types.Error +import Galley.Types.Teams (FanoutLimit) import Imports hiding (forkIO) import Polysemy import Polysemy.Error @@ -138,6 +135,9 @@ import Wire.CodeStore.Code import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View +import Wire.Effects.ClientStore qualified as E import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess qualified as E diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs index bc37fece531..57f8f8f9025 100644 --- a/services/galley/src/Galley/Cassandra/Client.hs +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -29,7 +29,6 @@ import Data.List.Split (chunksOf) import Galley.Cassandra.Queries qualified as Cql import Galley.Cassandra.Store import Galley.Cassandra.Util -import Galley.Effects.ClientStore (ClientStore (..)) import Galley.Env import Galley.Monad import Galley.Options @@ -40,6 +39,7 @@ import Polysemy import Polysemy.Input import Polysemy.TinyLog import UnliftIO qualified +import Wire.Effects.ClientStore (ClientStore (..)) updateClient :: Bool -> UserId -> ClientId -> Client () updateClient add usr cls = do diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index af09983856f..a401fffb157 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -64,7 +64,6 @@ import Data.Map (Map) import Data.Misc (HttpsUrl) import Data.Qualified import Data.Text (Text) -import Galley.Effects.ClientStore import Galley.Effects.CustomBackendStore import Galley.Effects.Queue import Galley.Effects.SearchVisibilityStore @@ -86,6 +85,7 @@ import Wire.BrigAPIAccess import Wire.CodeStore import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationSubsystem +import Wire.Effects.ClientStore import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist) diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index f9b8400d930..1bc0c4e778d 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -29,6 +29,7 @@ import Data.Time.Clock.DiffTime (millisecondsToDiffTime) import Galley.Options import Galley.Options qualified as O import Galley.Queue qualified as Q +import Galley.Types.Teams (FanoutLimit) import HTTP2.Client.Manager (Http2Manager) import Hasql.Pool import Imports @@ -37,7 +38,6 @@ import Network.HTTP.Client import System.Logger import Util.Options import Wire.API.MLS.Keys -import Wire.API.Team.Member import Wire.AWS qualified as Aws import Wire.ExternalAccess.External import Wire.NotificationSubsystem.Interpreter @@ -46,8 +46,6 @@ import Wire.RateLimit.Interpreter (RateLimitEnv) data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) deriving (Eq, Ord, Show) -type FanoutLimit = Range 1 HardTruncationLimit Int32 - -- | Main application environment. data Env = Env { _reqId :: RequestId, diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 313f11f0f55..f527d520caf 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 Galley.Options (federator, rabbitmq) import Imports hiding (id) import Imports qualified as I @@ -105,6 +104,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.View import Wire.StoredConversation hiding (convName) tests :: IO TestSetup -> TestTree diff --git a/services/galley/test/integration/Federation.hs b/services/galley/test/integration/Federation.hs index 5b5a2cd69fe..281a8fca9cb 100644 --- a/services/galley/test/integration/Federation.hs +++ b/services/galley/test/integration/Federation.hs @@ -22,7 +22,6 @@ import Data.Domain import Data.Id import Data.Qualified import Data.UUID qualified as UUID -import Galley.API.Util import Galley.App import Galley.Options import Imports @@ -31,6 +30,7 @@ import TestSetup import Wire.API.Conversation import Wire.API.Conversation.Protocol (Protocol (..)) import Wire.API.Conversation.Role (roleNameWireMember) +import Wire.ConversationSubsystem.Util import Wire.StoredConversation isConvMemberLTests :: TestM () diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/services/galley/test/unit/Test/Galley/API/One2One.hs index 9a93da22743..88a0df0ff57 100644 --- a/services/galley/test/unit/Test/Galley/API/One2One.hs +++ b/services/galley/test/unit/Test/Galley/API/One2One.hs @@ -21,12 +21,12 @@ module Test.Galley.API.One2One where import Data.Id import Data.List.Extra import Data.Qualified -import Galley.API.One2One (one2OneConvId) import Imports import Test.Tasty import Test.Tasty.HUnit (Assertion, testCase, (@?=)) import Test.Tasty.QuickCheck import Wire.API.User +import Wire.ConversationSubsystem.One2One (one2OneConvId) tests :: TestTree tests = diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index b73a27c17b4..722f6525582 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,7 +25,6 @@ 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) @@ -41,6 +40,7 @@ import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), RemoteConversationV2 (..), ) +import Wire.ConversationSubsystem.View import Wire.Sem.Logger qualified as P import Wire.StoredConversation From 1f6359f2c0ce118e7b77a1654097a5f7af85daf4 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 26 Jan 2026 12:06:19 +0100 Subject: [PATCH 03/11] fix: try to fix incorrect notifications (3) --- .../src/Wire/ConversationSubsystem/Create.hs | 46 +++--------- .../Wire/ConversationSubsystem/Interpreter.hs | 3 +- services/galley/galley.cabal | 1 - services/galley/src/Galley/API/Action.hs | 4 +- services/galley/src/Galley/Validation.hs | 71 ------------------- 5 files changed, 12 insertions(+), 113 deletions(-) delete mode 100644 services/galley/src/Galley/Validation.hs diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs index f3b01f05a98..c49dba47a9d 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - -- 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 @@ -22,6 +21,8 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE DataKinds #-} + module Wire.ConversationSubsystem.Create ( createGroupConversationUpToV3, createGroupOwnConversation, @@ -35,8 +36,7 @@ where import Control.Error (headMay) import Control.Lens hiding ((??)) import Data.Default -import Data.Id -import Data.Json.Util +import Data.Id (ConnId, ConvId, Id (toUUID), TeamId, UserId) import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range @@ -60,7 +60,6 @@ import Wire.API.Event.Conversation import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.FederationStatus -import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Util import Wire.API.Team @@ -85,7 +84,6 @@ import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now import Wire.Sem.Random (Random) import Wire.Sem.Random qualified as Random import Wire.StoredConversation hiding (convTeam, localOne2OneConvId) @@ -95,7 +93,7 @@ import Wire.TeamStore (TeamStore) import Wire.TeamStore qualified as TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -import Wire.UserList +import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) ---------------------------------------------------------------------------- -- Group conversations @@ -118,8 +116,6 @@ createGroupConversationUpToV3 :: Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, Member (Error UnreachableBackendsLegacy) r, - Member NotificationSubsystem r, - Member Now r, Member LegalHoldStore r, Member TeamStore r, Member P.TinyLog r, @@ -159,9 +155,7 @@ createGroupOwnConversation :: Member (ErrorS NotAnMlsConversation) r, Member (Error UnreachableBackends) r, Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, Member (Input ConversationSubsystemConfig) r, - Member Now r, Member LegalHoldStore r, Member TeamStore r, Member P.TinyLog r, @@ -205,9 +199,7 @@ createGroupConversation :: Member (ErrorS NotAnMlsConversation) r, Member (Error UnreachableBackends) r, Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, Member (Input ConversationSubsystemConfig) r, - Member Now r, Member LegalHoldStore r, Member TeamStore r, Member FeaturesConfigSubsystem r, @@ -233,8 +225,7 @@ createGroupConversation lusr conn newConv = do ) createGroupConvAndMkResponse :: - ( Member Now r, - Member (ErrorS OperationDenied) r, + ( Member (ErrorS OperationDenied) r, Member (ErrorS ConvAccessDenied) r, Member (ErrorS NotATeamMember) r, Member (ErrorS NotConnected) r, @@ -252,7 +243,6 @@ createGroupConvAndMkResponse :: Member BrigAPIAccess r, Member ConversationStore r, Member ConversationSubsystem.ConversationSubsystem r, - Member NotificationSubsystem r, Member LegalHoldStore r, Member TeamStore r, Member FeaturesConfigSubsystem r, @@ -289,9 +279,7 @@ createGroupConversationGeneric :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, - Member NotificationSubsystem r, Member (Input ConversationSubsystemConfig) r, - Member Now r, Member LegalHoldStore r, Member TeamStore r, Member FeaturesConfigSubsystem r, @@ -303,7 +291,7 @@ createGroupConversationGeneric :: Maybe ConnId -> NewConv -> Sem r StoredConversation -createGroupConversationGeneric lusr conn newConv = do +createGroupConversationGeneric lusr _conn newConv = do (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers ensureNoLegalholdConflicts allUsers @@ -312,28 +300,10 @@ createGroupConversationGeneric lusr conn newConv = do -- Here we fail early in order to notify users of this misconfiguration assertMLSEnabled - lcnv <- traverse (const $ Id <$> Random.uuid) lusr + lcnv <- traverse (const Random.newId) lusr conv <- ConversationSubsystem.createConversation lcnv lusr nc - -- NOTE: We only send (conversation) events to members of the conversation - sendCellsNotification conv E.getConversation conv.id_ >>= note (BadConvState conv.id_) - where - sendCellsNotification :: StoredConversation -> Sem r () - sendCellsNotification conv = do - now <- Now.get - let lconv = qualifyAs lusr conv.id_ - event = CellsEvent (tUntagged lconv) (tUntagged lusr) now CellsConvCreateNoData - when (conv.metadata.cnvmCellsState /= CellsDisabled) $ do - let push = - def - { origin = Just (tUnqualified lusr), - json = toJSONObject event, - isCellsEvent = True, - route = PushV2.RouteAny, - conn - } - pushNotifications [push] ensureNoLegalholdConflicts :: ( Member (ErrorS 'MissingLegalholdConsent) r, @@ -659,7 +629,7 @@ createOne2OneConversationRemotely :: Maybe TeamId -> Qualified UserId -> Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationRemotely _ _ _ _ _ _ = +createOne2OneConversationRemotely _ _ _ _name _mtid _ = throw FederationNotImplemented createConnectConversation :: diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index b66ba8bf678..c0dce6fc8b4 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -138,7 +138,8 @@ createConversationImpl :: Sem r StoredConversation createConversationImpl lconv lusr newConv = do storedConv <- ConvStore.upsertConversation lconv newConv - notifyCreatedConversation lusr Nothing storedConv def + unless (Data.convType storedConv == Public.SelfConv) $ do + notifyCreatedConversation lusr Nothing storedConv def sendCellsNotification lusr Nothing storedConv pure storedConv diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index d558569b23b..eefbd7301cb 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -239,7 +239,6 @@ library Galley.Schema.V97_CellsConversation Galley.Schema.V98_ChannelAddPermission Galley.Schema.V99_ConversationAddParent - Galley.Validation ghc-options: -fplugin=Polysemy.Plugin other-modules: Paths_galley diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 6707774641a..4df091a4583 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -59,6 +59,7 @@ import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Misc import Data.Qualified +import Data.Range (checkedEither) import Data.Set ((\\)) import Data.Set qualified as Set import Data.Singletons @@ -75,7 +76,6 @@ import Galley.Effects import Galley.Env (Env) import Galley.Options (Opts) import Galley.Types.Error -import Galley.Validation import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -510,7 +510,7 @@ performAction tag origUser lconv action = do SConversationRenameTag -> do zusrMembership <- join <$> forM storedConv.metadata.cnvmTeam (TeamSubsystem.internalGetTeamMember (qUnqualified origUser)) for_ zusrMembership $ \tm -> unless (tm `hasPermission` ModifyConvName) $ throwS @'InvalidOperation - cn <- rangeChecked (cupName action) + cn <- either (throw . InvalidRange . fromString) pure $ checkedEither (cupName action) E.setConversationName (tUnqualified lcnv) cn pure $ mkPerformActionResult action SConversationMessageTimerUpdateTag -> do diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs deleted file mode 100644 index 6c43091116f..00000000000 --- a/services/galley/src/Galley/Validation.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- 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.Validation - ( rangeChecked, - rangeCheckedMaybe, - fromConvSize, - ConvSizeChecked, - checkedConvSize, - ) -where - -import Control.Lens -import Data.Range -import GHC.TypeNats -import Galley.Options -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error - -rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) -rangeChecked = either throwErr pure . checkedEither -{-# INLINE rangeChecked #-} - -rangeCheckedMaybe :: - (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => - Maybe a -> - Sem r (Maybe (Range n m a)) -rangeCheckedMaybe Nothing = pure Nothing -rangeCheckedMaybe (Just a) = Just <$> rangeChecked a -{-# INLINE rangeCheckedMaybe #-} - --- Between 0 and (setMaxConvSize - 1) -newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} - deriving (Functor, Foldable, Traversable) - -deriving newtype instance (Semigroup (f a)) => Semigroup (ConvSizeChecked f a) - -deriving newtype instance (Monoid (f a)) => Monoid (ConvSizeChecked f a) - -checkedConvSize :: - (Member (Error InvalidInput) r, Foldable f) => - Opts -> - f a -> - Sem r (ConvSizeChecked f a) -checkedConvSize o x = do - let minV :: Integer = 0 - limit = o ^. settings . maxConvSize - 1 - if length x <= fromIntegral limit - then pure (ConvSizeChecked x) - else throwErr (errorMsg minV limit "") - -throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a -throwErr = throw . InvalidRange . fromString From 8e0123adf2d5871055c511263e63e711f09ca4a7 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 26 Jan 2026 21:31:08 +0100 Subject: [PATCH 04/11] refactor: integrate creation operations in the effect --- .../src/Wire/ConversationSubsystem.hs | 21 +- .../src/Wire/ConversationSubsystem/Create.hs | 862 --------------- .../Wire/ConversationSubsystem/Interpreter.hs | 999 +++++++++++++----- .../ConversationSubsystem/Notification.hs | 256 ----- .../src/Wire/ConversationSubsystem/Util.hs | 12 - libs/wire-subsystems/wire-subsystems.cabal | 3 - .../background-worker/background-worker.cabal | 2 + services/background-worker/default.nix | 4 + .../Wire/BackgroundWorker/Jobs/Registry.hs | 69 +- services/galley/galley.cabal | 1 + services/galley/src/Galley/API/Federation.hs | 4 +- services/galley/src/Galley/API/Internal.hs | 4 +- .../src/Galley/API/Public/Conversation.hs | 219 +++- services/galley/src/Galley/API/Query.hs | 4 +- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/src/Galley/App.hs | 21 +- services/galley/src/Galley/Effects.hs | 18 +- .../galley/src/Galley/Mapping.hs | 2 +- services/galley/test/integration/API.hs | 2 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 20 files changed, 1065 insertions(+), 1442 deletions(-) delete mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs delete mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs rename libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs => services/galley/src/Galley/Mapping.hs (99%) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index a84b8a2a98a..5c961df950e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -24,7 +24,7 @@ import Data.Qualified import Data.Singletons (Sing) import Imports import Polysemy -import Wire.API.Conversation (ExtraConversationData) +import Wire.API.Conversation (ExtraConversationData, NewConv, NewOne2OneConv) import Wire.API.Conversation.Action import Wire.API.Event.Conversation import Wire.NotificationSubsystem (LocalConversationUpdate) @@ -43,10 +43,23 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate - CreateConversation :: - Local ConvId -> + CreateGroupConversation :: Local UserId -> - NewConversation -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m StoredConversation + CreateOne2OneConversation :: + Local UserId -> + ConnId -> + NewOne2OneConv -> + ConversationSubsystem m (StoredConversation, Bool) + CreateProteusSelfConversation :: + Local UserId -> + ConversationSubsystem m (StoredConversation, Bool) + CreateConnectConversation :: + Local UserId -> + Maybe ConnId -> + Connect -> ConversationSubsystem m StoredConversation makeSem ''ConversationSubsystem diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs deleted file mode 100644 index c49dba47a9d..00000000000 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ /dev/null @@ -1,862 +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 . --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -{-# LANGUAGE DataKinds #-} - -module Wire.ConversationSubsystem.Create - ( createGroupConversationUpToV3, - createGroupOwnConversation, - createProteusSelfConversation, - createOne2OneConversation, - createConnectConversation, - createGroupConversation, - ) -where - -import Control.Error (headMay) -import Control.Lens hiding ((??)) -import Data.Default -import Data.Id (ConnId, ConvId, Id (toUUID), TeamId, UserId) -import Data.Misc (FutureWork (FutureWork)) -import Data.Qualified -import Data.Range -import Data.Set qualified as Set -import Data.UUID.Tagged qualified as U -import GHC.TypeNats -import Galley.Types.Error -import Galley.Types.Teams (notTeamMember) -import Imports hiding ((\\)) -import Polysemy -import Polysemy.Error -import Polysemy.Input -import Polysemy.TinyLog qualified as P -import Wire.API.Conversation hiding (Conversation, Member) -import Wire.API.Conversation qualified as Public -import Wire.API.Conversation.CellsState -import Wire.API.Conversation.Role -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 -import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util -import Wire.API.Team -import Wire.API.Team.Collaborator qualified as CollaboratorPermission -import Wire.API.Team.Feature -import Wire.API.Team.Feature qualified as Conf -import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) -import Wire.API.Team.Member -import Wire.API.Team.Permission hiding (self) -import Wire.API.User -import Wire.BrigAPIAccess -import Wire.ConversationStore (ConversationStore) -import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Federation -import Wire.ConversationSubsystem.One2One -import Wire.ConversationSubsystem.Types -import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View -import Wire.FeaturesConfigSubsystem -import Wire.FederationAPIAccess (FederationAPIAccess) -import Wire.LegalHoldStore (LegalHoldStore) -import Wire.NotificationSubsystem -import Wire.Sem.Now (Now) -import Wire.Sem.Random (Random) -import Wire.Sem.Random qualified as Random -import Wire.StoredConversation hiding (convTeam, localOne2OneConvId) -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 qualified as TeamSubsystem -import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) - ----------------------------------------------------------------------------- --- Group conversations - --- | The public-facing endpoint for creating group conversations in the client --- API up to and including version 3. -createGroupConversationUpToV3 :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error InternalError) 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 (Error UnreachableBackendsLegacy) r, - Member LegalHoldStore r, - Member TeamStore r, - Member P.TinyLog r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = - mapError UnreachableBackendsLegacy $ - createGroupConversationGeneric lusr conn newConv - >>= conversationCreated lusr - --- | The public-facing endpoint for creating group conversations in the client --- API in from version 4 to 8 -createGroupOwnConversation :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (Error NonFederatingBackends) 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 (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member P.TinyLog r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - createGroupConvAndMkResponse - lusr - conn - newConv - ( \dbConv -> do - conv <- conversationViewV9 lusr dbConv - pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty - ) - --- | The public-facing endpoint for creating group conversations in the client --- API in version 9 and above. -createGroupConversation :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (Error NonFederatingBackends) 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 (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - createGroupConvAndMkResponse - lusr - conn - newConv - ( \dbConv -> - pure $ - CreateGroupConversation - { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, - failedToAdd = mempty - } - ) - -createGroupConvAndMkResponse :: - ( Member (ErrorS OperationDenied) r, - Member (ErrorS ConvAccessDenied) r, - Member (ErrorS NotATeamMember) 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 (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error NonFederatingBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (FederationAPIAccess FederatorClient) r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - (StoredConversation -> Sem r b) -> - Sem r b -createGroupConvAndMkResponse lusr conn newConv mkResponse = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- createGroupConversationGeneric lusr conn newConv - mkResponse dbConv - -createGroupConversationGeneric :: - forall r. - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error InternalError) 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 (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r StoredConversation -createGroupConversationGeneric lusr _conn newConv = do - (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv - checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers - ensureNoLegalholdConflicts allUsers - - when (newConvProtocol newConv == BaseProtocolMLSTag) $ do - -- Here we fail early in order to notify users of this misconfiguration - assertMLSEnabled - - lcnv <- traverse (const Random.newId) lusr - conv <- ConversationSubsystem.createConversation lcnv lusr nc - E.getConversation conv.id_ - >>= note (BadConvState conv.id_) - -ensureNoLegalholdConflicts :: - ( Member (ErrorS 'MissingLegalholdConsent) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member TeamSubsystem r - ) => - UserList UserId -> - Sem r () -ensureNoLegalholdConflicts (UserList locals remotes) = do - let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes - whenM (anyLegalholdActivated locals) $ - unlessM (allLegalholdConsentGiven locals) $ - throwS @'MissingLegalholdConsent - -checkCreateConvPermissions :: - ( Member BrigAPIAccess r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS ChannelsNotEnabled) r, - Member (ErrorS NotAnMlsConversation) r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - NewConv -> - Maybe ConvTeamInfo -> - UserList UserId -> - Sem r () -checkCreateConvPermissions lusr newConv Nothing allUsers = do - when (newConv.newConvGroupConvType == Channel) $ throwS @OperationDenied - activated <- listToMaybe <$> lookupActivatedUsers [tUnqualified lusr] - void $ noteS @OperationDenied activated - -- an external partner is not allowed to create group conversations (except 1:1 team conversations that are handled below) - tm <- getTeamMember (tUnqualified lusr) Nothing - for_ tm $ - permissionCheck AddRemoveConvMember . Just - ensureConnected lusr allUsers -checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do - let convTeam = cnvTeamId tinfo - mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam) - teamAssociation <- case mTeamMember of - Just tm -> pure (Just (Right tm)) - Nothing -> do - Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr) - - case newConv.newConvGroupConvType of - Channel -> do - ensureCreateChannelPermissions tinfo.cnvTeamId mTeamMember - GroupConversation -> do - void $ permissionCheck CreateConversation teamAssociation - -- In teams we don't have 1:1 conversations, only regular conversations. We want - -- users without the 'AddRemoveConvMember' permission to still be able to create - -- regular conversations, therefore we check for 'AddRemoveConvMember' only if - -- there are going to be more than two users in the conversation. - -- FUTUREWORK: We keep this permission around because not doing so will break backwards - -- compatibility in the sense that the team role 'partners' would be able to create group - -- conversations (which they should not be able to). - -- Not sure at the moment how to best solve this but it is unlikely - -- we can ever get rid of the team permission model anyway - the only thing I can - -- think of is that 'partners' can create convs but not be admins... - -- this only applies to proteus conversations, because in MLS we have proper 1:1 conversations, - -- so we don't allow an external partner to create an MLS group conversation at all - when (length allUsers > 1 || newConv.newConvProtocol == BaseProtocolMLSTag) $ do - void $ permissionCheck AddRemoveConvMember teamAssociation - - convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) - ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) - -- Team members are always considered to be connected, so we only check - -- 'ensureConnected' for non-team-members. - ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) - ensureConnectedToRemotes lusr (ulRemotes allUsers) - where - ensureCreateChannelPermissions :: - forall r. - ( Member (ErrorS OperationDenied) r, - Member FeaturesConfigSubsystem r, - Member (ErrorS NotATeamMember) r, - Member (ErrorS ChannelsNotEnabled) r, - Member (ErrorS NotAnMlsConversation) r - ) => - TeamId -> - Maybe TeamMember -> - Sem r () - ensureCreateChannelPermissions tid (Just tm) = do - channelsConf :: LockableFeature ChannelsConfig <- getFeatureForTeam tid - when (channelsConf.status == FeatureStatusDisabled) $ throwS @ChannelsNotEnabled - when (newConv.newConvProtocol /= BaseProtocolMLSTag) $ throwS @NotAnMlsConversation - case channelsConf.config.allowedToCreateChannels of - Conf.Everyone -> pure () - Conf.TeamMembers -> void $ permissionCheck AddRemoveConvMember $ Just tm - Conf.Admins -> unless (isAdminOrOwner (tm ^. permissions)) $ throwS @OperationDenied - ensureCreateChannelPermissions _ Nothing = do - throwS @NotATeamMember - -getTeamMember :: (Member TeamStore r, Member TeamSubsystem r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) -getTeamMember uid (Just tid) = TeamSubsystem.internalGetTeamMember uid tid -getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember uid) . headMay - ----------------------------------------------------------------------------- --- Other kinds of conversations - -createProteusSelfConversation :: - forall r. - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - let lcnv = fmap Data.selfConv lusr - c <- E.getConversation (tUnqualified lcnv) - maybe (create lcnv) (conversationExisted lusr) c - where - create :: Local ConvId -> Sem r (ConversationResponse Public.OwnConversation) - create lcnv = do - let nc = - NewConversation - { metadata = (defConversationMetadata (Just (tUnqualified lusr))) {cnvmType = SelfConv}, - users = ulFromLocals [toUserRole (tUnqualified lusr)], - protocol = BaseProtocolProteusTag, - groupId = Nothing - } - ConversationSubsystem.createConversation lcnv lusr nc - >>= conversationCreated lusr - -createOne2OneConversation :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotConnected) r, - Member (Error UnreachableBackendsLegacy) r, - Member TeamStore r, - Member P.TinyLog r, - Member TeamCollaboratorsSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - NewOne2OneConv -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversation lusr zcon j = - mapError @UnreachableBackends @UnreachableBackendsLegacy UnreachableBackendsLegacy $ do - let allUsers = newOne2OneConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (tUntagged lusr == other) $ - throwS @'InvalidOperation - mtid <- case j.team of - Just ti -> do - foldQualified - lusr - (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) - (const (pure Nothing)) - other - Nothing -> ensureConnected lusr allUsers $> Nothing - foldQualified - lusr - (createLegacyOne2OneConversationUnchecked lusr zcon j.name mtid) - (createOne2OneConversationUnchecked lusr zcon j.name mtid . tUntagged) - other - where - verifyMembership :: - ( Member (ErrorS 'NoBindingTeamMembers) r, - Member TeamSubsystem r - ) => - TeamId -> - UserId -> - Sem r () - verifyMembership tid u = do - membership <- TeamSubsystem.internalGetTeamMember u tid - when (isNothing membership) $ - throwS @'NoBindingTeamMembers - checkBindingTeamPermissions :: - ( Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamCollaboratorsSubsystem r, - Member TeamStore r, - Member TeamSubsystem r - ) => - Local UserId -> - TeamId -> - Sem r (Maybe TeamId) - checkBindingTeamPermissions lother tid = do - mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr) - zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - case (mTeamCollaborator, zusrMembership) of - (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator - (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember - (Just collaborator, Just member) -> - unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $ - throwS @OperationDenied - TeamStore.getTeamBinding tid >>= \case - Just Binding -> do - when (isJust zusrMembership) $ - verifyMembership tid (tUnqualified lusr) - mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother) - unless (isJust mOtherTeamCollaborator) $ - verifyMembership tid (tUnqualified lother) - pure (Just tid) - Just _ -> throwS @'NonBindingTeam - Nothing -> throwS @'TeamNotFound - - guardPerm p m = - if m `hasPermission` p - then pure () - else throwS @OperationDenied - -createLegacyOne2OneConversationUnchecked :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do - lcnv <- localOne2OneConvId self other - let meta = - (defConversationMetadata (Just (tUnqualified self))) - { cnvmType = One2OneConv, - cnvmTeam = mtid, - cnvmName = fmap fromRange name - } - let nc = - NewConversation - { users = ulFromLocals (map (toUserRole . tUnqualified) [self, other]), - protocol = BaseProtocolProteusTag, - metadata = meta, - groupId = Nothing - } - mc <- E.getConversation (tUnqualified lcnv) - case mc of - Just c -> conversationExisted self c - Nothing -> do - ConversationSubsystem.createConversation lcnv self nc - >>= conversationCreated self - -createOne2OneConversationUnchecked :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationUnchecked self zcon name mtid other = do - let create = - foldQualified - self - createOne2OneConversationLocally - createOne2OneConversationRemotely - create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other - -createOne2OneConversationLocally :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationLocally lcnv self _zcon name mtid other = do - mc <- E.getConversation (tUnqualified lcnv) - case mc of - Just c -> conversationExisted self c - Nothing -> do - let meta = - (defConversationMetadata (Just (tUnqualified self))) - { cnvmType = One2OneConv, - cnvmTeam = mtid, - cnvmName = fmap fromRange name - } - let nc = - NewConversation - { metadata = meta, - users = fmap toUserRole (toUserList lcnv [tUntagged self, other]), - protocol = BaseProtocolProteusTag, - groupId = Nothing - } - ConversationSubsystem.createConversation lcnv self nc - >>= conversationCreated self - -createOne2OneConversationRemotely :: - (Member (Error FederationError) r) => - Remote ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationRemotely _ _ _ _name _mtid _ = - throw FederationNotImplemented - -createConnectConversation :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvNotFound) r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'InvalidOperation) r, - Member NotificationSubsystem r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Connect -> - Sem r (ConversationResponse Public.OwnConversation) -createConnectConversation lusr conn j = do - lrecipient <- ensureLocal lusr (cRecipient j) - n <- rangeCheckedMaybe (cName j) - let meta = - (defConversationMetadata (Just (tUnqualified lusr))) - { cnvmType = ConnectConv, - cnvmName = fmap fromRange n - } - lcnv <- localOne2OneConvId lusr lrecipient - let nc = - NewConversation - { -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - users = ulFromLocals ([(toUserRole . tUnqualified) lusr]), - protocol = BaseProtocolProteusTag, - metadata = meta, - groupId = Nothing - } - E.getConversation (tUnqualified lcnv) - >>= maybe (create lcnv nc) (update n) - where - create lcnv nc = do - c <- ConversationSubsystem.createConversation lcnv lusr nc - conversationCreated lusr c - update n conv = do - let mems = conv.localMembers - in conversationExisted lusr - =<< if tUnqualified lusr `isMember` mems - then -- we already were in the conversation, maybe also other - connect n conv - else do - let lcid = qualifyAs lusr conv.id_ - mm <- E.upsertMember lcid lusr - let conv' = - conv - { localMembers = conv.localMembers <> toList mm - } - if null mems - then do - -- the conversation was empty - connect n conv' - else do - -- we were not in the conversation, but someone else - conv'' <- acceptOne2One lusr conv' conn - if Data.convType conv'' == ConnectConv - then connect n conv'' - else pure conv'' - connect n conv - | Data.convType conv == ConnectConv = do - n' <- case n of - Just x -> do - E.setConversationName conv.id_ x - pure . Just $ fromRange x - Nothing -> pure $ Data.convName conv - notifyConversationUpdated lusr conn j conv - pure $ Data.convSetName n' conv - | otherwise = pure conv - --------------------------------------------------------------------------------- --- Conversation creation records - --- | Return a 'NewConversation' record suitable for creating a group conversation. -newRegularConversation :: - ( Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS OperationDenied) r, - Member (Error InvalidInput) r, - Member (Input ConversationSubsystemConfig) r, - Member ConversationStore r - ) => - Local UserId -> - NewConv -> - Sem r (NewConversation, ConvSizeChecked UserList UserId) -newRegularConversation lusr newConv = do - cfg <- input - let uncheckedUsers = newConvMembers lusr newConv - forM_ newConv.newConvParent $ \parent -> do - mMembership <- E.getLocalMember parent (tUnqualified lusr) - when (isNothing mMembership) $ - throwS @OperationDenied - users <- case newConvProtocol newConv of - BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers - BaseProtocolMLSTag -> do - unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList - pure mempty - let usersWithoutCreator = (,newConvUsersRole newConv) <$> fromConvSize users - newConvUsersRoles = - if newConv.newConvSkipCreator - then usersWithoutCreator - else ulAddLocal (toUserRole (tUnqualified lusr)) usersWithoutCreator - let nc = - NewConversation - { metadata = - ConversationMetadata - { cnvmType = RegularConv, - cnvmCreator = Just (tUnqualified lusr), - cnvmAccess = access newConv, - cnvmAccessRoles = accessRoles newConv, - cnvmName = fmap fromRange newConv.newConvName, - cnvmMessageTimer = newConv.newConvMessageTimer, - cnvmReceiptMode = case newConv.newConvProtocol of - BaseProtocolProteusTag -> newConv.newConvReceiptMode - BaseProtocolMLSTag -> Just def, - cnvmTeam = fmap cnvTeamId newConv.newConvTeam, - cnvmGroupConvType = Just newConv.newConvGroupConvType, - cnvmChannelAddPermission = if newConv.newConvGroupConvType == Channel then newConv.newConvChannelAddPermission <|> Just def else Nothing, - cnvmCellsState = - if newConv.newConvCells - then CellsPending - else CellsDisabled, - cnvmParent = newConv.newConvParent - }, - users = newConvUsersRoles, - protocol = newConvProtocol newConv, - groupId = Nothing - } - pure (nc, users) - -------------------------------------------------------------------------------- --- Helpers - -conversationCreated :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationCreated lusr cnv = Created <$> conversationViewV9 lusr cnv - -localOne2OneConvId :: - (Member (Error InvalidInput) r) => - Local UserId -> - Local UserId -> - Sem r (Local ConvId) -localOne2OneConvId self other = do - (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - pure . qualifyAs self $ Data.localOne2OneConvId x y - -toUUIDs :: - (Member (Error InvalidInput) r) => - UserId -> - UserId -> - Sem r (U.UUID U.V4, U.UUID U.V4) -toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & note InvalidUUID4 - b' <- U.fromUUID (toUUID b) & note InvalidUUID4 - pure (a', b') - -accessRoles :: NewConv -> Set AccessRole -accessRoles b = fromMaybe defRole (newConvAccessRoles b) - -access :: NewConv -> [Access] -access a = case Set.toList (newConvAccess a) of - [] -> Data.defRegularConvAccess - (x : xs) -> x : xs - -newConvMembers :: Local x -> NewConv -> UserList UserId -newConvMembers loc body = - UserList (newConvUsers body) [] - <> toUserList loc (newConvQualifiedUsers body) - -newOne2OneConvMembers :: Local x -> NewOne2OneConv -> UserList UserId -newOne2OneConvMembers loc body = - UserList body.users [] - <> toUserList loc body.qualifiedUsers - -ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a -ensureOne [x] = pure x -ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") - --------------------------------------------------------------------------------- --- Validation and MLS Helpers - -assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () -assertMLSEnabled = do - cfg <- input - when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled - --- Between 0 and (setMaxConvSize - 1) -newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} - deriving (Functor, Foldable, Traversable) - -deriving newtype instance (Semigroup (f a)) => Semigroup (ConvSizeChecked f a) - -deriving newtype instance (Monoid (f a)) => Monoid (ConvSizeChecked f a) - -checkedConvSize :: - (Member (Error InvalidInput) r, Foldable f) => - ConversationSubsystemConfig -> - f a -> - Sem r (ConvSizeChecked f a) -checkedConvSize cfg x = do - let minV :: Integer = 0 - limit = cfg.maxConvSize - 1 - if length x <= fromIntegral limit - then pure (ConvSizeChecked x) - else throwErr (errorMsg minV limit "") - -rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) -rangeChecked = either throwErr pure . checkedEither -{-# INLINE rangeChecked #-} - -rangeCheckedMaybe :: - (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => - Maybe a -> - Sem r (Maybe (Range n m a)) -rangeCheckedMaybe Nothing = pure Nothing -rangeCheckedMaybe (Just a) = Just <$> rangeChecked a -{-# INLINE rangeCheckedMaybe #-} - -throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a -throwErr = throw . InvalidRange . fromString diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index c0dce6fc8b4..1afc4817df5 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -35,70 +35,101 @@ module Wire.ConversationSubsystem.Interpreter createConversationImpl, sendCellsNotification, notifyConversationActionImpl, - pushConversationEvent, - toConversationCreated, - fromConversationCreated, registerRemoteConversationMemberships, - notifyCreatedConversation, ) where -import Data.Bifunctor (second) +import Control.Error (headMay) +import Control.Lens hiding ((??)) import Data.Default import Data.Id -import Data.Json.Util -import Data.List.Extra (nubOrd) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE +import Data.Json.Util (ToJSONObject (toJSONObject)) +import Data.Misc (FutureWork (FutureWork)) import Data.Qualified +import Data.Range import Data.Set qualified as Set -import Data.Singletons (Sing, sing) -import Data.Text qualified as T -import Data.Text.Lazy qualified as LT -import Data.Time (UTCTime) -import Galley.Types.Error (InternalError) -import Galley.Types.Error qualified as GalleyError +import Data.Singletons (Sing) +import Data.UUID.Tagged qualified as U +import GHC.TypeNats +import Galley.Types.Error (InternalError, InvalidInput (..)) +import Galley.Types.Teams (notTeamMember) 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.Component (Component (Brig, Galley)) +import Wire.API.Conversation hiding (Member) import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action import Wire.API.Conversation.CellsState -import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus)) import Wire.API.Conversation.Role +import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation -import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) -import Wire.API.Federation.API.Galley (ConversationCreated (..), ccRemoteOrigUserId) +import Wire.API.Federation.API (makeConversationUpdateBundle, sendBundle) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.FederationStatus import Wire.API.Push.V2 qualified as PushV2 -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently, enqueueNotificationsConcurrentlyBuckets) +import Wire.API.Team +import Wire.API.Team.Collaborator qualified as CollaboratorPermission +import Wire.API.Team.Feature +import Wire.API.Team.Feature qualified as Conf +import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) +import Wire.API.Team.Member +import Wire.API.Team.Permission hiding (self) +import Wire.API.User +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently) +import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Federation +import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Types as X -import Wire.ConversationSubsystem.View (conversationViewWithCachedOthers) -import Wire.ExternalAccess (ExternalAccess, deliverAsync) -import Wire.FederationAPIAccess (FederationAPIAccess, runFederatedConcurrentlyEither) -import Wire.FederationAPIAccess qualified as E +import Wire.ConversationSubsystem.Util +import Wire.ExternalAccess (ExternalAccess) +import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now +import Wire.Sem.Random (Random) +import Wire.Sem.Random qualified as Random import Wire.StoredConversation hiding (convTeam, id_, localOne2OneConvId) -import Wire.StoredConversation as Data (LocalMember (..), NewConversation (..), RemoteMember (..), convType) +import Wire.StoredConversation as Data (NewConversation (..), convType) 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 qualified as TeamSubsystem +import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) interpretConversationSubsystem :: ( Member (Error FederationError) r, - Member (Error GalleyError.InternalError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) 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 BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -106,19 +137,203 @@ interpretConversationSubsystem :: Member (Embed IO) r, Member ConversationStore r, Member (FederationAPIAccess FederatorClient) r, - Member TinyLog r + Member TinyLog r, + Member BrigAPIAccess r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r ) => Sem (ConversationSubsystem : r) a -> Sem r a interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData - CreateConversation lconv lusr newConv -> do - res <- runError @UnreachableBackends $ runError @InternalError $ createConversationImpl lconv lusr newConv - case res of - Left (unreachable :: UnreachableBackends) -> throw $ FederationUnexpectedError (T.pack $ show unreachable) - Right (Left (err :: InternalError)) -> throw err - Right (Right val') -> pure val' + ConversationSubsystem.CreateGroupConversation lusr conn newConv -> + createGroupConv lusr conn newConv + ConversationSubsystem.CreateOne2OneConversation lusr conn newOne2One -> + createOne2OneConversationLogic lusr conn newOne2One + ConversationSubsystem.CreateProteusSelfConversation lusr -> + createProteusSelfConversationLogic lusr + ConversationSubsystem.CreateConnectConversation lusr conn j -> + createConnectConversationLogic lusr conn j + +createGroupConv :: + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'ConvAccessDenied) r, + Member (ErrorS 'NotATeamMember) 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 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (FederationAPIAccess FederatorClient) r, + Member BrigAPIAccess r, + Member ConversationStore r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member (Input ConversationSubsystemConfig) r, + Member Now r, + Member NotificationSubsystem r, + Member (Embed IO) r, + Member TinyLog r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Maybe ConnId -> + Public.NewConv -> + Sem r StoredConversation +createGroupConv lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + createGroupConversationGeneric lusr conn newConv + +createGroupConversationGeneric :: + forall r. + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InternalError) 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 'NonBindingTeam) r, + Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) 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 (Embed IO) r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member TinyLog r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + Maybe ConnId -> + Public.NewConv -> + Sem r StoredConversation +createGroupConversationGeneric lusr conn newConv = do + (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv + checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers + ensureNoLegalholdConflicts allUsers + + when (Public.newConvProtocol newConv == BaseProtocolMLSTag) $ do + assertMLSEnabled + + lcnv <- traverse (const Random.newId) lusr + storedConv <- createConversationImpl lcnv lusr nc + sendCellsNotification lusr conn storedConv + pure storedConv + +createOne2OneConversationLogic :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) 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 TinyLog r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + ConnId -> + Public.NewOne2OneConv -> + Sem r (StoredConversation, Bool) +createOne2OneConversationLogic lusr zcon j = do + let allUsers = newOne2OneConvMembers lusr j + other <- ensureOne (ulAll lusr allUsers) + when (tUntagged lusr == other) $ + throwS @'InvalidOperation + mtid <- case j.team of + Just ti -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) + (const (pure Nothing)) + other + Nothing -> ensureConnected lusr allUsers $> Nothing + foldQualified + lusr + (createLegacyOne2OneConversationUnchecked lusr zcon j.name mtid) + (createOne2OneConversationUnchecked lusr zcon j.name mtid . tUntagged) + other + +createProteusSelfConversationLogic :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + Sem r (StoredConversation, Bool) +createProteusSelfConversationLogic lusr = do + let lcnv = fmap Data.selfConv lusr + c <- ConvStore.getConversation (tUnqualified lcnv) + maybe (create lcnv) (\conv -> pure (conv, False)) c + where + create lcnv = do + let nc = + Data.NewConversation + { metadata = (defConversationMetadata (Just (tUnqualified lusr))) {cnvmType = Public.SelfConv}, + users = ulFromLocals [toUserRole (tUnqualified lusr)], + protocol = BaseProtocolProteusTag, + groupId = Nothing + } + conv <- createConversationImpl lcnv lusr nc + pure (conv, True) createConversationImpl :: ( Member (Error FederationError) r, @@ -136,13 +351,474 @@ createConversationImpl :: Local UserId -> Data.NewConversation -> Sem r StoredConversation -createConversationImpl lconv lusr newConv = do - storedConv <- ConvStore.upsertConversation lconv newConv - unless (Data.convType storedConv == Public.SelfConv) $ do - notifyCreatedConversation lusr Nothing storedConv def - sendCellsNotification lusr Nothing storedConv +createConversationImpl lconv _lusr nc = do + storedConv <- ConvStore.upsertConversation lconv nc pure storedConv +createConnectConversationLogic :: + ( 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 TinyLog r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Sem r StoredConversation +createConnectConversationLogic lusr conn j = do + lrecipient <- ensureLocal lusr (cRecipient j) + n <- rangeCheckedMaybe (cName j) + let meta = + (defConversationMetadata (Just (tUnqualified lusr))) + { cnvmType = Public.ConnectConv, + cnvmName = fmap fromRange n + } + lcnv <- localOne2OneConvId lusr lrecipient + let nc = + Data.NewConversation + { -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + users = ulFromLocals [(toUserRole . tUnqualified) lusr], + protocol = BaseProtocolProteusTag, + metadata = meta, + groupId = Nothing + } + ConvStore.getConversation (tUnqualified lcnv) + >>= maybe (create lcnv nc) (update n) + where + create lcnv nc = do + createConversationImpl lcnv lusr nc + update n conv = do + let mems = conv.localMembers + if tUnqualified lusr `isMember` mems + then -- we already were in the conversation, maybe also other + connect n conv + else do + let lcid = qualifyAs lusr conv.id_ + mm <- ConvStore.upsertMember lcid lusr + let conv' = + conv + { localMembers = conv.localMembers <> toList mm + } + if null mems + then -- the conversation was empty + connect n conv' + else do + -- we were not in the conversation, but someone else + conv'' <- acceptOne2One lusr conv' conn + if Data.convType conv'' == Public.ConnectConv + then connect n conv'' + else pure conv'' + connect n conv + | Data.convType conv == Public.ConnectConv = do + n' <- case n of + Just x -> do + ConvStore.setConversationName conv.id_ x + pure . Just $ fromRange x + Nothing -> pure $ Data.convName conv + notifyConversationUpdated lusr conn j conv + pure $ Data.convSetName n' conv + | otherwise = pure conv + +ensureNoLegalholdConflicts :: + ( Member (ErrorS 'MissingLegalholdConsent) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member TeamSubsystem r + ) => + UserList UserId -> + Sem r () +ensureNoLegalholdConflicts (UserList locals remotes) = do + let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes + whenM (anyLegalholdActivated locals) $ + unlessM (allLegalholdConsentGiven locals) $ + throwS @'MissingLegalholdConsent + +checkCreateConvPermissions :: + ( Member BrigAPIAccess r, + Member (ErrorS 'ConvAccessDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r + ) => + Local UserId -> + Public.NewConv -> + Maybe ConvTeamInfo -> + UserList UserId -> + Sem r () +checkCreateConvPermissions lusr newConv Nothing allUsers = do + when (newConv.newConvGroupConvType == Channel) $ throwS @OperationDenied + activated <- listToMaybe <$> lookupActivatedUsers [tUnqualified lusr] + void $ noteS @OperationDenied activated + tm <- getTeamMember (tUnqualified lusr) Nothing + for_ tm $ + permissionCheck AddRemoveConvMember . Just + ensureConnected lusr allUsers +checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do + let convTeam = cnvTeamId tinfo + mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam) + teamAssociation <- case mTeamMember of + Just tm -> pure (Just (Right tm)) + Nothing -> do + Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr) + + case newConv.newConvGroupConvType of + Channel -> do + ensureCreateChannelPermissions tinfo.cnvTeamId mTeamMember + GroupConversation -> do + void $ permissionCheck CreateConversation teamAssociation + when (length allUsers > 1 || Public.newConvProtocol newConv == BaseProtocolMLSTag) $ do + void $ permissionCheck AddRemoveConvMember teamAssociation + + convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) + ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) + ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) + ensureConnectedToRemotes lusr (ulRemotes allUsers) + where + ensureCreateChannelPermissions :: + forall r. + ( Member (ErrorS OperationDenied) r, + Member FeaturesConfigSubsystem r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r + ) => + TeamId -> + Maybe TeamMember -> + Sem r () + ensureCreateChannelPermissions tid (Just tm) = do + channelsConf :: LockableFeature ChannelsConfig <- getFeatureForTeam tid + when (channelsConf.status == FeatureStatusDisabled) $ throwS @'ChannelsNotEnabled + when (Public.newConvProtocol newConv /= BaseProtocolMLSTag) $ throwS @'NotAnMlsConversation + case channelsConf.config.allowedToCreateChannels of + Conf.Everyone -> pure () + Conf.TeamMembers -> void $ permissionCheck AddRemoveConvMember $ Just tm + Conf.Admins -> unless (isAdminOrOwner (tm ^. permissions)) $ throwS @OperationDenied + ensureCreateChannelPermissions _ Nothing = do + throwS @'NotATeamMember + +getTeamMember :: (Member TeamStore r, Member TeamSubsystem r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) +getTeamMember uid (Just tid) = TeamSubsystem.internalGetTeamMember uid tid +getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember uid) . headMay + +createLegacyOne2OneConversationUnchecked :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Local UserId -> + Sem r (StoredConversation, Bool) +createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do + lcnv <- localOne2OneConvId self other + let meta = + (defConversationMetadata (Just (tUnqualified self))) + { cnvmType = Public.One2OneConv, + cnvmTeam = mtid, + cnvmName = fmap fromRange name + } + let nc = + Data.NewConversation + { users = ulFromLocals (map (toUserRole . tUnqualified) [self, other]), + protocol = BaseProtocolProteusTag, + metadata = meta, + groupId = Nothing + } + mc <- ConvStore.getConversation (tUnqualified lcnv) + case mc of + Just c -> pure (c, False) + Nothing -> do + conv <- createConversationImpl lcnv self nc + pure (conv, True) + +createOne2OneConversationUnchecked :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (StoredConversation, Bool) +createOne2OneConversationUnchecked self zcon name mtid other = do + let create = + foldQualified + self + createOne2OneConversationLocally + createOne2OneConversationRemotely + create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other + +createOne2OneConversationLocally :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (StoredConversation, Bool) +createOne2OneConversationLocally lcnv self _zcon name mtid other = do + mc <- ConvStore.getConversation (tUnqualified lcnv) + case mc of + Just c -> pure (c, False) + Nothing -> do + let meta = + (defConversationMetadata (Just (tUnqualified self))) + { cnvmType = Public.One2OneConv, + cnvmTeam = mtid, + cnvmName = fmap fromRange name + } + let nc = + Data.NewConversation + { metadata = meta, + users = fmap toUserRole (toUserList lcnv [tUntagged self, other]), + protocol = BaseProtocolProteusTag, + groupId = Nothing + } + conv <- createConversationImpl lcnv self nc + pure (conv, True) + +createOne2OneConversationRemotely :: + (Member (Error FederationError) r) => + Remote ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (StoredConversation, Bool) +createOne2OneConversationRemotely _ _ _ _name _mtid _ = + throw FederationNotImplemented + +newRegularConversation :: + ( Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS OperationDenied) r, + Member (Error InvalidInput) r, + Member (Input ConversationSubsystemConfig) r, + Member ConversationStore r + ) => + Local UserId -> + Public.NewConv -> + Sem r (Data.NewConversation, ConvSizeChecked UserList UserId) +newRegularConversation lusr newConv = do + cfg <- input + let uncheckedUsers = newConvMembers lusr newConv + forM_ newConv.newConvParent $ \parent -> do + mMembership <- ConvStore.getLocalMember parent (tUnqualified lusr) + when (isNothing mMembership) $ + throwS @OperationDenied + users <- case Public.newConvProtocol newConv of + BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers + BaseProtocolMLSTag -> do + unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList + pure mempty + let usersWithoutCreator = (,newConvUsersRole newConv) <$> fromConvSize users + newConvUsersRoles = + if newConv.newConvSkipCreator + then usersWithoutCreator + else ulAddLocal (toUserRole (tUnqualified lusr)) usersWithoutCreator + let nc = + Data.NewConversation + { metadata = + Public.ConversationMetadata + { cnvmType = Public.RegularConv, + cnvmCreator = Just (tUnqualified lusr), + cnvmAccess = access newConv, + cnvmAccessRoles = accessRoles newConv, + cnvmName = fmap fromRange newConv.newConvName, + cnvmMessageTimer = newConv.newConvMessageTimer, + cnvmReceiptMode = case Public.newConvProtocol newConv of + BaseProtocolProteusTag -> newConv.newConvReceiptMode + BaseProtocolMLSTag -> Just def, + cnvmTeam = fmap cnvTeamId newConv.newConvTeam, + cnvmGroupConvType = Just newConv.newConvGroupConvType, + cnvmChannelAddPermission = if newConv.newConvGroupConvType == Channel then newConv.newConvChannelAddPermission <|> Just def else Nothing, + cnvmCellsState = + if newConv.newConvCells + then CellsPending + else CellsDisabled, + cnvmParent = newConv.newConvParent + }, + users = newConvUsersRoles, + protocol = Public.newConvProtocol newConv, + groupId = Nothing + } + pure (nc, users) + +localOne2OneConvId :: + (Member (Error InvalidInput) r) => + Local UserId -> + Local UserId -> + Sem r (Local ConvId) +localOne2OneConvId self other = do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + pure . qualifyAs self $ Data.localOne2OneConvId x y + +toUUIDs :: + (Member (Error InvalidInput) r) => + UserId -> + UserId -> + Sem r (U.UUID U.V4, U.UUID U.V4) +toUUIDs a b = do + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 + pure (a', b') + +accessRoles :: Public.NewConv -> Set AccessRole +accessRoles b = fromMaybe defRole (newConvAccessRoles b) + +access :: Public.NewConv -> [Access] +access a = case Set.toList (Public.newConvAccess a) of + [] -> Data.defRegularConvAccess + (x : xs) -> x : xs + +newConvMembers :: Local x -> Public.NewConv -> UserList UserId +newConvMembers loc body = + UserList (newConvUsers body) [] + <> toUserList loc (newConvQualifiedUsers body) + +newOne2OneConvMembers :: Local x -> Public.NewOne2OneConv -> UserList UserId +newOne2OneConvMembers loc body = + UserList body.users [] + <> toUserList loc body.qualifiedUsers + +ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a +ensureOne [x] = pure x +ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") + +assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () +assertMLSEnabled = do + cfg <- input + when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled + +newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} + deriving (Functor, Foldable, Traversable) + deriving newtype (Semigroup, Monoid) + +checkedConvSize :: + (Member (Error InvalidInput) r, Foldable f) => + ConversationSubsystemConfig -> + f a -> + Sem r (ConvSizeChecked f a) +checkedConvSize cfg x = do + let minV :: Integer = 0 + limit = cfg.maxConvSize - 1 + if length x <= fromIntegral limit + then pure (ConvSizeChecked x) + else throwErr (errorMsg minV limit "") + +rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) +rangeChecked = either throwErr pure . checkedEither +{-# INLINE rangeChecked #-} + +rangeCheckedMaybe :: + (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => + Maybe a -> + Sem r (Maybe (Range n m a)) +rangeCheckedMaybe Nothing = pure Nothing +rangeCheckedMaybe (Just a) = Just <$> rangeChecked a +{-# INLINE rangeCheckedMaybe #-} + +throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a +throwErr = throw . InvalidRange . fromString + +checkBindingTeamPermissions :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamCollaboratorsSubsystem r, + Member TeamStore r, + Member TeamSubsystem r + ) => + Local UserId -> + Local UserId -> + TeamId -> + Sem r (Maybe TeamId) +checkBindingTeamPermissions lusr lother tid = do + mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr) + zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid + case (mTeamCollaborator, zusrMembership) of + (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator + (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember + (Just collaborator, Just member) -> + unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $ + throwS @OperationDenied + TeamStore.getTeamBinding tid >>= \case + Just Binding -> do + when (isJust zusrMembership) $ + verifyMembership tid (tUnqualified lusr) + mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother) + unless (isJust mOtherTeamCollaborator) $ + verifyMembership tid (tUnqualified lother) + pure (Just tid) + Just _ -> throwS @'NonBindingTeam + Nothing -> throwS @'TeamNotFound + where + guardPerm p m = + if m `hasPermission` p + then pure () + else throwS @OperationDenied + +verifyMembership :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member TeamSubsystem r + ) => + TeamId -> + UserId -> + Sem r () +verifyMembership tid u = do + membership <- TeamSubsystem.internalGetTeamMember u tid + when (isNothing membership) $ + throwS @'NoBindingTeamMembers + sendCellsNotification :: ( Member NotificationSubsystem r, Member Now r @@ -215,244 +891,3 @@ notifyConversationActionImpl tag eventFrom notifyOrigDomain con lconv targetsLoc pushConversationEvent con conv.metadata.cnvmCellsState e (qualifyAs lcnv targetsLocal) targetsBots pure $ LocalConversationUpdate {lcuEvent = e, lcuUpdate = update} - -pushConversationEvent :: - ( Member ExternalAccess r, - Member NotificationSubsystem r, - Foldable f - ) => - Maybe ConnId -> - CellsState -> - Event -> - Local (f UserId) -> - f BotMember -> - Sem r () -pushConversationEvent conn st e lusers bots = do - NS.pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] - deliverAsync (map (,e) (toList bots)) - where - newConversationEventPush :: Local [UserId] -> Push - newConversationEventPush users = - let eventFromUser = eventFromUserId e.evtFrom - musr = guard (tDomain users == qDomain eventFromUser) $> qUnqualified eventFromUser - in def - { origin = musr, - json = toJSONObject e, - recipients = map NS.userRecipient (tUnqualified users), - isCellsEvent = shouldPushToCells st e - } - -toConversationCreated :: - UTCTime -> - Local UserId -> - StoredConversation -> - ConversationCreated ConvId -toConversationCreated now lusr StoredConversation {metadata = Public.ConversationMetadata {..}, ..} = - ConversationCreated - { time = now, - origUserId = tUnqualified lusr, - cnvId = id_, - cnvType = cnvmType, - cnvAccess = cnvmAccess, - cnvAccessRoles = cnvmAccessRoles, - cnvName = cnvmName, - nonCreatorMembers = Set.empty, - messageTimer = cnvmMessageTimer, - receiptMode = cnvmReceiptMode, - protocol = protocol, - groupConvType = cnvmGroupConvType, - channelAddPermission = cnvmChannelAddPermission - } - -fromConversationCreated :: - Local x -> - ConversationCreated (Remote ConvId) -> - [(Public.Member, Public.OwnConversation)] -fromConversationCreated loc rc@ConversationCreated {..} = - let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers - creatorOther = - Public.OtherMember - (tUntagged (ccRemoteOrigUserId rc)) - Nothing - roleNameWireAdmin - in foldMap - ( \(me, others) -> - guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) - ) - membersView - where - inDomain :: Public.OtherMember -> Bool - inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId - setHoles :: (Ord a) => Set a -> [(a, Set a)] - setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s - toMember :: Public.OtherMember -> Public.Member - toMember m = - Public.Member - { memId = Public.omQualifiedId m, - memService = Public.omService m, - memOtrMutedStatus = Nothing, - memOtrMutedRef = Nothing, - memOtrArchived = False, - memOtrArchivedRef = Nothing, - memHidden = False, - memHiddenRef = Nothing, - memConvRoleName = Public.omConvRoleName m - } - conv :: Public.Member -> [Public.OtherMember] -> Public.OwnConversation - conv this others = - Public.OwnConversation - (tUntagged cnvId) - Public.ConversationMetadata - { cnvmType = cnvType, - cnvmCreator = Just origUserId, - cnvmAccess = cnvAccess, - cnvmAccessRoles = cnvAccessRoles, - cnvmName = cnvName, - cnvmTeam = Nothing, - cnvmMessageTimer = messageTimer, - cnvmReceiptMode = receiptMode, - cnvmGroupConvType = groupConvType, - cnvmChannelAddPermission = channelAddPermission, - cnvmCellsState = def, - cnvmParent = Nothing - } - (Public.OwnConvMembers this others) - ProtocolProteus - -registerRemoteConversationMemberships :: - ( Member ConvStore.ConversationStore r, - Member (Error UnreachableBackends) r, - Member (Error FederationError) r, - Member BackendNotificationQueueAccess r, - Member (FederationAPIAccess FederatorClient) r, - Member TinyLog r - ) => - UTCTime -> - Local UserId -> - Local StoredConversation -> - JoinType -> - Sem r () -registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do - let c = tUnqualified lc - rc = toConversationCreated now lusr c - allRemoteMembers = nubOrd c.remoteMembers - allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers - allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> - void $ fedClient @'Brig @"api-version" () - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ - \rrms -> - fedClient @'Galley @"on-conversation-created" - ( rc - { nonCreatorMembers = - toMembers (tUnqualified rrms) - } - ) - - let joined :: [Remote [RemoteMember]] = allRemoteBuckets - joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] - joinedCoupled = - foldMap - ( \ruids -> - let nj = - foldMap (fmap (.id_) . tUnqualified) $ - filter (\r -> tDomain r /= tDomain ruids) joined - in case NE.nonEmpty nj of - Nothing -> [] - Just v -> [fmap (,v) ruids] - ) - joined - - void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> - makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle - where - creator :: Maybe UserId - creator = Public.cnvmCreator . (.metadata) . tUnqualified $ lc - - localNonCreators :: [Public.OtherMember] - localNonCreators = - fmap (localMemberToOther . tDomain $ lc) - . filter (\lm -> lm.id_ `notElem` creator) - . (.localMembers) - . tUnqualified - $ lc - - toMembers :: [RemoteMember] -> Set Public.OtherMember - toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs - - convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate - convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = - ConversationUpdate - { time = now, - origUserId = tUntagged lusr, - convId = (tUnqualified lc).id_, - alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, - action = - SomeConversationAction - (sing @'ConversationJoinTag) - (Public.ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), - extraConversationData = def - } - - deleteOnUnreachable :: - ( Member ConvStore.ConversationStore r, - Member (Error UnreachableBackends) r, - Member TinyLog r - ) => - Sem r a -> - Sem r a - deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do - P.err . msg $ - val "Unreachable backend when notifying" - +++ val "error" - +++ (LT.pack . show $ e) - ConvStore.deleteConversation (tUnqualified lc).id_ - throw e - -notifyCreatedConversation :: - ( Member ConvStore.ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - NS.pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == Public.RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = [localMemberToRecipient m], - isCellsEvent = False, - route, - conn - } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs deleted file mode 100644 index cf4837fb6b8..00000000000 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} - -module Wire.ConversationSubsystem.Notification where - -import Data.Bifunctor -import Data.Default -import Data.Id -import Data.Json.Util -import Data.List.Extra (nubOrd) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Qualified -import Data.Set qualified as Set -import Data.Singletons -import Data.Time -import Galley.Types.Error (InternalError) -import Imports -import Network.AMQP qualified as Q -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import Wire.API.Component (Component (..)) -import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) -import Wire.API.Conversation qualified as Public -import Wire.API.Conversation.Action -import Wire.API.Conversation.Protocol -import Wire.API.Conversation.Role -import Wire.API.Error.Galley (UnreachableBackends (..)) -import Wire.API.Event.Conversation -import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) -import Wire.API.Federation.API.Galley -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.API.Push.V2 qualified as PushV2 -import Wire.BackendNotificationQueueAccess -import Wire.ConversationStore -import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) -import Wire.ConversationSubsystem.View -import Wire.FederationAPIAccess -import Wire.FederationAPIAccess qualified as E -import Wire.NotificationSubsystem -import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now -import Wire.StoredConversation as Data - -toConversationCreated :: - UTCTime -> - Local UserId -> - StoredConversation -> - ConversationCreated ConvId -toConversationCreated now lusr StoredConversation {metadata = ConversationMetadata {..}, ..} = - ConversationCreated - { time = now, - origUserId = tUnqualified lusr, - cnvId = id_, - cnvType = cnvmType, - cnvAccess = cnvmAccess, - cnvAccessRoles = cnvmAccessRoles, - cnvName = cnvmName, - nonCreatorMembers = Set.empty, - messageTimer = cnvmMessageTimer, - receiptMode = cnvmReceiptMode, - protocol = protocol, - groupConvType = cnvmGroupConvType, - channelAddPermission = cnvmChannelAddPermission - } - -fromConversationCreated :: - Local x -> - ConversationCreated (Remote ConvId) -> - [(Public.Member, Public.OwnConversation)] -fromConversationCreated loc rc@ConversationCreated {..} = - let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers - creatorOther = - OtherMember - (tUntagged (ccRemoteOrigUserId rc)) - Nothing - roleNameWireAdmin - in foldMap - ( \(me, others) -> - guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) - ) - membersView - where - inDomain :: OtherMember -> Bool - inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId - setHoles :: (Ord a) => Set a -> [(a, Set a)] - setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s - toMember :: OtherMember -> Public.Member - toMember m = - Public.Member - { memId = Public.omQualifiedId m, - memService = Public.omService m, - memOtrMutedStatus = Nothing, - memOtrMutedRef = Nothing, - memOtrArchived = False, - memOtrArchivedRef = Nothing, - memHidden = False, - memHiddenRef = Nothing, - memConvRoleName = Public.omConvRoleName m - } - conv :: Public.Member -> [OtherMember] -> Public.OwnConversation - conv this others = - Public.OwnConversation - (tUntagged cnvId) - ConversationMetadata - { cnvmType = cnvType, - cnvmCreator = Just origUserId, - cnvmAccess = cnvAccess, - cnvmAccessRoles = cnvAccessRoles, - cnvmName = cnvName, - cnvmTeam = Nothing, - cnvmMessageTimer = messageTimer, - cnvmReceiptMode = receiptMode, - cnvmGroupConvType = groupConvType, - cnvmChannelAddPermission = channelAddPermission, - cnvmCellsState = def, - cnvmParent = Nothing - } - (OwnConvMembers this others) - ProtocolProteus - -registerRemoteConversationMemberships :: - ( Member ConversationStore r, - Member (Error UnreachableBackends) r, - Member (Error FederationError) r, - Member BackendNotificationQueueAccess r, - Member (FederationAPIAccess FederatorClient) r - ) => - UTCTime -> - Local UserId -> - Local StoredConversation -> - JoinType -> - Sem r () -registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do - let c = tUnqualified lc - rc = toConversationCreated now lusr c - allRemoteMembers = nubOrd c.remoteMembers - allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers - allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> - void $ fedClient @'Brig @"api-version" () - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ - \rrms -> - fedClient @'Galley @"on-conversation-created" - ( rc - { nonCreatorMembers = - toMembers (tUnqualified rrms) - } - ) - - let joined :: [Remote [RemoteMember]] = allRemoteBuckets - joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] - joinedCoupled = - foldMap - ( \ruids -> - let nj = - foldMap (fmap (.id_) . tUnqualified) $ - filter (\r -> tDomain r /= tDomain ruids) joined - in case NE.nonEmpty nj of - Nothing -> [] - Just v -> [fmap (,v) ruids] - ) - joined - - void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> - makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle - where - creator :: Maybe UserId - creator = cnvmCreator . (.metadata) . tUnqualified $ lc - - localNonCreators :: [OtherMember] - localNonCreators = - fmap (localMemberToOther . tDomain $ lc) - . filter (\lm -> lm.id_ `notElem` creator) - . (.localMembers) - . tUnqualified - $ lc - - toMembers :: [RemoteMember] -> Set OtherMember - toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs - - convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate - convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = - ConversationUpdate - { time = now, - origUserId = tUntagged lusr, - convId = (tUnqualified lc).id_, - alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, - action = - SomeConversationAction - (sing @'ConversationJoinTag) - (ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), - extraConversationData = def - } - - deleteOnUnreachable :: - ( Member ConversationStore r, - Member (Error UnreachableBackends) r - ) => - Sem r a -> - Sem r a - deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do - deleteConversation (tUnqualified lc).id_ - throw e - -notifyCreatedConversation :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = [localMemberToRecipient m], - isCellsEvent = False, - route, - conn - } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 63370a7223e..bba97428e16 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -49,7 +49,6 @@ import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.TinyLog qualified as P import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -67,7 +66,6 @@ import Wire.API.Federation.Error import Wire.API.Federation.Version import Wire.API.MLS.Group.Serialisation import Wire.API.Push.V2 qualified as PushV2 -import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Util import Wire.API.Team.Collaborator import Wire.API.Team.Collaborator qualified as CollaboratorPermission (CollaboratorPermission (..)) @@ -85,7 +83,6 @@ import Wire.CodeStore.Code as DataTypes import Wire.ConversationStore import Wire.ConversationSubsystem.Federation import Wire.ConversationSubsystem.Types -import Wire.ConversationSubsystem.View import Wire.Effects.ClientStore import Wire.ExternalAccess import Wire.FederationAPIAccess @@ -1127,15 +1124,6 @@ ensureMemberLimit _ old new = do when (length old + length new > maxSize) $ throwS @'TooManyMembers -conversationExisted :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse OwnConversation) -conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv - getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 80cfd1d87e9..9046c667d8a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -243,14 +243,11 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem - Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Interpreter - Wire.ConversationSubsystem.Notification Wire.ConversationSubsystem.One2One Wire.ConversationSubsystem.Types Wire.ConversationSubsystem.Util - Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 2b73310cbc5..b5d7957a945 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -42,6 +42,7 @@ library , exceptions , extended , extra + , galley , galley-types , hasql-pool , HsOpenSSL @@ -57,6 +58,7 @@ library , retry , servant-client , servant-server + , tagged , text , tinylog , transformers diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 58beb333294..68ff627096c 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -16,6 +16,7 @@ , extended , extra , federator +, galley , galley-types , gitignoreSource , hasql-pool @@ -39,6 +40,7 @@ , servant-client , servant-client-core , servant-server +, tagged , text , tinylog , transformers @@ -69,6 +71,7 @@ mkDerivation { exceptions extended extra + galley galley-types hasql-pool HsOpenSSL @@ -84,6 +87,7 @@ mkDerivation { retry servant-client servant-server + tagged text tinylog transformers diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 324e5d8f9ce..744329e3fae 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,9 +22,12 @@ where import Data.Id 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, internalErrorDescription) +import Galley.API.Teams.Features.Get (getAllTeamFeaturesForServer) +import Galley.Types.Error (InternalError, InvalidInput, internalErrorDescription) +import Galley.Types.Teams (FeatureDefaults (FeatureLegalHoldDisabledPermanently), FeatureFlags) import Hasql.Pool (UsageError) import Imports import Polysemy @@ -35,7 +38,9 @@ import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger as Logger import Wire.API.BackgroundJobs (Job (..)) +import Wire.API.Error.Galley import Wire.API.Federation.Error (FederationError) +import Wire.API.Team.Collaborator (TeamCollaboratorsError) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BackgroundJobsRunner (runJob) @@ -45,11 +50,15 @@ import Wire.BrigAPIAccess.Rpc import Wire.ConversationStore import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..), interpretConversationSubsystem) import Wire.ExternalAccess.External +import Wire.FeaturesConfigSubsystem.Interpreter (runFeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist (..)) import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) import Wire.FireAndForget (interpretFireAndForget) import Wire.GundeckAPIAccess +import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) +import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.NotificationSubsystem.Interpreter import Wire.ParseException import Wire.Rpc @@ -61,6 +70,13 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now.IO (nowToIO) import Wire.Sem.Random.IO (randomToIO) import Wire.ServiceStore.Cassandra (interpretServiceStoreToCassandra) +import Wire.SparAPIAccess.Rpc (interpretSparAPIAccessToRpc) +import Wire.TeamCollaboratorsStore.Postgres (interpretTeamCollaboratorsStoreToPostgres) +import Wire.TeamCollaboratorsSubsystem.Interpreter (interpretTeamCollaboratorsSubsystem) +import Wire.TeamFeatureStore.Cassandra (TeamFeatureStoreError, interpretTeamFeatureStoreToCassandra) +import Wire.TeamJournal.Aws (interpretTeamJournal) +import Wire.TeamStore.Cassandra (interpretTeamStoreToCassandra) +import Wire.TeamSubsystem.Interpreter (TeamSubsystemConfig (..), interpretTeamSubsystem) import Wire.UserGroupStore.Postgres (interpretUserGroupStoreToPostgres) import Wire.UserStore.Cassandra (interpretUserStoreCassandra) @@ -84,6 +100,15 @@ dispatchJob job = do http2Manager = env.http2Manager, requestId = job.requestId } + conversationSubsystemConfig = + ConversationSubsystemConfig + { mlsKeys = Nothing, + federationProtocols = Nothing, + legalholdDefaults = FeatureLegalHoldDisabledPermanently, + maxConvSize = 1000 + } + teamSubsystemConfig = TeamSubsystemConfig {concurrentDeletionEvents = 1} + legalHoldEnv = LegalHoldEnv (\_ _ _ -> pure (error "LegalHoldEnv")) (\_ _ _ -> pure (error "LegalHoldEnv")) runFinal @IO . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO @@ -94,29 +119,61 @@ dispatchJob job = do . 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 @NonFederatingBackends (T.pack . show) + . mapError @TeamCollaboratorsError (const ("Team collaborators error" :: Text)) + . mapError @TeamFeatureStoreError (const ("Team feature store error" :: 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)) . interpretTinyLog env job.requestId job.jobId . runInputConst env.hasqlPool . runInputConst (toLocalUnsafe env.federationDomain ()) + . runInputConst conversationSubsystemConfig + . runInputConst (error "FeatureFlags" :: FeatureFlags) + . runInputConst (FeatureLegalHoldDisabledPermanently) + . runInputConst env.cassandraGalley + . runInputConst legalHoldEnv + . runInputConst (ExposeInvitationURLsAllowlist []) . interpretServiceStoreToCassandra env.cassandraBrig . interpretUserStoreCassandra env.cassandraBrig . interpretUserGroupStoreToPostgres + . interpretTeamFeatureStoreToCassandra + . convStoreInterpreter env + . interpretTeamStoreToCassandra + . interpretTeamCollaboratorsStoreToPostgres + . interpretLegalHoldStoreToCassandra FeatureLegalHoldDisabledPermanently + . interpretTeamJournal Nothing . interpretBackgroundJobsPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel . nowToIO . randomToIO . interpretFireAndForget . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess (Just $ backendQueueEnv env) - . convStoreInterpreter env . runRpcWithHttp env.httpManager job.requestId . runGundeckAPIAccess env.gundeckEndpoint - -- FUTUREWORK: Currently the brig access effect is needed for the interpreter of ExternalAccess. - -- At the time of implementation the only function used from ExternalAccess is deliverAsync, which will not call brig access. - -- However, to prevent the background worker to require HTTP access to brig, we should consider refactoring this at some point. . interpretBrigAccess env.brigEndpoint . interpretExternalAccess extEnv + . interpretSparAPIAccessToRpc (error "Spar endpoint") . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) . interpretFederationAPIAccess federationAPIAccessConfig + . interpretTeamSubsystem teamSubsystemConfig + . runFeaturesConfigSubsystem + . runInputSem getAllTeamFeaturesForServer + . interpretTeamCollaboratorsSubsystem . interpretConversationSubsystem . interpretBackgroundJobsRunner diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index eefbd7301cb..51a51c6e3a8 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -152,6 +152,7 @@ library Galley.External.LegalHoldService.Internal Galley.Intra.Util Galley.Keys + Galley.Mapping Galley.Monad Galley.Options Galley.Queue diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index b47da28fcb6..875b07026a1 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -50,6 +50,8 @@ import Galley.API.Message import Galley.API.Push import Galley.App import Galley.Effects +import Galley.Mapping +import Galley.Mapping qualified as Mapping import Galley.Options import Galley.Types.Conversations.One2One import Galley.Types.Error @@ -95,8 +97,6 @@ import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View -import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FireAndForget qualified as E import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 9e090d3e5e2..15837d04c13 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -41,6 +41,7 @@ import Galley.API.Clients qualified as Clients import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts import Galley.API.MLS.Removal +import Galley.API.Public.Conversation qualified as Public import Galley.API.Public.Servant import Galley.API.Query qualified as Query import Galley.API.Teams @@ -89,7 +90,6 @@ import Wire.ConversationStore import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util @@ -115,7 +115,7 @@ internalAPI = hoistAPI @InternalAPIBase Imports.id $ mkNamedAPI @"status" (pure ()) <@> mkNamedAPI @"delete-user" rmUser - <@> mkNamedAPI @"connect" Create.createConnectConversation + <@> mkNamedAPI @"connect" Public.createConnectConversation <@> mkNamedAPI @"get-conversation-clients" iGetMLSClientListForConv <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH <@> legalholdWhitelistedTeamsAPI diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index aa05d3bc25a..4a3c3d8e9c8 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,16 +22,44 @@ module Galley.API.Public.Conversation where +import Data.Default +import Data.Id +import Data.Json.Util (ToJSONObject (toJSONObject)) +import Data.Qualified import Galley.API.MLS.GroupInfo import Galley.API.MLS.SubConversation import Galley.API.Query import Galley.API.Update import Galley.App +import Galley.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 (UnreachableBackends) +import Wire.API.Event.Conversation +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem.Create +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Interpreter qualified as Interpreter +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationAPIAccess qualified as E +import Wire.NotificationSubsystem (NotificationSubsystem) +import Wire.NotificationSubsystem qualified as NS +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredConversation (StoredConversation, localMemberToOther, remoteMemberToOther) +import Wire.StoredConversation qualified as Data conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = @@ -101,3 +134,187 @@ conversationAPI = <@> mkNamedAPI @"update-conversation-self" updateSelfMember <@> mkNamedAPI @"update-conversation-protocol" updateConversationProtocolWithLocalUser <@> mkNamedAPI @"update-channel-add-permission" updateChannelAddPermission + +---------------------------------------------------------------------------- +-- API Handlers + +createGroupConversationUpToV3 :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createGroupConversationUpToV3 lusr conn newConv = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + conversationCreated lusr dbConv + +createGroupOwnConversation :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + conv <- conversationViewV9 lusr dbConv + pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty + +createGroupConversation :: + (Member ConversationSubsystem.ConversationSubsystem r) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + 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 (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr + if created + then conversationCreated lusr c + else conversationExisted lusr c + +createOne2OneConversation :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess 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 conversationCreated lusr c + else conversationExisted lusr c + +---------------------------------------------------------------------------- +-- Helpers + +conversationCreated :: + ( Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationCreated lusr cnv = do + unless (Data.convType cnv == Public.SelfConv) $ do + notifyCreatedConversation lusr Nothing cnv def + Created <$> conversationViewV9 lusr cnv + +conversationExisted :: + ( Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + Interpreter.registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + NS.pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == Public.RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + NS.Push + { NS.origin = Just (tUnqualified lusr), + NS.json = toJSONObject e, + NS.recipients = [NS.userRecipient m.id_], + NS.isCellsEvent = False, + NS.route = route, + NS.conn = conn, + NS.transient = False, + NS.nativePriority = Nothing, + NS.apsData = Nothing + } + +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 <- ConversationSubsystem.createConnectConversation lusr conn j + conversationExisted lusr c diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 94ecae59804..5c5b08a8b8e 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -72,6 +72,8 @@ import Galley.API.MLS.One2One import Galley.API.Teams.Features.Get import Galley.Effects import Galley.Env +import Galley.Mapping +import Galley.Mapping qualified as Mapping import Galley.Types.Error import Imports import Polysemy @@ -108,8 +110,6 @@ import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View -import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess qualified as E import Wire.HashPassword (HashPassword) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index f0d8bb0826d..3f70edcb809 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -96,6 +96,7 @@ import Galley.API.Query qualified as Query import Galley.API.Teams.Features.Get import Galley.App import Galley.Effects +import Galley.Mapping import Galley.Options import Galley.Types.Error import Galley.Types.Teams (FanoutLimit) @@ -136,7 +137,6 @@ import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View import Wire.Effects.ClientStore qualified as E import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 611814c3563..340df91dc0f 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -100,6 +100,7 @@ import System.Logger.Extended qualified as Logger import UnliftIO.Exception qualified as UnliftIO import Wire.API.Conversation.Protocol import Wire.API.Error +import Wire.API.Error.Galley (NonFederatingBackends, UnreachableBackends) import Wire.API.Federation.Error import Wire.API.Team.Collaborator import Wire.API.Team.Feature @@ -155,9 +156,9 @@ type GalleyEffects0 = Error InvalidInput, Error ParseException, Error InternalError, - -- federation errors can be thrown by almost every endpoint, so we avoid - -- having to declare it every single time, and simply handle it here Error FederationError, + Error UnreachableBackends, + Error NonFederatingBackends, Error TeamCollaboratorsError, Error Hasql.UsageError, Error HttpError, @@ -346,6 +347,8 @@ evalGalley e = . mapError toResponse . mapError toResponse . mapError toResponse + . mapError toResponse + . mapError toResponse . logAndMapError toResponse (Text.pack . show) "migration error" . mapError mapTeamFeatureStoreError . runInputConst conversationSubsystemConfig @@ -354,6 +357,18 @@ evalGalley e = . runInputConst (e ^. cstate) . mapError toResponse . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse . mapError rateLimitExceededToHttpError . mapError toResponse -- DynError . interpretQueue (e ^. deleteQueue) @@ -400,8 +415,8 @@ evalGalley e = . interpretTeamSubsystem teamSubsystemConfig . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer - . interpretConversationSubsystem . interpretTeamCollaboratorsSubsystem + . interpretConversationSubsystem where lh = view (options . settings . featureFlags . to npProject) e legalHoldEnv = diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index a401fffb157..7d1b9c5d48f 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -115,8 +115,8 @@ import Wire.UserGroupStore -- All the possible high-level effects. type GalleyEffects1 = - '[ TeamCollaboratorsSubsystem, - ConversationSubsystem, + '[ ConversationSubsystem, + TeamCollaboratorsSubsystem, Input AllTeamFeatures, FeaturesConfigSubsystem, TeamSubsystem, @@ -164,5 +164,17 @@ type GalleyEffects1 = Error DynError, Error RateLimitExceeded, ErrorS OperationDenied, - ErrorS 'NotATeamMember + ErrorS 'NotATeamMember, + ErrorS 'ConvAccessDenied, + ErrorS 'NotConnected, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSNonEmptyMemberList, + ErrorS 'MissingLegalholdConsent, + ErrorS 'NonBindingTeam, + ErrorS 'NoBindingTeamMembers, + ErrorS 'TeamNotFound, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ChannelsNotEnabled, + ErrorS 'NotAnMlsConversation ] diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/services/galley/src/Galley/Mapping.hs similarity index 99% rename from libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs rename to services/galley/src/Galley/Mapping.hs index e6a71cf0d95..6998387c53c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs +++ b/services/galley/src/Galley/Mapping.hs @@ -1,4 +1,4 @@ -module Wire.ConversationSubsystem.View where +module Galley.Mapping where import Data.Domain (Domain) import Data.Id (UserId, idToText) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index f527d520caf..61ff020370c 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -66,6 +66,7 @@ import Data.Text.Ascii qualified as Ascii import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer hiding (status) +import Galley.Mapping import Galley.Options (federator, rabbitmq) import Imports hiding (id) import Imports qualified as I @@ -104,7 +105,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.View import Wire.StoredConversation hiding (convName) tests :: IO TestSetup -> TestTree diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index 722f6525582..58062ba379b 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,6 +25,7 @@ import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set +import Galley.Mapping import Galley.Types.Error (InternalError) import Imports import Polysemy (Sem) @@ -40,7 +41,6 @@ import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), RemoteConversationV2 (..), ) -import Wire.ConversationSubsystem.View import Wire.Sem.Logger qualified as P import Wire.StoredConversation From 9c92dcc594e73f8a0a3d8f7c4fe9de4f72ee4b05 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 27 Jan 2026 10:14:11 +0100 Subject: [PATCH 05/11] refactor: try to reduce PR size --- .../Wire/ConversationSubsystem/Interpreter.hs | 6 +- .../background-worker/background-worker.cabal | 1 - services/background-worker/default.nix | 2 - .../Wire/BackgroundWorker/Jobs/Registry.hs | 5 +- services/galley/galley.cabal | 3 +- services/galley/src/Galley/API/Create.hs | 238 ++++++++++++++++++ services/galley/src/Galley/API/Federation.hs | 4 +- services/galley/src/Galley/API/Internal.hs | 4 +- .../galley/src/Galley/{ => API}/Mapping.hs | 43 +++- .../src/Galley/API/Public/Conversation.hs | 215 +--------------- services/galley/src/Galley/API/Query.hs | 4 +- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/test/integration/API.hs | 2 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 14 files changed, 298 insertions(+), 233 deletions(-) create mode 100644 services/galley/src/Galley/API/Create.hs rename services/galley/src/Galley/{ => API}/Mapping.hs (71%) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 1afc4817df5..9083de3e01a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -6,7 +6,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -351,9 +350,8 @@ createConversationImpl :: Local UserId -> Data.NewConversation -> Sem r StoredConversation -createConversationImpl lconv _lusr nc = do - storedConv <- ConvStore.upsertConversation lconv nc - pure storedConv +createConversationImpl lconv _lusr = + ConvStore.upsertConversation lconv createConnectConversationLogic :: ( Member ConversationStore r, diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index b5d7957a945..36a43859ddb 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -42,7 +42,6 @@ library , exceptions , extended , extra - , galley , galley-types , hasql-pool , HsOpenSSL diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 68ff627096c..539e391c276 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -16,7 +16,6 @@ , extended , extra , federator -, galley , galley-types , gitignoreSource , hasql-pool @@ -71,7 +70,6 @@ mkDerivation { exceptions extended extra - galley galley-types hasql-pool HsOpenSSL diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 744329e3fae..3ce7684df64 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -25,7 +25,6 @@ import Data.Qualified import Data.Tagged (Tagged) import Data.Text qualified as T import Data.Text.Lazy qualified as TL -import Galley.API.Teams.Features.Get (getAllTeamFeaturesForServer) import Galley.Types.Error (InternalError, InvalidInput, internalErrorDescription) import Galley.Types.Teams (FeatureDefaults (FeatureLegalHoldDisabledPermanently), FeatureFlags) import Hasql.Pool (UsageError) @@ -52,6 +51,7 @@ import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..), 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) @@ -165,6 +165,9 @@ dispatchJob job = do . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess (Just $ backendQueueEnv env) . runRpcWithHttp env.httpManager job.requestId . runGundeckAPIAccess env.gundeckEndpoint + -- FUTUREWORK: Currently the brig access effect is needed for the interpreter of ExternalAccess. + -- At the time of implementation the only function used from ExternalAccess is deliverAsync, which will not call brig access. + -- However, to prevent the background worker to require HTTP access to brig, we should consider refactoring this at some point. . interpretBrigAccess env.brigEndpoint . interpretExternalAccess extEnv . interpretSparAPIAccessToRpc (error "Spar endpoint") diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 51a51c6e3a8..f6d0cb8507f 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -79,6 +79,7 @@ library Galley.API.Action.Notify Galley.API.Action.Reset Galley.API.Clients + Galley.API.Create Galley.API.CustomBackend Galley.API.Federation Galley.API.Internal @@ -86,6 +87,7 @@ library Galley.API.LegalHold.Conflicts Galley.API.LegalHold.Get Galley.API.LegalHold.Team + Galley.API.Mapping Galley.API.Message Galley.API.MLS Galley.API.MLS.CheckClients @@ -152,7 +154,6 @@ library Galley.External.LegalHoldService.Internal Galley.Intra.Util Galley.Keys - Galley.Mapping Galley.Monad Galley.Options Galley.Queue diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs new file mode 100644 index 00000000000..3c8e8e2a9d8 --- /dev/null +++ b/services/galley/src/Galley/API/Create.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- 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.Default +import Data.Id +import Data.Json.Util (ToJSONObject (toJSONObject)) +import Data.Qualified +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 (UnreachableBackends) +import Wire.API.Event.Conversation +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as PushV2 +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Interpreter qualified as Interpreter +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationAPIAccess qualified as E +import Wire.NotificationSubsystem (NotificationSubsystem) +import Wire.NotificationSubsystem qualified as NS +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredConversation (StoredConversation, localMemberToOther, remoteMemberToOther) +import Wire.StoredConversation qualified as Data + +---------------------------------------------------------------------------- +-- API Handlers + +createGroupConversationUpToV3 :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createGroupConversationUpToV3 lusr conn newConv = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + conversationCreated lusr dbConv + +createGroupOwnConversation :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + conv <- conversationViewV9 lusr dbConv + pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty + +createGroupConversation :: + (Member ConversationSubsystem.ConversationSubsystem r) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + 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 (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr + if created + then conversationCreated lusr c + else conversationExisted lusr c + +createOne2OneConversation :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess 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 conversationCreated lusr c + else conversationExisted lusr c + +---------------------------------------------------------------------------- +-- Helpers + +conversationCreated :: + ( Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationCreated lusr cnv = do + unless (Data.convType cnv == Public.SelfConv) $ do + notifyCreatedConversation lusr Nothing cnv def + Created <$> conversationViewV9 lusr cnv + +conversationExisted :: + ( Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + Interpreter.registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + NS.pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == Public.RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + NS.Push + { NS.origin = Just (tUnqualified lusr), + NS.json = toJSONObject e, + NS.recipients = [NS.userRecipient m.id_], + NS.isCellsEvent = False, + NS.route = route, + NS.conn = conn, + NS.transient = False, + NS.nativePriority = Nothing, + NS.apsData = Nothing + } + +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 <- ConversationSubsystem.createConnectConversation lusr conn j + conversationExisted lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 875b07026a1..d370bbfc230 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -46,12 +46,12 @@ 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.API.Push import Galley.App import Galley.Effects -import Galley.Mapping -import Galley.Mapping qualified as Mapping import Galley.Options import Galley.Types.Conversations.One2One import Galley.Types.Error diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 15837d04c13..179d74c8d54 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,10 +38,10 @@ 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.Conversation qualified as Public import Galley.API.Public.Servant import Galley.API.Query qualified as Query import Galley.API.Teams @@ -115,7 +115,7 @@ internalAPI = hoistAPI @InternalAPIBase Imports.id $ mkNamedAPI @"status" (pure ()) <@> mkNamedAPI @"delete-user" rmUser - <@> mkNamedAPI @"connect" Public.createConnectConversation + <@> mkNamedAPI @"connect" Create.createConnectConversation <@> mkNamedAPI @"get-conversation-clients" iGetMLSClientListForConv <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH <@> legalholdWhitelistedTeamsAPI diff --git a/services/galley/src/Galley/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs similarity index 71% rename from services/galley/src/Galley/Mapping.hs rename to services/galley/src/Galley/API/Mapping.hs index 6998387c53c..efdde3f0111 100644 --- a/services/galley/src/Galley/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -1,4 +1,29 @@ -module Galley.Mapping where +-- 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.Mapping + ( conversationViewV9, + conversationView, + conversationViewWithCachedOthers, + remoteConversationView, + conversationToRemote, + localMemberToSelf, + ) +where import Data.Domain (Domain) import Data.Id (UserId, idToText) @@ -14,6 +39,9 @@ import Wire.API.Conversation qualified as Conversation import Wire.API.Federation.API.Galley import Wire.StoredConversation +-- | View for a given user of a stored conversation. +-- +-- Throws @BadMemberState@ when the user is not part of the conversation. conversationViewV9 :: ( Member (Error InternalError) r, Member P.TinyLog r @@ -44,6 +72,9 @@ conversationView l luid conv = 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 @@ -65,6 +96,9 @@ conversationViewWithCachedOthers remoteOthers localOthers conv luid = do +++ 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 @@ -77,6 +111,7 @@ conversationViewMaybe luid remoteOthers localOthers conv = do (OwnConvMembers self others) conv.protocol +-- | View for a local user of a remote conversation. remoteConversationView :: Local UserId -> MemberStatus -> @@ -100,6 +135,10 @@ remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = (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 -> @@ -124,6 +163,8 @@ conversationToRemote localDomain ruid conv = do protocol = conv.protocol } +-- | Convert a local conversation member (as stored in the DB) to a publicly +-- facing 'Member' structure. localMemberToSelf :: Local x -> LocalMember -> Conversation.Member localMemberToSelf loc lm = Conversation.Member diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 4a3c3d8e9c8..faae87331a9 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TypeApplications #-} -- This file is part of the Wire Server implementation. @@ -22,44 +21,16 @@ module Galley.API.Public.Conversation where -import Data.Default -import Data.Id -import Data.Json.Util (ToJSONObject (toJSONObject)) -import Data.Qualified +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 Galley.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 (UnreachableBackends) -import Wire.API.Event.Conversation -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) -import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Interpreter qualified as Interpreter -import Wire.FederationAPIAccess (FederationAPIAccess) -import Wire.FederationAPIAccess qualified as E -import Wire.NotificationSubsystem (NotificationSubsystem) -import Wire.NotificationSubsystem qualified as NS -import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now -import Wire.StoredConversation (StoredConversation, localMemberToOther, remoteMemberToOther) -import Wire.StoredConversation qualified as Data conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = @@ -134,187 +105,3 @@ conversationAPI = <@> mkNamedAPI @"update-conversation-self" updateSelfMember <@> mkNamedAPI @"update-conversation-protocol" updateConversationProtocolWithLocalUser <@> mkNamedAPI @"update-channel-add-permission" updateChannelAddPermission - ----------------------------------------------------------------------------- --- API Handlers - -createGroupConversationUpToV3 :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - conversationCreated lusr dbConv - -createGroupOwnConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - conv <- conversationViewV9 lusr dbConv - pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty - -createGroupConversation :: - (Member ConversationSubsystem.ConversationSubsystem r) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - 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 (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr - if created - then conversationCreated lusr c - else conversationExisted lusr c - -createOne2OneConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess 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 conversationCreated lusr c - else conversationExisted lusr c - ----------------------------------------------------------------------------- --- Helpers - -conversationCreated :: - ( Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationCreated lusr cnv = do - unless (Data.convType cnv == Public.SelfConv) $ do - notifyCreatedConversation lusr Nothing cnv def - Created <$> conversationViewV9 lusr cnv - -conversationExisted :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv - -notifyCreatedConversation :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - Interpreter.registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - NS.pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == Public.RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - NS.Push - { NS.origin = Just (tUnqualified lusr), - NS.json = toJSONObject e, - NS.recipients = [NS.userRecipient m.id_], - NS.isCellsEvent = False, - NS.route = route, - NS.conn = conn, - NS.transient = False, - NS.nativePriority = Nothing, - NS.apsData = Nothing - } - -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 <- ConversationSubsystem.createConnectConversation lusr conn j - conversationExisted lusr c diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 5c5b08a8b8e..d8ccc7fb952 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -69,11 +69,11 @@ 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.Effects import Galley.Env -import Galley.Mapping -import Galley.Mapping qualified as Mapping import Galley.Types.Error import Imports import Polysemy diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 3f70edcb809..a3f3f4f51cf 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,12 +91,12 @@ 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.Effects -import Galley.Mapping import Galley.Options import Galley.Types.Error import Galley.Types.Teams (FanoutLimit) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 61ff020370c..313f11f0f55 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -66,7 +66,7 @@ import Data.Text.Ascii qualified as Ascii import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer hiding (status) -import Galley.Mapping +import Galley.API.Mapping import Galley.Options (federator, rabbitmq) import Imports hiding (id) import Imports qualified as I diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index 58062ba379b..b73a27c17b4 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,7 +25,7 @@ import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.Mapping +import Galley.API.Mapping import Galley.Types.Error (InternalError) import Imports import Polysemy (Sem) From 4f6003a09461181f2e5035d7f4bae7c57f7b71ca Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 27 Jan 2026 14:19:09 +0100 Subject: [PATCH 06/11] Revert last 2 commits, is the CI alive? This reverts commit d8127971f5cdc9e2c02fff8d1b96d349015504a2. --- .../src/Wire/ConversationSubsystem.hs | 21 +- .../src/Wire/ConversationSubsystem/Create.hs | 862 ++++++++++++++ .../Wire/ConversationSubsystem/Interpreter.hs | 1001 +++++------------ .../ConversationSubsystem/Notification.hs | 256 +++++ .../src/Wire/ConversationSubsystem/Util.hs | 12 + .../src/Wire/ConversationSubsystem/View.hs | 43 +- libs/wire-subsystems/wire-subsystems.cabal | 3 + .../background-worker/background-worker.cabal | 1 - services/background-worker/default.nix | 2 - .../Wire/BackgroundWorker/Jobs/Registry.hs | 66 +- services/galley/galley.cabal | 2 - services/galley/src/Galley/API/Create.hs | 238 ---- services/galley/src/Galley/API/Federation.hs | 4 +- services/galley/src/Galley/API/Internal.hs | 2 +- .../src/Galley/API/Public/Conversation.hs | 6 +- services/galley/src/Galley/API/Query.hs | 4 +- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/src/Galley/App.hs | 21 +- services/galley/src/Galley/Effects.hs | 18 +- services/galley/test/integration/API.hs | 2 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 21 files changed, 1440 insertions(+), 1128 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs rename services/galley/src/Galley/API/Mapping.hs => libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs (71%) delete mode 100644 services/galley/src/Galley/API/Create.hs diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 5c961df950e..a84b8a2a98a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -24,7 +24,7 @@ import Data.Qualified import Data.Singletons (Sing) import Imports import Polysemy -import Wire.API.Conversation (ExtraConversationData, NewConv, NewOne2OneConv) +import Wire.API.Conversation (ExtraConversationData) import Wire.API.Conversation.Action import Wire.API.Event.Conversation import Wire.NotificationSubsystem (LocalConversationUpdate) @@ -43,23 +43,10 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate - CreateGroupConversation :: + CreateConversation :: + Local ConvId -> Local UserId -> - Maybe ConnId -> - NewConv -> - ConversationSubsystem m StoredConversation - CreateOne2OneConversation :: - Local UserId -> - ConnId -> - NewOne2OneConv -> - ConversationSubsystem m (StoredConversation, Bool) - CreateProteusSelfConversation :: - Local UserId -> - ConversationSubsystem m (StoredConversation, Bool) - CreateConnectConversation :: - Local UserId -> - Maybe ConnId -> - Connect -> + NewConversation -> ConversationSubsystem m StoredConversation makeSem ''ConversationSubsystem 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..c49dba47a9d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -0,0 +1,862 @@ +-- 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 . +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE DataKinds #-} + +module Wire.ConversationSubsystem.Create + ( createGroupConversationUpToV3, + createGroupOwnConversation, + createProteusSelfConversation, + createOne2OneConversation, + createConnectConversation, + createGroupConversation, + ) +where + +import Control.Error (headMay) +import Control.Lens hiding ((??)) +import Data.Default +import Data.Id (ConnId, ConvId, Id (toUUID), TeamId, UserId) +import Data.Misc (FutureWork (FutureWork)) +import Data.Qualified +import Data.Range +import Data.Set qualified as Set +import Data.UUID.Tagged qualified as U +import GHC.TypeNats +import Galley.Types.Error +import Galley.Types.Teams (notTeamMember) +import Imports hiding ((\\)) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.CellsState +import Wire.API.Conversation.Role +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 +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util +import Wire.API.Team +import Wire.API.Team.Collaborator qualified as CollaboratorPermission +import Wire.API.Team.Feature +import Wire.API.Team.Feature qualified as Conf +import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) +import Wire.API.Team.Member +import Wire.API.Team.Permission hiding (self) +import Wire.API.User +import Wire.BrigAPIAccess +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Federation +import Wire.ConversationSubsystem.One2One +import Wire.ConversationSubsystem.Types +import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View +import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.LegalHoldStore (LegalHoldStore) +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.Sem.Random (Random) +import Wire.Sem.Random qualified as Random +import Wire.StoredConversation hiding (convTeam, localOne2OneConvId) +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 qualified as TeamSubsystem +import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) + +---------------------------------------------------------------------------- +-- Group conversations + +-- | The public-facing endpoint for creating group conversations in the client +-- API up to and including version 3. +createGroupConversationUpToV3 :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InternalError) 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 (Error UnreachableBackendsLegacy) r, + Member LegalHoldStore r, + Member TeamStore r, + Member P.TinyLog r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member (Input ConversationSubsystemConfig) r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createGroupConversationUpToV3 lusr conn newConv = + mapError UnreachableBackendsLegacy $ + createGroupConversationGeneric lusr conn newConv + >>= conversationCreated lusr + +-- | The public-facing endpoint for creating group conversations in the client +-- API in from version 4 to 8 +createGroupOwnConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (Error NonFederatingBackends) 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 (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member P.TinyLog r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + createGroupConvAndMkResponse + lusr + conn + newConv + ( \dbConv -> do + conv <- conversationViewV9 lusr dbConv + pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty + ) + +-- | The public-facing endpoint for creating group conversations in the client +-- API in version 9 and above. +createGroupConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (Error NonFederatingBackends) 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 (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + createGroupConvAndMkResponse + lusr + conn + newConv + ( \dbConv -> + pure $ + CreateGroupConversation + { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, + failedToAdd = mempty + } + ) + +createGroupConvAndMkResponse :: + ( Member (ErrorS OperationDenied) r, + Member (ErrorS ConvAccessDenied) r, + Member (ErrorS NotATeamMember) 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 (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (FederationAPIAccess FederatorClient) r, + Member BrigAPIAccess r, + Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member (Input ConversationSubsystemConfig) r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + (StoredConversation -> Sem r b) -> + Sem r b +createGroupConvAndMkResponse lusr conn newConv mkResponse = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + mkResponse dbConv + +createGroupConversationGeneric :: + forall r. + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InternalError) 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 (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r StoredConversation +createGroupConversationGeneric lusr _conn newConv = do + (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv + checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers + ensureNoLegalholdConflicts allUsers + + when (newConvProtocol newConv == BaseProtocolMLSTag) $ do + -- Here we fail early in order to notify users of this misconfiguration + assertMLSEnabled + + lcnv <- traverse (const Random.newId) lusr + conv <- ConversationSubsystem.createConversation lcnv lusr nc + E.getConversation conv.id_ + >>= note (BadConvState conv.id_) + +ensureNoLegalholdConflicts :: + ( Member (ErrorS 'MissingLegalholdConsent) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member TeamSubsystem r + ) => + UserList UserId -> + Sem r () +ensureNoLegalholdConflicts (UserList locals remotes) = do + let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes + whenM (anyLegalholdActivated locals) $ + unlessM (allLegalholdConsentGiven locals) $ + throwS @'MissingLegalholdConsent + +checkCreateConvPermissions :: + ( Member BrigAPIAccess r, + Member (ErrorS 'ConvAccessDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS ChannelsNotEnabled) r, + Member (ErrorS NotAnMlsConversation) r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r + ) => + Local UserId -> + NewConv -> + Maybe ConvTeamInfo -> + UserList UserId -> + Sem r () +checkCreateConvPermissions lusr newConv Nothing allUsers = do + when (newConv.newConvGroupConvType == Channel) $ throwS @OperationDenied + activated <- listToMaybe <$> lookupActivatedUsers [tUnqualified lusr] + void $ noteS @OperationDenied activated + -- an external partner is not allowed to create group conversations (except 1:1 team conversations that are handled below) + tm <- getTeamMember (tUnqualified lusr) Nothing + for_ tm $ + permissionCheck AddRemoveConvMember . Just + ensureConnected lusr allUsers +checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do + let convTeam = cnvTeamId tinfo + mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam) + teamAssociation <- case mTeamMember of + Just tm -> pure (Just (Right tm)) + Nothing -> do + Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr) + + case newConv.newConvGroupConvType of + Channel -> do + ensureCreateChannelPermissions tinfo.cnvTeamId mTeamMember + GroupConversation -> do + void $ permissionCheck CreateConversation teamAssociation + -- In teams we don't have 1:1 conversations, only regular conversations. We want + -- users without the 'AddRemoveConvMember' permission to still be able to create + -- regular conversations, therefore we check for 'AddRemoveConvMember' only if + -- there are going to be more than two users in the conversation. + -- FUTUREWORK: We keep this permission around because not doing so will break backwards + -- compatibility in the sense that the team role 'partners' would be able to create group + -- conversations (which they should not be able to). + -- Not sure at the moment how to best solve this but it is unlikely + -- we can ever get rid of the team permission model anyway - the only thing I can + -- think of is that 'partners' can create convs but not be admins... + -- this only applies to proteus conversations, because in MLS we have proper 1:1 conversations, + -- so we don't allow an external partner to create an MLS group conversation at all + when (length allUsers > 1 || newConv.newConvProtocol == BaseProtocolMLSTag) $ do + void $ permissionCheck AddRemoveConvMember teamAssociation + + convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) + ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) + -- Team members are always considered to be connected, so we only check + -- 'ensureConnected' for non-team-members. + ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) + ensureConnectedToRemotes lusr (ulRemotes allUsers) + where + ensureCreateChannelPermissions :: + forall r. + ( Member (ErrorS OperationDenied) r, + Member FeaturesConfigSubsystem r, + Member (ErrorS NotATeamMember) r, + Member (ErrorS ChannelsNotEnabled) r, + Member (ErrorS NotAnMlsConversation) r + ) => + TeamId -> + Maybe TeamMember -> + Sem r () + ensureCreateChannelPermissions tid (Just tm) = do + channelsConf :: LockableFeature ChannelsConfig <- getFeatureForTeam tid + when (channelsConf.status == FeatureStatusDisabled) $ throwS @ChannelsNotEnabled + when (newConv.newConvProtocol /= BaseProtocolMLSTag) $ throwS @NotAnMlsConversation + case channelsConf.config.allowedToCreateChannels of + Conf.Everyone -> pure () + Conf.TeamMembers -> void $ permissionCheck AddRemoveConvMember $ Just tm + Conf.Admins -> unless (isAdminOrOwner (tm ^. permissions)) $ throwS @OperationDenied + ensureCreateChannelPermissions _ Nothing = do + throwS @NotATeamMember + +getTeamMember :: (Member TeamStore r, Member TeamSubsystem r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) +getTeamMember uid (Just tid) = TeamSubsystem.internalGetTeamMember uid tid +getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember uid) . headMay + +---------------------------------------------------------------------------- +-- Other kinds of conversations + +createProteusSelfConversation :: + forall r. + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + let lcnv = fmap Data.selfConv lusr + c <- E.getConversation (tUnqualified lcnv) + maybe (create lcnv) (conversationExisted lusr) c + where + create :: Local ConvId -> Sem r (ConversationResponse Public.OwnConversation) + create lcnv = do + let nc = + NewConversation + { metadata = (defConversationMetadata (Just (tUnqualified lusr))) {cnvmType = SelfConv}, + users = ulFromLocals [toUserRole (tUnqualified lusr)], + protocol = BaseProtocolProteusTag, + groupId = Nothing + } + ConversationSubsystem.createConversation lcnv lusr nc + >>= conversationCreated lusr + +createOne2OneConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'NotConnected) r, + Member (Error UnreachableBackendsLegacy) r, + Member TeamStore r, + Member P.TinyLog r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r + ) => + Local UserId -> + ConnId -> + NewOne2OneConv -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversation lusr zcon j = + mapError @UnreachableBackends @UnreachableBackendsLegacy UnreachableBackendsLegacy $ do + let allUsers = newOne2OneConvMembers lusr j + other <- ensureOne (ulAll lusr allUsers) + when (tUntagged lusr == other) $ + throwS @'InvalidOperation + mtid <- case j.team of + Just ti -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) + (const (pure Nothing)) + other + Nothing -> ensureConnected lusr allUsers $> Nothing + foldQualified + lusr + (createLegacyOne2OneConversationUnchecked lusr zcon j.name mtid) + (createOne2OneConversationUnchecked lusr zcon j.name mtid . tUntagged) + other + where + verifyMembership :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member TeamSubsystem r + ) => + TeamId -> + UserId -> + Sem r () + verifyMembership tid u = do + membership <- TeamSubsystem.internalGetTeamMember u tid + when (isNothing membership) $ + throwS @'NoBindingTeamMembers + checkBindingTeamPermissions :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamCollaboratorsSubsystem r, + Member TeamStore r, + Member TeamSubsystem r + ) => + Local UserId -> + TeamId -> + Sem r (Maybe TeamId) + checkBindingTeamPermissions lother tid = do + mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr) + zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid + case (mTeamCollaborator, zusrMembership) of + (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator + (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember + (Just collaborator, Just member) -> + unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $ + throwS @OperationDenied + TeamStore.getTeamBinding tid >>= \case + Just Binding -> do + when (isJust zusrMembership) $ + verifyMembership tid (tUnqualified lusr) + mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother) + unless (isJust mOtherTeamCollaborator) $ + verifyMembership tid (tUnqualified lother) + pure (Just tid) + Just _ -> throwS @'NonBindingTeam + Nothing -> throwS @'TeamNotFound + + guardPerm p m = + if m `hasPermission` p + then pure () + else throwS @OperationDenied + +createLegacyOne2OneConversationUnchecked :: + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member P.TinyLog r + ) => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do + lcnv <- localOne2OneConvId self other + let meta = + (defConversationMetadata (Just (tUnqualified self))) + { cnvmType = One2OneConv, + cnvmTeam = mtid, + cnvmName = fmap fromRange name + } + let nc = + NewConversation + { users = ulFromLocals (map (toUserRole . tUnqualified) [self, other]), + protocol = BaseProtocolProteusTag, + metadata = meta, + groupId = Nothing + } + mc <- E.getConversation (tUnqualified lcnv) + case mc of + Just c -> conversationExisted self c + Nothing -> do + ConversationSubsystem.createConversation lcnv self nc + >>= conversationCreated self + +createOne2OneConversationUnchecked :: + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversationUnchecked self zcon name mtid other = do + let create = + foldQualified + self + createOne2OneConversationLocally + createOne2OneConversationRemotely + create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other + +createOne2OneConversationLocally :: + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversationLocally lcnv self _zcon name mtid other = do + mc <- E.getConversation (tUnqualified lcnv) + case mc of + Just c -> conversationExisted self c + Nothing -> do + let meta = + (defConversationMetadata (Just (tUnqualified self))) + { cnvmType = One2OneConv, + cnvmTeam = mtid, + cnvmName = fmap fromRange name + } + let nc = + NewConversation + { metadata = meta, + users = fmap toUserRole (toUserList lcnv [tUntagged self, other]), + protocol = BaseProtocolProteusTag, + groupId = Nothing + } + ConversationSubsystem.createConversation lcnv self nc + >>= conversationCreated self + +createOne2OneConversationRemotely :: + (Member (Error FederationError) r) => + Remote ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversationRemotely _ _ _ _name _mtid _ = + throw FederationNotImplemented + +createConnectConversation :: + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, + Member (ErrorS 'ConvNotFound) r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (ErrorS 'InvalidOperation) r, + Member NotificationSubsystem r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Sem r (ConversationResponse Public.OwnConversation) +createConnectConversation lusr conn j = do + lrecipient <- ensureLocal lusr (cRecipient j) + n <- rangeCheckedMaybe (cName j) + let meta = + (defConversationMetadata (Just (tUnqualified lusr))) + { cnvmType = ConnectConv, + cnvmName = fmap fromRange n + } + lcnv <- localOne2OneConvId lusr lrecipient + let nc = + NewConversation + { -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + users = ulFromLocals ([(toUserRole . tUnqualified) lusr]), + protocol = BaseProtocolProteusTag, + metadata = meta, + groupId = Nothing + } + E.getConversation (tUnqualified lcnv) + >>= maybe (create lcnv nc) (update n) + where + create lcnv nc = do + c <- ConversationSubsystem.createConversation lcnv lusr nc + conversationCreated lusr c + update n conv = do + let mems = conv.localMembers + in conversationExisted lusr + =<< if tUnqualified lusr `isMember` mems + then -- we already were in the conversation, maybe also other + connect n conv + else do + let lcid = qualifyAs lusr conv.id_ + mm <- E.upsertMember lcid lusr + let conv' = + conv + { localMembers = conv.localMembers <> toList mm + } + if null mems + then do + -- the conversation was empty + connect n conv' + else do + -- we were not in the conversation, but someone else + conv'' <- acceptOne2One lusr conv' conn + if Data.convType conv'' == ConnectConv + then connect n conv'' + else pure conv'' + connect n conv + | Data.convType conv == ConnectConv = do + n' <- case n of + Just x -> do + E.setConversationName conv.id_ x + pure . Just $ fromRange x + Nothing -> pure $ Data.convName conv + notifyConversationUpdated lusr conn j conv + pure $ Data.convSetName n' conv + | otherwise = pure conv + +-------------------------------------------------------------------------------- +-- Conversation creation records + +-- | Return a 'NewConversation' record suitable for creating a group conversation. +newRegularConversation :: + ( Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS OperationDenied) r, + Member (Error InvalidInput) r, + Member (Input ConversationSubsystemConfig) r, + Member ConversationStore r + ) => + Local UserId -> + NewConv -> + Sem r (NewConversation, ConvSizeChecked UserList UserId) +newRegularConversation lusr newConv = do + cfg <- input + let uncheckedUsers = newConvMembers lusr newConv + forM_ newConv.newConvParent $ \parent -> do + mMembership <- E.getLocalMember parent (tUnqualified lusr) + when (isNothing mMembership) $ + throwS @OperationDenied + users <- case newConvProtocol newConv of + BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers + BaseProtocolMLSTag -> do + unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList + pure mempty + let usersWithoutCreator = (,newConvUsersRole newConv) <$> fromConvSize users + newConvUsersRoles = + if newConv.newConvSkipCreator + then usersWithoutCreator + else ulAddLocal (toUserRole (tUnqualified lusr)) usersWithoutCreator + let nc = + NewConversation + { metadata = + ConversationMetadata + { cnvmType = RegularConv, + cnvmCreator = Just (tUnqualified lusr), + cnvmAccess = access newConv, + cnvmAccessRoles = accessRoles newConv, + cnvmName = fmap fromRange newConv.newConvName, + cnvmMessageTimer = newConv.newConvMessageTimer, + cnvmReceiptMode = case newConv.newConvProtocol of + BaseProtocolProteusTag -> newConv.newConvReceiptMode + BaseProtocolMLSTag -> Just def, + cnvmTeam = fmap cnvTeamId newConv.newConvTeam, + cnvmGroupConvType = Just newConv.newConvGroupConvType, + cnvmChannelAddPermission = if newConv.newConvGroupConvType == Channel then newConv.newConvChannelAddPermission <|> Just def else Nothing, + cnvmCellsState = + if newConv.newConvCells + then CellsPending + else CellsDisabled, + cnvmParent = newConv.newConvParent + }, + users = newConvUsersRoles, + protocol = newConvProtocol newConv, + groupId = Nothing + } + pure (nc, users) + +------------------------------------------------------------------------------- +-- Helpers + +conversationCreated :: + ( Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationCreated lusr cnv = Created <$> conversationViewV9 lusr cnv + +localOne2OneConvId :: + (Member (Error InvalidInput) r) => + Local UserId -> + Local UserId -> + Sem r (Local ConvId) +localOne2OneConvId self other = do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + pure . qualifyAs self $ Data.localOne2OneConvId x y + +toUUIDs :: + (Member (Error InvalidInput) r) => + UserId -> + UserId -> + Sem r (U.UUID U.V4, U.UUID U.V4) +toUUIDs a b = do + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 + pure (a', b') + +accessRoles :: NewConv -> Set AccessRole +accessRoles b = fromMaybe defRole (newConvAccessRoles b) + +access :: NewConv -> [Access] +access a = case Set.toList (newConvAccess a) of + [] -> Data.defRegularConvAccess + (x : xs) -> x : xs + +newConvMembers :: Local x -> NewConv -> UserList UserId +newConvMembers loc body = + UserList (newConvUsers body) [] + <> toUserList loc (newConvQualifiedUsers body) + +newOne2OneConvMembers :: Local x -> NewOne2OneConv -> UserList UserId +newOne2OneConvMembers loc body = + UserList body.users [] + <> toUserList loc body.qualifiedUsers + +ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a +ensureOne [x] = pure x +ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") + +-------------------------------------------------------------------------------- +-- Validation and MLS Helpers + +assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () +assertMLSEnabled = do + cfg <- input + when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled + +-- Between 0 and (setMaxConvSize - 1) +newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} + deriving (Functor, Foldable, Traversable) + +deriving newtype instance (Semigroup (f a)) => Semigroup (ConvSizeChecked f a) + +deriving newtype instance (Monoid (f a)) => Monoid (ConvSizeChecked f a) + +checkedConvSize :: + (Member (Error InvalidInput) r, Foldable f) => + ConversationSubsystemConfig -> + f a -> + Sem r (ConvSizeChecked f a) +checkedConvSize cfg x = do + let minV :: Integer = 0 + limit = cfg.maxConvSize - 1 + if length x <= fromIntegral limit + then pure (ConvSizeChecked x) + else throwErr (errorMsg minV limit "") + +rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) +rangeChecked = either throwErr pure . checkedEither +{-# INLINE rangeChecked #-} + +rangeCheckedMaybe :: + (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => + Maybe a -> + Sem r (Maybe (Range n m a)) +rangeCheckedMaybe Nothing = pure Nothing +rangeCheckedMaybe (Just a) = Just <$> rangeChecked a +{-# INLINE rangeCheckedMaybe #-} + +throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a +throwErr = throw . InvalidRange . fromString diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9083de3e01a..c0dce6fc8b4 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -34,101 +35,70 @@ module Wire.ConversationSubsystem.Interpreter createConversationImpl, sendCellsNotification, notifyConversationActionImpl, + pushConversationEvent, + toConversationCreated, + fromConversationCreated, registerRemoteConversationMemberships, + notifyCreatedConversation, ) where -import Control.Error (headMay) -import Control.Lens hiding ((??)) +import Data.Bifunctor (second) import Data.Default import Data.Id -import Data.Json.Util (ToJSONObject (toJSONObject)) -import Data.Misc (FutureWork (FutureWork)) +import Data.Json.Util +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Qualified -import Data.Range import Data.Set qualified as Set -import Data.Singletons (Sing) -import Data.UUID.Tagged qualified as U -import GHC.TypeNats -import Galley.Types.Error (InternalError, InvalidInput (..)) -import Galley.Types.Teams (notTeamMember) +import Data.Singletons (Sing, sing) +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Time (UTCTime) +import Galley.Types.Error (InternalError) +import Galley.Types.Error qualified as GalleyError import Imports import Network.AMQP qualified as Q import Polysemy import Polysemy.Error -import Polysemy.Input import Polysemy.TinyLog (TinyLog) -import Wire.API.Conversation hiding (Member) +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) +import Wire.API.Component (Component (Brig, Galley)) import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action import Wire.API.Conversation.CellsState +import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus)) import Wire.API.Conversation.Role -import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation -import Wire.API.Federation.API (makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API.Galley (ConversationCreated (..), ccRemoteOrigUserId) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error -import Wire.API.FederationStatus import Wire.API.Push.V2 qualified as PushV2 -import Wire.API.Team -import Wire.API.Team.Collaborator qualified as CollaboratorPermission -import Wire.API.Team.Feature -import Wire.API.Team.Feature qualified as Conf -import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) -import Wire.API.Team.Member -import Wire.API.Team.Permission hiding (self) -import Wire.API.User -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently) -import Wire.BrigAPIAccess +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently, enqueueNotificationsConcurrentlyBuckets) import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Federation -import Wire.ConversationSubsystem.One2One +import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) import Wire.ConversationSubsystem.Types as X -import Wire.ConversationSubsystem.Util -import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem -import Wire.FederationAPIAccess (FederationAPIAccess) -import Wire.LegalHoldStore (LegalHoldStore) +import Wire.ConversationSubsystem.View (conversationViewWithCachedOthers) +import Wire.ExternalAccess (ExternalAccess, deliverAsync) +import Wire.FederationAPIAccess (FederationAPIAccess, runFederatedConcurrentlyEither) +import Wire.FederationAPIAccess qualified as E import Wire.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now -import Wire.Sem.Random (Random) -import Wire.Sem.Random qualified as Random import Wire.StoredConversation hiding (convTeam, id_, localOne2OneConvId) -import Wire.StoredConversation as Data (NewConversation (..), convType) +import Wire.StoredConversation as Data (LocalMember (..), NewConversation (..), RemoteMember (..), convType) 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 qualified as TeamSubsystem -import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) interpretConversationSubsystem :: ( Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error NonFederatingBackends) 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 (Error GalleyError.InternalError) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -136,203 +106,19 @@ interpretConversationSubsystem :: Member (Embed IO) r, Member ConversationStore r, Member (FederationAPIAccess FederatorClient) r, - Member TinyLog r, - Member BrigAPIAccess r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r + Member TinyLog r ) => Sem (ConversationSubsystem : r) a -> Sem r a interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData - ConversationSubsystem.CreateGroupConversation lusr conn newConv -> - createGroupConv lusr conn newConv - ConversationSubsystem.CreateOne2OneConversation lusr conn newOne2One -> - createOne2OneConversationLogic lusr conn newOne2One - ConversationSubsystem.CreateProteusSelfConversation lusr -> - createProteusSelfConversationLogic lusr - ConversationSubsystem.CreateConnectConversation lusr conn j -> - createConnectConversationLogic lusr conn j - -createGroupConv :: - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) 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 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error NonFederatingBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (FederationAPIAccess FederatorClient) r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member Now r, - Member NotificationSubsystem r, - Member (Embed IO) r, - Member TinyLog r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - Maybe ConnId -> - Public.NewConv -> - Sem r StoredConversation -createGroupConv lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - createGroupConversationGeneric lusr conn newConv - -createGroupConversationGeneric :: - forall r. - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error InternalError) 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 'NonBindingTeam) r, - Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) 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 (Embed IO) r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member TinyLog r, - Member BackendNotificationQueueAccess r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local UserId -> - Maybe ConnId -> - Public.NewConv -> - Sem r StoredConversation -createGroupConversationGeneric lusr conn newConv = do - (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv - checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers - ensureNoLegalholdConflicts allUsers - - when (Public.newConvProtocol newConv == BaseProtocolMLSTag) $ do - assertMLSEnabled - - lcnv <- traverse (const Random.newId) lusr - storedConv <- createConversationImpl lcnv lusr nc - sendCellsNotification lusr conn storedConv - pure storedConv - -createOne2OneConversationLogic :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) 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 TinyLog r, - Member TeamCollaboratorsSubsystem r, - Member TeamSubsystem r, - Member Now r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member (Embed IO) r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local UserId -> - ConnId -> - Public.NewOne2OneConv -> - Sem r (StoredConversation, Bool) -createOne2OneConversationLogic lusr zcon j = do - let allUsers = newOne2OneConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (tUntagged lusr == other) $ - throwS @'InvalidOperation - mtid <- case j.team of - Just ti -> do - foldQualified - lusr - (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) - (const (pure Nothing)) - other - Nothing -> ensureConnected lusr allUsers $> Nothing - foldQualified - lusr - (createLegacyOne2OneConversationUnchecked lusr zcon j.name mtid) - (createOne2OneConversationUnchecked lusr zcon j.name mtid . tUntagged) - other - -createProteusSelfConversationLogic :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member TinyLog r, - Member Now r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member (Embed IO) r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local UserId -> - Sem r (StoredConversation, Bool) -createProteusSelfConversationLogic lusr = do - let lcnv = fmap Data.selfConv lusr - c <- ConvStore.getConversation (tUnqualified lcnv) - maybe (create lcnv) (\conv -> pure (conv, False)) c - where - create lcnv = do - let nc = - Data.NewConversation - { metadata = (defConversationMetadata (Just (tUnqualified lusr))) {cnvmType = Public.SelfConv}, - users = ulFromLocals [toUserRole (tUnqualified lusr)], - protocol = BaseProtocolProteusTag, - groupId = Nothing - } - conv <- createConversationImpl lcnv lusr nc - pure (conv, True) + CreateConversation lconv lusr newConv -> do + res <- runError @UnreachableBackends $ runError @InternalError $ createConversationImpl lconv lusr newConv + case res of + Left (unreachable :: UnreachableBackends) -> throw $ FederationUnexpectedError (T.pack $ show unreachable) + Right (Left (err :: InternalError)) -> throw err + Right (Right val') -> pure val' createConversationImpl :: ( Member (Error FederationError) r, @@ -350,472 +136,12 @@ createConversationImpl :: Local UserId -> Data.NewConversation -> Sem r StoredConversation -createConversationImpl lconv _lusr = - ConvStore.upsertConversation lconv - -createConnectConversationLogic :: - ( 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 TinyLog r, - Member (Embed IO) r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local UserId -> - Maybe ConnId -> - Connect -> - Sem r StoredConversation -createConnectConversationLogic lusr conn j = do - lrecipient <- ensureLocal lusr (cRecipient j) - n <- rangeCheckedMaybe (cName j) - let meta = - (defConversationMetadata (Just (tUnqualified lusr))) - { cnvmType = Public.ConnectConv, - cnvmName = fmap fromRange n - } - lcnv <- localOne2OneConvId lusr lrecipient - let nc = - Data.NewConversation - { -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - users = ulFromLocals [(toUserRole . tUnqualified) lusr], - protocol = BaseProtocolProteusTag, - metadata = meta, - groupId = Nothing - } - ConvStore.getConversation (tUnqualified lcnv) - >>= maybe (create lcnv nc) (update n) - where - create lcnv nc = do - createConversationImpl lcnv lusr nc - update n conv = do - let mems = conv.localMembers - if tUnqualified lusr `isMember` mems - then -- we already were in the conversation, maybe also other - connect n conv - else do - let lcid = qualifyAs lusr conv.id_ - mm <- ConvStore.upsertMember lcid lusr - let conv' = - conv - { localMembers = conv.localMembers <> toList mm - } - if null mems - then -- the conversation was empty - connect n conv' - else do - -- we were not in the conversation, but someone else - conv'' <- acceptOne2One lusr conv' conn - if Data.convType conv'' == Public.ConnectConv - then connect n conv'' - else pure conv'' - connect n conv - | Data.convType conv == Public.ConnectConv = do - n' <- case n of - Just x -> do - ConvStore.setConversationName conv.id_ x - pure . Just $ fromRange x - Nothing -> pure $ Data.convName conv - notifyConversationUpdated lusr conn j conv - pure $ Data.convSetName n' conv - | otherwise = pure conv - -ensureNoLegalholdConflicts :: - ( Member (ErrorS 'MissingLegalholdConsent) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member TeamSubsystem r - ) => - UserList UserId -> - Sem r () -ensureNoLegalholdConflicts (UserList locals remotes) = do - let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes - whenM (anyLegalholdActivated locals) $ - unlessM (allLegalholdConsentGiven locals) $ - throwS @'MissingLegalholdConsent - -checkCreateConvPermissions :: - ( Member BrigAPIAccess r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - Public.NewConv -> - Maybe ConvTeamInfo -> - UserList UserId -> - Sem r () -checkCreateConvPermissions lusr newConv Nothing allUsers = do - when (newConv.newConvGroupConvType == Channel) $ throwS @OperationDenied - activated <- listToMaybe <$> lookupActivatedUsers [tUnqualified lusr] - void $ noteS @OperationDenied activated - tm <- getTeamMember (tUnqualified lusr) Nothing - for_ tm $ - permissionCheck AddRemoveConvMember . Just - ensureConnected lusr allUsers -checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do - let convTeam = cnvTeamId tinfo - mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam) - teamAssociation <- case mTeamMember of - Just tm -> pure (Just (Right tm)) - Nothing -> do - Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr) - - case newConv.newConvGroupConvType of - Channel -> do - ensureCreateChannelPermissions tinfo.cnvTeamId mTeamMember - GroupConversation -> do - void $ permissionCheck CreateConversation teamAssociation - when (length allUsers > 1 || Public.newConvProtocol newConv == BaseProtocolMLSTag) $ do - void $ permissionCheck AddRemoveConvMember teamAssociation - - convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) - ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) - ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) - ensureConnectedToRemotes lusr (ulRemotes allUsers) - where - ensureCreateChannelPermissions :: - forall r. - ( Member (ErrorS OperationDenied) r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r - ) => - TeamId -> - Maybe TeamMember -> - Sem r () - ensureCreateChannelPermissions tid (Just tm) = do - channelsConf :: LockableFeature ChannelsConfig <- getFeatureForTeam tid - when (channelsConf.status == FeatureStatusDisabled) $ throwS @'ChannelsNotEnabled - when (Public.newConvProtocol newConv /= BaseProtocolMLSTag) $ throwS @'NotAnMlsConversation - case channelsConf.config.allowedToCreateChannels of - Conf.Everyone -> pure () - Conf.TeamMembers -> void $ permissionCheck AddRemoveConvMember $ Just tm - Conf.Admins -> unless (isAdminOrOwner (tm ^. permissions)) $ throwS @OperationDenied - ensureCreateChannelPermissions _ Nothing = do - throwS @'NotATeamMember - -getTeamMember :: (Member TeamStore r, Member TeamSubsystem r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) -getTeamMember uid (Just tid) = TeamSubsystem.internalGetTeamMember uid tid -getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember uid) . headMay - -createLegacyOne2OneConversationUnchecked :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member TinyLog r, - Member Now r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member (Embed IO) r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Local UserId -> - Sem r (StoredConversation, Bool) -createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do - lcnv <- localOne2OneConvId self other - let meta = - (defConversationMetadata (Just (tUnqualified self))) - { cnvmType = Public.One2OneConv, - cnvmTeam = mtid, - cnvmName = fmap fromRange name - } - let nc = - Data.NewConversation - { users = ulFromLocals (map (toUserRole . tUnqualified) [self, other]), - protocol = BaseProtocolProteusTag, - metadata = meta, - groupId = Nothing - } - mc <- ConvStore.getConversation (tUnqualified lcnv) - case mc of - Just c -> pure (c, False) - Nothing -> do - conv <- createConversationImpl lcnv self nc - pure (conv, True) - -createOne2OneConversationUnchecked :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member TinyLog r, - Member Now r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member (Embed IO) r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (StoredConversation, Bool) -createOne2OneConversationUnchecked self zcon name mtid other = do - let create = - foldQualified - self - createOne2OneConversationLocally - createOne2OneConversationRemotely - create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other - -createOne2OneConversationLocally :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member TinyLog r, - Member Now r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member (Embed IO) r, - Member (FederationAPIAccess FederatorClient) r - ) => - Local ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (StoredConversation, Bool) -createOne2OneConversationLocally lcnv self _zcon name mtid other = do - mc <- ConvStore.getConversation (tUnqualified lcnv) - case mc of - Just c -> pure (c, False) - Nothing -> do - let meta = - (defConversationMetadata (Just (tUnqualified self))) - { cnvmType = Public.One2OneConv, - cnvmTeam = mtid, - cnvmName = fmap fromRange name - } - let nc = - Data.NewConversation - { metadata = meta, - users = fmap toUserRole (toUserList lcnv [tUntagged self, other]), - protocol = BaseProtocolProteusTag, - groupId = Nothing - } - conv <- createConversationImpl lcnv self nc - pure (conv, True) - -createOne2OneConversationRemotely :: - (Member (Error FederationError) r) => - Remote ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (StoredConversation, Bool) -createOne2OneConversationRemotely _ _ _ _name _mtid _ = - throw FederationNotImplemented - -newRegularConversation :: - ( Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS OperationDenied) r, - Member (Error InvalidInput) r, - Member (Input ConversationSubsystemConfig) r, - Member ConversationStore r - ) => - Local UserId -> - Public.NewConv -> - Sem r (Data.NewConversation, ConvSizeChecked UserList UserId) -newRegularConversation lusr newConv = do - cfg <- input - let uncheckedUsers = newConvMembers lusr newConv - forM_ newConv.newConvParent $ \parent -> do - mMembership <- ConvStore.getLocalMember parent (tUnqualified lusr) - when (isNothing mMembership) $ - throwS @OperationDenied - users <- case Public.newConvProtocol newConv of - BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers - BaseProtocolMLSTag -> do - unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList - pure mempty - let usersWithoutCreator = (,newConvUsersRole newConv) <$> fromConvSize users - newConvUsersRoles = - if newConv.newConvSkipCreator - then usersWithoutCreator - else ulAddLocal (toUserRole (tUnqualified lusr)) usersWithoutCreator - let nc = - Data.NewConversation - { metadata = - Public.ConversationMetadata - { cnvmType = Public.RegularConv, - cnvmCreator = Just (tUnqualified lusr), - cnvmAccess = access newConv, - cnvmAccessRoles = accessRoles newConv, - cnvmName = fmap fromRange newConv.newConvName, - cnvmMessageTimer = newConv.newConvMessageTimer, - cnvmReceiptMode = case Public.newConvProtocol newConv of - BaseProtocolProteusTag -> newConv.newConvReceiptMode - BaseProtocolMLSTag -> Just def, - cnvmTeam = fmap cnvTeamId newConv.newConvTeam, - cnvmGroupConvType = Just newConv.newConvGroupConvType, - cnvmChannelAddPermission = if newConv.newConvGroupConvType == Channel then newConv.newConvChannelAddPermission <|> Just def else Nothing, - cnvmCellsState = - if newConv.newConvCells - then CellsPending - else CellsDisabled, - cnvmParent = newConv.newConvParent - }, - users = newConvUsersRoles, - protocol = Public.newConvProtocol newConv, - groupId = Nothing - } - pure (nc, users) - -localOne2OneConvId :: - (Member (Error InvalidInput) r) => - Local UserId -> - Local UserId -> - Sem r (Local ConvId) -localOne2OneConvId self other = do - (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - pure . qualifyAs self $ Data.localOne2OneConvId x y - -toUUIDs :: - (Member (Error InvalidInput) r) => - UserId -> - UserId -> - Sem r (U.UUID U.V4, U.UUID U.V4) -toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & note InvalidUUID4 - b' <- U.fromUUID (toUUID b) & note InvalidUUID4 - pure (a', b') - -accessRoles :: Public.NewConv -> Set AccessRole -accessRoles b = fromMaybe defRole (newConvAccessRoles b) - -access :: Public.NewConv -> [Access] -access a = case Set.toList (Public.newConvAccess a) of - [] -> Data.defRegularConvAccess - (x : xs) -> x : xs - -newConvMembers :: Local x -> Public.NewConv -> UserList UserId -newConvMembers loc body = - UserList (newConvUsers body) [] - <> toUserList loc (newConvQualifiedUsers body) - -newOne2OneConvMembers :: Local x -> Public.NewOne2OneConv -> UserList UserId -newOne2OneConvMembers loc body = - UserList body.users [] - <> toUserList loc body.qualifiedUsers - -ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a -ensureOne [x] = pure x -ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") - -assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () -assertMLSEnabled = do - cfg <- input - when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled - -newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} - deriving (Functor, Foldable, Traversable) - deriving newtype (Semigroup, Monoid) - -checkedConvSize :: - (Member (Error InvalidInput) r, Foldable f) => - ConversationSubsystemConfig -> - f a -> - Sem r (ConvSizeChecked f a) -checkedConvSize cfg x = do - let minV :: Integer = 0 - limit = cfg.maxConvSize - 1 - if length x <= fromIntegral limit - then pure (ConvSizeChecked x) - else throwErr (errorMsg minV limit "") - -rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) -rangeChecked = either throwErr pure . checkedEither -{-# INLINE rangeChecked #-} - -rangeCheckedMaybe :: - (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => - Maybe a -> - Sem r (Maybe (Range n m a)) -rangeCheckedMaybe Nothing = pure Nothing -rangeCheckedMaybe (Just a) = Just <$> rangeChecked a -{-# INLINE rangeCheckedMaybe #-} - -throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a -throwErr = throw . InvalidRange . fromString - -checkBindingTeamPermissions :: - ( Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamCollaboratorsSubsystem r, - Member TeamStore r, - Member TeamSubsystem r - ) => - Local UserId -> - Local UserId -> - TeamId -> - Sem r (Maybe TeamId) -checkBindingTeamPermissions lusr lother tid = do - mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr) - zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - case (mTeamCollaborator, zusrMembership) of - (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator - (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember - (Just collaborator, Just member) -> - unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $ - throwS @OperationDenied - TeamStore.getTeamBinding tid >>= \case - Just Binding -> do - when (isJust zusrMembership) $ - verifyMembership tid (tUnqualified lusr) - mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother) - unless (isJust mOtherTeamCollaborator) $ - verifyMembership tid (tUnqualified lother) - pure (Just tid) - Just _ -> throwS @'NonBindingTeam - Nothing -> throwS @'TeamNotFound - where - guardPerm p m = - if m `hasPermission` p - then pure () - else throwS @OperationDenied - -verifyMembership :: - ( Member (ErrorS 'NoBindingTeamMembers) r, - Member TeamSubsystem r - ) => - TeamId -> - UserId -> - Sem r () -verifyMembership tid u = do - membership <- TeamSubsystem.internalGetTeamMember u tid - when (isNothing membership) $ - throwS @'NoBindingTeamMembers +createConversationImpl lconv lusr newConv = do + storedConv <- ConvStore.upsertConversation lconv newConv + unless (Data.convType storedConv == Public.SelfConv) $ do + notifyCreatedConversation lusr Nothing storedConv def + sendCellsNotification lusr Nothing storedConv + pure storedConv sendCellsNotification :: ( Member NotificationSubsystem r, @@ -889,3 +215,244 @@ notifyConversationActionImpl tag eventFrom notifyOrigDomain con lconv targetsLoc pushConversationEvent con conv.metadata.cnvmCellsState e (qualifyAs lcnv targetsLocal) targetsBots pure $ LocalConversationUpdate {lcuEvent = e, lcuUpdate = update} + +pushConversationEvent :: + ( Member ExternalAccess r, + Member NotificationSubsystem r, + Foldable f + ) => + Maybe ConnId -> + CellsState -> + Event -> + Local (f UserId) -> + f BotMember -> + Sem r () +pushConversationEvent conn st e lusers bots = do + NS.pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] + deliverAsync (map (,e) (toList bots)) + where + newConversationEventPush :: Local [UserId] -> Push + newConversationEventPush users = + let eventFromUser = eventFromUserId e.evtFrom + musr = guard (tDomain users == qDomain eventFromUser) $> qUnqualified eventFromUser + in def + { origin = musr, + json = toJSONObject e, + recipients = map NS.userRecipient (tUnqualified users), + isCellsEvent = shouldPushToCells st e + } + +toConversationCreated :: + UTCTime -> + Local UserId -> + StoredConversation -> + ConversationCreated ConvId +toConversationCreated now lusr StoredConversation {metadata = Public.ConversationMetadata {..}, ..} = + ConversationCreated + { time = now, + origUserId = tUnqualified lusr, + cnvId = id_, + cnvType = cnvmType, + cnvAccess = cnvmAccess, + cnvAccessRoles = cnvmAccessRoles, + cnvName = cnvmName, + nonCreatorMembers = Set.empty, + messageTimer = cnvmMessageTimer, + receiptMode = cnvmReceiptMode, + protocol = protocol, + groupConvType = cnvmGroupConvType, + channelAddPermission = cnvmChannelAddPermission + } + +fromConversationCreated :: + Local x -> + ConversationCreated (Remote ConvId) -> + [(Public.Member, Public.OwnConversation)] +fromConversationCreated loc rc@ConversationCreated {..} = + let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers + creatorOther = + Public.OtherMember + (tUntagged (ccRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin + in foldMap + ( \(me, others) -> + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) + ) + membersView + where + inDomain :: Public.OtherMember -> Bool + inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId + setHoles :: (Ord a) => Set a -> [(a, Set a)] + setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s + toMember :: Public.OtherMember -> Public.Member + toMember m = + Public.Member + { memId = Public.omQualifiedId m, + memService = Public.omService m, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = False, + memHiddenRef = Nothing, + memConvRoleName = Public.omConvRoleName m + } + conv :: Public.Member -> [Public.OtherMember] -> Public.OwnConversation + conv this others = + Public.OwnConversation + (tUntagged cnvId) + Public.ConversationMetadata + { cnvmType = cnvType, + cnvmCreator = Just origUserId, + cnvmAccess = cnvAccess, + cnvmAccessRoles = cnvAccessRoles, + cnvmName = cnvName, + cnvmTeam = Nothing, + cnvmMessageTimer = messageTimer, + cnvmReceiptMode = receiptMode, + cnvmGroupConvType = groupConvType, + cnvmChannelAddPermission = channelAddPermission, + cnvmCellsState = def, + cnvmParent = Nothing + } + (Public.OwnConvMembers this others) + ProtocolProteus + +registerRemoteConversationMemberships :: + ( Member ConvStore.ConversationStore r, + Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog r + ) => + UTCTime -> + Local UserId -> + Local StoredConversation -> + JoinType -> + Sem r () +registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do + let c = tUnqualified lc + rc = toConversationCreated now lusr c + allRemoteMembers = nubOrd c.remoteMembers + allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers + allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> + void $ fedClient @'Brig @"api-version" () + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ + \rrms -> + fedClient @'Galley @"on-conversation-created" + ( rc + { nonCreatorMembers = + toMembers (tUnqualified rrms) + } + ) + + let joined :: [Remote [RemoteMember]] = allRemoteBuckets + joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] + joinedCoupled = + foldMap + ( \ruids -> + let nj = + foldMap (fmap (.id_) . tUnqualified) $ + filter (\r -> tDomain r /= tDomain ruids) joined + in case NE.nonEmpty nj of + Nothing -> [] + Just v -> [fmap (,v) ruids] + ) + joined + + void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle + where + creator :: Maybe UserId + creator = Public.cnvmCreator . (.metadata) . tUnqualified $ lc + + localNonCreators :: [Public.OtherMember] + localNonCreators = + fmap (localMemberToOther . tDomain $ lc) + . filter (\lm -> lm.id_ `notElem` creator) + . (.localMembers) + . tUnqualified + $ lc + + toMembers :: [RemoteMember] -> Set Public.OtherMember + toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs + + convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate + convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = + ConversationUpdate + { time = now, + origUserId = tUntagged lusr, + convId = (tUnqualified lc).id_, + alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, + action = + SomeConversationAction + (sing @'ConversationJoinTag) + (Public.ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), + extraConversationData = def + } + + deleteOnUnreachable :: + ( Member ConvStore.ConversationStore r, + Member (Error UnreachableBackends) r, + Member TinyLog r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + P.err . msg $ + val "Unreachable backend when notifying" + +++ val "error" + +++ (LT.pack . show $ e) + ConvStore.deleteConversation (tUnqualified lc).id_ + throw e + +notifyCreatedConversation :: + ( Member ConvStore.ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + NS.pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == Public.RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [localMemberToRecipient m], + isCellsEvent = False, + route, + conn + } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs new file mode 100644 index 00000000000..cf4837fb6b8 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Wire.ConversationSubsystem.Notification where + +import Data.Bifunctor +import Data.Default +import Data.Id +import Data.Json.Util +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Qualified +import Data.Set qualified as Set +import Data.Singletons +import Data.Time +import Galley.Types.Error (InternalError) +import Imports +import Network.AMQP qualified as Q +import Polysemy +import Polysemy.Error +import Polysemy.TinyLog qualified as P +import Wire.API.Component (Component (..)) +import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.Action +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role +import Wire.API.Error.Galley (UnreachableBackends (..)) +import Wire.API.Event.Conversation +import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as PushV2 +import Wire.BackendNotificationQueueAccess +import Wire.ConversationStore +import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) +import Wire.ConversationSubsystem.View +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess qualified as E +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredConversation as Data + +toConversationCreated :: + UTCTime -> + Local UserId -> + StoredConversation -> + ConversationCreated ConvId +toConversationCreated now lusr StoredConversation {metadata = ConversationMetadata {..}, ..} = + ConversationCreated + { time = now, + origUserId = tUnqualified lusr, + cnvId = id_, + cnvType = cnvmType, + cnvAccess = cnvmAccess, + cnvAccessRoles = cnvmAccessRoles, + cnvName = cnvmName, + nonCreatorMembers = Set.empty, + messageTimer = cnvmMessageTimer, + receiptMode = cnvmReceiptMode, + protocol = protocol, + groupConvType = cnvmGroupConvType, + channelAddPermission = cnvmChannelAddPermission + } + +fromConversationCreated :: + Local x -> + ConversationCreated (Remote ConvId) -> + [(Public.Member, Public.OwnConversation)] +fromConversationCreated loc rc@ConversationCreated {..} = + let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers + creatorOther = + OtherMember + (tUntagged (ccRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin + in foldMap + ( \(me, others) -> + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) + ) + membersView + where + inDomain :: OtherMember -> Bool + inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId + setHoles :: (Ord a) => Set a -> [(a, Set a)] + setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s + toMember :: OtherMember -> Public.Member + toMember m = + Public.Member + { memId = Public.omQualifiedId m, + memService = Public.omService m, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = False, + memHiddenRef = Nothing, + memConvRoleName = Public.omConvRoleName m + } + conv :: Public.Member -> [OtherMember] -> Public.OwnConversation + conv this others = + Public.OwnConversation + (tUntagged cnvId) + ConversationMetadata + { cnvmType = cnvType, + cnvmCreator = Just origUserId, + cnvmAccess = cnvAccess, + cnvmAccessRoles = cnvAccessRoles, + cnvmName = cnvName, + cnvmTeam = Nothing, + cnvmMessageTimer = messageTimer, + cnvmReceiptMode = receiptMode, + cnvmGroupConvType = groupConvType, + cnvmChannelAddPermission = channelAddPermission, + cnvmCellsState = def, + cnvmParent = Nothing + } + (OwnConvMembers this others) + ProtocolProteus + +registerRemoteConversationMemberships :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r + ) => + UTCTime -> + Local UserId -> + Local StoredConversation -> + JoinType -> + Sem r () +registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do + let c = tUnqualified lc + rc = toConversationCreated now lusr c + allRemoteMembers = nubOrd c.remoteMembers + allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers + allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> + void $ fedClient @'Brig @"api-version" () + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ + \rrms -> + fedClient @'Galley @"on-conversation-created" + ( rc + { nonCreatorMembers = + toMembers (tUnqualified rrms) + } + ) + + let joined :: [Remote [RemoteMember]] = allRemoteBuckets + joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] + joinedCoupled = + foldMap + ( \ruids -> + let nj = + foldMap (fmap (.id_) . tUnqualified) $ + filter (\r -> tDomain r /= tDomain ruids) joined + in case NE.nonEmpty nj of + Nothing -> [] + Just v -> [fmap (,v) ruids] + ) + joined + + void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle + where + creator :: Maybe UserId + creator = cnvmCreator . (.metadata) . tUnqualified $ lc + + localNonCreators :: [OtherMember] + localNonCreators = + fmap (localMemberToOther . tDomain $ lc) + . filter (\lm -> lm.id_ `notElem` creator) + . (.localMembers) + . tUnqualified + $ lc + + toMembers :: [RemoteMember] -> Set OtherMember + toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs + + convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate + convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = + ConversationUpdate + { time = now, + origUserId = tUntagged lusr, + convId = (tUnqualified lc).id_, + alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, + action = + SomeConversationAction + (sing @'ConversationJoinTag) + (ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), + extraConversationData = def + } + + deleteOnUnreachable :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + deleteConversation (tUnqualified lc).id_ + throw e + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [localMemberToRecipient m], + isCellsEvent = False, + route, + conn + } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index bba97428e16..63370a7223e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -49,6 +49,7 @@ import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog qualified as P import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -66,6 +67,7 @@ import Wire.API.Federation.Error import Wire.API.Federation.Version import Wire.API.MLS.Group.Serialisation import Wire.API.Push.V2 qualified as PushV2 +import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Util import Wire.API.Team.Collaborator import Wire.API.Team.Collaborator qualified as CollaboratorPermission (CollaboratorPermission (..)) @@ -83,6 +85,7 @@ import Wire.CodeStore.Code as DataTypes import Wire.ConversationStore import Wire.ConversationSubsystem.Federation import Wire.ConversationSubsystem.Types +import Wire.ConversationSubsystem.View import Wire.Effects.ClientStore import Wire.ExternalAccess import Wire.FederationAPIAccess @@ -1124,6 +1127,15 @@ ensureMemberLimit _ old new = do when (length old + length new > maxSize) $ throwS @'TooManyMembers +conversationExisted :: + ( Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse OwnConversation) +conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv + getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList diff --git a/services/galley/src/Galley/API/Mapping.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs similarity index 71% rename from services/galley/src/Galley/API/Mapping.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs index efdde3f0111..e6a71cf0d95 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -1,29 +1,4 @@ --- 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.Mapping - ( conversationViewV9, - conversationView, - conversationViewWithCachedOthers, - remoteConversationView, - conversationToRemote, - localMemberToSelf, - ) -where +module Wire.ConversationSubsystem.View where import Data.Domain (Domain) import Data.Id (UserId, idToText) @@ -39,9 +14,6 @@ import Wire.API.Conversation qualified as Conversation import Wire.API.Federation.API.Galley import Wire.StoredConversation --- | View for a given user of a stored conversation. --- --- Throws @BadMemberState@ when the user is not part of the conversation. conversationViewV9 :: ( Member (Error InternalError) r, Member P.TinyLog r @@ -72,9 +44,6 @@ conversationView l luid conv = 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 @@ -96,9 +65,6 @@ conversationViewWithCachedOthers remoteOthers localOthers conv luid = do +++ 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 @@ -111,7 +77,6 @@ conversationViewMaybe luid remoteOthers localOthers conv = do (OwnConvMembers self others) conv.protocol --- | View for a local user of a remote conversation. remoteConversationView :: Local UserId -> MemberStatus -> @@ -135,10 +100,6 @@ remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = (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 -> @@ -163,8 +124,6 @@ conversationToRemote localDomain ruid conv = do protocol = conv.protocol } --- | Convert a local conversation member (as stored in the DB) to a publicly --- facing 'Member' structure. localMemberToSelf :: Local x -> LocalMember -> Conversation.Member localMemberToSelf loc lm = Conversation.Member diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 9046c667d8a..80cfd1d87e9 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -243,11 +243,14 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem + Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.Notification Wire.ConversationSubsystem.One2One Wire.ConversationSubsystem.Types Wire.ConversationSubsystem.Util + Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 36a43859ddb..2b73310cbc5 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -57,7 +57,6 @@ library , retry , servant-client , servant-server - , tagged , text , tinylog , transformers diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 539e391c276..58beb333294 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -39,7 +39,6 @@ , servant-client , servant-client-core , servant-server -, tagged , text , tinylog , transformers @@ -85,7 +84,6 @@ mkDerivation { retry servant-client servant-server - tagged text tinylog transformers diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 3ce7684df64..324e5d8f9ce 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,11 +22,9 @@ where import Data.Id 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) -import Galley.Types.Teams (FeatureDefaults (FeatureLegalHoldDisabledPermanently), FeatureFlags) +import Galley.Types.Error (InternalError, internalErrorDescription) import Hasql.Pool (UsageError) import Imports import Polysemy @@ -37,9 +35,7 @@ import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger as Logger import Wire.API.BackgroundJobs (Job (..)) -import Wire.API.Error.Galley import Wire.API.Federation.Error (FederationError) -import Wire.API.Team.Collaborator (TeamCollaboratorsError) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BackgroundJobsRunner (runJob) @@ -49,16 +45,11 @@ import Wire.BrigAPIAccess.Rpc import Wire.ConversationStore import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) -import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..), interpretConversationSubsystem) +import Wire.ConversationSubsystem.Interpreter (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.FireAndForget (interpretFireAndForget) import Wire.GundeckAPIAccess -import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) -import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.NotificationSubsystem.Interpreter import Wire.ParseException import Wire.Rpc @@ -70,13 +61,6 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now.IO (nowToIO) import Wire.Sem.Random.IO (randomToIO) import Wire.ServiceStore.Cassandra (interpretServiceStoreToCassandra) -import Wire.SparAPIAccess.Rpc (interpretSparAPIAccessToRpc) -import Wire.TeamCollaboratorsStore.Postgres (interpretTeamCollaboratorsStoreToPostgres) -import Wire.TeamCollaboratorsSubsystem.Interpreter (interpretTeamCollaboratorsSubsystem) -import Wire.TeamFeatureStore.Cassandra (TeamFeatureStoreError, interpretTeamFeatureStoreToCassandra) -import Wire.TeamJournal.Aws (interpretTeamJournal) -import Wire.TeamStore.Cassandra (interpretTeamStoreToCassandra) -import Wire.TeamSubsystem.Interpreter (TeamSubsystemConfig (..), interpretTeamSubsystem) import Wire.UserGroupStore.Postgres (interpretUserGroupStoreToPostgres) import Wire.UserStore.Cassandra (interpretUserStoreCassandra) @@ -100,15 +84,6 @@ dispatchJob job = do http2Manager = env.http2Manager, requestId = job.requestId } - conversationSubsystemConfig = - ConversationSubsystemConfig - { mlsKeys = Nothing, - federationProtocols = Nothing, - legalholdDefaults = FeatureLegalHoldDisabledPermanently, - maxConvSize = 1000 - } - teamSubsystemConfig = TeamSubsystemConfig {concurrentDeletionEvents = 1} - legalHoldEnv = LegalHoldEnv (\_ _ _ -> pure (error "LegalHoldEnv")) (\_ _ _ -> pure (error "LegalHoldEnv")) runFinal @IO . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO @@ -119,50 +94,20 @@ dispatchJob job = do . 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 @NonFederatingBackends (T.pack . show) - . mapError @TeamCollaboratorsError (const ("Team collaborators error" :: Text)) - . mapError @TeamFeatureStoreError (const ("Team feature store error" :: 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)) . interpretTinyLog env job.requestId job.jobId . runInputConst env.hasqlPool . runInputConst (toLocalUnsafe env.federationDomain ()) - . runInputConst conversationSubsystemConfig - . runInputConst (error "FeatureFlags" :: FeatureFlags) - . runInputConst (FeatureLegalHoldDisabledPermanently) - . runInputConst env.cassandraGalley - . runInputConst legalHoldEnv - . runInputConst (ExposeInvitationURLsAllowlist []) . interpretServiceStoreToCassandra env.cassandraBrig . interpretUserStoreCassandra env.cassandraBrig . interpretUserGroupStoreToPostgres - . interpretTeamFeatureStoreToCassandra - . convStoreInterpreter env - . interpretTeamStoreToCassandra - . interpretTeamCollaboratorsStoreToPostgres - . interpretLegalHoldStoreToCassandra FeatureLegalHoldDisabledPermanently - . interpretTeamJournal Nothing . interpretBackgroundJobsPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel . nowToIO . randomToIO . interpretFireAndForget . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess (Just $ backendQueueEnv env) + . convStoreInterpreter env . runRpcWithHttp env.httpManager job.requestId . runGundeckAPIAccess env.gundeckEndpoint -- FUTUREWORK: Currently the brig access effect is needed for the interpreter of ExternalAccess. @@ -170,13 +115,8 @@ dispatchJob job = do -- However, to prevent the background worker to require HTTP access to brig, we should consider refactoring this at some point. . interpretBrigAccess env.brigEndpoint . interpretExternalAccess extEnv - . interpretSparAPIAccessToRpc (error "Spar endpoint") . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) . interpretFederationAPIAccess federationAPIAccessConfig - . interpretTeamSubsystem teamSubsystemConfig - . runFeaturesConfigSubsystem - . runInputSem getAllTeamFeaturesForServer - . interpretTeamCollaboratorsSubsystem . interpretConversationSubsystem . interpretBackgroundJobsRunner diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f6d0cb8507f..eefbd7301cb 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -79,7 +79,6 @@ library Galley.API.Action.Notify Galley.API.Action.Reset Galley.API.Clients - Galley.API.Create Galley.API.CustomBackend Galley.API.Federation Galley.API.Internal @@ -87,7 +86,6 @@ library Galley.API.LegalHold.Conflicts Galley.API.LegalHold.Get Galley.API.LegalHold.Team - Galley.API.Mapping Galley.API.Message Galley.API.MLS Galley.API.MLS.CheckClients diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs deleted file mode 100644 index 3c8e8e2a9d8..00000000000 --- a/services/galley/src/Galley/API/Create.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} - --- 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.Default -import Data.Id -import Data.Json.Util (ToJSONObject (toJSONObject)) -import Data.Qualified -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 (UnreachableBackends) -import Wire.API.Event.Conversation -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.API.Push.V2 qualified as PushV2 -import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) -import Wire.ConversationStore (ConversationStore) -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Interpreter qualified as Interpreter -import Wire.FederationAPIAccess (FederationAPIAccess) -import Wire.FederationAPIAccess qualified as E -import Wire.NotificationSubsystem (NotificationSubsystem) -import Wire.NotificationSubsystem qualified as NS -import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now -import Wire.StoredConversation (StoredConversation, localMemberToOther, remoteMemberToOther) -import Wire.StoredConversation qualified as Data - ----------------------------------------------------------------------------- --- API Handlers - -createGroupConversationUpToV3 :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - conversationCreated lusr dbConv - -createGroupOwnConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - conv <- conversationViewV9 lusr dbConv - pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty - -createGroupConversation :: - (Member ConversationSubsystem.ConversationSubsystem r) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - 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 (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr - if created - then conversationCreated lusr c - else conversationExisted lusr c - -createOne2OneConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess 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 conversationCreated lusr c - else conversationExisted lusr c - ----------------------------------------------------------------------------- --- Helpers - -conversationCreated :: - ( Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationCreated lusr cnv = do - unless (Data.convType cnv == Public.SelfConv) $ do - notifyCreatedConversation lusr Nothing cnv def - Created <$> conversationViewV9 lusr cnv - -conversationExisted :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv - -notifyCreatedConversation :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - Interpreter.registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - NS.pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == Public.RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - NS.Push - { NS.origin = Just (tUnqualified lusr), - NS.json = toJSONObject e, - NS.recipients = [NS.userRecipient m.id_], - NS.isCellsEvent = False, - NS.route = route, - NS.conn = conn, - NS.transient = False, - NS.nativePriority = Nothing, - NS.apsData = Nothing - } - -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 <- ConversationSubsystem.createConnectConversation lusr conn j - conversationExisted lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index d370bbfc230..b47da28fcb6 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -46,8 +46,6 @@ 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.API.Push import Galley.App @@ -97,6 +95,8 @@ import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View +import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FireAndForget qualified as E import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 179d74c8d54..9e090d3e5e2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,7 +38,6 @@ 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 @@ -90,6 +89,7 @@ import Wire.ConversationStore import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index faae87331a9..aa05d3bc25a 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE TypeApplications #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -21,7 +17,6 @@ module Galley.API.Public.Conversation where -import Galley.API.Create import Galley.API.MLS.GroupInfo import Galley.API.MLS.SubConversation import Galley.API.Query @@ -31,6 +26,7 @@ import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.Create conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index d8ccc7fb952..94ecae59804 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -69,8 +69,6 @@ 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.Effects import Galley.Env @@ -110,6 +108,8 @@ import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View +import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess qualified as E import Wire.HashPassword (HashPassword) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index a3f3f4f51cf..f0d8bb0826d 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,7 +91,6 @@ 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 @@ -137,6 +136,7 @@ import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem.View import Wire.Effects.ClientStore qualified as E import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 340df91dc0f..611814c3563 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -100,7 +100,6 @@ import System.Logger.Extended qualified as Logger import UnliftIO.Exception qualified as UnliftIO import Wire.API.Conversation.Protocol import Wire.API.Error -import Wire.API.Error.Galley (NonFederatingBackends, UnreachableBackends) import Wire.API.Federation.Error import Wire.API.Team.Collaborator import Wire.API.Team.Feature @@ -156,9 +155,9 @@ type GalleyEffects0 = Error InvalidInput, Error ParseException, Error InternalError, + -- federation errors can be thrown by almost every endpoint, so we avoid + -- having to declare it every single time, and simply handle it here Error FederationError, - Error UnreachableBackends, - Error NonFederatingBackends, Error TeamCollaboratorsError, Error Hasql.UsageError, Error HttpError, @@ -347,8 +346,6 @@ evalGalley e = . mapError toResponse . mapError toResponse . mapError toResponse - . mapError toResponse - . mapError toResponse . logAndMapError toResponse (Text.pack . show) "migration error" . mapError mapTeamFeatureStoreError . runInputConst conversationSubsystemConfig @@ -357,18 +354,6 @@ evalGalley e = . runInputConst (e ^. cstate) . mapError toResponse . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse - . mapError toResponse . mapError rateLimitExceededToHttpError . mapError toResponse -- DynError . interpretQueue (e ^. deleteQueue) @@ -415,8 +400,8 @@ evalGalley e = . interpretTeamSubsystem teamSubsystemConfig . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer - . interpretTeamCollaboratorsSubsystem . interpretConversationSubsystem + . interpretTeamCollaboratorsSubsystem where lh = view (options . settings . featureFlags . to npProject) e legalHoldEnv = diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 7d1b9c5d48f..a401fffb157 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -115,8 +115,8 @@ import Wire.UserGroupStore -- All the possible high-level effects. type GalleyEffects1 = - '[ ConversationSubsystem, - TeamCollaboratorsSubsystem, + '[ TeamCollaboratorsSubsystem, + ConversationSubsystem, Input AllTeamFeatures, FeaturesConfigSubsystem, TeamSubsystem, @@ -164,17 +164,5 @@ type GalleyEffects1 = Error DynError, Error RateLimitExceeded, ErrorS OperationDenied, - ErrorS 'NotATeamMember, - ErrorS 'ConvAccessDenied, - ErrorS 'NotConnected, - ErrorS 'MLSNotEnabled, - ErrorS 'MLSNonEmptyMemberList, - ErrorS 'MissingLegalholdConsent, - ErrorS 'NonBindingTeam, - ErrorS 'NoBindingTeamMembers, - ErrorS 'TeamNotFound, - ErrorS 'InvalidOperation, - ErrorS 'ConvNotFound, - ErrorS 'ChannelsNotEnabled, - ErrorS 'NotAnMlsConversation + ErrorS 'NotATeamMember ] diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 313f11f0f55..f527d520caf 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 Galley.Options (federator, rabbitmq) import Imports hiding (id) import Imports qualified as I @@ -105,6 +104,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.View import Wire.StoredConversation hiding (convName) tests :: IO TestSetup -> TestTree diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index b73a27c17b4..722f6525582 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,7 +25,6 @@ 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) @@ -41,6 +40,7 @@ import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), RemoteConversationV2 (..), ) +import Wire.ConversationSubsystem.View import Wire.Sem.Logger qualified as P import Wire.StoredConversation From 7cf425b931e979fe0f200b0fdfa6cbcfc9cf4f2d Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 27 Jan 2026 15:17:47 +0100 Subject: [PATCH 07/11] Revert "Revert last 2 commits, is the CI alive?" This reverts commit 41246b83af388d7f401bbc9c50e82e5ff3dcde66. --- .../src/Wire/ConversationSubsystem.hs | 21 +- .../src/Wire/ConversationSubsystem/Create.hs | 862 -------------- .../Wire/ConversationSubsystem/Interpreter.hs | 1001 ++++++++++++----- .../ConversationSubsystem/Notification.hs | 256 ----- .../src/Wire/ConversationSubsystem/Util.hs | 12 - libs/wire-subsystems/wire-subsystems.cabal | 3 - .../background-worker/background-worker.cabal | 1 + services/background-worker/default.nix | 2 + .../Wire/BackgroundWorker/Jobs/Registry.hs | 66 +- services/galley/galley.cabal | 2 + services/galley/src/Galley/API/Create.hs | 238 ++++ services/galley/src/Galley/API/Federation.hs | 4 +- services/galley/src/Galley/API/Internal.hs | 2 +- .../galley/src/Galley/API/Mapping.hs | 43 +- .../src/Galley/API/Public/Conversation.hs | 6 +- services/galley/src/Galley/API/Query.hs | 4 +- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/src/Galley/App.hs | 21 +- services/galley/src/Galley/Effects.hs | 18 +- services/galley/test/integration/API.hs | 2 +- .../galley/test/unit/Test/Galley/Mapping.hs | 2 +- 21 files changed, 1128 insertions(+), 1440 deletions(-) delete mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs delete mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs create mode 100644 services/galley/src/Galley/API/Create.hs rename libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs => services/galley/src/Galley/API/Mapping.hs (71%) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index a84b8a2a98a..5c961df950e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -24,7 +24,7 @@ import Data.Qualified import Data.Singletons (Sing) import Imports import Polysemy -import Wire.API.Conversation (ExtraConversationData) +import Wire.API.Conversation (ExtraConversationData, NewConv, NewOne2OneConv) import Wire.API.Conversation.Action import Wire.API.Event.Conversation import Wire.NotificationSubsystem (LocalConversationUpdate) @@ -43,10 +43,23 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate - CreateConversation :: - Local ConvId -> + CreateGroupConversation :: Local UserId -> - NewConversation -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m StoredConversation + CreateOne2OneConversation :: + Local UserId -> + ConnId -> + NewOne2OneConv -> + ConversationSubsystem m (StoredConversation, Bool) + CreateProteusSelfConversation :: + Local UserId -> + ConversationSubsystem m (StoredConversation, Bool) + CreateConnectConversation :: + Local UserId -> + Maybe ConnId -> + Connect -> ConversationSubsystem m StoredConversation makeSem ''ConversationSubsystem diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs deleted file mode 100644 index c49dba47a9d..00000000000 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs +++ /dev/null @@ -1,862 +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 . --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -{-# LANGUAGE DataKinds #-} - -module Wire.ConversationSubsystem.Create - ( createGroupConversationUpToV3, - createGroupOwnConversation, - createProteusSelfConversation, - createOne2OneConversation, - createConnectConversation, - createGroupConversation, - ) -where - -import Control.Error (headMay) -import Control.Lens hiding ((??)) -import Data.Default -import Data.Id (ConnId, ConvId, Id (toUUID), TeamId, UserId) -import Data.Misc (FutureWork (FutureWork)) -import Data.Qualified -import Data.Range -import Data.Set qualified as Set -import Data.UUID.Tagged qualified as U -import GHC.TypeNats -import Galley.Types.Error -import Galley.Types.Teams (notTeamMember) -import Imports hiding ((\\)) -import Polysemy -import Polysemy.Error -import Polysemy.Input -import Polysemy.TinyLog qualified as P -import Wire.API.Conversation hiding (Conversation, Member) -import Wire.API.Conversation qualified as Public -import Wire.API.Conversation.CellsState -import Wire.API.Conversation.Role -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 -import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util -import Wire.API.Team -import Wire.API.Team.Collaborator qualified as CollaboratorPermission -import Wire.API.Team.Feature -import Wire.API.Team.Feature qualified as Conf -import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) -import Wire.API.Team.Member -import Wire.API.Team.Permission hiding (self) -import Wire.API.User -import Wire.BrigAPIAccess -import Wire.ConversationStore (ConversationStore) -import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Federation -import Wire.ConversationSubsystem.One2One -import Wire.ConversationSubsystem.Types -import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View -import Wire.FeaturesConfigSubsystem -import Wire.FederationAPIAccess (FederationAPIAccess) -import Wire.LegalHoldStore (LegalHoldStore) -import Wire.NotificationSubsystem -import Wire.Sem.Now (Now) -import Wire.Sem.Random (Random) -import Wire.Sem.Random qualified as Random -import Wire.StoredConversation hiding (convTeam, localOne2OneConvId) -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 qualified as TeamSubsystem -import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) - ----------------------------------------------------------------------------- --- Group conversations - --- | The public-facing endpoint for creating group conversations in the client --- API up to and including version 3. -createGroupConversationUpToV3 :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error InternalError) 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 (Error UnreachableBackendsLegacy) r, - Member LegalHoldStore r, - Member TeamStore r, - Member P.TinyLog r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = - mapError UnreachableBackendsLegacy $ - createGroupConversationGeneric lusr conn newConv - >>= conversationCreated lusr - --- | The public-facing endpoint for creating group conversations in the client --- API in from version 4 to 8 -createGroupOwnConversation :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (Error NonFederatingBackends) 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 (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member P.TinyLog r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - createGroupConvAndMkResponse - lusr - conn - newConv - ( \dbConv -> do - conv <- conversationViewV9 lusr dbConv - pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty - ) - --- | The public-facing endpoint for creating group conversations in the client --- API in version 9 and above. -createGroupConversation :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (Error NonFederatingBackends) 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 (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - createGroupConvAndMkResponse - lusr - conn - newConv - ( \dbConv -> - pure $ - CreateGroupConversation - { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, - failedToAdd = mempty - } - ) - -createGroupConvAndMkResponse :: - ( Member (ErrorS OperationDenied) r, - Member (ErrorS ConvAccessDenied) r, - Member (ErrorS NotATeamMember) 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 (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error NonFederatingBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (FederationAPIAccess FederatorClient) r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - (StoredConversation -> Sem r b) -> - Sem r b -createGroupConvAndMkResponse lusr conn newConv mkResponse = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- createGroupConversationGeneric lusr conn newConv - mkResponse dbConv - -createGroupConversationGeneric :: - forall r. - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error InternalError) 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 (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r StoredConversation -createGroupConversationGeneric lusr _conn newConv = do - (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv - checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers - ensureNoLegalholdConflicts allUsers - - when (newConvProtocol newConv == BaseProtocolMLSTag) $ do - -- Here we fail early in order to notify users of this misconfiguration - assertMLSEnabled - - lcnv <- traverse (const Random.newId) lusr - conv <- ConversationSubsystem.createConversation lcnv lusr nc - E.getConversation conv.id_ - >>= note (BadConvState conv.id_) - -ensureNoLegalholdConflicts :: - ( Member (ErrorS 'MissingLegalholdConsent) r, - Member (Input ConversationSubsystemConfig) r, - Member LegalHoldStore r, - Member TeamStore r, - Member TeamSubsystem r - ) => - UserList UserId -> - Sem r () -ensureNoLegalholdConflicts (UserList locals remotes) = do - let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes - whenM (anyLegalholdActivated locals) $ - unlessM (allLegalholdConsentGiven locals) $ - throwS @'MissingLegalholdConsent - -checkCreateConvPermissions :: - ( Member BrigAPIAccess r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS ChannelsNotEnabled) r, - Member (ErrorS NotAnMlsConversation) r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - NewConv -> - Maybe ConvTeamInfo -> - UserList UserId -> - Sem r () -checkCreateConvPermissions lusr newConv Nothing allUsers = do - when (newConv.newConvGroupConvType == Channel) $ throwS @OperationDenied - activated <- listToMaybe <$> lookupActivatedUsers [tUnqualified lusr] - void $ noteS @OperationDenied activated - -- an external partner is not allowed to create group conversations (except 1:1 team conversations that are handled below) - tm <- getTeamMember (tUnqualified lusr) Nothing - for_ tm $ - permissionCheck AddRemoveConvMember . Just - ensureConnected lusr allUsers -checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do - let convTeam = cnvTeamId tinfo - mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam) - teamAssociation <- case mTeamMember of - Just tm -> pure (Just (Right tm)) - Nothing -> do - Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr) - - case newConv.newConvGroupConvType of - Channel -> do - ensureCreateChannelPermissions tinfo.cnvTeamId mTeamMember - GroupConversation -> do - void $ permissionCheck CreateConversation teamAssociation - -- In teams we don't have 1:1 conversations, only regular conversations. We want - -- users without the 'AddRemoveConvMember' permission to still be able to create - -- regular conversations, therefore we check for 'AddRemoveConvMember' only if - -- there are going to be more than two users in the conversation. - -- FUTUREWORK: We keep this permission around because not doing so will break backwards - -- compatibility in the sense that the team role 'partners' would be able to create group - -- conversations (which they should not be able to). - -- Not sure at the moment how to best solve this but it is unlikely - -- we can ever get rid of the team permission model anyway - the only thing I can - -- think of is that 'partners' can create convs but not be admins... - -- this only applies to proteus conversations, because in MLS we have proper 1:1 conversations, - -- so we don't allow an external partner to create an MLS group conversation at all - when (length allUsers > 1 || newConv.newConvProtocol == BaseProtocolMLSTag) $ do - void $ permissionCheck AddRemoveConvMember teamAssociation - - convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) - ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) - -- Team members are always considered to be connected, so we only check - -- 'ensureConnected' for non-team-members. - ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) - ensureConnectedToRemotes lusr (ulRemotes allUsers) - where - ensureCreateChannelPermissions :: - forall r. - ( Member (ErrorS OperationDenied) r, - Member FeaturesConfigSubsystem r, - Member (ErrorS NotATeamMember) r, - Member (ErrorS ChannelsNotEnabled) r, - Member (ErrorS NotAnMlsConversation) r - ) => - TeamId -> - Maybe TeamMember -> - Sem r () - ensureCreateChannelPermissions tid (Just tm) = do - channelsConf :: LockableFeature ChannelsConfig <- getFeatureForTeam tid - when (channelsConf.status == FeatureStatusDisabled) $ throwS @ChannelsNotEnabled - when (newConv.newConvProtocol /= BaseProtocolMLSTag) $ throwS @NotAnMlsConversation - case channelsConf.config.allowedToCreateChannels of - Conf.Everyone -> pure () - Conf.TeamMembers -> void $ permissionCheck AddRemoveConvMember $ Just tm - Conf.Admins -> unless (isAdminOrOwner (tm ^. permissions)) $ throwS @OperationDenied - ensureCreateChannelPermissions _ Nothing = do - throwS @NotATeamMember - -getTeamMember :: (Member TeamStore r, Member TeamSubsystem r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) -getTeamMember uid (Just tid) = TeamSubsystem.internalGetTeamMember uid tid -getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember uid) . headMay - ----------------------------------------------------------------------------- --- Other kinds of conversations - -createProteusSelfConversation :: - forall r. - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - let lcnv = fmap Data.selfConv lusr - c <- E.getConversation (tUnqualified lcnv) - maybe (create lcnv) (conversationExisted lusr) c - where - create :: Local ConvId -> Sem r (ConversationResponse Public.OwnConversation) - create lcnv = do - let nc = - NewConversation - { metadata = (defConversationMetadata (Just (tUnqualified lusr))) {cnvmType = SelfConv}, - users = ulFromLocals [toUserRole (tUnqualified lusr)], - protocol = BaseProtocolProteusTag, - groupId = Nothing - } - ConversationSubsystem.createConversation lcnv lusr nc - >>= conversationCreated lusr - -createOne2OneConversation :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotConnected) r, - Member (Error UnreachableBackendsLegacy) r, - Member TeamStore r, - Member P.TinyLog r, - Member TeamCollaboratorsSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - NewOne2OneConv -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversation lusr zcon j = - mapError @UnreachableBackends @UnreachableBackendsLegacy UnreachableBackendsLegacy $ do - let allUsers = newOne2OneConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (tUntagged lusr == other) $ - throwS @'InvalidOperation - mtid <- case j.team of - Just ti -> do - foldQualified - lusr - (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) - (const (pure Nothing)) - other - Nothing -> ensureConnected lusr allUsers $> Nothing - foldQualified - lusr - (createLegacyOne2OneConversationUnchecked lusr zcon j.name mtid) - (createOne2OneConversationUnchecked lusr zcon j.name mtid . tUntagged) - other - where - verifyMembership :: - ( Member (ErrorS 'NoBindingTeamMembers) r, - Member TeamSubsystem r - ) => - TeamId -> - UserId -> - Sem r () - verifyMembership tid u = do - membership <- TeamSubsystem.internalGetTeamMember u tid - when (isNothing membership) $ - throwS @'NoBindingTeamMembers - checkBindingTeamPermissions :: - ( Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamCollaboratorsSubsystem r, - Member TeamStore r, - Member TeamSubsystem r - ) => - Local UserId -> - TeamId -> - Sem r (Maybe TeamId) - checkBindingTeamPermissions lother tid = do - mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr) - zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - case (mTeamCollaborator, zusrMembership) of - (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator - (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember - (Just collaborator, Just member) -> - unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $ - throwS @OperationDenied - TeamStore.getTeamBinding tid >>= \case - Just Binding -> do - when (isJust zusrMembership) $ - verifyMembership tid (tUnqualified lusr) - mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother) - unless (isJust mOtherTeamCollaborator) $ - verifyMembership tid (tUnqualified lother) - pure (Just tid) - Just _ -> throwS @'NonBindingTeam - Nothing -> throwS @'TeamNotFound - - guardPerm p m = - if m `hasPermission` p - then pure () - else throwS @OperationDenied - -createLegacyOne2OneConversationUnchecked :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do - lcnv <- localOne2OneConvId self other - let meta = - (defConversationMetadata (Just (tUnqualified self))) - { cnvmType = One2OneConv, - cnvmTeam = mtid, - cnvmName = fmap fromRange name - } - let nc = - NewConversation - { users = ulFromLocals (map (toUserRole . tUnqualified) [self, other]), - protocol = BaseProtocolProteusTag, - metadata = meta, - groupId = Nothing - } - mc <- E.getConversation (tUnqualified lcnv) - case mc of - Just c -> conversationExisted self c - Nothing -> do - ConversationSubsystem.createConversation lcnv self nc - >>= conversationCreated self - -createOne2OneConversationUnchecked :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationUnchecked self zcon name mtid other = do - let create = - foldQualified - self - createOne2OneConversationLocally - createOne2OneConversationRemotely - create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other - -createOne2OneConversationLocally :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationLocally lcnv self _zcon name mtid other = do - mc <- E.getConversation (tUnqualified lcnv) - case mc of - Just c -> conversationExisted self c - Nothing -> do - let meta = - (defConversationMetadata (Just (tUnqualified self))) - { cnvmType = One2OneConv, - cnvmTeam = mtid, - cnvmName = fmap fromRange name - } - let nc = - NewConversation - { metadata = meta, - users = fmap toUserRole (toUserList lcnv [tUntagged self, other]), - protocol = BaseProtocolProteusTag, - groupId = Nothing - } - ConversationSubsystem.createConversation lcnv self nc - >>= conversationCreated self - -createOne2OneConversationRemotely :: - (Member (Error FederationError) r) => - Remote ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationRemotely _ _ _ _name _mtid _ = - throw FederationNotImplemented - -createConnectConversation :: - ( Member ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (ErrorS 'ConvNotFound) r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'InvalidOperation) r, - Member NotificationSubsystem r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Connect -> - Sem r (ConversationResponse Public.OwnConversation) -createConnectConversation lusr conn j = do - lrecipient <- ensureLocal lusr (cRecipient j) - n <- rangeCheckedMaybe (cName j) - let meta = - (defConversationMetadata (Just (tUnqualified lusr))) - { cnvmType = ConnectConv, - cnvmName = fmap fromRange n - } - lcnv <- localOne2OneConvId lusr lrecipient - let nc = - NewConversation - { -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - users = ulFromLocals ([(toUserRole . tUnqualified) lusr]), - protocol = BaseProtocolProteusTag, - metadata = meta, - groupId = Nothing - } - E.getConversation (tUnqualified lcnv) - >>= maybe (create lcnv nc) (update n) - where - create lcnv nc = do - c <- ConversationSubsystem.createConversation lcnv lusr nc - conversationCreated lusr c - update n conv = do - let mems = conv.localMembers - in conversationExisted lusr - =<< if tUnqualified lusr `isMember` mems - then -- we already were in the conversation, maybe also other - connect n conv - else do - let lcid = qualifyAs lusr conv.id_ - mm <- E.upsertMember lcid lusr - let conv' = - conv - { localMembers = conv.localMembers <> toList mm - } - if null mems - then do - -- the conversation was empty - connect n conv' - else do - -- we were not in the conversation, but someone else - conv'' <- acceptOne2One lusr conv' conn - if Data.convType conv'' == ConnectConv - then connect n conv'' - else pure conv'' - connect n conv - | Data.convType conv == ConnectConv = do - n' <- case n of - Just x -> do - E.setConversationName conv.id_ x - pure . Just $ fromRange x - Nothing -> pure $ Data.convName conv - notifyConversationUpdated lusr conn j conv - pure $ Data.convSetName n' conv - | otherwise = pure conv - --------------------------------------------------------------------------------- --- Conversation creation records - --- | Return a 'NewConversation' record suitable for creating a group conversation. -newRegularConversation :: - ( Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS OperationDenied) r, - Member (Error InvalidInput) r, - Member (Input ConversationSubsystemConfig) r, - Member ConversationStore r - ) => - Local UserId -> - NewConv -> - Sem r (NewConversation, ConvSizeChecked UserList UserId) -newRegularConversation lusr newConv = do - cfg <- input - let uncheckedUsers = newConvMembers lusr newConv - forM_ newConv.newConvParent $ \parent -> do - mMembership <- E.getLocalMember parent (tUnqualified lusr) - when (isNothing mMembership) $ - throwS @OperationDenied - users <- case newConvProtocol newConv of - BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers - BaseProtocolMLSTag -> do - unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList - pure mempty - let usersWithoutCreator = (,newConvUsersRole newConv) <$> fromConvSize users - newConvUsersRoles = - if newConv.newConvSkipCreator - then usersWithoutCreator - else ulAddLocal (toUserRole (tUnqualified lusr)) usersWithoutCreator - let nc = - NewConversation - { metadata = - ConversationMetadata - { cnvmType = RegularConv, - cnvmCreator = Just (tUnqualified lusr), - cnvmAccess = access newConv, - cnvmAccessRoles = accessRoles newConv, - cnvmName = fmap fromRange newConv.newConvName, - cnvmMessageTimer = newConv.newConvMessageTimer, - cnvmReceiptMode = case newConv.newConvProtocol of - BaseProtocolProteusTag -> newConv.newConvReceiptMode - BaseProtocolMLSTag -> Just def, - cnvmTeam = fmap cnvTeamId newConv.newConvTeam, - cnvmGroupConvType = Just newConv.newConvGroupConvType, - cnvmChannelAddPermission = if newConv.newConvGroupConvType == Channel then newConv.newConvChannelAddPermission <|> Just def else Nothing, - cnvmCellsState = - if newConv.newConvCells - then CellsPending - else CellsDisabled, - cnvmParent = newConv.newConvParent - }, - users = newConvUsersRoles, - protocol = newConvProtocol newConv, - groupId = Nothing - } - pure (nc, users) - -------------------------------------------------------------------------------- --- Helpers - -conversationCreated :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationCreated lusr cnv = Created <$> conversationViewV9 lusr cnv - -localOne2OneConvId :: - (Member (Error InvalidInput) r) => - Local UserId -> - Local UserId -> - Sem r (Local ConvId) -localOne2OneConvId self other = do - (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - pure . qualifyAs self $ Data.localOne2OneConvId x y - -toUUIDs :: - (Member (Error InvalidInput) r) => - UserId -> - UserId -> - Sem r (U.UUID U.V4, U.UUID U.V4) -toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & note InvalidUUID4 - b' <- U.fromUUID (toUUID b) & note InvalidUUID4 - pure (a', b') - -accessRoles :: NewConv -> Set AccessRole -accessRoles b = fromMaybe defRole (newConvAccessRoles b) - -access :: NewConv -> [Access] -access a = case Set.toList (newConvAccess a) of - [] -> Data.defRegularConvAccess - (x : xs) -> x : xs - -newConvMembers :: Local x -> NewConv -> UserList UserId -newConvMembers loc body = - UserList (newConvUsers body) [] - <> toUserList loc (newConvQualifiedUsers body) - -newOne2OneConvMembers :: Local x -> NewOne2OneConv -> UserList UserId -newOne2OneConvMembers loc body = - UserList body.users [] - <> toUserList loc body.qualifiedUsers - -ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a -ensureOne [x] = pure x -ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") - --------------------------------------------------------------------------------- --- Validation and MLS Helpers - -assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () -assertMLSEnabled = do - cfg <- input - when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled - --- Between 0 and (setMaxConvSize - 1) -newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} - deriving (Functor, Foldable, Traversable) - -deriving newtype instance (Semigroup (f a)) => Semigroup (ConvSizeChecked f a) - -deriving newtype instance (Monoid (f a)) => Monoid (ConvSizeChecked f a) - -checkedConvSize :: - (Member (Error InvalidInput) r, Foldable f) => - ConversationSubsystemConfig -> - f a -> - Sem r (ConvSizeChecked f a) -checkedConvSize cfg x = do - let minV :: Integer = 0 - limit = cfg.maxConvSize - 1 - if length x <= fromIntegral limit - then pure (ConvSizeChecked x) - else throwErr (errorMsg minV limit "") - -rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) -rangeChecked = either throwErr pure . checkedEither -{-# INLINE rangeChecked #-} - -rangeCheckedMaybe :: - (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => - Maybe a -> - Sem r (Maybe (Range n m a)) -rangeCheckedMaybe Nothing = pure Nothing -rangeCheckedMaybe (Just a) = Just <$> rangeChecked a -{-# INLINE rangeCheckedMaybe #-} - -throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a -throwErr = throw . InvalidRange . fromString diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index c0dce6fc8b4..9083de3e01a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -6,7 +6,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -35,70 +34,101 @@ module Wire.ConversationSubsystem.Interpreter createConversationImpl, sendCellsNotification, notifyConversationActionImpl, - pushConversationEvent, - toConversationCreated, - fromConversationCreated, registerRemoteConversationMemberships, - notifyCreatedConversation, ) where -import Data.Bifunctor (second) +import Control.Error (headMay) +import Control.Lens hiding ((??)) import Data.Default import Data.Id -import Data.Json.Util -import Data.List.Extra (nubOrd) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE +import Data.Json.Util (ToJSONObject (toJSONObject)) +import Data.Misc (FutureWork (FutureWork)) import Data.Qualified +import Data.Range import Data.Set qualified as Set -import Data.Singletons (Sing, sing) -import Data.Text qualified as T -import Data.Text.Lazy qualified as LT -import Data.Time (UTCTime) -import Galley.Types.Error (InternalError) -import Galley.Types.Error qualified as GalleyError +import Data.Singletons (Sing) +import Data.UUID.Tagged qualified as U +import GHC.TypeNats +import Galley.Types.Error (InternalError, InvalidInput (..)) +import Galley.Types.Teams (notTeamMember) 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.Component (Component (Brig, Galley)) +import Wire.API.Conversation hiding (Member) import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action import Wire.API.Conversation.CellsState -import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus)) import Wire.API.Conversation.Role +import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation -import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) -import Wire.API.Federation.API.Galley (ConversationCreated (..), ccRemoteOrigUserId) +import Wire.API.Federation.API (makeConversationUpdateBundle, sendBundle) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.FederationStatus import Wire.API.Push.V2 qualified as PushV2 -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently, enqueueNotificationsConcurrentlyBuckets) +import Wire.API.Team +import Wire.API.Team.Collaborator qualified as CollaboratorPermission +import Wire.API.Team.Feature +import Wire.API.Team.Feature qualified as Conf +import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) +import Wire.API.Team.Member +import Wire.API.Team.Permission hiding (self) +import Wire.API.User +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently) +import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Federation +import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Types as X -import Wire.ConversationSubsystem.View (conversationViewWithCachedOthers) -import Wire.ExternalAccess (ExternalAccess, deliverAsync) -import Wire.FederationAPIAccess (FederationAPIAccess, runFederatedConcurrentlyEither) -import Wire.FederationAPIAccess qualified as E +import Wire.ConversationSubsystem.Util +import Wire.ExternalAccess (ExternalAccess) +import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now +import Wire.Sem.Random (Random) +import Wire.Sem.Random qualified as Random import Wire.StoredConversation hiding (convTeam, id_, localOne2OneConvId) -import Wire.StoredConversation as Data (LocalMember (..), NewConversation (..), RemoteMember (..), convType) +import Wire.StoredConversation as Data (NewConversation (..), convType) 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 qualified as TeamSubsystem +import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) interpretConversationSubsystem :: ( Member (Error FederationError) r, - Member (Error GalleyError.InternalError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) 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 BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -106,19 +136,203 @@ interpretConversationSubsystem :: Member (Embed IO) r, Member ConversationStore r, Member (FederationAPIAccess FederatorClient) r, - Member TinyLog r + Member TinyLog r, + Member BrigAPIAccess r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r ) => Sem (ConversationSubsystem : r) a -> Sem r a interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData - CreateConversation lconv lusr newConv -> do - res <- runError @UnreachableBackends $ runError @InternalError $ createConversationImpl lconv lusr newConv - case res of - Left (unreachable :: UnreachableBackends) -> throw $ FederationUnexpectedError (T.pack $ show unreachable) - Right (Left (err :: InternalError)) -> throw err - Right (Right val') -> pure val' + ConversationSubsystem.CreateGroupConversation lusr conn newConv -> + createGroupConv lusr conn newConv + ConversationSubsystem.CreateOne2OneConversation lusr conn newOne2One -> + createOne2OneConversationLogic lusr conn newOne2One + ConversationSubsystem.CreateProteusSelfConversation lusr -> + createProteusSelfConversationLogic lusr + ConversationSubsystem.CreateConnectConversation lusr conn j -> + createConnectConversationLogic lusr conn j + +createGroupConv :: + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'ConvAccessDenied) r, + Member (ErrorS 'NotATeamMember) 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 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (FederationAPIAccess FederatorClient) r, + Member BrigAPIAccess r, + Member ConversationStore r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member (Input ConversationSubsystemConfig) r, + Member Now r, + Member NotificationSubsystem r, + Member (Embed IO) r, + Member TinyLog r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Maybe ConnId -> + Public.NewConv -> + Sem r StoredConversation +createGroupConv lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + createGroupConversationGeneric lusr conn newConv + +createGroupConversationGeneric :: + forall r. + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InternalError) 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 'NonBindingTeam) r, + Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) 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 (Embed IO) r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member TinyLog r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + Maybe ConnId -> + Public.NewConv -> + Sem r StoredConversation +createGroupConversationGeneric lusr conn newConv = do + (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv + checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers + ensureNoLegalholdConflicts allUsers + + when (Public.newConvProtocol newConv == BaseProtocolMLSTag) $ do + assertMLSEnabled + + lcnv <- traverse (const Random.newId) lusr + storedConv <- createConversationImpl lcnv lusr nc + sendCellsNotification lusr conn storedConv + pure storedConv + +createOne2OneConversationLogic :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) 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 TinyLog r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + ConnId -> + Public.NewOne2OneConv -> + Sem r (StoredConversation, Bool) +createOne2OneConversationLogic lusr zcon j = do + let allUsers = newOne2OneConvMembers lusr j + other <- ensureOne (ulAll lusr allUsers) + when (tUntagged lusr == other) $ + throwS @'InvalidOperation + mtid <- case j.team of + Just ti -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) + (const (pure Nothing)) + other + Nothing -> ensureConnected lusr allUsers $> Nothing + foldQualified + lusr + (createLegacyOne2OneConversationUnchecked lusr zcon j.name mtid) + (createOne2OneConversationUnchecked lusr zcon j.name mtid . tUntagged) + other + +createProteusSelfConversationLogic :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + Sem r (StoredConversation, Bool) +createProteusSelfConversationLogic lusr = do + let lcnv = fmap Data.selfConv lusr + c <- ConvStore.getConversation (tUnqualified lcnv) + maybe (create lcnv) (\conv -> pure (conv, False)) c + where + create lcnv = do + let nc = + Data.NewConversation + { metadata = (defConversationMetadata (Just (tUnqualified lusr))) {cnvmType = Public.SelfConv}, + users = ulFromLocals [toUserRole (tUnqualified lusr)], + protocol = BaseProtocolProteusTag, + groupId = Nothing + } + conv <- createConversationImpl lcnv lusr nc + pure (conv, True) createConversationImpl :: ( Member (Error FederationError) r, @@ -136,12 +350,472 @@ createConversationImpl :: Local UserId -> Data.NewConversation -> Sem r StoredConversation -createConversationImpl lconv lusr newConv = do - storedConv <- ConvStore.upsertConversation lconv newConv - unless (Data.convType storedConv == Public.SelfConv) $ do - notifyCreatedConversation lusr Nothing storedConv def - sendCellsNotification lusr Nothing storedConv - pure storedConv +createConversationImpl lconv _lusr = + ConvStore.upsertConversation lconv + +createConnectConversationLogic :: + ( 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 TinyLog r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Sem r StoredConversation +createConnectConversationLogic lusr conn j = do + lrecipient <- ensureLocal lusr (cRecipient j) + n <- rangeCheckedMaybe (cName j) + let meta = + (defConversationMetadata (Just (tUnqualified lusr))) + { cnvmType = Public.ConnectConv, + cnvmName = fmap fromRange n + } + lcnv <- localOne2OneConvId lusr lrecipient + let nc = + Data.NewConversation + { -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + users = ulFromLocals [(toUserRole . tUnqualified) lusr], + protocol = BaseProtocolProteusTag, + metadata = meta, + groupId = Nothing + } + ConvStore.getConversation (tUnqualified lcnv) + >>= maybe (create lcnv nc) (update n) + where + create lcnv nc = do + createConversationImpl lcnv lusr nc + update n conv = do + let mems = conv.localMembers + if tUnqualified lusr `isMember` mems + then -- we already were in the conversation, maybe also other + connect n conv + else do + let lcid = qualifyAs lusr conv.id_ + mm <- ConvStore.upsertMember lcid lusr + let conv' = + conv + { localMembers = conv.localMembers <> toList mm + } + if null mems + then -- the conversation was empty + connect n conv' + else do + -- we were not in the conversation, but someone else + conv'' <- acceptOne2One lusr conv' conn + if Data.convType conv'' == Public.ConnectConv + then connect n conv'' + else pure conv'' + connect n conv + | Data.convType conv == Public.ConnectConv = do + n' <- case n of + Just x -> do + ConvStore.setConversationName conv.id_ x + pure . Just $ fromRange x + Nothing -> pure $ Data.convName conv + notifyConversationUpdated lusr conn j conv + pure $ Data.convSetName n' conv + | otherwise = pure conv + +ensureNoLegalholdConflicts :: + ( Member (ErrorS 'MissingLegalholdConsent) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member TeamSubsystem r + ) => + UserList UserId -> + Sem r () +ensureNoLegalholdConflicts (UserList locals remotes) = do + let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes + whenM (anyLegalholdActivated locals) $ + unlessM (allLegalholdConsentGiven locals) $ + throwS @'MissingLegalholdConsent + +checkCreateConvPermissions :: + ( Member BrigAPIAccess r, + Member (ErrorS 'ConvAccessDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r + ) => + Local UserId -> + Public.NewConv -> + Maybe ConvTeamInfo -> + UserList UserId -> + Sem r () +checkCreateConvPermissions lusr newConv Nothing allUsers = do + when (newConv.newConvGroupConvType == Channel) $ throwS @OperationDenied + activated <- listToMaybe <$> lookupActivatedUsers [tUnqualified lusr] + void $ noteS @OperationDenied activated + tm <- getTeamMember (tUnqualified lusr) Nothing + for_ tm $ + permissionCheck AddRemoveConvMember . Just + ensureConnected lusr allUsers +checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do + let convTeam = cnvTeamId tinfo + mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam) + teamAssociation <- case mTeamMember of + Just tm -> pure (Just (Right tm)) + Nothing -> do + Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr) + + case newConv.newConvGroupConvType of + Channel -> do + ensureCreateChannelPermissions tinfo.cnvTeamId mTeamMember + GroupConversation -> do + void $ permissionCheck CreateConversation teamAssociation + when (length allUsers > 1 || Public.newConvProtocol newConv == BaseProtocolMLSTag) $ do + void $ permissionCheck AddRemoveConvMember teamAssociation + + convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) + ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) + ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) + ensureConnectedToRemotes lusr (ulRemotes allUsers) + where + ensureCreateChannelPermissions :: + forall r. + ( Member (ErrorS OperationDenied) r, + Member FeaturesConfigSubsystem r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r + ) => + TeamId -> + Maybe TeamMember -> + Sem r () + ensureCreateChannelPermissions tid (Just tm) = do + channelsConf :: LockableFeature ChannelsConfig <- getFeatureForTeam tid + when (channelsConf.status == FeatureStatusDisabled) $ throwS @'ChannelsNotEnabled + when (Public.newConvProtocol newConv /= BaseProtocolMLSTag) $ throwS @'NotAnMlsConversation + case channelsConf.config.allowedToCreateChannels of + Conf.Everyone -> pure () + Conf.TeamMembers -> void $ permissionCheck AddRemoveConvMember $ Just tm + Conf.Admins -> unless (isAdminOrOwner (tm ^. permissions)) $ throwS @OperationDenied + ensureCreateChannelPermissions _ Nothing = do + throwS @'NotATeamMember + +getTeamMember :: (Member TeamStore r, Member TeamSubsystem r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) +getTeamMember uid (Just tid) = TeamSubsystem.internalGetTeamMember uid tid +getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember uid) . headMay + +createLegacyOne2OneConversationUnchecked :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Local UserId -> + Sem r (StoredConversation, Bool) +createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do + lcnv <- localOne2OneConvId self other + let meta = + (defConversationMetadata (Just (tUnqualified self))) + { cnvmType = Public.One2OneConv, + cnvmTeam = mtid, + cnvmName = fmap fromRange name + } + let nc = + Data.NewConversation + { users = ulFromLocals (map (toUserRole . tUnqualified) [self, other]), + protocol = BaseProtocolProteusTag, + metadata = meta, + groupId = Nothing + } + mc <- ConvStore.getConversation (tUnqualified lcnv) + case mc of + Just c -> pure (c, False) + Nothing -> do + conv <- createConversationImpl lcnv self nc + pure (conv, True) + +createOne2OneConversationUnchecked :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (StoredConversation, Bool) +createOne2OneConversationUnchecked self zcon name mtid other = do + let create = + foldQualified + self + createOne2OneConversationLocally + createOne2OneConversationRemotely + create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other + +createOne2OneConversationLocally :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member TinyLog r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (Embed IO) r, + Member (FederationAPIAccess FederatorClient) r + ) => + Local ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (StoredConversation, Bool) +createOne2OneConversationLocally lcnv self _zcon name mtid other = do + mc <- ConvStore.getConversation (tUnqualified lcnv) + case mc of + Just c -> pure (c, False) + Nothing -> do + let meta = + (defConversationMetadata (Just (tUnqualified self))) + { cnvmType = Public.One2OneConv, + cnvmTeam = mtid, + cnvmName = fmap fromRange name + } + let nc = + Data.NewConversation + { metadata = meta, + users = fmap toUserRole (toUserList lcnv [tUntagged self, other]), + protocol = BaseProtocolProteusTag, + groupId = Nothing + } + conv <- createConversationImpl lcnv self nc + pure (conv, True) + +createOne2OneConversationRemotely :: + (Member (Error FederationError) r) => + Remote ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Sem r (StoredConversation, Bool) +createOne2OneConversationRemotely _ _ _ _name _mtid _ = + throw FederationNotImplemented + +newRegularConversation :: + ( Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS OperationDenied) r, + Member (Error InvalidInput) r, + Member (Input ConversationSubsystemConfig) r, + Member ConversationStore r + ) => + Local UserId -> + Public.NewConv -> + Sem r (Data.NewConversation, ConvSizeChecked UserList UserId) +newRegularConversation lusr newConv = do + cfg <- input + let uncheckedUsers = newConvMembers lusr newConv + forM_ newConv.newConvParent $ \parent -> do + mMembership <- ConvStore.getLocalMember parent (tUnqualified lusr) + when (isNothing mMembership) $ + throwS @OperationDenied + users <- case Public.newConvProtocol newConv of + BaseProtocolProteusTag -> checkedConvSize cfg uncheckedUsers + BaseProtocolMLSTag -> do + unless (null uncheckedUsers) $ throwS @'MLSNonEmptyMemberList + pure mempty + let usersWithoutCreator = (,newConvUsersRole newConv) <$> fromConvSize users + newConvUsersRoles = + if newConv.newConvSkipCreator + then usersWithoutCreator + else ulAddLocal (toUserRole (tUnqualified lusr)) usersWithoutCreator + let nc = + Data.NewConversation + { metadata = + Public.ConversationMetadata + { cnvmType = Public.RegularConv, + cnvmCreator = Just (tUnqualified lusr), + cnvmAccess = access newConv, + cnvmAccessRoles = accessRoles newConv, + cnvmName = fmap fromRange newConv.newConvName, + cnvmMessageTimer = newConv.newConvMessageTimer, + cnvmReceiptMode = case Public.newConvProtocol newConv of + BaseProtocolProteusTag -> newConv.newConvReceiptMode + BaseProtocolMLSTag -> Just def, + cnvmTeam = fmap cnvTeamId newConv.newConvTeam, + cnvmGroupConvType = Just newConv.newConvGroupConvType, + cnvmChannelAddPermission = if newConv.newConvGroupConvType == Channel then newConv.newConvChannelAddPermission <|> Just def else Nothing, + cnvmCellsState = + if newConv.newConvCells + then CellsPending + else CellsDisabled, + cnvmParent = newConv.newConvParent + }, + users = newConvUsersRoles, + protocol = Public.newConvProtocol newConv, + groupId = Nothing + } + pure (nc, users) + +localOne2OneConvId :: + (Member (Error InvalidInput) r) => + Local UserId -> + Local UserId -> + Sem r (Local ConvId) +localOne2OneConvId self other = do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + pure . qualifyAs self $ Data.localOne2OneConvId x y + +toUUIDs :: + (Member (Error InvalidInput) r) => + UserId -> + UserId -> + Sem r (U.UUID U.V4, U.UUID U.V4) +toUUIDs a b = do + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 + pure (a', b') + +accessRoles :: Public.NewConv -> Set AccessRole +accessRoles b = fromMaybe defRole (newConvAccessRoles b) + +access :: Public.NewConv -> [Access] +access a = case Set.toList (Public.newConvAccess a) of + [] -> Data.defRegularConvAccess + (x : xs) -> x : xs + +newConvMembers :: Local x -> Public.NewConv -> UserList UserId +newConvMembers loc body = + UserList (newConvUsers body) [] + <> toUserList loc (newConvQualifiedUsers body) + +newOne2OneConvMembers :: Local x -> Public.NewOne2OneConv -> UserList UserId +newOne2OneConvMembers loc body = + UserList body.users [] + <> toUserList loc body.qualifiedUsers + +ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a +ensureOne [x] = pure x +ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") + +assertMLSEnabled :: (Member (Input ConversationSubsystemConfig) r, Member (ErrorS 'MLSNotEnabled) r) => Sem r () +assertMLSEnabled = do + cfg <- input + when (null cfg.mlsKeys) $ throwS @'MLSNotEnabled + +newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} + deriving (Functor, Foldable, Traversable) + deriving newtype (Semigroup, Monoid) + +checkedConvSize :: + (Member (Error InvalidInput) r, Foldable f) => + ConversationSubsystemConfig -> + f a -> + Sem r (ConvSizeChecked f a) +checkedConvSize cfg x = do + let minV :: Integer = 0 + limit = cfg.maxConvSize - 1 + if length x <= fromIntegral limit + then pure (ConvSizeChecked x) + else throwErr (errorMsg minV limit "") + +rangeChecked :: (KnownNat n, KnownNat m, Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) +rangeChecked = either throwErr pure . checkedEither +{-# INLINE rangeChecked #-} + +rangeCheckedMaybe :: + (Member (Error InvalidInput) r, KnownNat n, KnownNat m, Within a n m) => + Maybe a -> + Sem r (Maybe (Range n m a)) +rangeCheckedMaybe Nothing = pure Nothing +rangeCheckedMaybe (Just a) = Just <$> rangeChecked a +{-# INLINE rangeCheckedMaybe #-} + +throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a +throwErr = throw . InvalidRange . fromString + +checkBindingTeamPermissions :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamCollaboratorsSubsystem r, + Member TeamStore r, + Member TeamSubsystem r + ) => + Local UserId -> + Local UserId -> + TeamId -> + Sem r (Maybe TeamId) +checkBindingTeamPermissions lusr lother tid = do + mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr) + zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid + case (mTeamCollaborator, zusrMembership) of + (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator + (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember + (Just collaborator, Just member) -> + unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $ + throwS @OperationDenied + TeamStore.getTeamBinding tid >>= \case + Just Binding -> do + when (isJust zusrMembership) $ + verifyMembership tid (tUnqualified lusr) + mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother) + unless (isJust mOtherTeamCollaborator) $ + verifyMembership tid (tUnqualified lother) + pure (Just tid) + Just _ -> throwS @'NonBindingTeam + Nothing -> throwS @'TeamNotFound + where + guardPerm p m = + if m `hasPermission` p + then pure () + else throwS @OperationDenied + +verifyMembership :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member TeamSubsystem r + ) => + TeamId -> + UserId -> + Sem r () +verifyMembership tid u = do + membership <- TeamSubsystem.internalGetTeamMember u tid + when (isNothing membership) $ + throwS @'NoBindingTeamMembers sendCellsNotification :: ( Member NotificationSubsystem r, @@ -215,244 +889,3 @@ notifyConversationActionImpl tag eventFrom notifyOrigDomain con lconv targetsLoc pushConversationEvent con conv.metadata.cnvmCellsState e (qualifyAs lcnv targetsLocal) targetsBots pure $ LocalConversationUpdate {lcuEvent = e, lcuUpdate = update} - -pushConversationEvent :: - ( Member ExternalAccess r, - Member NotificationSubsystem r, - Foldable f - ) => - Maybe ConnId -> - CellsState -> - Event -> - Local (f UserId) -> - f BotMember -> - Sem r () -pushConversationEvent conn st e lusers bots = do - NS.pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] - deliverAsync (map (,e) (toList bots)) - where - newConversationEventPush :: Local [UserId] -> Push - newConversationEventPush users = - let eventFromUser = eventFromUserId e.evtFrom - musr = guard (tDomain users == qDomain eventFromUser) $> qUnqualified eventFromUser - in def - { origin = musr, - json = toJSONObject e, - recipients = map NS.userRecipient (tUnqualified users), - isCellsEvent = shouldPushToCells st e - } - -toConversationCreated :: - UTCTime -> - Local UserId -> - StoredConversation -> - ConversationCreated ConvId -toConversationCreated now lusr StoredConversation {metadata = Public.ConversationMetadata {..}, ..} = - ConversationCreated - { time = now, - origUserId = tUnqualified lusr, - cnvId = id_, - cnvType = cnvmType, - cnvAccess = cnvmAccess, - cnvAccessRoles = cnvmAccessRoles, - cnvName = cnvmName, - nonCreatorMembers = Set.empty, - messageTimer = cnvmMessageTimer, - receiptMode = cnvmReceiptMode, - protocol = protocol, - groupConvType = cnvmGroupConvType, - channelAddPermission = cnvmChannelAddPermission - } - -fromConversationCreated :: - Local x -> - ConversationCreated (Remote ConvId) -> - [(Public.Member, Public.OwnConversation)] -fromConversationCreated loc rc@ConversationCreated {..} = - let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers - creatorOther = - Public.OtherMember - (tUntagged (ccRemoteOrigUserId rc)) - Nothing - roleNameWireAdmin - in foldMap - ( \(me, others) -> - guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) - ) - membersView - where - inDomain :: Public.OtherMember -> Bool - inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId - setHoles :: (Ord a) => Set a -> [(a, Set a)] - setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s - toMember :: Public.OtherMember -> Public.Member - toMember m = - Public.Member - { memId = Public.omQualifiedId m, - memService = Public.omService m, - memOtrMutedStatus = Nothing, - memOtrMutedRef = Nothing, - memOtrArchived = False, - memOtrArchivedRef = Nothing, - memHidden = False, - memHiddenRef = Nothing, - memConvRoleName = Public.omConvRoleName m - } - conv :: Public.Member -> [Public.OtherMember] -> Public.OwnConversation - conv this others = - Public.OwnConversation - (tUntagged cnvId) - Public.ConversationMetadata - { cnvmType = cnvType, - cnvmCreator = Just origUserId, - cnvmAccess = cnvAccess, - cnvmAccessRoles = cnvAccessRoles, - cnvmName = cnvName, - cnvmTeam = Nothing, - cnvmMessageTimer = messageTimer, - cnvmReceiptMode = receiptMode, - cnvmGroupConvType = groupConvType, - cnvmChannelAddPermission = channelAddPermission, - cnvmCellsState = def, - cnvmParent = Nothing - } - (Public.OwnConvMembers this others) - ProtocolProteus - -registerRemoteConversationMemberships :: - ( Member ConvStore.ConversationStore r, - Member (Error UnreachableBackends) r, - Member (Error FederationError) r, - Member BackendNotificationQueueAccess r, - Member (FederationAPIAccess FederatorClient) r, - Member TinyLog r - ) => - UTCTime -> - Local UserId -> - Local StoredConversation -> - JoinType -> - Sem r () -registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do - let c = tUnqualified lc - rc = toConversationCreated now lusr c - allRemoteMembers = nubOrd c.remoteMembers - allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers - allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> - void $ fedClient @'Brig @"api-version" () - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ - \rrms -> - fedClient @'Galley @"on-conversation-created" - ( rc - { nonCreatorMembers = - toMembers (tUnqualified rrms) - } - ) - - let joined :: [Remote [RemoteMember]] = allRemoteBuckets - joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] - joinedCoupled = - foldMap - ( \ruids -> - let nj = - foldMap (fmap (.id_) . tUnqualified) $ - filter (\r -> tDomain r /= tDomain ruids) joined - in case NE.nonEmpty nj of - Nothing -> [] - Just v -> [fmap (,v) ruids] - ) - joined - - void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> - makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle - where - creator :: Maybe UserId - creator = Public.cnvmCreator . (.metadata) . tUnqualified $ lc - - localNonCreators :: [Public.OtherMember] - localNonCreators = - fmap (localMemberToOther . tDomain $ lc) - . filter (\lm -> lm.id_ `notElem` creator) - . (.localMembers) - . tUnqualified - $ lc - - toMembers :: [RemoteMember] -> Set Public.OtherMember - toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs - - convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate - convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = - ConversationUpdate - { time = now, - origUserId = tUntagged lusr, - convId = (tUnqualified lc).id_, - alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, - action = - SomeConversationAction - (sing @'ConversationJoinTag) - (Public.ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), - extraConversationData = def - } - - deleteOnUnreachable :: - ( Member ConvStore.ConversationStore r, - Member (Error UnreachableBackends) r, - Member TinyLog r - ) => - Sem r a -> - Sem r a - deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do - P.err . msg $ - val "Unreachable backend when notifying" - +++ val "error" - +++ (LT.pack . show $ e) - ConvStore.deleteConversation (tUnqualified lc).id_ - throw e - -notifyCreatedConversation :: - ( Member ConvStore.ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - NS.pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == Public.RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = [localMemberToRecipient m], - isCellsEvent = False, - route, - conn - } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs deleted file mode 100644 index cf4837fb6b8..00000000000 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} - -module Wire.ConversationSubsystem.Notification where - -import Data.Bifunctor -import Data.Default -import Data.Id -import Data.Json.Util -import Data.List.Extra (nubOrd) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Qualified -import Data.Set qualified as Set -import Data.Singletons -import Data.Time -import Galley.Types.Error (InternalError) -import Imports -import Network.AMQP qualified as Q -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import Wire.API.Component (Component (..)) -import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) -import Wire.API.Conversation qualified as Public -import Wire.API.Conversation.Action -import Wire.API.Conversation.Protocol -import Wire.API.Conversation.Role -import Wire.API.Error.Galley (UnreachableBackends (..)) -import Wire.API.Event.Conversation -import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) -import Wire.API.Federation.API.Galley -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.API.Push.V2 qualified as PushV2 -import Wire.BackendNotificationQueueAccess -import Wire.ConversationStore -import Wire.ConversationSubsystem.Federation (ensureNoUnreachableBackends) -import Wire.ConversationSubsystem.View -import Wire.FederationAPIAccess -import Wire.FederationAPIAccess qualified as E -import Wire.NotificationSubsystem -import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now -import Wire.StoredConversation as Data - -toConversationCreated :: - UTCTime -> - Local UserId -> - StoredConversation -> - ConversationCreated ConvId -toConversationCreated now lusr StoredConversation {metadata = ConversationMetadata {..}, ..} = - ConversationCreated - { time = now, - origUserId = tUnqualified lusr, - cnvId = id_, - cnvType = cnvmType, - cnvAccess = cnvmAccess, - cnvAccessRoles = cnvmAccessRoles, - cnvName = cnvmName, - nonCreatorMembers = Set.empty, - messageTimer = cnvmMessageTimer, - receiptMode = cnvmReceiptMode, - protocol = protocol, - groupConvType = cnvmGroupConvType, - channelAddPermission = cnvmChannelAddPermission - } - -fromConversationCreated :: - Local x -> - ConversationCreated (Remote ConvId) -> - [(Public.Member, Public.OwnConversation)] -fromConversationCreated loc rc@ConversationCreated {..} = - let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers - creatorOther = - OtherMember - (tUntagged (ccRemoteOrigUserId rc)) - Nothing - roleNameWireAdmin - in foldMap - ( \(me, others) -> - guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) - ) - membersView - where - inDomain :: OtherMember -> Bool - inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId - setHoles :: (Ord a) => Set a -> [(a, Set a)] - setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s - toMember :: OtherMember -> Public.Member - toMember m = - Public.Member - { memId = Public.omQualifiedId m, - memService = Public.omService m, - memOtrMutedStatus = Nothing, - memOtrMutedRef = Nothing, - memOtrArchived = False, - memOtrArchivedRef = Nothing, - memHidden = False, - memHiddenRef = Nothing, - memConvRoleName = Public.omConvRoleName m - } - conv :: Public.Member -> [OtherMember] -> Public.OwnConversation - conv this others = - Public.OwnConversation - (tUntagged cnvId) - ConversationMetadata - { cnvmType = cnvType, - cnvmCreator = Just origUserId, - cnvmAccess = cnvAccess, - cnvmAccessRoles = cnvAccessRoles, - cnvmName = cnvName, - cnvmTeam = Nothing, - cnvmMessageTimer = messageTimer, - cnvmReceiptMode = receiptMode, - cnvmGroupConvType = groupConvType, - cnvmChannelAddPermission = channelAddPermission, - cnvmCellsState = def, - cnvmParent = Nothing - } - (OwnConvMembers this others) - ProtocolProteus - -registerRemoteConversationMemberships :: - ( Member ConversationStore r, - Member (Error UnreachableBackends) r, - Member (Error FederationError) r, - Member BackendNotificationQueueAccess r, - Member (FederationAPIAccess FederatorClient) r - ) => - UTCTime -> - Local UserId -> - Local StoredConversation -> - JoinType -> - Sem r () -registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do - let c = tUnqualified lc - rc = toConversationCreated now lusr c - allRemoteMembers = nubOrd c.remoteMembers - allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers - allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> - void $ fedClient @'Brig @"api-version" () - - void . (ensureNoUnreachableBackends =<<) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ - \rrms -> - fedClient @'Galley @"on-conversation-created" - ( rc - { nonCreatorMembers = - toMembers (tUnqualified rrms) - } - ) - - let joined :: [Remote [RemoteMember]] = allRemoteBuckets - joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] - joinedCoupled = - foldMap - ( \ruids -> - let nj = - foldMap (fmap (.id_) . tUnqualified) $ - filter (\r -> tDomain r /= tDomain ruids) joined - in case NE.nonEmpty nj of - Nothing -> [] - Just v -> [fmap (,v) ruids] - ) - joined - - void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> - makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle - where - creator :: Maybe UserId - creator = cnvmCreator . (.metadata) . tUnqualified $ lc - - localNonCreators :: [OtherMember] - localNonCreators = - fmap (localMemberToOther . tDomain $ lc) - . filter (\lm -> lm.id_ `notElem` creator) - . (.localMembers) - . tUnqualified - $ lc - - toMembers :: [RemoteMember] -> Set OtherMember - toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs - - convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate - convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = - ConversationUpdate - { time = now, - origUserId = tUntagged lusr, - convId = (tUnqualified lc).id_, - alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, - action = - SomeConversationAction - (sing @'ConversationJoinTag) - (ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), - extraConversationData = def - } - - deleteOnUnreachable :: - ( Member ConversationStore r, - Member (Error UnreachableBackends) r - ) => - Sem r a -> - Sem r a - deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do - deleteConversation (tUnqualified lc).id_ - throw e - -notifyCreatedConversation :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = [localMemberToRecipient m], - isCellsEvent = False, - route, - conn - } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 63370a7223e..bba97428e16 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -49,7 +49,6 @@ import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.TinyLog qualified as P import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -67,7 +66,6 @@ import Wire.API.Federation.Error import Wire.API.Federation.Version import Wire.API.MLS.Group.Serialisation import Wire.API.Push.V2 qualified as PushV2 -import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Util import Wire.API.Team.Collaborator import Wire.API.Team.Collaborator qualified as CollaboratorPermission (CollaboratorPermission (..)) @@ -85,7 +83,6 @@ import Wire.CodeStore.Code as DataTypes import Wire.ConversationStore import Wire.ConversationSubsystem.Federation import Wire.ConversationSubsystem.Types -import Wire.ConversationSubsystem.View import Wire.Effects.ClientStore import Wire.ExternalAccess import Wire.FederationAPIAccess @@ -1127,15 +1124,6 @@ ensureMemberLimit _ old new = do when (length old + length new > maxSize) $ throwS @'TooManyMembers -conversationExisted :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse OwnConversation) -conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv - getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 80cfd1d87e9..9046c667d8a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -243,14 +243,11 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem - Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Interpreter - Wire.ConversationSubsystem.Notification Wire.ConversationSubsystem.One2One Wire.ConversationSubsystem.Types Wire.ConversationSubsystem.Util - Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 2b73310cbc5..36a43859ddb 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -57,6 +57,7 @@ library , retry , servant-client , servant-server + , tagged , text , tinylog , transformers diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 58beb333294..539e391c276 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -39,6 +39,7 @@ , servant-client , servant-client-core , servant-server +, tagged , text , tinylog , transformers @@ -84,6 +85,7 @@ mkDerivation { retry servant-client servant-server + tagged text tinylog transformers diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 324e5d8f9ce..3ce7684df64 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,9 +22,11 @@ where import Data.Id 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, internalErrorDescription) +import Galley.Types.Error (InternalError, InvalidInput, internalErrorDescription) +import Galley.Types.Teams (FeatureDefaults (FeatureLegalHoldDisabledPermanently), FeatureFlags) import Hasql.Pool (UsageError) import Imports import Polysemy @@ -35,7 +37,9 @@ import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger as Logger import Wire.API.BackgroundJobs (Job (..)) +import Wire.API.Error.Galley import Wire.API.Federation.Error (FederationError) +import Wire.API.Team.Collaborator (TeamCollaboratorsError) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BackgroundJobsRunner (runJob) @@ -45,11 +49,16 @@ import Wire.BrigAPIAccess.Rpc import Wire.ConversationStore import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..), 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.FireAndForget (interpretFireAndForget) import Wire.GundeckAPIAccess +import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) +import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.NotificationSubsystem.Interpreter import Wire.ParseException import Wire.Rpc @@ -61,6 +70,13 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now.IO (nowToIO) import Wire.Sem.Random.IO (randomToIO) import Wire.ServiceStore.Cassandra (interpretServiceStoreToCassandra) +import Wire.SparAPIAccess.Rpc (interpretSparAPIAccessToRpc) +import Wire.TeamCollaboratorsStore.Postgres (interpretTeamCollaboratorsStoreToPostgres) +import Wire.TeamCollaboratorsSubsystem.Interpreter (interpretTeamCollaboratorsSubsystem) +import Wire.TeamFeatureStore.Cassandra (TeamFeatureStoreError, interpretTeamFeatureStoreToCassandra) +import Wire.TeamJournal.Aws (interpretTeamJournal) +import Wire.TeamStore.Cassandra (interpretTeamStoreToCassandra) +import Wire.TeamSubsystem.Interpreter (TeamSubsystemConfig (..), interpretTeamSubsystem) import Wire.UserGroupStore.Postgres (interpretUserGroupStoreToPostgres) import Wire.UserStore.Cassandra (interpretUserStoreCassandra) @@ -84,6 +100,15 @@ dispatchJob job = do http2Manager = env.http2Manager, requestId = job.requestId } + conversationSubsystemConfig = + ConversationSubsystemConfig + { mlsKeys = Nothing, + federationProtocols = Nothing, + legalholdDefaults = FeatureLegalHoldDisabledPermanently, + maxConvSize = 1000 + } + teamSubsystemConfig = TeamSubsystemConfig {concurrentDeletionEvents = 1} + legalHoldEnv = LegalHoldEnv (\_ _ _ -> pure (error "LegalHoldEnv")) (\_ _ _ -> pure (error "LegalHoldEnv")) runFinal @IO . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO @@ -94,20 +119,50 @@ dispatchJob job = do . 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 @NonFederatingBackends (T.pack . show) + . mapError @TeamCollaboratorsError (const ("Team collaborators error" :: Text)) + . mapError @TeamFeatureStoreError (const ("Team feature store error" :: 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)) . interpretTinyLog env job.requestId job.jobId . runInputConst env.hasqlPool . runInputConst (toLocalUnsafe env.federationDomain ()) + . runInputConst conversationSubsystemConfig + . runInputConst (error "FeatureFlags" :: FeatureFlags) + . runInputConst (FeatureLegalHoldDisabledPermanently) + . runInputConst env.cassandraGalley + . runInputConst legalHoldEnv + . runInputConst (ExposeInvitationURLsAllowlist []) . interpretServiceStoreToCassandra env.cassandraBrig . interpretUserStoreCassandra env.cassandraBrig . interpretUserGroupStoreToPostgres + . interpretTeamFeatureStoreToCassandra + . convStoreInterpreter env + . interpretTeamStoreToCassandra + . interpretTeamCollaboratorsStoreToPostgres + . interpretLegalHoldStoreToCassandra FeatureLegalHoldDisabledPermanently + . interpretTeamJournal Nothing . interpretBackgroundJobsPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel . nowToIO . randomToIO . interpretFireAndForget . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess (Just $ backendQueueEnv env) - . convStoreInterpreter env . runRpcWithHttp env.httpManager job.requestId . runGundeckAPIAccess env.gundeckEndpoint -- FUTUREWORK: Currently the brig access effect is needed for the interpreter of ExternalAccess. @@ -115,8 +170,13 @@ dispatchJob job = do -- However, to prevent the background worker to require HTTP access to brig, we should consider refactoring this at some point. . interpretBrigAccess env.brigEndpoint . interpretExternalAccess extEnv + . interpretSparAPIAccessToRpc (error "Spar endpoint") . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) . interpretFederationAPIAccess federationAPIAccessConfig + . interpretTeamSubsystem teamSubsystemConfig + . runFeaturesConfigSubsystem + . runInputSem getAllTeamFeaturesForServer + . interpretTeamCollaboratorsSubsystem . interpretConversationSubsystem . interpretBackgroundJobsRunner diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index eefbd7301cb..f6d0cb8507f 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -79,6 +79,7 @@ library Galley.API.Action.Notify Galley.API.Action.Reset Galley.API.Clients + Galley.API.Create Galley.API.CustomBackend Galley.API.Federation Galley.API.Internal @@ -86,6 +87,7 @@ library Galley.API.LegalHold.Conflicts Galley.API.LegalHold.Get Galley.API.LegalHold.Team + Galley.API.Mapping Galley.API.Message Galley.API.MLS Galley.API.MLS.CheckClients diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs new file mode 100644 index 00000000000..3c8e8e2a9d8 --- /dev/null +++ b/services/galley/src/Galley/API/Create.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- 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.Default +import Data.Id +import Data.Json.Util (ToJSONObject (toJSONObject)) +import Data.Qualified +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 (UnreachableBackends) +import Wire.API.Event.Conversation +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as PushV2 +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Interpreter qualified as Interpreter +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationAPIAccess qualified as E +import Wire.NotificationSubsystem (NotificationSubsystem) +import Wire.NotificationSubsystem qualified as NS +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredConversation (StoredConversation, localMemberToOther, remoteMemberToOther) +import Wire.StoredConversation qualified as Data + +---------------------------------------------------------------------------- +-- API Handlers + +createGroupConversationUpToV3 :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createGroupConversationUpToV3 lusr conn newConv = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + conversationCreated lusr dbConv + +createGroupOwnConversation :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + conv <- conversationViewV9 lusr dbConv + pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty + +createGroupConversation :: + (Member ConversationSubsystem.ConversationSubsystem r) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + 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 (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr + if created + then conversationCreated lusr c + else conversationExisted lusr c + +createOne2OneConversation :: + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess 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 conversationCreated lusr c + else conversationExisted lusr c + +---------------------------------------------------------------------------- +-- Helpers + +conversationCreated :: + ( Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member P.TinyLog r, + Member Now r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationCreated lusr cnv = do + unless (Data.convType cnv == Public.SelfConv) $ do + notifyCreatedConversation lusr Nothing cnv def + Created <$> conversationViewV9 lusr cnv + +conversationExisted :: + ( Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r (ConversationResponse Public.OwnConversation) +conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InternalError) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + Interpreter.registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + NS.pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == Public.RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + NS.Push + { NS.origin = Just (tUnqualified lusr), + NS.json = toJSONObject e, + NS.recipients = [NS.userRecipient m.id_], + NS.isCellsEvent = False, + NS.route = route, + NS.conn = conn, + NS.transient = False, + NS.nativePriority = Nothing, + NS.apsData = Nothing + } + +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 <- ConversationSubsystem.createConnectConversation lusr conn j + conversationExisted lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index b47da28fcb6..d370bbfc230 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -46,6 +46,8 @@ 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.API.Push import Galley.App @@ -95,8 +97,6 @@ import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View -import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FireAndForget qualified as E import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 9e090d3e5e2..179d74c8d54 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,6 +38,7 @@ 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 @@ -89,7 +90,6 @@ import Wire.ConversationStore import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/services/galley/src/Galley/API/Mapping.hs similarity index 71% rename from libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs rename to services/galley/src/Galley/API/Mapping.hs index e6a71cf0d95..efdde3f0111 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -1,4 +1,29 @@ -module Wire.ConversationSubsystem.View where +-- 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.Mapping + ( conversationViewV9, + conversationView, + conversationViewWithCachedOthers, + remoteConversationView, + conversationToRemote, + localMemberToSelf, + ) +where import Data.Domain (Domain) import Data.Id (UserId, idToText) @@ -14,6 +39,9 @@ import Wire.API.Conversation qualified as Conversation import Wire.API.Federation.API.Galley import Wire.StoredConversation +-- | View for a given user of a stored conversation. +-- +-- Throws @BadMemberState@ when the user is not part of the conversation. conversationViewV9 :: ( Member (Error InternalError) r, Member P.TinyLog r @@ -44,6 +72,9 @@ conversationView l luid conv = 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 @@ -65,6 +96,9 @@ conversationViewWithCachedOthers remoteOthers localOthers conv luid = do +++ 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 @@ -77,6 +111,7 @@ conversationViewMaybe luid remoteOthers localOthers conv = do (OwnConvMembers self others) conv.protocol +-- | View for a local user of a remote conversation. remoteConversationView :: Local UserId -> MemberStatus -> @@ -100,6 +135,10 @@ remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = (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 -> @@ -124,6 +163,8 @@ conversationToRemote localDomain ruid conv = do protocol = conv.protocol } +-- | Convert a local conversation member (as stored in the DB) to a publicly +-- facing 'Member' structure. localMemberToSelf :: Local x -> LocalMember -> Conversation.Member localMemberToSelf loc lm = Conversation.Member diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index aa05d3bc25a..faae87331a9 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,6 +21,7 @@ module Galley.API.Public.Conversation where +import Galley.API.Create import Galley.API.MLS.GroupInfo import Galley.API.MLS.SubConversation import Galley.API.Query @@ -26,7 +31,6 @@ import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem.Create conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 94ecae59804..d8ccc7fb952 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -69,6 +69,8 @@ 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.Effects import Galley.Env @@ -108,8 +110,6 @@ import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View -import Wire.ConversationSubsystem.View qualified as Mapping import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess qualified as E import Wire.HashPassword (HashPassword) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index f0d8bb0826d..a3f3f4f51cf 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,6 +91,7 @@ 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 @@ -136,7 +137,6 @@ import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.ConversationSubsystem.Util -import Wire.ConversationSubsystem.View import Wire.Effects.ClientStore qualified as E import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 611814c3563..340df91dc0f 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -100,6 +100,7 @@ import System.Logger.Extended qualified as Logger import UnliftIO.Exception qualified as UnliftIO import Wire.API.Conversation.Protocol import Wire.API.Error +import Wire.API.Error.Galley (NonFederatingBackends, UnreachableBackends) import Wire.API.Federation.Error import Wire.API.Team.Collaborator import Wire.API.Team.Feature @@ -155,9 +156,9 @@ type GalleyEffects0 = Error InvalidInput, Error ParseException, Error InternalError, - -- federation errors can be thrown by almost every endpoint, so we avoid - -- having to declare it every single time, and simply handle it here Error FederationError, + Error UnreachableBackends, + Error NonFederatingBackends, Error TeamCollaboratorsError, Error Hasql.UsageError, Error HttpError, @@ -346,6 +347,8 @@ evalGalley e = . mapError toResponse . mapError toResponse . mapError toResponse + . mapError toResponse + . mapError toResponse . logAndMapError toResponse (Text.pack . show) "migration error" . mapError mapTeamFeatureStoreError . runInputConst conversationSubsystemConfig @@ -354,6 +357,18 @@ evalGalley e = . runInputConst (e ^. cstate) . mapError toResponse . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse + . mapError toResponse . mapError rateLimitExceededToHttpError . mapError toResponse -- DynError . interpretQueue (e ^. deleteQueue) @@ -400,8 +415,8 @@ evalGalley e = . interpretTeamSubsystem teamSubsystemConfig . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer - . interpretConversationSubsystem . interpretTeamCollaboratorsSubsystem + . interpretConversationSubsystem where lh = view (options . settings . featureFlags . to npProject) e legalHoldEnv = diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index a401fffb157..7d1b9c5d48f 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -115,8 +115,8 @@ import Wire.UserGroupStore -- All the possible high-level effects. type GalleyEffects1 = - '[ TeamCollaboratorsSubsystem, - ConversationSubsystem, + '[ ConversationSubsystem, + TeamCollaboratorsSubsystem, Input AllTeamFeatures, FeaturesConfigSubsystem, TeamSubsystem, @@ -164,5 +164,17 @@ type GalleyEffects1 = Error DynError, Error RateLimitExceeded, ErrorS OperationDenied, - ErrorS 'NotATeamMember + ErrorS 'NotATeamMember, + ErrorS 'ConvAccessDenied, + ErrorS 'NotConnected, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSNonEmptyMemberList, + ErrorS 'MissingLegalholdConsent, + ErrorS 'NonBindingTeam, + ErrorS 'NoBindingTeamMembers, + ErrorS 'TeamNotFound, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ChannelsNotEnabled, + ErrorS 'NotAnMlsConversation ] diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index f527d520caf..313f11f0f55 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -66,6 +66,7 @@ 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 Galley.Options (federator, rabbitmq) import Imports hiding (id) import Imports qualified as I @@ -104,7 +105,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.View import Wire.StoredConversation hiding (convName) tests :: IO TestSetup -> TestTree diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index 722f6525582..b73a27c17b4 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,6 +25,7 @@ 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) @@ -40,7 +41,6 @@ import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), RemoteConversationV2 (..), ) -import Wire.ConversationSubsystem.View import Wire.Sem.Logger qualified as P import Wire.StoredConversation From 946c788c0f162c0cf712b0c4a574fa0d7687c99a Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 27 Jan 2026 21:48:20 +0100 Subject: [PATCH 08/11] fix: notifications --- .../Wire/ConversationSubsystem/Interpreter.hs | 12 +- .../src/Wire/ConversationSubsystem/Util.hs | 76 ++++++++++ services/galley/src/Galley/API/Create.hs | 133 ++---------------- 3 files changed, 95 insertions(+), 126 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9083de3e01a..afeb387fafe 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -255,6 +255,7 @@ createGroupConversationGeneric lusr conn newConv = do lcnv <- traverse (const Random.newId) lusr storedConv <- createConversationImpl lcnv lusr nc sendCellsNotification lusr conn storedConv + notifyConversationCreated lusr conn storedConv def pure storedConv createOne2OneConversationLogic :: @@ -332,6 +333,7 @@ createProteusSelfConversationLogic lusr = do groupId = Nothing } conv <- createConversationImpl lcnv lusr nc + notifyConversationCreated lusr Nothing conv def pure (conv, True) createConversationImpl :: @@ -394,7 +396,9 @@ createConnectConversationLogic lusr conn j = do >>= maybe (create lcnv nc) (update n) where create lcnv nc = do - createConversationImpl lcnv lusr nc + conv <- createConversationImpl lcnv lusr nc + notifyConversationCreated lusr conn conv def + pure conv update n conv = do let mems = conv.localMembers if tUnqualified lusr `isMember` mems @@ -534,7 +538,7 @@ createLegacyOne2OneConversationUnchecked :: Maybe TeamId -> Local UserId -> Sem r (StoredConversation, Bool) -createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do +createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other let meta = (defConversationMetadata (Just (tUnqualified self))) @@ -554,6 +558,7 @@ createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do Just c -> pure (c, False) Nothing -> do conv <- createConversationImpl lcnv self nc + notifyConversationCreated self (Just zcon) conv def pure (conv, True) createOne2OneConversationUnchecked :: @@ -601,7 +606,7 @@ createOne2OneConversationLocally :: Maybe TeamId -> Qualified UserId -> Sem r (StoredConversation, Bool) -createOne2OneConversationLocally lcnv self _zcon name mtid other = do +createOne2OneConversationLocally lcnv self zcon name mtid other = do mc <- ConvStore.getConversation (tUnqualified lcnv) case mc of Just c -> pure (c, False) @@ -620,6 +625,7 @@ createOne2OneConversationLocally lcnv self _zcon name mtid other = do groupId = Nothing } conv <- createConversationImpl lcnv self nc + notifyConversationCreated self (Just zcon) conv def pure (conv, True) createOne2OneConversationRemotely :: diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index bba97428e16..e1b7eb39523 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -1190,3 +1190,79 @@ notifyConversationUpdated lusr conn j conv = do conn } ] + +-- | Convert a local conversation member (as stored in the DB) to a publicly +-- facing 'Member' structure. +localMemberToSelf :: Local x -> LocalMember -> Public.Member +localMemberToSelf 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 <- localMemberToSelf 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, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member BackendNotificationQueueAccess r, + Member Now r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyConversationCreated lusr conn conv joinType = do + now <- Now.get + registerRemoteConversationMemberships now lusr (qualifyAs lusr conv) joinType + unless (null conv.remoteMembers) $ + unlessM isFederationConfigured $ + throw FederationNotConfigured + + let remoteOthers = map remoteMemberToOther $ conv.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ conv.localMembers + lusers = conv.localMembers + route + | Data.convType conv == Public.RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + + forM_ lusers $ \lm -> do + let luid = toLocalUnsafe (tDomain lusr) lm.id_ + forM_ (conversationViewMaybe luid remoteOthers localOthers conv) $ \ownConv -> do + let e = Event (tUntagged . qualifyAs luid $ conv.id_) Nothing (EventFromUser (tUntagged lusr)) now Nothing (EdConversation ownConv) + pushNotifications + [ def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [userRecipient lm.id_], + isCellsEvent = shouldPushToCells conv.metadata e, + route = route, + conn = if lm.id_ == tUnqualified lusr then conn else Nothing + } + ] diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 3c8e8e2a9d8..adbc061ff4d 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -21,9 +21,7 @@ module Galley.API.Create where -import Data.Default import Data.Id -import Data.Json.Util (ToJSONObject (toJSONObject)) import Data.Qualified import Galley.API.Mapping import Galley.Types.Error @@ -33,25 +31,10 @@ 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 (UnreachableBackends) -import Wire.API.Event.Conversation -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.API.Push.V2 qualified as PushV2 +import Wire.API.Event.Conversation (Connect) import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) -import Wire.ConversationStore (ConversationStore) import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Interpreter qualified as Interpreter -import Wire.FederationAPIAccess (FederationAPIAccess) -import Wire.FederationAPIAccess qualified as E -import Wire.NotificationSubsystem (NotificationSubsystem) -import Wire.NotificationSubsystem qualified as NS -import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now -import Wire.StoredConversation (StoredConversation, localMemberToOther, remoteMemberToOther) -import Wire.StoredConversation qualified as Data ---------------------------------------------------------------------------- -- API Handlers @@ -59,14 +42,7 @@ import Wire.StoredConversation qualified as Data createGroupConversationUpToV3 :: ( Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r + Member P.TinyLog r ) => Local UserId -> Maybe ConnId -> @@ -74,7 +50,7 @@ createGroupConversationUpToV3 :: Sem r (ConversationResponse Public.OwnConversation) createGroupConversationUpToV3 lusr conn newConv = do dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - conversationCreated lusr dbConv + Created <$> conversationViewV9 lusr dbConv createGroupOwnConversation :: ( Member ConversationSubsystem.ConversationSubsystem r, @@ -107,34 +83,20 @@ createGroupConversation lusr conn newConv = do createProteusSelfConversation :: ( Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r + Member P.TinyLog r ) => Local UserId -> Sem r (ConversationResponse Public.OwnConversation) createProteusSelfConversation lusr = do (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr if created - then conversationCreated lusr c - else conversationExisted lusr c + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c createOne2OneConversation :: ( Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r + Member P.TinyLog r ) => Local UserId -> ConnId -> @@ -143,87 +105,12 @@ createOne2OneConversation :: createOne2OneConversation lusr zcon j = do (c, created) <- ConversationSubsystem.createOne2OneConversation lusr zcon j if created - then conversationCreated lusr c - else conversationExisted lusr c + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c ---------------------------------------------------------------------------- -- Helpers -conversationCreated :: - ( Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member P.TinyLog r, - Member Now r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationCreated lusr cnv = do - unless (Data.convType cnv == Public.SelfConv) $ do - notifyCreatedConversation lusr Nothing cnv def - Created <$> conversationViewV9 lusr cnv - -conversationExisted :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r (ConversationResponse Public.OwnConversation) -conversationExisted lusr cnv = Existed <$> conversationViewV9 lusr cnv - -notifyCreatedConversation :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member BackendNotificationQueueAccess r, - Member Now r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - StoredConversation -> - JoinType -> - Sem r () -notifyCreatedConversation lusr conn c joinType = do - now <- Now.get - Interpreter.registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType - unless (null c.remoteMembers) $ - unlessM E.isFederationConfigured $ - throw FederationNotConfigured - - NS.pushNotifications =<< mapM (toPush now) c.localMembers - where - route - | Data.convType c == Public.RegularConv = PushV2.RouteAny - | otherwise = PushV2.RouteDirect - toPush t m = do - let remoteOthers = remoteMemberToOther <$> c.remoteMembers - localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers - lconv = qualifyAs lusr c.id_ - c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) - let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') - pure $ - NS.Push - { NS.origin = Just (tUnqualified lusr), - NS.json = toJSONObject e, - NS.recipients = [NS.userRecipient m.id_], - NS.isCellsEvent = False, - NS.route = route, - NS.conn = conn, - NS.transient = False, - NS.nativePriority = Nothing, - NS.apsData = Nothing - } - createConnectConversation :: ( Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, @@ -235,4 +122,4 @@ createConnectConversation :: Sem r (ConversationResponse Public.OwnConversation) createConnectConversation lusr conn j = do c <- ConversationSubsystem.createConnectConversation lusr conn j - conversationExisted lusr c + Existed <$> conversationViewV9 lusr c From 90bd30ce2e5a04b88e92a843f309c89ee38a37f1 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 27 Jan 2026 23:39:08 +0100 Subject: [PATCH 09/11] fix: last extra event --- .../src/Wire/ConversationSubsystem/Interpreter.hs | 1 - services/galley/src/Galley/API/Create.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index afeb387fafe..bd34b86e2ad 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -333,7 +333,6 @@ createProteusSelfConversationLogic lusr = do groupId = Nothing } conv <- createConversationImpl lcnv lusr nc - notifyConversationCreated lusr Nothing conv def pure (conv, True) createConversationImpl :: diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index adbc061ff4d..18f5af99a1b 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} -- This file is part of the Wire Server implementation. -- From e7b91414c8dcbea02046d68ed3496b57c98f3575 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 28 Jan 2026 12:12:36 +0100 Subject: [PATCH 10/11] fix: Cells/Events/Conversations regressions --- .../Wire/ConversationSubsystem/Interpreter.hs | 52 ++----------------- .../src/Wire/ConversationSubsystem/Util.hs | 2 +- services/galley/src/Galley/API/Create.hs | 32 ++++++++++-- 3 files changed, 33 insertions(+), 53 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index bd34b86e2ad..45e0125da5e 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -70,7 +70,6 @@ import Wire.API.Federation.API (makeConversationUpdateBundle, sendBundle) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error -import Wire.API.FederationStatus import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Team import Wire.API.Team.Collaborator qualified as CollaboratorPermission @@ -86,7 +85,6 @@ import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.ConversationSubsystem.Federation import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Types as X import Wire.ConversationSubsystem.Util @@ -152,7 +150,7 @@ interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData ConversationSubsystem.CreateGroupConversation lusr conn newConv -> - createGroupConv lusr conn newConv + createGroupConversationGeneric lusr conn newConv ConversationSubsystem.CreateOne2OneConversation lusr conn newOne2One -> createOne2OneConversationLogic lusr conn newOne2One ConversationSubsystem.CreateProteusSelfConversation lusr -> @@ -160,51 +158,6 @@ interpretConversationSubsystem = interpret $ \case ConversationSubsystem.CreateConnectConversation lusr conn j -> createConnectConversationLogic lusr conn j -createGroupConv :: - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) 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 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r, - Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error NonFederatingBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (FederationAPIAccess FederatorClient) r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member LegalHoldStore r, - Member TeamStore r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member Now r, - Member NotificationSubsystem r, - Member (Embed IO) r, - Member TinyLog r, - Member BackendNotificationQueueAccess r - ) => - Local UserId -> - Maybe ConnId -> - Public.NewConv -> - Sem r StoredConversation -createGroupConv lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - createGroupConversationGeneric lusr conn newConv - createGroupConversationGeneric :: forall r. ( Member BrigAPIAccess r, @@ -254,8 +207,8 @@ createGroupConversationGeneric lusr conn newConv = do lcnv <- traverse (const Random.newId) lusr storedConv <- createConversationImpl lcnv lusr nc - sendCellsNotification lusr conn storedConv notifyConversationCreated lusr conn storedConv def + sendCellsNotification lusr conn storedConv pure storedConv createOne2OneConversationLogic :: @@ -397,6 +350,7 @@ createConnectConversationLogic lusr conn j = do create lcnv nc = do conv <- createConversationImpl lcnv lusr nc notifyConversationCreated lusr conn conv def + notifyConversationUpdated lusr conn j conv pure conv update n conv = do let mems = conv.localMembers diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index e1b7eb39523..060364abc67 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -1261,7 +1261,7 @@ notifyConversationCreated lusr conn conv joinType = do { origin = Just (tUnqualified lusr), json = toJSONObject e, recipients = [userRecipient lm.id_], - isCellsEvent = shouldPushToCells conv.metadata e, + isCellsEvent = False, route = route, conn = if lm.id_ == tUnqualified lusr then conn else Nothing } diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 18f5af99a1b..897dc3ec7e4 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -22,18 +22,28 @@ 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.Input (Input) 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 (NonFederatingBackends, UnreachableBackends) import Wire.API.Event.Conversation (Connect) +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error (FederationError) +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.ConversationSubsystem.Federation (checkFederationStatus, enforceFederationProtocol) +import Wire.ConversationSubsystem.Types (ConversationSubsystemConfig) +import Wire.FederationAPIAccess (FederationAPIAccess) ---------------------------------------------------------------------------- -- API Handlers @@ -54,6 +64,11 @@ createGroupConversationUpToV3 lusr conn newConv = do createGroupOwnConversation :: ( Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member (Input ConversationSubsystemConfig) r, Member P.TinyLog r ) => Local UserId -> @@ -61,17 +76,28 @@ createGroupOwnConversation :: 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 - conv <- conversationViewV9 lusr dbConv - pure . GroupConversationCreatedV9 $ CreateGroupOwnConversation conv mempty + GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) createGroupConversation :: - (Member ConversationSubsystem.ConversationSubsystem r) => + ( Member ConversationSubsystem.ConversationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member (Input ConversationSubsystemConfig) 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 From afee1009d10aa97860e4a8eb717d8f15f947e120 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 28 Jan 2026 16:50:00 +0100 Subject: [PATCH 11/11] fix: 201 vs 200 on creation --- .../src/Wire/ConversationSubsystem.hs | 2 +- .../src/Wire/ConversationSubsystem/Interpreter.hs | 12 +++++++++--- services/galley/src/Galley/API/Create.hs | 6 ++++-- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 5c961df950e..5236ff8b814 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -60,6 +60,6 @@ data ConversationSubsystem m a where Local UserId -> Maybe ConnId -> Connect -> - ConversationSubsystem m StoredConversation + ConversationSubsystem m (StoredConversation, Bool) makeSem ''ConversationSubsystem diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 45e0125da5e..c16809777aa 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -325,7 +325,7 @@ createConnectConversationLogic :: Local UserId -> Maybe ConnId -> Connect -> - Sem r StoredConversation + Sem r (StoredConversation, Bool) createConnectConversationLogic lusr conn j = do lrecipient <- ensureLocal lusr (cRecipient j) n <- rangeCheckedMaybe (cName j) @@ -344,8 +344,14 @@ createConnectConversationLogic lusr conn j = do metadata = meta, groupId = Nothing } - ConvStore.getConversation (tUnqualified lcnv) - >>= maybe (create lcnv nc) (update n) + mconv <- ConvStore.getConversation (tUnqualified lcnv) + case mconv of + Nothing -> do + conv <- create lcnv nc + pure (conv, True) + Just conv -> do + conv' <- update n conv + pure (conv', False) where create lcnv nc = do conv <- createConversationImpl lcnv lusr nc diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 897dc3ec7e4..f0efb3921ff 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -146,5 +146,7 @@ createConnectConversation :: Connect -> Sem r (ConversationResponse Public.OwnConversation) createConnectConversation lusr conn j = do - c <- ConversationSubsystem.createConnectConversation lusr conn j - Existed <$> conversationViewV9 lusr c + (c, created) <- ConversationSubsystem.createConnectConversation lusr conn j + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c