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..f17b6cc285f 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -14,8 +14,10 @@ library -- cabal-fmt: expand src exposed-modules: Galley.Types + Galley.Types.Clients Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles + Galley.Types.Error Galley.Types.Teams other-modules: Paths_galley_types @@ -76,6 +78,7 @@ library , crypton , data-default , errors + , http-types , imports , lens >=4.12 , memory @@ -84,6 +87,7 @@ library , types-common >=0.16 , utf8-string , uuid + , wai-utilities , wire-api default-language: GHC2021 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/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/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/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index ca068239bde..5236ff8b814 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,5 +43,23 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate + CreateGroupConversation :: + 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 -> + ConversationSubsystem m (StoredConversation, Bool) makeSem ''ConversationSubsystem 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 089e6d14c76..c16809777aa 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -1,3 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PolyKinds #-} +{-# 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 @@ -15,55 +28,782 @@ -- 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, + registerRemoteConversationMemberships, + ) +where +import Control.Error (headMay) +import Control.Lens hiding ((??)) import Data.Default import Data.Id 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) -import Galley.Types.Teams (FeatureDefaults) +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 Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action -import Wire.API.Conversation.CellsState (CellsState (..)) -import Wire.API.Conversation.Protocol (ProtocolTag) +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.API (makeConversationUpdateBundle, sendBundle) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) -import Wire.API.Federation.Error (FederationError) -import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) -import Wire.API.Team.Feature (LegalholdConfig) +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +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.ConversationStore (ConversationStore) +import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem -import Wire.ExternalAccess (ExternalAccess, deliverAsync) +import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.One2One +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.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now -import Wire.StoredConversation - -data ConversationSubsystemConfig = ConversationSubsystemConfig - { mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), - federationProtocols :: Maybe [ProtocolTag], - legalholdDefaults :: FeatureDefaults LegalholdConfig, - maxConvSize :: Word16 - } +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 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 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, + 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 + ConversationSubsystem.CreateGroupConversation lusr conn newConv -> + createGroupConversationGeneric 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 + +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 + notifyConversationCreated lusr conn storedConv def + 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, + Member (Error UnreachableBackends) r, + Member (Error InternalError) 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 = + 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, Bool) +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 + } + 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 + notifyConversationCreated lusr conn conv def + notifyConversationUpdated lusr conn j conv + pure conv + 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 + notifyConversationCreated self (Just zcon) conv def + 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 + notifyConversationCreated self (Just zcon) conv def + 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 + ) => + 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 +822,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 @@ -114,29 +854,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 - 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 userRecipient (tUnqualified users), - isCellsEvent = shouldPushToCells st e - } 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 91% rename from services/galley/src/Galley/API/Util.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index d8a1143b9ef..060364abc67 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,20 +40,15 @@ 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.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 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 @@ -71,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 (..)) @@ -87,7 +81,9 @@ 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.Effects.ClientStore import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.HashPassword (HashPassword) @@ -902,16 +898,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, @@ -1138,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 @@ -1187,3 +1164,105 @@ 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 + } + ] + +-- | 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 = False, + route = route, + conn = if lm.id_ == tUnqualified lusr then conn else Nothing + } + ] 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 5dc5e19c770..9046c667d8a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -243,13 +243,18 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem + Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.One2One + Wire.ConversationSubsystem.Types + Wire.ConversationSubsystem.Util Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore Wire.DomainRegistrationStore.Cassandra Wire.DomainVerificationChallengeStore Wire.DomainVerificationChallengeStore.Cassandra + Wire.Effects.ClientStore Wire.EmailSending Wire.EmailSending.SES Wire.EmailSending.SMTP diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 595e3d01eac..36a43859ddb 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 @@ -56,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 011bc91bea0..539e391c276 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 @@ -38,6 +39,7 @@ , servant-client , servant-client-core , servant-server +, tagged , text , tinylog , transformers @@ -68,6 +70,7 @@ mkDerivation { exceptions extended extra + galley-types hasql-pool HsOpenSSL http-client @@ -82,6 +85,7 @@ mkDerivation { retry servant-client servant-server + tagged text tinylog transformers 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..3ce7684df64 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,7 +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, InvalidInput, internalErrorDescription) +import Galley.Types.Teams (FeatureDefaults (FeatureLegalHoldDisabledPermanently), FeatureFlags) import Hasql.Pool (UsageError) import Imports import Polysemy @@ -33,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) @@ -43,19 +49,34 @@ 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 +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) 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) @@ -72,7 +93,24 @@ 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 + } + 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 . asyncToIOFinal . interpretRace @@ -81,19 +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. @@ -101,7 +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/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/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 988d5378dc7..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 @@ -296,6 +295,7 @@ mkDerivation { base containers extra + galley-types imports lens polysemy diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f1d6b4f299c..f6d0cb8507f 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 @@ -113,7 +112,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 @@ -134,7 +132,6 @@ library Galley.API.Teams.Features.Get Galley.API.Teams.Notifications Galley.API.Update - Galley.API.Util Galley.App Galley.Cassandra Galley.Cassandra.Client @@ -147,7 +144,6 @@ library Galley.Cassandra.Util Galley.Data.TeamNotifications Galley.Effects - Galley.Effects.ClientStore Galley.Effects.CustomBackendStore Galley.Effects.Queue Galley.Effects.SearchVisibilityStore @@ -245,8 +241,6 @@ library Galley.Schema.V97_CellsConversation Galley.Schema.V98_ChannelAddPermission Galley.Schema.V99_ConversationAddParent - Galley.Types.Clients - Galley.Validation ghc-options: -fplugin=Polysemy.Plugin other-modules: Paths_galley @@ -313,7 +307,6 @@ library , text >=0.11 , time >=1.4 , tinylog >=0.10 - , transformers , types-common >=0.16 , types-common-aws , unliftio >=0.2 @@ -571,6 +564,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..4df091a4583 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 @@ -61,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 @@ -69,16 +68,14 @@ 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 import Galley.API.Teams.Features.Get -import Galley.API.Util import Galley.Effects import Galley.Env (Env) import Galley.Options (Opts) -import Galley.Validation +import Galley.Types.Error import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -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 @@ -568,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/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 60dae17eaaf..2a402c0f40b 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -25,14 +25,12 @@ 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 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 @@ -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/Create.hs b/services/galley/src/Galley/API/Create.hs index d22b336ea75..f0efb3921ff 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -15,710 +18,127 @@ -- 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 . -module Galley.API.Create - ( createGroupConversationUpToV3, - createGroupOwnConversation, - createProteusSelfConversation, - createOne2OneConversation, - createConnectConversation, - createGroupConversation, - ) -where +module Galley.API.Create where -import Control.Error (headMay) -import Control.Lens hiding ((??)) -import Data.Default import Data.Id -import Data.Json.Util -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 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.Types.Teams (notTeamMember) -import Galley.Validation -import Imports hiding ((\\)) +import Galley.Types.Error +import Imports import Polysemy import Polysemy.Error -import Polysemy.Input +import Polysemy.Input (Input) import Polysemy.TinyLog qualified as P -import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation (CreateGroupConversation (..), CreateGroupOwnConversation (..), NewConv, NewOne2OneConv) 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.Error.Galley (NonFederatingBackends, UnreachableBackends) +import Wire.API.Event.Conversation (Connect) 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.Federation.Error (FederationError) +import Wire.API.FederationStatus (RemoteDomains (..)) 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 qualified as E -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 -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 qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem -import Wire.UserList +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) ---------------------------------------------------------------------------- --- Group conversations +-- API Handlers --- | 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 ConversationStore r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, + ( Member ConversationSubsystem.ConversationSubsystem 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 (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, - Member Now 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 + Member P.TinyLog r ) => Local UserId -> 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 = do + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + Created <$> conversationViewV9 lusr dbConv --- | 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 ConversationStore r, - Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, + ( Member ConversationSubsystem.ConversationSubsystem 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 FederationError) r, Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) 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, - Member TeamStore r, - Member P.TinyLog r, - Member FeaturesConfigSubsystem r, - Member TeamCollaboratorsSubsystem r, - Member Random r, - Member TeamSubsystem r + Member P.TinyLog 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 - ) + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) --- | 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 ConversationStore 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 NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, - Member (Input ConversationSubsystemConfig) r, - Member Now 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 CreateGroupConversation -createGroupConversation lusr conn newConv = do - createGroupConvAndMkResponse - lusr - conn - newConv - ( \dbConv -> - pure $ - CreateGroupConversation - { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, - failedToAdd = mempty - } - ) - -createGroupConvAndMkResponse :: - ( Member (Input Opts) r, - Member (Input Env) r, - Member Now r, - 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 ConversationSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member (Error UnreachableBackends) r, 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 NotificationSubsystem 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 + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- createGroupConversationGeneric lusr conn newConv def - mkResponse dbConv - -createGroupConversationGeneric :: - forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore 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 (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 NotificationSubsystem r, - Member (Input Env) r, - Member (Input Opts) r, - Member (Input ConversationSubsystemConfig) r, - Member Now 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 -> - JoinType -> - Sem r StoredConversation -createGroupConversationGeneric lusr conn newConv joinType = 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 $ Id <$> Random.uuid) lusr - conv <- E.upsertConversation lcnv 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)) - 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, - 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 + dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv + pure $ + CreateGroupConversation + { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, + failedToAdd = mempty + } 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 - } - c <- E.upsertConversation lcnv nc - conversationCreated lusr c + (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c createOne2OneConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member ConversationSubsystem.ConversationSubsystem 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 (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now 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 BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) 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 -> 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 - 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 - -createOne2OneConversationUnchecked :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore 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 -> - 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 BackendNotificationQueueAccess r, - Member ConversationStore 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 ConvId -> - Local UserId -> - ConnId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Qualified UserId -> + NewOne2OneConv -> 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 - } - c <- E.upsertConversation lcnv nc - notifyCreatedConversation self (Just zcon) c def - conversationCreated self c +createOne2OneConversation lusr zcon j = do + (c, created) <- ConversationSubsystem.createOne2OneConversation lusr zcon j + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c -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 _ _ _ _ _ _ = - throw FederationNotImplemented +---------------------------------------------------------------------------- +-- Helpers createConnectConversation :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r, - Member (Error FederationError) r, + ( Member ConversationSubsystem.ConversationSubsystem 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 ) => Local UserId -> @@ -726,248 +146,7 @@ createConnectConversation :: 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 <- 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 - } - ] - 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 - 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 - } - ] - 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 Opts) r, - Member ConversationStore r - ) => - Local UserId -> - NewConv -> - Sem r (NewConversation, ConvSizeChecked UserList UserId) -newRegularConversation lusr newConv = do - o <- 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 - 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 - --- | 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 -> - 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") + (c, created) <- ConversationSubsystem.createConnectConversation lusr conn j + if created + then Created <$> conversationViewV9 lusr c + else Existed <$> conversationViewV9 lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 725117fe7f6..d370bbfc230 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 @@ -51,11 +50,11 @@ 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 import Galley.Types.Conversations.One2One +import Galley.Types.Error import Imports import Network.Wai.Utilities.Exception import Polysemy @@ -97,6 +96,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.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 7c50cd9d5ee..179d74c8d54 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -39,11 +39,9 @@ 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 -import Galley.API.One2One import Galley.API.Public.Servant import Galley.API.Query qualified as Query import Galley.API.Teams @@ -51,15 +49,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 @@ -94,6 +91,9 @@ import Wire.ConversationStore qualified as E import Wire.ConversationStore.MLS.Types import Wire.ConversationSubsystem 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 2aa4a480886..60ffdfb2041 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -41,16 +41,15 @@ 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) import Galley.API.Update (removeMemberFromLocalConv) -import Galley.API.Util 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) @@ -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/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/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.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..06d8270ac78 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 @@ -38,8 +37,8 @@ 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 import Polysemy import Polysemy.Error @@ -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 8ca29cac361..074e6d4d9c3 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 @@ -56,8 +55,8 @@ 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 import Polysemy import Polysemy.Error @@ -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 68dc6a0a7a4..302a962338d 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -38,12 +38,11 @@ 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 @@ -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/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/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 index 91d2c338c7b..efdde3f0111 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 (InternalError (BadMemberState)) import Imports import Polysemy import Polysemy.Error 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..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 diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index ee61bf748a4..d8ccc7fb952 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -66,17 +66,15 @@ 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 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 import Imports import Polysemy import Polysemy.Error @@ -110,6 +108,8 @@ 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.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 2ac49386349..35a1ea18cf8 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -77,19 +77,17 @@ 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 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 import Imports hiding (forkIO) import Polysemy @@ -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 4c9bf4b9797..23e9c3016e7 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -41,16 +41,14 @@ 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 -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 import Imports import Polysemy @@ -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 fd4e4606b8a..a3f3f4f51cf 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,17 +91,15 @@ 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 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 +136,8 @@ import Wire.CodeStore.Code import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) +import Wire.ConversationSubsystem.Util +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/App.hs b/services/galley/src/Galley/App.hs index 2035a64c1cf..340df91dc0f 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 @@ -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/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..7d1b9c5d48f 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) @@ -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/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/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 deleted file mode 100644 index 7d045d21026..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.API.Error -import Galley.Options -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 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 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