From 5aa77be58bc9b1c76c7079842ff26e1c92878941 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 21 Apr 2026 14:10:14 +0200 Subject: [PATCH 01/18] brig-index: Don't fail when a user doc fails to build (#4839) * GalleyAPIAccess: Delete unnecessary logs * IndexUserStore.Bulk.ES: Make logs give a better idea of progress * IndexUserStore.Bulk.ElasticSearch: Don't fail when a user doc fails to build Instead just log and move on. This removes the effect and implement all actions as IO by passing the interpreter and calling it everywhere. This is not the prettiest way to do this, perhaps we figure out a way later. * Brig.Index.Eval: Share manager and cassClient between multiple invocations of runSem * brig-index: Log JSONs * Brig.Index.Eval: Remove unused effects from the stack This removes the need for having postgres. This commit doesn't remove the requirement of postgres from various commands because this might be needed again soon as the work for migrating user data to postgres is underway. --- .../3-bug-fixes/brig-index-invalid-users | 1 + .../src/Wire/GalleyAPIAccess/Rpc.hs | 145 +++----------- .../src/Wire/IndexedUserStore/Bulk.hs | 40 ---- .../IndexedUserStore/Bulk/ElasticSearch.hs | 179 ++++++++++-------- libs/wire-subsystems/wire-subsystems.cabal | 1 - services/brig/brig.cabal | 1 + services/brig/index/src/Main.hs | 9 +- services/brig/src/Brig/Index/Eval.hs | 81 +++----- 8 files changed, 149 insertions(+), 308 deletions(-) create mode 100644 changelog.d/3-bug-fixes/brig-index-invalid-users delete mode 100644 libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs diff --git a/changelog.d/3-bug-fixes/brig-index-invalid-users b/changelog.d/3-bug-fixes/brig-index-invalid-users new file mode 100644 index 00000000000..7d165e74582 --- /dev/null +++ b/changelog.d/3-bug-fixes/brig-index-invalid-users @@ -0,0 +1 @@ +brig-index: Continue indexing even when an invalid user is found in the DB \ No newline at end of file diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 4a01842e676..3479c082df8 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -38,7 +38,6 @@ import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.TinyLog import Servant.API (toHeader) import System.Logger.Message import Util.Options @@ -67,7 +66,6 @@ import Wire.Rpc interpretGalleyAPIAccessToRpc :: ( Member (Error ParseException) r, Member Rpc r, - Member TinyLog r, Member (Error ClientError) r ) => Set Version -> @@ -113,17 +111,13 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GuardLegalHold protectee userClient -> guardLegalhold protectee userClient getUserLegalholdStatus :: - ( Member TinyLog r, - Member (Error ParseException) r, + ( Member (Error ParseException) r, Member Rpc r ) => Local UserId -> TeamId -> Sem (Input Endpoint : r) (Maybe UserLegalHoldStatusResponse) getUserLegalholdStatus luid tid = do - debug $ - remote "galley" - . msg (val "get legalhold user status") rs <- galleyRequest do method GET . paths ["teams", toByteString' tid, "legalhold", toByteString' (tUnqualified luid)] @@ -141,16 +135,12 @@ galleyRequest req = do -- | Calls 'Galley.API.createSelfConversationH'. createSelfConv :: ( Member Rpc r, - Member TinyLog r, Member (Input Endpoint) r ) => Version -> UserId -> Sem r () createSelfConv v u = do - debug $ - remote "galley" - . msg (val "Creating self conversation") void $ galleyRequest $ method POST @@ -162,19 +152,13 @@ createSelfConv v u = do getConv :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Version -> UserId -> Local ConvId -> Sem r (Maybe OwnConversation) getConv v usr lcnv = do - debug $ - remote "galley" - . field "domain" (toByteString (tDomain lcnv)) - . field "conv" (toByteString (tUnqualified lcnv)) - . msg (val "Getting conversation") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -195,8 +179,7 @@ getConv v usr lcnv = do getTeamConv :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Version -> UserId -> @@ -204,10 +187,6 @@ getTeamConv :: ConvId -> Sem r (Maybe Conv.TeamConversation) getTeamConv v usr tid cnv = do - debug $ - remote "galley" - . field "conv" (toByteString cnv) - . msg (val "Getting team conversation") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -228,18 +207,12 @@ getTeamConv v usr tid cnv = do -- | Calls 'Galley.API.addClientH'. newClient :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> ClientId -> Sem r () newClient u c = do - debug $ - remote "galley" - . field "user" (toByteString u) - . field "client" (toByteString c) - . msg (val "new client") void . galleyRequest $ method POST . paths ["i", "clients", toByteString' c] @@ -249,15 +222,11 @@ newClient u c = do -- | Calls 'Galley.API.canUserJoinTeamH'. checkUserCanJoinTeam :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r (Maybe Wai.Error) checkUserCanJoinTeam tid = do - debug $ - remote "galley" - . msg (val "Check if can add member to team") rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> Nothing @@ -273,8 +242,7 @@ checkUserCanJoinTeam tid = do -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. addTeamMember :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> TeamId -> @@ -282,9 +250,6 @@ addTeamMember :: Role -> Sem r Bool addTeamMember u tid minvmeta role = do - debug $ - remote "galley" - . msg (val "Adding member to team") rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> True @@ -303,17 +268,13 @@ addTeamMember u tid minvmeta role = do -- | Calls 'Galley.API.createBindingTeamH'. createTeam :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> NewTeam -> TeamId -> Sem r () createTeam u t teamid = do - debug $ - remote "galley" - . msg (val "Creating Team") void $ galleyRequest $ req teamid where req tid = @@ -328,16 +289,12 @@ createTeam u t teamid = do getTeamMember :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> TeamId -> Sem r (Maybe TeamMember) getTeamMember u tid = do - debug $ - remote "galley" - . msg (val "Get team member") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -357,14 +314,12 @@ getTeamMember u tid = do getTeamMembersWithLimit :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> Sem r TeamMemberList getTeamMembersWithLimit tid maxResults = do - debug $ remote "galley" . msg (val "Get team members") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -376,14 +331,12 @@ getTeamMembersWithLimit tid maxResults = do selectTeamMemberInfos :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> [UserId] -> Sem r TeamMemberInfoList selectTeamMemberInfos tid uids = do - debug $ remote "galley" . msg (val "Select team members") let bdy = UserIds uids galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" where @@ -416,13 +369,11 @@ selectTeamMembers tid uids = do getTeamAdmins :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r TeamMemberList getTeamAdmins tid = do - debug $ remote "galley" . msg (val "Get team admins") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -446,13 +397,11 @@ memberIsTeamOwner tid uid = do getTeamId :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> Sem r (Maybe TeamId) getTeamId u = do - debug $ remote "galley" . msg (val "Get team from user") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -467,13 +416,11 @@ getTeamId u = do getTeam :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r Team.TeamData getTeam tid = do - debug $ remote "galley" . msg (val "Get team info") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -485,13 +432,11 @@ getTeam tid = do getTeamName :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r Team.TeamName getTeamName tid = do - debug $ remote "galley" . msg (val "Get team info") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -503,13 +448,11 @@ getTeamName tid = do getTeamLegalHoldStatus :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r (LockableFeature LegalholdConfig) getTeamLegalHoldStatus tid = do - debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -521,14 +464,12 @@ getTeamLegalHoldStatus tid = do getTeamSearchVisibility :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r TeamSearchVisibility getTeamSearchVisibility tid = coerce @TeamSearchVisibilityView @TeamSearchVisibility <$> do - debug $ remote "galley" . msg (val "Get search visibility settings") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -540,14 +481,12 @@ getFeatureConfigForTeam :: forall feature r. ( IsFeatureConfig feature, Typeable feature, - Member TinyLog r, Member Rpc r, Member (Error ParseException) r ) => TeamId -> Sem (Input Endpoint : r) (LockableFeature feature) getFeatureConfigForTeam tid = do - debug $ remote "galley" . msg (val "Get feature config for team") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -558,13 +497,11 @@ getFeatureConfigForTeam tid = do getVerificationCodeEnabled :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r Bool getVerificationCodeEnabled tid = do - debug $ remote "galley" . msg (val "Get snd factor password challenge settings") response <- galleyRequest req status <- (.status) <$> decodeBodyOrThrow @(LockableFeature SndFactorPasswordChallengeConfig) "galley" response case status of @@ -593,12 +530,10 @@ getAllTeamFeaturesForUser mbUserId = getConfiguredFeatureFlags :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Sem r FeatureFlags getConfiguredFeatureFlags = do - debug $ remote "galley" . msg (val "Getting configured feature flags") responseJsonUnsafe <$> galleyRequest ( method GET @@ -609,15 +544,13 @@ getConfiguredFeatureFlags = do -- | Calls 'Galley.API.updateTeamStatusH'. changeTeamStatus :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> Sem r () changeTeamStatus tid s cur = do - debug $ remote "galley" . msg (val "Change Team status") void $ galleyRequest req where req = @@ -648,13 +581,11 @@ finalizeDeleteTeam lusr mconn tid = do getTeamExposeInvitationURLsToTeamAdmin :: ( Member Rpc r, Member (Input Endpoint) r, - Member (Error ParseException) r, - Member TinyLog r + Member (Error ParseException) r ) => TeamId -> Sem r ShowOrHideInvitationUrl getTeamExposeInvitationURLsToTeamAdmin tid = do - debug $ remote "galley" . msg (val "Get expose invitation URLs to team admin settings") response <- galleyRequest req status <- (.status) <$> decodeBodyOrThrow @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) "galley" response case status of @@ -669,14 +600,12 @@ getTeamExposeInvitationURLsToTeamAdmin tid = do checkMLSOne2OneEstablished :: ( Member (Error ParseException) r, Member (Input Endpoint) r, - Member Rpc r, - Member TinyLog r + Member Rpc r ) => Local UserId -> Qualified UserId -> Sem r MLSOneToOneEstablished checkMLSOne2OneEstablished self (Qualified other otherDomain) = do - debug $ remote "galley" . msg (val "Get the MLS one-to-one conversation") responseSelf <- galleyRequest req case HTTP.statusCode (HTTP.responseStatus responseSelf) of 200 -> do @@ -700,8 +629,7 @@ checkMLSOne2OneEstablished self (Qualified other otherDomain) = do unblockConversation :: ( Member (Error ParseException) r, Member (Input Endpoint) r, - Member Rpc r, - Member TinyLog r + Member Rpc r ) => Version -> Local UserId -> @@ -709,11 +637,6 @@ unblockConversation :: Qualified ConvId -> Sem r OwnConversation unblockConversation v lusr mconn (Qualified cnv cdom) = do - debug $ - remote "galley" - . field "conv" (toByteString cnv) - . field "domain" (toByteString cdom) - . msg (val "Unblocking conversation") void $ galleyRequest putReq galleyRequest getReq >>= decodeBodyOrThrow @OwnConversation "galley" where @@ -734,17 +657,13 @@ remote = field "remote" getEJPDConvInfo :: forall r. - ( Member TinyLog r, - Member (Error ParseException) r, + ( Member (Error ParseException) r, Member (Input Endpoint) r, Member Rpc r ) => UserId -> Sem r [EJPDConvInfo] getEJPDConvInfo uid = do - debug $ - remote "galley" - . msg (val "get conversation info for ejpd") decodeBodyOrThrow "galley" =<< galleyRequest getReq where getReq = @@ -754,16 +673,11 @@ getEJPDConvInfo uid = do internalGetConversation :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => ConvId -> Sem r (Maybe Conversation) internalGetConversation convId = do - debug $ - remote "galley" - . field "conv" (toByteString convId) - . msg (val "Getting conversation (internal)") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -777,16 +691,11 @@ internalGetConversation convId = do getTeamContacts :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> Sem r (Maybe Member.TeamMemberList) getTeamContacts uid = do - debug $ - remote "galley" - . field "user" (toByteString uid) - . msg (val "Getting team contacts") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -799,12 +708,10 @@ getTeamContacts uid = do getConversationConfig :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Sem r ConversationSubsystemConfig getConversationConfig = do - debug $ remote "galley" . msg (val "Getting conversation config") responseJsonUnsafe <$> galleyRequest ( method GET diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs deleted file mode 100644 index 47985da588c..00000000000 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2025 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Wire.IndexedUserStore.Bulk where - -import Polysemy -import Wire.UserSearch.Migration - --- | Increase this number any time you want to force reindexing. -expectedMigrationVersion :: MigrationVersion -expectedMigrationVersion = MigrationVersion 6 - --- | Bulk operations, must not be used from any web handler -data IndexedUserStoreBulk m a where - -- | Only changes data if it is not updated since last update, use when users - -- need to be synced because of an outage, or migrating to a new ES instance. - SyncAllUsers :: IndexedUserStoreBulk m () - -- | Overwrite all users in the ES index, use it when trying to fix some - -- inconsistency or while introducing a new field in the mapping. - ForceSyncAllUsers :: IndexedUserStoreBulk m () - -- | Run `ForceSyncAllUsers` iff the index version is out of date. - MigrateData :: IndexedUserStoreBulk m () - -makeSem ''IndexedUserStoreBulk diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index ed5de07f65c..135ea1e834b 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -20,93 +20,68 @@ module Wire.IndexedUserStore.Bulk.ElasticSearch where import Cassandra.Exec (paginateWithStateC) import Cassandra.Util (Writetime (Writetime)) import Conduit (ConduitT, runConduit, (.|)) +import Control.Error (headMay) +import Control.Exception (try) +import Control.Monad.Extra (mapMaybeM) import Data.Conduit.Combinators qualified as Conduit +import Data.Conduit.Internal (zipSources) +import Data.Conduit.List qualified as CL import Data.Id import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis)) import Data.Map qualified as Map import Database.Bloodhound qualified as ES import Imports import Polysemy -import Polysemy.Error +import Polysemy.Error hiding (try) import Polysemy.TinyLog import Polysemy.TinyLog qualified as Log import System.Logger.Message qualified as Log +import UnliftIO (pooledForConcurrentlyN) import Wire.API.Team.Feature import Wire.API.Team.Member.Info import Wire.API.Team.Role import Wire.GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore -import Wire.IndexedUserStore.Bulk import Wire.IndexedUserStore.MigrationStore import Wire.IndexedUserStore.MigrationStore qualified as MigrationStore -import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) import Wire.UserSearch.Migration import Wire.UserSearch.Types import Wire.UserStore import Wire.UserStore.IndexUser -interpretIndexedUserStoreBulk :: - ( Member TinyLog r, - Member UserStore r, - Member (Concurrency Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r, - Member (Error MigrationException) r, - Member IndexedUserMigrationStore r - ) => - InterpreterFor IndexedUserStoreBulk r -interpretIndexedUserStoreBulk = interpret \case - SyncAllUsers -> syncAllUsersImpl - ForceSyncAllUsers -> forceSyncAllUsersImpl - MigrateData -> migrateDataImpl - -syncAllUsersImpl :: - forall r. - ( Member UserStore r, - Member TinyLog r, - Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r - ) => - Sem r () -syncAllUsersImpl = syncAllUsersWithVersion ES.ExternalGT - -forceSyncAllUsersImpl :: - forall r. - ( Member UserStore r, - Member TinyLog r, - Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r - ) => - Sem r () -forceSyncAllUsersImpl = syncAllUsersWithVersion ES.ExternalGTE - -syncAllUsersWithVersion :: - forall r. - ( Member UserStore r, - Member TinyLog r, - Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r - ) => - (ES.ExternalDocVersion -> ES.VersionControl) -> - Sem r () -syncAllUsersWithVersion mkVersion = +type IOInterpreter r = forall a. Sem r a -> IO a + +-- | Increase this number any time you want to force reindexing. +expectedMigrationVersion :: MigrationVersion +expectedMigrationVersion = MigrationVersion 6 + +syncAllUsers :: (Member UserStore r, Member IndexedUserStore r, Member TinyLog r, Member GalleyAPIAccess r) => IOInterpreter r -> IO () +syncAllUsers interpreter = syncAllUsersWithVersion interpreter ES.ExternalGT + +forceSyncAllUsers :: (Member UserStore r, Member IndexedUserStore r, Member TinyLog r, Member GalleyAPIAccess r) => IOInterpreter r -> IO () +forceSyncAllUsers interpreter = syncAllUsersWithVersion interpreter ES.ExternalGTE + +syncAllUsersWithVersion :: (Member UserStore r, Member IndexedUserStore r, Member TinyLog r, Member GalleyAPIAccess r) => IOInterpreter r -> (ES.ExternalDocVersion -> ES.VersionControl) -> IO () +syncAllUsersWithVersion interpreter mkVersion = runConduit $ - paginateWithStateC (getIndexUsersPaginated 1000) + zipSources (CL.sourceList [1 ..]) (paginateWithStateC (interpreter . getIndexUsersPaginated pageSize)) .| logPage .| mkUserDocs - .| Conduit.mapM_ IndexedUserStore.bulkUpsert + .| Conduit.mapM_ (interpreter . IndexedUserStore.bulkUpsert) where - logPage :: ConduitT [IndexUser] [IndexUser] (Sem r) () - logPage = Conduit.iterM $ \page -> do - info $ - Log.field "size" (length page) - . Log.msg (Log.val "Reindex: processing C* page") + pageSize = 10000 - mkUserDocs :: ConduitT [IndexUser] [(ES.DocId, UserDoc, ES.VersionControl)] (Sem r) () + logPage :: ConduitT (Int32, [IndexUser]) [IndexUser] IO () + logPage = Conduit.mapM $ \(pageNumber, page) -> do + interpreter $ + info $ + Log.field "estimatedUserSoFar" (length page + fromIntegral (pageSize * pageNumber)) + . Log.msg (Log.val "Received user page") + . Log.field "firstUser" (maybe "N/A" (idToText . (.userId)) (headMay page)) + pure page + + mkUserDocs :: ConduitT [IndexUser] [(ES.DocId, UserDoc, ES.VersionControl)] IO () mkUserDocs = Conduit.mapM $ \page -> do -- FUTUREWORK: extract team visibilities, roles and user type -- more efficiently sending one query per page @@ -117,19 +92,61 @@ syncAllUsersWithVersion mkVersion = let teams :: Map TeamId [IndexUser] = Map.fromListWith (<>) $ mapMaybe (\u -> (,[u]) <$> u.teamId) page teamIds = Map.keys teams - visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 teamIds $ \t -> - (t,) <$> teamSearchVisibilityInbound t - roles :: Map UserId (WithWritetime Role) <- fmap (Map.fromList . concat) . unsafePooledForConcurrentlyN 16 (Map.toList teams) $ \(t, us) -> do - tms <- (.members) <$> selectTeamMemberInfos t (fmap (.userId) us) - pure $ mapMaybe mkRoleWithWriteTime tms - let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ (flip Map.lookup visMap =<< indexUser.teamId) - mkUserDoc indexUser = - indexUserToDoc - (vis indexUser) - ((.value) <$> Map.lookup indexUser.userId roles) - indexUser - mkDocVersion u = mkVersion . ES.ExternalDocVersion . docVersion $ indexUserToVersion (Map.lookup u.userId roles) u - pure $ map (\u -> (userIdToDocId u.userId, mkUserDoc u, mkDocVersion u)) page + + visMap <- fmap Map.fromList . pooledForConcurrentlyN 16 teamIds $ \t -> do + x <- try $ interpreter $ teamSearchVisibilityInbound t + pure (t, x) + + let getRoles :: TeamId -> [UserId] -> IO (Map UserId (Either SomeException (WithWritetime Role))) + getRoles tid uids = do + eithMembers <- try $ interpreter $ (.members) <$> selectTeamMemberInfos tid uids + case eithMembers of + Left e -> do + let lenUids = length uids + if lenUids <= 1 + then pure . Map.fromList $ map (,Left e) uids + else do + let (uids1, uids2) = splitAt (lenUids `div` 2) uids + roles1 <- getRoles tid uids1 + roles2 <- getRoles tid uids2 + pure $ Map.union roles1 roles2 + Right tms -> pure . Map.fromList $ mapMaybe (fmap rightSecond . mkRoleWithWriteTime) tms + + roles :: Map UserId (Either SomeException (WithWritetime Role)) <- + fmap Map.unions . pooledForConcurrentlyN 16 (Map.toList teams) $ \(t, us) -> + getRoles t (fmap (.userId) us) + + let vis :: IndexUser -> Either SomeException SearchVisibilityInbound + vis indexUser = + fromMaybe (Right defaultSearchVisibilityInbound) $ flip Map.lookup visMap =<< indexUser.teamId + + mkUserDoc :: IndexUser -> Either SomeException UserDoc + mkUserDoc indexUser = do + currentVis <- vis indexUser + currentRole <- sequence $ Map.lookup indexUser.userId roles + pure $ indexUserToDoc currentVis ((.value) <$> currentRole) indexUser + + mkDocVersion :: IndexUser -> Either SomeException ES.VersionControl + mkDocVersion u = do + roleWithTime <- sequence (Map.lookup u.userId roles) + pure . mkVersion . ES.ExternalDocVersion . docVersion $ indexUserToVersion roleWithTime u + + let docsWithErrors = map (\u -> (userIdToDocId u.userId, mkUserDoc u, mkDocVersion u)) page + interpreter . flip mapMaybeM docsWithErrors $ logAndHush + + rightSecond :: (a, b) -> (a, Either c b) + rightSecond (a, b) = (a, Right b) + + logAndHush :: (Member TinyLog r) => (ES.DocId, Either SomeException UserDoc, Either SomeException ES.VersionControl) -> Sem r (Maybe (ES.DocId, UserDoc, ES.VersionControl)) + logAndHush (docId@(ES.DocId idText), eithUserDoc, eithVersion) = + case (,) <$> eithUserDoc <*> eithVersion of + Left e -> do + Log.err $ + Log.msg (Log.val "Error ocurred while indexing user") + . Log.field "userId" idText + . Log.field "error" (show e) + pure Nothing + Right (userDoc, version) -> pure $ Just (docId, userDoc, version) mkRoleWithWriteTime :: TeamMemberInfo -> Maybe (UserId, WithWritetime Role) mkRoleWithWriteTime tmi = @@ -143,17 +160,11 @@ syncAllUsersWithVersion mkVersion = ) <$> permissionsToRole tmi.permissions -migrateDataImpl :: - ( Member IndexedUserStore r, - Member (Error MigrationException) r, - Member IndexedUserMigrationStore r, - Member UserStore r, - Member (Concurrency Unsafe) r, - Member GalleyAPIAccess r, - Member TinyLog r - ) => - Sem r () -migrateDataImpl = do +migrateData :: + (Member (Embed IO) r, Member IndexedUserStore r, Member (Error MigrationException) r, Member IndexedUserMigrationStore r, Member TinyLog r, Member UserStore r, Member GalleyAPIAccess r) => + IOInterpreter r -> + IO () +migrateData interpreter = interpreter $ do unlessM IndexedUserStore.doesIndexExist $ throw TargetIndexAbsent MigrationStore.ensureMigrationIndex @@ -164,7 +175,7 @@ migrateDataImpl = do Log.msg (Log.val "Migration necessary.") . Log.field "expectedVersion" expectedMigrationVersion . Log.field "foundVersion" foundVersion - forceSyncAllUsersImpl + embed $ forceSyncAllUsers interpreter MigrationStore.persistMigrationVersion expectedMigrationVersion else do Log.info $ diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 546a155cb3c..8ba7efffdaa 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -312,7 +312,6 @@ library Wire.IdPSubsystem Wire.IdPSubsystem.Interpreter Wire.IndexedUserStore - Wire.IndexedUserStore.Bulk Wire.IndexedUserStore.Bulk.ElasticSearch Wire.IndexedUserStore.ElasticSearch Wire.IndexedUserStore.MigrationStore diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 1f711c37aec..70e95dcd393 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -332,6 +332,7 @@ executable brig-index build-depends: , base , brig + , extended , imports , optparse-applicative , tinylog diff --git a/services/brig/index/src/Main.hs b/services/brig/index/src/Main.hs index bf2412d475c..99ea1f0c595 100644 --- a/services/brig/index/src/Main.hs +++ b/services/brig/index/src/Main.hs @@ -25,7 +25,7 @@ import Brig.Index.Options import Imports import Options.Applicative import System.Exit -import System.Logger.Class qualified as Log +import System.Logger.Extended qualified as Log main :: IO () main = do @@ -39,9 +39,4 @@ main = do header "brig-index" <> progDesc "Brig Search Index Utilities" <> fullDesc - initLogger = - Log.new -- TODO: use mkLogger'? - . Log.setOutput Log.StdOut - . Log.setFormat Nothing - . Log.setBufSize 0 - $ Log.defSettings + initLogger = Log.mkLogger Log.Debug Nothing (Just $ Last Log.JSON) diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index e6196546041..f2b1baa3d1f 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -25,7 +25,8 @@ import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) import Brig.Index.Options as IxOpts import Brig.Options as Opt import Brig.User.Search.Index -import Cassandra (Client, runClient) +import Cassandra (ClientState) +import Cassandra.Options import Cassandra.Util (defInitCassandra) import Control.Exception (throwIO) import Control.Lens @@ -39,83 +40,56 @@ import Data.Id import Database.Bloodhound qualified as ES import Database.Bloodhound.Internal.Client (BHEnv (..)) import Hasql.Pool -import Hasql.Pool.Extended import Imports +import Network.HTTP.Client (Manager) import Polysemy -import Polysemy.Embed (runEmbedded) import Polysemy.Error -import Polysemy.Input -import Polysemy.TinyLog hiding (Logger) +import Polysemy.TinyLog (TinyLog) import System.Logger qualified as Log import System.Logger.Class (Logger) import Util.Options -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.AppStore -import Wire.AppStore.Postgres -import Wire.BlockListStore (BlockListStore) -import Wire.BlockListStore.Cassandra import Wire.ClientSubsystem.Error (ClientError) -import Wire.FederationAPIAccess -import Wire.FederationAPIAccess.Interpreter (noFederationAPIAccess) -import Wire.FederationConfigStore (FederationConfigStore) -import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig) -import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.IndexedUserStore -import Wire.IndexedUserStore.Bulk (IndexedUserStoreBulk) -import Wire.IndexedUserStore.Bulk qualified as IndexedUserStoreBulk -import Wire.IndexedUserStore.Bulk.ElasticSearch (interpretIndexedUserStoreBulk) +import Wire.IndexedUserStore.Bulk.ElasticSearch qualified as IndexedUserStoreBulk import Wire.IndexedUserStore.ElasticSearch import Wire.IndexedUserStore.MigrationStore (IndexedUserMigrationStore) import Wire.IndexedUserStore.MigrationStore.ElasticSearch import Wire.ParseException import Wire.Rpc -import Wire.Sem.Concurrency -import Wire.Sem.Concurrency.IO import Wire.Sem.Logger.TinyLog -import Wire.Sem.Metrics +import Wire.Sem.Metrics (Metrics) import Wire.Sem.Metrics.IO import Wire.UserKeyStore (UserKeyStore) import Wire.UserKeyStore.Cassandra import Wire.UserSearch.Migration (MigrationException) -import Wire.UserStore +import Wire.UserStore (UserStore) import Wire.UserStore.Cassandra -import Wire.UserSubsystem.Error type BrigIndexEffectStack = - [ IndexedUserStoreBulk, - UserKeyStore, - BlockListStore, - Error UserSubsystemError, - FederationAPIAccess FederatorClient, - Error FederationError, + [ UserKeyStore, UserStore, - AppStore, IndexedUserStore, Error IndexedUserStoreError, IndexedUserMigrationStore, Error MigrationException, - FederationConfigStore, GalleyAPIAccess, Error ParseException, Rpc, Metrics, TinyLog, - Concurrency 'Unsafe, - Input Pool, Error UsageError, Error ClientError, Embed IO, Final IO ] -runSem :: ESConnectionSettings -> CassandraSettings -> PostgresSettings -> Endpoint -> Logger -> Sem BrigIndexEffectStack a -> IO a -runSem esConn cas pg galleyEndpoint logger action = do +mkSemDeps :: ESConnectionSettings -> CassandraSettings -> Logger -> IO (Manager, ClientState, BHEnv, IndexedUserStoreConfig, RequestId, IndexName) +mkSemDeps esConn cas logger = do mgr <- initHttpManagerWithTLSConfig esConn.esInsecureSkipVerifyTls esConn.esCaCert mEsCreds :: Maybe Credentials <- for esConn.esCredentials initCredentials casClient <- defInitCassandra (toCassandraOpts cas) logger - pgPool <- initPostgresPool pg.pool pg.settings pg.passwordFile let bhEnv = BHEnv { bhServer = toESServer esConn.esServer, @@ -133,32 +107,25 @@ runSem esConn cas pg galleyEndpoint logger action = do } reqId = (RequestId "brig-index") migrationIndexName = fromMaybe defaultMigrationIndexName (esMigrationIndexName esConn) + pure (mgr, casClient, bhEnv, indexedUserStoreConfig, reqId, migrationIndexName) + +runSem :: (Manager, ClientState, BHEnv, IndexedUserStoreConfig, RequestId, IndexName) -> Endpoint -> Logger -> Sem BrigIndexEffectStack a -> IO a +runSem (mgr, casClient, bhEnv, indexedUserStoreConfig, reqId, migrationIndexName) galleyEndpoint logger action = do runFinal . embedToFinal . throwErrorToIOFinal @ClientError . throwErrorToIOFinal @UsageError - . runInputConst pgPool - . unsafelyPerformConcurrency . loggerToTinyLogReqId reqId logger . ignoreMetrics . runRpcWithHttp mgr reqId . throwErrorToIOFinal @ParseException . interpretGalleyAPIAccessToRpc mempty galleyEndpoint - . runEmbedded (runClient casClient) - . interpretFederationDomainConfig casClient Nothing mempty - . raiseUnder @(Embed Client) . throwErrorToIOFinal @MigrationException . interpretIndexedUserMigrationStoreES bhEnv migrationIndexName . throwErrorToIOFinal @IndexedUserStoreError . interpretIndexedUserStoreES indexedUserStoreConfig - . interpretAppStoreToPostgres . interpretUserStoreCassandra casClient - . throwErrorToIOFinal @FederationError - . noFederationAPIAccess - . throwErrorToIOFinal @UserSubsystemError - . interpretBlockListStoreToCassandra casClient . interpretUserKeyStoreCassandra casClient - . interpretIndexedUserStoreBulk $ action throwErrorToIOFinal :: (Exception e, Member (Final IO) r) => InterpreterFor (Error e) r @@ -175,18 +142,18 @@ runCommand l = \case Reset es galley -> do e <- initIndex l (es ^. esConnection) galley runIndexIO e $ resetIndex (mkCreateIndexSettings es) - Reindex es cas pg galley -> do - runSem (es ^. esConnection) cas pg galley l $ - IndexedUserStoreBulk.syncAllUsers - ReindexSameOrNewer es cas pg galley -> do - runSem (es ^. esConnection) cas pg galley l $ - IndexedUserStoreBulk.forceSyncAllUsers + Reindex es cas _pg galley -> do + semDeps <- mkSemDeps (es ^. esConnection) cas l + IndexedUserStoreBulk.syncAllUsers (runSem semDeps galley l) + ReindexSameOrNewer es cas _pg galley -> do + semDeps <- mkSemDeps (es ^. esConnection) cas l + IndexedUserStoreBulk.forceSyncAllUsers (runSem semDeps galley l) UpdateMapping esConn galley -> do e <- initIndex l esConn galley runIndexIO e updateMapping - Migrate es cas pg galley -> do - runSem (es ^. esConnection) cas pg galley l $ - IndexedUserStoreBulk.migrateData + Migrate es cas _pg galley -> do + semDeps <- mkSemDeps (es ^. esConnection) cas l + IndexedUserStoreBulk.migrateData (runSem semDeps galley l) ReindexFromAnotherIndex reindexSettings -> do mgr <- initHttpManagerWithTLSConfig From 5a94d23a4a051c0d3403f56ddb2bcc0e27fe1c70 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 22 Apr 2026 18:46:14 +0200 Subject: [PATCH 02/18] WPB-00000: stabilize migration-related tests (#5198) --- changelog.d/5-internal/WPB-00000 | 1 + services/brig/test/integration/API/Search.hs | 8 +++++--- 2 files changed, 6 insertions(+), 3 deletions(-) create mode 100644 changelog.d/5-internal/WPB-00000 diff --git a/changelog.d/5-internal/WPB-00000 b/changelog.d/5-internal/WPB-00000 new file mode 100644 index 00000000000..86dad9d6fc8 --- /dev/null +++ b/changelog.d/5-internal/WPB-00000 @@ -0,0 +1 @@ +Using a random-generated index name to stabilize `testSearchNoExtraResults` (`brig-integration`). diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 2fb1fbdf5fa..966bec0f148 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -396,12 +396,14 @@ testSearchNoMatch brig = do testSearchNoExtraResults :: (TestConstraints m) => Brig -> m () testSearchNoExtraResults brig = do - u1 <- randomUser brig - u2 <- randomUser brig + u1Handle <- ("zqnoextra1-" <>) <$> randomHandle + u1 <- createUser' True u1Handle brig + u2Handle <- ("zqnoextra2-" <>) <$> randomHandle + u2 <- createUser' True u2Handle brig let uid1 = userId u1 quid2 = userQualifiedId u2 refreshIndex brig - resultUIds <- map contactQualifiedId . searchResults <$> executeSearch brig uid1 (fromName $ userDisplayName u2) + resultUIds <- map contactQualifiedId . searchResults <$> executeSearch brig uid1 u2Handle liftIO $ assertEqual "Expected search returns only the searched" [quid2] resultUIds From c05e49a058401f8c53e633dfdde8f44ca9d5beef Mon Sep 17 00:00:00 2001 From: Stefan Berthold Date: Thu, 23 Apr 2026 14:22:57 +0200 Subject: [PATCH 03/18] build Docker image for mlsstats (#5200) --- changelog.d/5-internal/mlsstats | 1 + nix/wire-server.nix | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 changelog.d/5-internal/mlsstats diff --git a/changelog.d/5-internal/mlsstats b/changelog.d/5-internal/mlsstats new file mode 100644 index 00000000000..f266679a9dd --- /dev/null +++ b/changelog.d/5-internal/mlsstats @@ -0,0 +1 @@ +Add tools/mlsstats to the Docker images to be built in CI runs. diff --git a/nix/wire-server.nix b/nix/wire-server.nix index 8c1122d40d0..726fcdaa1e8 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -63,7 +63,7 @@ let owner = "hercules-ci"; repo = "gitignore.nix"; # put the latest commit sha of gitignore Nix library here: - rev = "a20de23b925fd8264fd7fad6454652e142fd7f73"; + rev = "a19de23b925fd8264fd7fad6454652e142fd7f73"; # use what nix suggests in the mismatch message here: sha256 = "sha256:07vg2i9va38zbld9abs9lzqblz193vc5wvqd6h7amkmwf66ljcgh"; }; @@ -90,6 +90,7 @@ let team-info = [ "team-info" ]; wire-server-enterprise = [ "wire-server-enterprise" ]; migrate-features = [ "migrate-features" ]; + mlsstats = [ "mlsstats" ]; }; inherit (lib) attrsets; From a2739689985ba0bd25516edbd1911b0ed8068fef Mon Sep 17 00:00:00 2001 From: Valentin Date: Fri, 24 Apr 2026 09:54:40 +0100 Subject: [PATCH 04/18] feat: mlsstats version bump (#5201) --- charts/mlsstats/values.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/charts/mlsstats/values.yaml b/charts/mlsstats/values.yaml index 399bc1ec996..5d05594a124 100644 --- a/charts/mlsstats/values.yaml +++ b/charts/mlsstats/values.yaml @@ -1,6 +1,6 @@ image: repository: quay.io/wire/mlsstats - tag: 0.1 + tag: 5.30.3 resources: requests: memory: "256Mi" From 95401571f76400e6e12245af4e1c97da16dcb233 Mon Sep 17 00:00:00 2001 From: Stefan Berthold Date: Fri, 24 Apr 2026 18:10:07 +0200 Subject: [PATCH 05/18] fix part number in mlsstats' upload function (#5203) The first part number cannot be 0, but has to be 1. --- tools/mlsstats/src/MlsStats/Run.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/mlsstats/src/MlsStats/Run.hs b/tools/mlsstats/src/MlsStats/Run.hs index 3523b8252a9..4ee5d0f9367 100644 --- a/tools/mlsstats/src/MlsStats/Run.hs +++ b/tools/mlsstats/src/MlsStats/Run.hs @@ -197,7 +197,7 @@ uploadStream env bucket key stream = do runConduit $ stream .| chunksOfE chunkSize - .| uploadParts env bucket key uploadId' 0 + .| uploadParts env bucket key uploadId' 1 .| mapC (uncurry newCompletedPart) .| sinkList void $ From 52328d9f5c1f000a42e27f1ccdc6c4b3b62f5cac Mon Sep 17 00:00:00 2001 From: Valentin Date: Fri, 24 Apr 2026 18:05:44 +0100 Subject: [PATCH 06/18] fix: helm fixes (#5202) --- charts/mlsstats/templates/cronjob.yaml | 7 +++---- charts/mlsstats/templates/secret.yaml | 2 +- charts/mlsstats/values.yaml | 2 +- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/charts/mlsstats/templates/cronjob.yaml b/charts/mlsstats/templates/cronjob.yaml index 5247b15cd38..67ef4e8f7a0 100644 --- a/charts/mlsstats/templates/cronjob.yaml +++ b/charts/mlsstats/templates/cronjob.yaml @@ -27,8 +27,7 @@ spec: - name: mlsstats image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} - args: [ "mlsstats" - , "--brig-cassandra-host", {{ .Values.config.cassandra.brig.host | quote }} + args: [ "--brig-cassandra-host", {{ .Values.config.cassandra.brig.host | quote }} , "--brig-cassandra-port", {{ .Values.config.cassandra.brig.port | quote }} , "--brig-cassandra-keyspace", {{ .Values.config.cassandra.brig.keyspace | quote }} , "--galley-cassandra-host", {{ .Values.config.cassandra.galley.host | quote }} @@ -47,12 +46,12 @@ spec: - name: AWS_ACCESS_KEY_ID valueFrom: secretKeyRef: - name: mlsstats + name: {{ .Chart.Name }} key: awsKeyId - name: AWS_SECRET_ACCESS_KEY valueFrom: secretKeyRef: - name: mlsstats + name: {{ .Chart.Name }} key: awsSecretKey {{- end }} - name: AWS_REGION diff --git a/charts/mlsstats/templates/secret.yaml b/charts/mlsstats/templates/secret.yaml index 3f93be5120c..868df7460b6 100644 --- a/charts/mlsstats/templates/secret.yaml +++ b/charts/mlsstats/templates/secret.yaml @@ -1,7 +1,7 @@ apiVersion: v1 kind: Secret metadata: - name: {{ .Release.Name }} + name: {{ .Chart.Name }} labels: app: mlsstats chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" diff --git a/charts/mlsstats/values.yaml b/charts/mlsstats/values.yaml index 5d05594a124..5c86308f859 100644 --- a/charts/mlsstats/values.yaml +++ b/charts/mlsstats/values.yaml @@ -1,6 +1,6 @@ image: repository: quay.io/wire/mlsstats - tag: 5.30.3 + tag: 5.30.5 resources: requests: memory: "256Mi" From a2aa8c48d07137f28f342ced3a2cf88682a93051 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 28 Apr 2026 10:32:19 +0200 Subject: [PATCH 07/18] WPB-24072: Move operation to ConversationSubsystem (#5126) --------- Co-authored-by: Akshay Mankar Co-authored-by: Leif Battermann --- changelog.d/5-internal/WPB-24072 | 1 + .../src/Wire/API/Federation/API/Galley.hs | 40 +- .../Golden/GetOne2OneConversationResponse.hs | 4 +- .../src/Wire/API/Routes/Internal/Galley.hs | 21 +- .../src/Wire/API/Team/FeatureFlags.hs | 13 +- libs/wire-api/src/Wire/API/Team/LegalHold.hs | 19 + libs/wire-subsystems/default.nix | 6 + .../Wire/BackgroundJobsRunner/Interpreter.hs | 2 +- .../wire-subsystems/src/Wire/BrigAPIAccess.hs | 18 + .../src/Wire/ConversationStore/Cassandra.hs | 2 +- .../src/Wire/ConversationSubsystem.hs | 582 +++++++++++++++++- .../src/Wire/ConversationSubsystem}/Action.hs | 80 ++- .../ConversationSubsystem}/Action/Kick.hs | 8 +- .../ConversationSubsystem}/Action/Leave.hs | 4 +- .../ConversationSubsystem}/Action/Notify.hs | 18 +- .../ConversationSubsystem}/Action/Reset.hs | 8 +- .../Wire/ConversationSubsystem}/Clients.hs | 19 +- .../src/Wire/ConversationSubsystem/Create.hs | 266 ++++++++ .../ConversationSubsystem/CreateInternal.hs | 2 +- .../src/Wire/ConversationSubsystem/Errors.hs | 325 ++++++++++ .../Wire/ConversationSubsystem/Federation.hs | 146 ++--- .../Wire/ConversationSubsystem/Internal.hs | 6 +- .../Wire/ConversationSubsystem/Interpreter.hs | 302 +++++++-- .../LegalholdConflicts.hs | 11 +- .../src/Wire/ConversationSubsystem}/MLS.hs | 14 +- .../MLS/CheckClients.hs | 4 +- .../ConversationSubsystem}/MLS/Commit/Core.hs | 8 +- .../MLS/Commit/ExternalCommit.hs | 12 +- .../MLS/Commit/InternalCommit.hs | 22 +- .../MLS/Conversation.hs | 2 +- .../ConversationSubsystem}/MLS/Enabled.hs | 4 +- .../ConversationSubsystem}/MLS/GroupInfo.hs | 6 +- .../MLS/GroupInfoCheck.hs | 5 +- .../MLS/IncomingMessage.hs | 2 +- .../Wire/ConversationSubsystem}/MLS/Keys.hs | 2 +- .../ConversationSubsystem}/MLS/Message.hs | 115 ++-- .../ConversationSubsystem}/MLS/Migration.hs | 2 +- .../ConversationSubsystem}/MLS/One2One.hs | 6 +- .../ConversationSubsystem}/MLS/OutOfSync.hs | 4 +- .../ConversationSubsystem}/MLS/Propagate.hs | 2 +- .../ConversationSubsystem}/MLS/Proposal.hs | 4 +- .../ConversationSubsystem}/MLS/Removal.hs | 8 +- .../Wire/ConversationSubsystem}/MLS/Reset.hs | 18 +- .../MLS/SubConversation.hs | 26 +- .../Wire/ConversationSubsystem}/MLS/Util.hs | 2 +- .../ConversationSubsystem}/MLS/Welcome.hs | 2 +- .../Wire/ConversationSubsystem}/Message.hs | 30 +- .../src/Wire/ConversationSubsystem/One2One.hs | 6 +- .../src/Wire/ConversationSubsystem}/Query.hs | 83 +-- .../src/Wire/ConversationSubsystem}/Update.hs | 358 +++-------- .../src/Wire/ConversationSubsystem/Util.hs | 203 +----- .../src/Wire/FeaturesConfigSubsystem.hs | 25 +- .../FeaturesConfigSubsystem/Interpreter.hs | 155 +++++ .../src/Wire/GalleyAPIAccess.hs | 6 + .../src/Wire/GalleyAPIAccess/Rpc.hs | 102 ++- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 2 +- .../Wire/NotificationSubsystem/Interpreter.hs | 5 +- .../src/Wire/Options/Galley.hs | 27 +- .../src/Wire/StoredConversation.hs | 131 ++++ .../TeamInvitationSubsystem/Interpreter.hs | 2 +- .../wire-subsystems/src/Wire/TeamSubsystem.hs | 107 ++++ .../src/Wire/TeamSubsystem/GalleyAPI.hs | 23 +- .../src/Wire/TeamSubsystem/Interpreter.hs | 175 +++++- .../src/Wire/UserClientIndexStore.hs | 16 +- .../Wire/ConversationSubsystem/MessageSpec.hs | 130 ++-- .../Wire/ConversationSubsystem/One2OneSpec.hs | 23 +- .../Wire/MeetingsSubsystem/InterpreterSpec.hs | 13 + .../test/unit/Wire/MiniBackend.hs | 66 +- .../MockInterpreters/ConversationSubsystem.hs | 8 +- .../Wire/MockInterpreters/GalleyAPIAccess.hs | 3 + .../SAMLEmailSubsystem/InterpreterSpec.hs | 9 + .../Wire/ScimSubsystem/InterpreterSpec.hs | 4 +- .../test/unit/Wire/StoredConversationSpec.hs | 121 ++-- .../InterpreterSpec.hs | 45 +- .../UserGroupSubsystem/InterpreterSpec.hs | 59 +- libs/wire-subsystems/wire-subsystems.cabal | 40 ++ .../src/Wire/BackgroundWorker/Env.hs | 28 +- .../Wire/BackgroundWorker/Jobs/Registry.hs | 79 ++- .../Wire/BackendNotificationPusherSpec.hs | 26 +- .../background-worker/test/Test/Wire/Util.hs | 25 +- .../brig/src/Brig/CanonicalInterpreter.hs | 9 + services/galley/default.nix | 29 - services/galley/galley.cabal | 75 --- services/galley/src/Galley/API/Create.hs | 140 ----- services/galley/src/Galley/API/Federation.hs | 66 +- services/galley/src/Galley/API/Internal.hs | 91 ++- services/galley/src/Galley/API/LegalHold.hs | 198 ++---- .../galley/src/Galley/API/LegalHold/Get.hs | 78 --- .../galley/src/Galley/API/LegalHold/Team.hs | 18 + services/galley/src/Galley/API/Mapping.hs | 163 ----- services/galley/src/Galley/API/Public/Bot.hs | 30 +- .../src/Galley/API/Public/Conversation.hs | 44 +- .../galley/src/Galley/API/Public/Feature.hs | 6 +- .../galley/src/Galley/API/Public/LegalHold.hs | 1 + services/galley/src/Galley/API/Public/MLS.hs | 3 +- .../galley/src/Galley/API/Public/Messaging.hs | 2 +- services/galley/src/Galley/API/Public/Team.hs | 2 +- services/galley/src/Galley/API/Teams.hs | 142 ++--- .../galley/src/Galley/API/Teams/Features.hs | 44 +- .../src/Galley/API/Teams/Features/Get.hs | 168 ----- services/galley/src/Galley/App.hs | 26 +- services/galley/src/Galley/Env.hs | 57 +- services/galley/test/integration/API.hs | 11 +- .../galley/test/integration/API/Federation.hs | 4 +- services/galley/test/integration/API/Teams.hs | 2 +- .../test/integration/API/Teams/LegalHold.hs | 2 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 4 +- services/galley/test/integration/API/Util.hs | 4 +- services/galley/test/unit/Run.hs | 37 -- 109 files changed, 3464 insertions(+), 2300 deletions(-) create mode 100644 changelog.d/5-internal/WPB-24072 rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Kick.hs (93%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Leave.hs (94%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Notify.hs (76%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Action/Reset.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Clients.hs (89%) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs rename services/galley/src/Galley/API/Federation/Handlers.hs => libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs (92%) rename services/galley/src/Galley/API/LegalHold/Conflicts.hs => libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS.hs (88%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/CheckClients.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Commit/Core.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Commit/ExternalCommit.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Commit/InternalCommit.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Conversation.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Enabled.hs (95%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/GroupInfo.hs (95%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/GroupInfoCheck.hs (96%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/IncomingMessage.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Keys.hs (95%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Message.hs (90%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Migration.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/One2One.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/OutOfSync.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Propagate.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Proposal.hs (99%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Removal.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Reset.hs (93%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/SubConversation.hs (94%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Util.hs (98%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/MLS/Welcome.hs (99%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Message.hs (97%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Query.hs (94%) rename {services/galley/src/Galley/API => libs/wire-subsystems/src/Wire/ConversationSubsystem}/Update.hs (86%) rename services/galley/test/unit/Test/Galley/API/Message.hs => libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs (56%) rename services/galley/test/unit/Test/Galley/API/One2One.hs => libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs (80%) rename services/galley/test/unit/Test/Galley/Mapping.hs => libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs (54%) delete mode 100644 services/galley/src/Galley/API/Create.hs delete mode 100644 services/galley/src/Galley/API/LegalHold/Get.hs delete mode 100644 services/galley/src/Galley/API/Mapping.hs delete mode 100644 services/galley/src/Galley/API/Teams/Features/Get.hs delete mode 100644 services/galley/test/unit/Run.hs diff --git a/changelog.d/5-internal/WPB-24072 b/changelog.d/5-internal/WPB-24072 new file mode 100644 index 00000000000..61a31439bf8 --- /dev/null +++ b/changelog.d/5-internal/WPB-24072 @@ -0,0 +1 @@ +Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 0f4afc600a0..b2ae91b06e4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -83,7 +83,7 @@ type GalleyApi = '[From 'V2] "get-conversations" GetConversationsRequest - GetConversationsResponseV2 + GetRemoteConversationViewsResponse :<|> FedEndpoint "leave-conversation" LeaveConversationRequest @@ -236,7 +236,7 @@ instance ToSchema RemoteConversation -- information as a 'Conversation', with the exception that conversation status -- fields (muted\/archived\/hidden) are omitted, since they are not known by the -- remote backend. -data RemoteConversationV2 = RemoteConversationV2 +data RemoteConversationView = RemoteConversationView { -- | Id of the conversation, implicitly qualified with the domain of the -- backend that created this value. id :: ConvId, @@ -245,13 +245,13 @@ data RemoteConversationV2 = RemoteConversationV2 protocol :: Protocol } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform RemoteConversationV2) - deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConversationV2) + deriving (Arbitrary) via (GenericUniform RemoteConversationView) + deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConversationView) -instance ToSchema RemoteConversationV2 +instance ToSchema RemoteConversationView -remoteConversationFromV2 :: RemoteConversationV2 -> RemoteConversation -remoteConversationFromV2 rc = +remoteConversationFromView :: RemoteConversationView -> RemoteConversation +remoteConversationFromView rc = RemoteConversation { id = rc.id, metadata = rc.metadata, @@ -259,9 +259,9 @@ remoteConversationFromV2 rc = protocol = ClientAPI.Versioned rc.protocol } -remoteConversationToV2 :: RemoteConversation -> RemoteConversationV2 -remoteConversationToV2 rc = - RemoteConversationV2 +remoteConversationToView :: RemoteConversation -> RemoteConversationView +remoteConversationToView rc = + RemoteConversationView { id = rc.id, metadata = rc.metadata, members = rc.members, @@ -277,20 +277,20 @@ newtype GetConversationsResponse = GetConversationsResponse instance ToSchema GetConversationsResponse -newtype GetConversationsResponseV2 = GetConversationsResponseV2 - { convs :: [RemoteConversationV2] +newtype GetRemoteConversationViewsResponse = GetRemoteConversationViewsResponse + { convs :: [RemoteConversationView] } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform GetConversationsResponseV2) - deriving (ToJSON, FromJSON) via (CustomEncoded GetConversationsResponseV2) + deriving (Arbitrary) via (GenericUniform GetRemoteConversationViewsResponse) + deriving (ToJSON, FromJSON) via (CustomEncoded GetRemoteConversationViewsResponse) -instance ToSchema GetConversationsResponseV2 +instance ToSchema GetRemoteConversationViewsResponse -getConversationsResponseToV2 :: GetConversationsResponse -> GetConversationsResponseV2 -getConversationsResponseToV2 res = GetConversationsResponseV2 (map remoteConversationToV2 res.convs) +getConversationsResponseToView :: GetConversationsResponse -> GetRemoteConversationViewsResponse +getConversationsResponseToView res = GetRemoteConversationViewsResponse (map remoteConversationToView res.convs) -getConversationsResponseFromV2 :: GetConversationsResponseV2 -> GetConversationsResponse -getConversationsResponseFromV2 res = GetConversationsResponse (map remoteConversationFromV2 res.convs) +getConversationsResponseFromView :: GetRemoteConversationViewsResponse -> GetConversationsResponse +getConversationsResponseFromView res = GetConversationsResponse (map remoteConversationFromView res.convs) data GetOne2OneConversationResponse = GetOne2OneConversationOk RemoteConversation @@ -321,7 +321,7 @@ data GetOne2OneConversationResponseV2 instance ToSchema GetOne2OneConversationResponseV2 data RemoteMLSOne2OneConversation = RemoteMLSOne2OneConversation - { conversation :: RemoteConversationV2, + { conversation :: RemoteConversationView, publicKeys :: MLSKeysByPurpose MLSPublicKeys } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs index 25cd3f9025e..5e95cdd713b 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs @@ -116,9 +116,9 @@ remoteConversation = } } -remoteConversationV2 :: RemoteConversationV2 +remoteConversationV2 :: RemoteConversationView remoteConversationV2 = - RemoteConversationV2 + RemoteConversationView { id = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200040001"))), metadata = ConversationMetadata diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index b46992e018f..a254f170483 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -20,10 +20,11 @@ module Wire.API.Routes.Internal.Galley where import Control.Lens ((.~)) import Data.Domain import Data.Id as Id +import Data.LegalHold (UserLegalHoldStatus) import Data.OpenApi (OpenApi, info, title) import Data.Range import GHC.TypeLits (AppendSymbol) -import Imports hiding (head) +import Imports import Servant import Servant.OpenApi import Wire.API.Bot @@ -52,6 +53,7 @@ import Wire.API.Routes.QualifiedCapture import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Feature +import Wire.API.Team.LegalHold qualified as LegalHold import Wire.API.Team.Member import Wire.API.Team.Member.Info import Wire.API.Team.SearchVisibility @@ -550,7 +552,7 @@ type IMiscAPI = (RespondEmpty 200 "OK") ) :<|> Named - "test-delete-client" + "remove-client" ( "clients" :> ZUser :> Capture "cid" ClientId @@ -622,6 +624,21 @@ type IMiscAPI = :> Capture "domain" Domain :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 200 "OK") ) + :<|> Named + "get-user-lh-status" + ( "users" + :> Capture "uid" UserId + :> "lh-status" + :> QueryParam "team_id" TeamId + :> Get '[JSON] UserLegalHoldStatus + ) + :<|> Named + "get-users-lh-status" + ( "users" + :> "lh-status" + :> ReqBody '[JSON] UserIds + :> Post '[JSON] [LegalHold.UserLegalHoldStatusEntry] + ) type IEJPDAPI = Named diff --git a/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs b/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs index 7915eb9a126..638da672409 100644 --- a/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs +++ b/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs @@ -25,6 +25,8 @@ module Wire.API.Team.FeatureFlags FeatureFlags, FanoutLimit, featureDefaults, + defaultFanoutLimit, + currentFanoutLimit, notTeamMember, findTeamMember, isTeamMember, @@ -42,7 +44,7 @@ import Data.ByteString.UTF8 qualified as UTF8 import Data.Default import Data.Id (UserId) import Data.OpenApi qualified as S -import Data.Range (Range) +import Data.Range (Range, fromRange, toRange, unsafeRange) import Data.SOP import Data.Schema import Data.Set qualified as Set @@ -53,6 +55,15 @@ import Wire.API.Team.Permission type FanoutLimit = Range 1 HardTruncationLimit Int32 +defaultFanoutLimit :: FanoutLimit +defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) + +currentFanoutLimit :: Word32 -> Maybe FanoutLimit -> FanoutLimit +currentFanoutLimit maxTeamSize maxFanoutSize = + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit maxFanoutSize + maxSize = fromIntegral maxTeamSize + in unsafeRange (min maxSize optFanoutLimit) + -- | Used to extract the feature config type out of 'FeatureDefaults' or -- related types. type family ConfigOf a diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index a7c65addd22..492229be234 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -22,6 +22,7 @@ module Wire.API.Team.LegalHold ViewLegalHoldService (..), ViewLegalHoldServiceInfo (..), UserLegalHoldStatusResponse (..), + UserLegalHoldStatusEntry (..), RemoveLegalHoldSettingsRequest (..), DisableLegalHoldForUserRequest (..), ApproveLegalHoldForUserRequest (..), @@ -162,6 +163,24 @@ instance ToSchema UserLegalHoldStatusResponse where <*> ulhsrLastPrekey .= maybe_ (optField "last_prekey" schema) <*> (fmap IdObject . ulhsrClientId) .= maybe_ (optField "client" (fromIdObject <$> schema)) +-------------------------------------------------------------------------------- +-- UserLegalHoldStatusEntry + +data UserLegalHoldStatusEntry = UserLegalHoldStatusEntry + { ulhseUser :: UserId, + ulhseStatus :: UserLegalHoldStatus + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserLegalHoldStatusEntry) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserLegalHoldStatusEntry) + +instance ToSchema UserLegalHoldStatusEntry where + schema = + object $ + UserLegalHoldStatusEntry + <$> ulhseUser .= field "user" schema + <*> ulhseStatus .= field "status" schema + -------------------------------------------------------------------------------- -- RemoveLegalHoldSettingsRequest diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index e62655cecc3..88cd2d1e2e9 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -25,6 +25,7 @@ , bytestring-conversion , case-insensitive , cassandra-util +, comonad , conduit , constraints , containers @@ -69,6 +70,7 @@ , imports , iproute , iso639 +, kan-extensions , lens , lens-aeson , lib @@ -164,6 +166,7 @@ mkDerivation { bytestring-conversion case-insensitive cassandra-util + comonad conduit constraints containers @@ -204,6 +207,7 @@ mkDerivation { imports iproute iso639 + kan-extensions lens lens-aeson lrucaching @@ -289,6 +293,7 @@ mkDerivation { bytestring-conversion case-insensitive cassandra-util + comonad conduit constraints containers @@ -330,6 +335,7 @@ mkDerivation { imports iproute iso639 + kan-extensions lens lens-aeson lrucaching diff --git a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs index 7353ad6092f..fc2ba75eb69 100644 --- a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs @@ -44,7 +44,7 @@ import Wire.API.UserGroup import Wire.BackgroundJobsPublisher import Wire.BackgroundJobsRunner (BackgroundJobsRunner (..)) import Wire.ConversationStore (ConversationStore, getConversation, upsertMembers) -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem hiding (getConversation) import Wire.Sem.Random import Wire.StoredConversation import Wire.UserGroupStore (UserGroupStore, getUserGroup, getUserGroupChannels) diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index a4e53f2b9b3..1f9dabb13b6 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -75,6 +75,9 @@ module Wire.BrigAPIAccess -- * Account status setAccountStatus, + + -- * Assertions + ensureConnectedToLocals, ) where @@ -92,6 +95,7 @@ import Polysemy import Polysemy.Error import Web.Scim.Filter qualified as Scim import Wire.API.Connection +import Wire.API.Error import Wire.API.Error.Galley import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig @@ -198,3 +202,17 @@ getConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 = do res1 <- getConnectionsUnqualified uids1 (Just uids2) mrel1 res2 <- getConnectionsUnqualified uids2 (Just uids1) mrel2 pure (res1, res2) + +ensureConnectedToLocals :: + ( Member (ErrorS 'NotConnected) r, + Member BrigAPIAccess r + ) => + UserId -> + [UserId] -> + Sem r () +ensureConnectedToLocals _ [] = pure () +ensureConnectedToLocals u uids = do + (connsFrom, connsTo) <- + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) + unless (length connsFrom == length uids && length connsTo == length uids) $ + throwS @'NotConnected diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index 6fdd631757d..bc36f8de6bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -455,7 +455,7 @@ addMembers conv (UserList lusers rusers) = do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has - -- been (or will be) made separately. See Galley.API.Update.addMembers + -- been (or will be) made separately. See Wire.ConversationSubsystem.Update.addMembers addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 3a4593cf22a..44605b64467 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -17,18 +17,64 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem where +module Wire.ConversationSubsystem + ( module Wire.ConversationSubsystem, + Util.BotsAndMembers (..), + Util.canDeleteMember, + Util.isMember, + Util.userLHEnabled, + MLSRemoval.RemoveUserIncludeMain (..), + LegalholdConflicts.guardLegalholdPolicyConflicts, + ) +where +import Data.Code qualified as Code +import Data.CommaSeparatedList (CommaSeparatedList) +import Data.Domain import Data.Id +import Data.Misc (IpAddr) import Data.Qualified -import Data.Range (Range) +import Data.Range import Data.Singletons (Sing) -import Galley.Types.Clients (Clients) import Imports import Polysemy -import Wire.API.Conversation (ConvIdsPage, ConversationPagingState, ExtraConversationData, NewConv, NewOne2OneConv) +import Wire.API.Bot (AddBot, RemoveBot) +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action +import Wire.API.Conversation.CellsState (CellsState) +import Wire.API.Conversation.Code (ConversationCodeInfo, CreateConversationCodeRequest, JoinConversationByCode) +import Wire.API.Conversation.Pagination (ConversationPage) +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role (ConversationRolesList) +import Wire.API.Conversation.Typing import Wire.API.Event.Conversation +import Wire.API.Federation.API.Common +import Wire.API.Federation.API.Galley +import Wire.API.MLS.CommitBundle +import Wire.API.MLS.GroupInfo (GroupInfoData) +import Wire.API.MLS.Keys (MLSKeys, MLSKeysByPurpose, MLSPublicKey, MLSPublicKeyFormat, SomeKey) +import Wire.API.MLS.Message +import Wire.API.MLS.OutOfSync (EnableOutOfSyncCheck) +import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation (ConvOrSubConvId, PublicSubConversation, SubConvId) +import Wire.API.Message (ClientMismatch, IgnoreMissing, MessageSendingStatus, NewOtrMessage, QualifiedNewOtrMessage, ReportMissing) +import Wire.API.Pagination (PageSize, SortOrder) +import Wire.API.Provider.Bot qualified as Public (BotConvView) +import Wire.API.Routes.Internal.Galley.ConversationsIntra (UpsertOne2OneConversationRequest) +import Wire.API.Routes.Public (ZHostValue) +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Galley.MLS (MLSReset) +import Wire.API.Routes.Public.Galley.Messaging (MessageNotSent, PostOtrResponse) +import Wire.API.Routes.Public.Util (UpdateResult) +import Wire.API.Routes.Version +import Wire.API.ServantProto (RawProto (..)) +import Wire.API.Team.Feature (GuestLinksConfig, LockableFeature) +import Wire.ConversationStore.MLS.Types (ListGlobalSelfConvs) +import Wire.ConversationSubsystem.LegalholdConflicts qualified as LegalholdConflicts +import Wire.ConversationSubsystem.MLS.IncomingMessage (IncomingBundle, IncomingMessage) +import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval +import Wire.ConversationSubsystem.Util qualified as Util import Wire.NotificationSubsystem (LocalConversationUpdate) import Wire.StoredConversation @@ -45,24 +91,39 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate - CreateGroupConversation :: + InternalCreateGroupConversation :: Local UserId -> Maybe ConnId -> NewConv -> ConversationSubsystem m StoredConversation + CreateLegacyGroupConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m (ConversationResponse Public.OwnConversation) + CreateGroupOwnConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m CreateGroupConversationResponseV9 + CreateGroupConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m CreateGroupConversation + CreateProteusSelfConversation :: + Local UserId -> + ConversationSubsystem m (ConversationResponse Public.OwnConversation) CreateOne2OneConversation :: Local UserId -> ConnId -> NewOne2OneConv -> - ConversationSubsystem m (StoredConversation, Bool) - CreateProteusSelfConversation :: - Local UserId -> - ConversationSubsystem m (StoredConversation, Bool) + ConversationSubsystem m (ConversationResponse Public.OwnConversation) CreateConnectConversation :: Local UserId -> Maybe ConnId -> Connect -> - ConversationSubsystem m (StoredConversation, Bool) + ConversationSubsystem m (ConversationResponse Public.OwnConversation) GetConversations :: [ConvId] -> ConversationSubsystem m [StoredConversation] @@ -71,10 +132,509 @@ data ConversationSubsystem m a where Range 1 1000 Int32 -> Maybe ConversationPagingState -> ConversationSubsystem r ConvIdsPage - InternalGetClientIds :: [UserId] -> ConversationSubsystem m Clients InternalGetLocalMember :: ConvId -> UserId -> ConversationSubsystem m (Maybe LocalMember) + InternalGetMember :: + Qualified ConvId -> + UserId -> + ConversationSubsystem m (Maybe Public.Member) + GetConversationMeta :: + ConvId -> + ConversationSubsystem m ConversationMetadata + GetMLSOne2OneConversationInternal :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Public.OwnConversation + IsMLSOne2OneEstablished :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Bool + GetLocalConversationInternal :: + ConvId -> + ConversationSubsystem m Conversation + RemoveClient :: + UserId -> + ClientId -> + ConversationSubsystem m () + AddBot :: + Local UserId -> + ConnId -> + AddBot -> + ConversationSubsystem m Event + RmBot :: + Local UserId -> + Maybe ConnId -> + RemoveBot -> + ConversationSubsystem m (UpdateResult Event) + UpdateCellsState :: + ConvId -> + CellsState -> + ConversationSubsystem m () + RemoveUser :: + Local StoredConversation -> + MLSRemoval.RemoveUserIncludeMain -> + Qualified UserId -> + ConversationSubsystem m () + PostMLSCommitBundle :: + Local x -> + Qualified UserId -> + ClientId -> + ConvType -> + Qualified ConvOrSubConvId -> + Maybe ConnId -> + EnableOutOfSyncCheck -> + IncomingBundle -> + ConversationSubsystem m [LocalConversationUpdate] + PostMLSCommitBundleFromLocalUser :: + Version -> + Local UserId -> + ClientId -> + ConnId -> + RawMLS CommitBundle -> + ConversationSubsystem m MLSMessageSendingStatus + PostMLSMessage :: + Local x -> + Qualified UserId -> + ClientId -> + ConvType -> + Qualified ConvOrSubConvId -> + Maybe ConnId -> + EnableOutOfSyncCheck -> + IncomingMessage -> + ConversationSubsystem m [LocalConversationUpdate] + PostMLSMessageFromLocalUser :: + Version -> + Local UserId -> + ClientId -> + ConnId -> + RawMLS Message -> + ConversationSubsystem m MLSMessageSendingStatus + IsMLSEnabled :: ConversationSubsystem m Bool + GetConversationsInternal :: + Local UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + ConversationSubsystem m (Public.ConversationList StoredConversation) + RemoveMemberFromLocalConv :: + Local ConvId -> + Local UserId -> + Maybe ConnId -> + Qualified UserId -> + ConversationSubsystem m (Maybe Event) + FederationOnConversationCreated :: + Domain -> + ConversationCreated ConvId -> + ConversationSubsystem m EmptyResponse + FederationGetConversations :: + Domain -> + GetConversationsRequest -> + ConversationSubsystem m GetRemoteConversationViewsResponse + FederationLeaveConversation :: + Domain -> + LeaveConversationRequest -> + ConversationSubsystem m LeaveConversationResponse + FederationSendMessage :: + Domain -> + ProteusMessageSendRequest -> + ConversationSubsystem m MessageSendResponse + FederationUpdateConversation :: + Domain -> + ConversationUpdateRequest -> + ConversationSubsystem m ConversationUpdateResponse + FederationMlsSendWelcome :: + Domain -> + MLSWelcomeRequest -> + ConversationSubsystem m MLSWelcomeResponse + FederationSendMLSMessage :: + Domain -> + MLSMessageSendRequest -> + ConversationSubsystem m MLSMessageResponse + FederationSendMLSCommitBundle :: + Domain -> + MLSMessageSendRequest -> + ConversationSubsystem m MLSMessageResponse + FederationQueryGroupInfo :: + Domain -> + GetGroupInfoRequest -> + ConversationSubsystem m GetGroupInfoResponse + FederationUpdateTypingIndicator :: + Domain -> + TypingDataUpdateRequest -> + ConversationSubsystem m TypingDataUpdateResponse + FederationOnTypingIndicatorUpdated :: + Domain -> + TypingDataUpdated -> + ConversationSubsystem m EmptyResponse + FederationGetSubConversationForRemoteUser :: + Domain -> + GetSubConversationsRequest -> + ConversationSubsystem m GetSubConversationsResponse + FederationDeleteSubConversationForRemoteUser :: + Domain -> + DeleteSubConversationFedRequest -> + ConversationSubsystem m DeleteSubConversationResponse + FederationLeaveSubConversation :: + Domain -> + LeaveSubConversationRequest -> + ConversationSubsystem m LeaveSubConversationResponse + FederationGetLegacyOne2OneConversation :: + Domain -> + GetOne2OneConversationRequest -> + ConversationSubsystem m GetOne2OneConversationResponse + FederationGetOne2OneConversation :: + Domain -> + GetOne2OneConversationRequest -> + ConversationSubsystem m GetOne2OneConversationResponseV2 + FederationOnClientRemoved :: + Domain -> + ClientRemovedRequest -> + ConversationSubsystem m EmptyResponse + FederationOnMessageSent :: + Domain -> + RemoteMessage ConvId -> + ConversationSubsystem m EmptyResponse + FederationOnMLSMessageSent :: + Domain -> + RemoteMLSMessage -> + ConversationSubsystem m EmptyResponse + FederationOnConversationUpdated :: + Domain -> + ConversationUpdate -> + ConversationSubsystem m EmptyResponse + FederationOnUserDeleted :: + Domain -> + UserDeletedConversationsNotification -> + ConversationSubsystem m EmptyResponse + PostOtrMessageUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (PostOtrResponse ClientMismatch) + PostOtrBroadcastUnqualified :: + Local UserId -> + ConnId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (PostOtrResponse ClientMismatch) + PostProteusMessage :: + Local UserId -> + ConnId -> + Qualified ConvId -> + RawProto QualifiedNewOtrMessage -> + ConversationSubsystem m (PostOtrResponse MessageSendingStatus) + PostProteusBroadcast :: + Local UserId -> + ConnId -> + QualifiedNewOtrMessage -> + ConversationSubsystem m (PostOtrResponse MessageSendingStatus) + DeleteLocalConversation :: + Local UserId -> + ConnId -> + Local ConvId -> + ConversationSubsystem m (UpdateResult Event) + GetMLSPublicKeys :: + Maybe MLSPublicKeyFormat -> + ConversationSubsystem m (MLSKeysByPurpose (MLSKeys SomeKey)) + ResetMLSConversation :: + Local UserId -> + MLSReset -> + ConversationSubsystem m () + GetSubConversation :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m PublicSubConversation + GetBotConversation :: + BotId -> + ConvId -> + ConversationSubsystem m Public.BotConvView + -- Query functions + GetUnqualifiedOwnConversation :: + Local UserId -> + ConvId -> + ConversationSubsystem m Public.OwnConversation + GetOwnConversation :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m Public.OwnConversation + GetPaginatedConversations :: + Local UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + ConversationSubsystem m (Public.ConversationList Public.OwnConversation) + GetConversation :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m Public.Conversation + InternalGetConversation :: + ConvId -> + ConversationSubsystem m (Maybe StoredConversation) + GetConversationRoles :: + Local UserId -> + ConvId -> + ConversationSubsystem m ConversationRolesList + SearchChannels :: + Local UserId -> + TeamId -> + Maybe Text -> + Maybe SortOrder -> + Maybe PageSize -> + Maybe Text -> + Maybe ConvId -> + Bool -> + ConversationSubsystem m ConversationPage + GetGroupInfo :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m GroupInfoData + ConversationIdsPageFromUnqualified :: + Local UserId -> + Maybe ConvId -> + Maybe (Range 1 1000 Int32) -> + ConversationSubsystem m (ConversationList ConvId) + ConversationIdsPaginated :: + ListGlobalSelfConvs -> + Local UserId -> + Public.GetPaginatedConversationIds -> + ConversationSubsystem m Public.ConvIdsPage + ConversationIdsPageFrom :: + Local UserId -> + Public.GetPaginatedConversationIds -> + ConversationSubsystem m Public.ConvIdsPage + ListConversations :: + Local UserId -> + Public.ListConversations -> + ConversationSubsystem m ConversationsResponse + GetConversationByReusableCode :: + Local UserId -> + Code.Key -> + Code.Value -> + ConversationSubsystem m ConversationCoverView + GetMLSSelfConversationWithError :: + Local UserId -> + ConversationSubsystem m Public.OwnConversation + GetMLSOne2OneOwnConversation :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Public.OwnConversation + GetMLSOne2OneMLSConversation :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m (MLSOne2OneConversation MLSPublicKey) + GetMLSOne2OneConversation :: + Local UserId -> + Qualified UserId -> + Maybe MLSPublicKeyFormat -> + ConversationSubsystem m (MLSOne2OneConversation SomeKey) + GetLocalSelf :: + Local UserId -> + ConvId -> + ConversationSubsystem m (Maybe Public.Member) + GetSelfMember :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m (Maybe Public.Member) + GetConversationGuestLinksStatus :: + UserId -> + ConvId -> + ConversationSubsystem m (LockableFeature GuestLinksConfig) + GetCode :: + Maybe Text -> + Local UserId -> + ConvId -> + ConversationSubsystem m ConversationCodeInfo + -- Update functions + + AddQualifiedMembersUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + InviteQualified -> + ConversationSubsystem m (UpdateResult Event) + AddMembers :: + Local UserId -> + ConnId -> + Qualified ConvId -> + InviteQualified -> + ConversationSubsystem m (UpdateResult Event) + ReplaceMembers :: + Local UserId -> + ConnId -> + Qualified ConvId -> + InviteQualified -> + ConversationSubsystem m () + JoinConversationById :: + Local UserId -> + ConnId -> + ConvId -> + ConversationSubsystem m (UpdateResult Event) + JoinConversationByReusableCode :: + Local UserId -> + ConnId -> + JoinConversationByCode -> + ConversationSubsystem m (UpdateResult Event) + CheckReusableCode :: + IpAddr -> + ConversationCode -> + ConversationSubsystem m () + AddCodeUnqualified :: + Maybe CreateConversationCodeRequest -> + UserId -> + Maybe ZHostValue -> + Maybe ConnId -> + ConvId -> + ConversationSubsystem m AddCodeResult + RmCodeUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + ConversationSubsystem m Event + MemberTyping :: + Local UserId -> + ConnId -> + Qualified ConvId -> + TypingStatus -> + ConversationSubsystem m () + RemoveMemberQualified :: + Local UserId -> + ConnId -> + Qualified ConvId -> + Qualified UserId -> + ConversationSubsystem m (Maybe Event) + UpdateOtherMember :: + Local UserId -> + ConnId -> + Qualified ConvId -> + Qualified UserId -> + OtherMemberUpdate -> + ConversationSubsystem m () + UpdateConversationName :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationRename -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationMessageTimer :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationMessageTimerUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationReceiptMode :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationReceiptModeUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationAccess :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationAccessData -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationHistory :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationHistoryUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateSelfMember :: + Local UserId -> + ConnId -> + Qualified ConvId -> + MemberUpdate -> + ConversationSubsystem m () + UpdateConversationProtocolWithLocalUser :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ProtocolUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateChannelAddPermission :: + Local UserId -> + ConnId -> + Qualified ConvId -> + AddPermissionUpdate -> + ConversationSubsystem m (UpdateResult Event) + PostBotMessageUnqualified :: + BotId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (Either (MessageNotSent ClientMismatch) ClientMismatch) + -- Sub-conversation functions + DeleteSubConversation :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + MLSReset -> + ConversationSubsystem m () + GetSubConversationGroupInfo :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m GroupInfoData + LeaveSubConversation :: + Local UserId -> + ClientId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m () + SendConversationActionNotifications :: + forall tag m. + Sing tag -> + Qualified UserId -> + Bool -> + Maybe ConnId -> + Local StoredConversation -> + Util.BotsAndMembers -> + ConversationAction (tag :: ConversationActionTag) -> + ExtraConversationData -> + ConversationSubsystem m LocalConversationUpdate + InternalUpsertOne2OneConversation :: + UpsertOne2OneConversationRequest -> + ConversationSubsystem m () + AcceptConv :: + QualifiedWithTag QLocal UserId -> + Maybe ConnId -> + ConvId -> + ConversationSubsystem m OwnConversation + BlockConv :: + QualifiedWithTag QLocal UserId -> + Qualified ConvId -> + ConversationSubsystem m () + UnblockConv :: + QualifiedWithTag QLocal UserId -> + Maybe ConnId -> + Qualified ConvId -> + ConversationSubsystem m () makeSem ''ConversationSubsystem + +iterateConversations :: + (Member ConversationSubsystem r) => + Local UserId -> + Range 1 500 Int32 -> + ([StoredConversation] -> Sem r a) -> + Sem r [a] +iterateConversations luid pageSize handleConvs = go Nothing + where + go mbConv = do + convResult <- getConversationsInternal luid Nothing mbConv (Just pageSize) + resultHead <- handleConvs (convList convResult) + resultTail <- case convList convResult of + (conv : rest) -> + if convHasMore convResult + then go (Just (maximum ((.id_) <$> (conv : rest)))) + else pure [] + _ -> pure [] + pure $ resultHead : resultTail diff --git a/services/galley/src/Galley/API/Action.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs similarity index 97% rename from services/galley/src/Galley/API/Action.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs index 7a0816a0153..3c81ed700f9 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action +module Wire.ConversationSubsystem.Action ( -- * Conversation action types ConversationActionTag (..), ConversationJoin (..), @@ -73,14 +73,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Time.Clock import GHC.TypeLits (KnownNat) -import Galley.API.Action.Kick -import Galley.API.Action.Leave -import Galley.API.Action.Notify -import Galley.API.Action.Reset -import Galley.API.MLS.Conversation -import Galley.API.MLS.Migration -import Galley.API.MLS.Removal -import Galley.API.Teams.Features.Get import Galley.Types.Error import Imports hiding ((\\)) import Polysemy @@ -122,7 +114,13 @@ import Wire.BrigAPIAccess qualified as E import Wire.CodeStore import Wire.CodeStore qualified as E import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Kick +import Wire.ConversationSubsystem.Action.Leave +import Wire.ConversationSubsystem.Action.Notify +import Wire.ConversationSubsystem.Action.Reset +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Migration +import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem @@ -140,7 +138,7 @@ import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList import Wire.Util @@ -189,7 +187,6 @@ instance IsConversationAction 'ConversationJoinTag where HasConversationActionEffects 'ConversationJoinTag r = ( -- TODO: Replace with subsystems Member BackendNotificationQueueAccess r, - Member ConversationSubsystem r, Member TeamCollaboratorsSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -461,7 +458,6 @@ instance IsConversationAction 'ConversationAccessDataTag where Member Random r, Member (Error FederationError) r, Member BackendNotificationQueueAccess r, - Member ConversationSubsystem r, Member TeamSubsystem r ) @@ -694,7 +690,6 @@ instance IsConversationAction 'ConversationResetTag where ( Member BackendNotificationQueueAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member E.ConversationStore r, Member NotificationSubsystem r, Member ProposalStore r, @@ -825,7 +820,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do -- - ensure that a consented conv admin exists -- - and kick all existing members that do not consent to LH from the conversation -- See also: "Brig.API.Connection.checkLegalholdPolicyConflict" - -- and "Galley.API.LegalHold.Conflicts.guardLegalholdPolicyConflictsUid". + -- and "Wire.ConversationSubsystem.LegalholdConflicts.guardLegalholdPolicyConflictsUid". checkLHPolicyConflictsLocal :: [UserId] -> Sem r () @@ -843,7 +838,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do throwS @'MissingLegalholdConsent convUsersLHStatus <- do - uidsStatus <- getLHStatusForUsers ((.id_) <$> convUsers) + uidsStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> convUsers) pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus if any @@ -995,7 +990,6 @@ updateLocalConversationJoin :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationJoinTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, @@ -1034,7 +1028,6 @@ updateLocalConversationLeave :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationLeaveTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, Member ExternalAccess r, @@ -1057,7 +1050,10 @@ updateLocalConversationMemberUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationMemberUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member (ErrorS ConvMemberNotFound) r, Member E.ConversationStore r @@ -1074,7 +1070,10 @@ updateLocalConversationDelete :: ( Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationDeleteTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member CodeStore r, Member E.ConversationStore r, @@ -1093,7 +1092,10 @@ updateLocalConversationRename :: ( Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRenameTag))) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member (Error InvalidInput) r, Member E.ConversationStore r, @@ -1112,7 +1114,10 @@ updateLocalConversationMessageTimerUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationMessageTimerUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member E.ConversationStore r, Member (Error NoChanges) r @@ -1130,7 +1135,10 @@ updateLocalConversationReceiptModeUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationReceiptModeUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member E.ConversationStore r, Member (Error NoChanges) r, @@ -1149,7 +1157,6 @@ updateLocalConversationAccessData :: Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationAccessDataTag))) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member TinyLog r, Member E.ConversationStore r, @@ -1179,7 +1186,6 @@ updateLocalConversationRemoveMembers :: ( Member BackendNotificationQueueAccess r, Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRemoveMembersTag))) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member TinyLog r, Member E.ConversationStore r, @@ -1207,7 +1213,6 @@ updateLocalConversationUpdateProtocol :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationUpdateProtocolTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member (E.FederationAPIAccess FederatorClient) r, Member TinyLog r, @@ -1237,7 +1242,10 @@ updateLocalConversationUpdateAddPermission :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationUpdateAddPermissionTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member (Error NoChanges) r, Member E.ConversationStore r, Member TeamSubsystem r, @@ -1257,7 +1265,6 @@ updateLocalConversationReset :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationResetTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (E.FederationAPIAccess FederatorClient) r, Member TinyLog r, Member E.ConversationStore r, @@ -1285,7 +1292,10 @@ updateLocalConversationHistoryUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationHistoryUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member E.ConversationStore r, Member TeamSubsystem r, Member (ErrorS HistoryNotSupported) r @@ -1304,7 +1314,6 @@ updateLocalConversationUncheckedJoin :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationJoinTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, @@ -1343,7 +1352,6 @@ updateLocalConversationUncheckedRemoveMembers :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRemoveMembersTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, Member (Error NoChanges) r, @@ -1370,7 +1378,10 @@ updateLocalConversation :: Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, HasConversationActionEffects tag r, IsConversationAction tag, SingI tag, @@ -1405,7 +1416,10 @@ updateLocalConversationUnchecked :: Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, HasConversationActionEffects tag r, Member TeamSubsystem r ) => diff --git a/services/galley/src/Galley/API/Action/Kick.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs similarity index 93% rename from services/galley/src/Galley/API/Action/Kick.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs index 7356b04c10b..ddb1caae8a0 100644 --- a/services/galley/src/Galley/API/Action/Kick.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs @@ -15,14 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Kick where +module Wire.ConversationSubsystem.Action.Kick where import Data.Default import Data.Id import Data.Qualified import Data.Singletons -import Galley.API.Action.Leave -import Galley.API.Action.Notify import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -35,7 +33,8 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.Error import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore) -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Leave +import Wire.ConversationSubsystem.Action.Notify import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.NotificationSubsystem @@ -53,7 +52,6 @@ kickMember :: ( Member BackendNotificationQueueAccess r, Member (Error FederationError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member ProposalStore r, Member Now r, diff --git a/services/galley/src/Galley/API/Action/Leave.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs similarity index 94% rename from services/galley/src/Galley/API/Action/Leave.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs index 0141cc4ad2c..4e88fd77f9a 100644 --- a/services/galley/src/Galley/API/Action/Leave.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs @@ -15,12 +15,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Leave (leaveConversation) where +module Wire.ConversationSubsystem.Action.Leave (leaveConversation) where import Control.Lens import Data.Id import Data.Qualified -import Galley.API.MLS.Removal import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -30,6 +29,7 @@ import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Federation.Error import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Action/Notify.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs similarity index 76% rename from services/galley/src/Galley/API/Action/Notify.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs index 77c8167ebc3..4a11ac20012 100644 --- a/services/galley/src/Galley/API/Action/Notify.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs @@ -15,24 +15,34 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Notify where +module Wire.ConversationSubsystem.Action.Notify where import Data.Id import Data.Qualified import Data.Singletons import Imports hiding ((\\)) import Polysemy +import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Event.Conversation -import Wire.ConversationSubsystem +import Wire.API.Federation.Error +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.ConversationSubsystem.Notify (notifyConversationActionImpl) import Wire.ConversationSubsystem.Util +import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) import Wire.StoredConversation sendConversationActionNotifications :: forall tag r. - (Member ConversationSubsystem r) => + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, + Member (Error FederationError) r, + Member Now r, + Member NotificationSubsystem r + ) => Sing tag -> Qualified UserId -> Bool -> @@ -43,7 +53,7 @@ sendConversationActionNotifications :: ExtraConversationData -> Sem r LocalConversationUpdate sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData = do - notifyConversationAction + notifyConversationActionImpl tag (EventFromUser quid) notifyOrigDomain diff --git a/services/galley/src/Galley/API/Action/Reset.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs similarity index 96% rename from services/galley/src/Galley/API/Action/Reset.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs index 49614ab300d..c31399a3b4d 100644 --- a/services/galley/src/Galley/API/Action/Reset.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs @@ -15,15 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Reset (resetLocalMLSMainConversation) where +module Wire.ConversationSubsystem.Action.Reset (resetLocalMLSMainConversation) where import Control.Monad.Codensity hiding (reset) import Data.Aeson qualified as A import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Qualified -import Galley.API.Action.Kick -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -47,7 +45,8 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.API.VersionInfo import Wire.BackendNotificationQueueAccess import Wire.ConversationStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Kick +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess @@ -65,7 +64,6 @@ resetLocalMLSMainConversation :: Member BackendNotificationQueueAccess r, Member (FederationAPIAccess FederatorClient) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member ProposalStore r, Member Random r, diff --git a/services/galley/src/Galley/API/Clients.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs similarity index 89% rename from services/galley/src/Galley/API/Clients.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs index 7aa4c2f12e9..52dae02033a 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs @@ -15,9 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Clients - ( getClients, - rmClient, +module Wire.ConversationSubsystem.Clients + ( rmClient, ) where @@ -25,8 +24,6 @@ import Data.Id import Data.Proxy import Data.Qualified import Data.Range -import Galley.API.MLS.Removal -import Galley.API.Query qualified as Query import Galley.Types.Clients (clientIds) import Galley.Types.Error import Imports @@ -45,7 +42,8 @@ import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Routes.MultiTablePaging import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore, getConversation) -import Wire.ConversationSubsystem qualified as ConvSubsystem +import Wire.ConversationSubsystem.MLS.Removal qualified as Removal +import Wire.ConversationSubsystem.Query qualified as Query import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem import Wire.ProposalStore (ProposalStore) @@ -54,12 +52,6 @@ import Wire.Sem.Random (Random) import Wire.UserClientIndexStore qualified as E import Wire.Util -getClients :: - (Member ConvSubsystem.ConversationSubsystem r) => - UserId -> - Sem r [ClientId] -getClients usr = clientIds usr <$> ConvSubsystem.internalGetClientIds [usr] - -- | Remove a client from conversations it is part of according to the -- conversation protocol (Proteus or MLS). In addition, remove the client from -- the "clients" table in Galley. @@ -67,7 +59,6 @@ rmClient :: forall r. ( Member E.UserClientIndexStore r, Member ConversationStore r, - Member ConvSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member ExternalAccess r, Member BackendNotificationQueueAccess r, @@ -107,7 +98,7 @@ rmClient usr cid = do mConv <- getConversation convId for_ mConv $ \conv -> do lconv <- qualifyLocal conv - removeClient lconv (tUntagged lusr) cid + Removal.removeClient lconv (tUntagged lusr) cid traverse_ removeRemoteMLSClients (rangedChunks remoteConvs) when (mtpHasMore page) $ do let nextState = mtpPagingState page diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs new file mode 100644 index 00000000000..983fd7f0af2 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConversationSubsystem.Create where + +import Data.Id +import Data.Qualified +import Data.Set qualified as Set +import Galley.Types.Error +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.Config +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Event.Conversation +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.FederationStatus (RemoteDomains (..)) +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.API.User +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.BrigAPIAccess +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.CreateInternal +import Wire.ConversationSubsystem.Util +import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) +import Wire.LegalHoldStore (LegalHoldStore) +import Wire.NotificationSubsystem as NS +import Wire.Sem.Now (Now) +import Wire.Sem.Random (Random) +import Wire.StoredConversation +import Wire.TeamCollaboratorsSubsystem +import Wire.TeamStore (TeamStore) +import Wire.TeamSubsystem (TeamSubsystem) + +---------------------------------------------------------------------------- +-- API Handlers + +createLegacyGroupConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error UnreachableBackendsLegacy) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createLegacyGroupConversation lusr conn newConv = mapError UnreachableBackendsLegacy $ do + dbConv <- createGroupConversationGeneric lusr conn newConv + maybe (throwIfNotOwnConversation lusr dbConv.id_) (pure . Created) $ ownConversationView lusr dbConv + +createGroupOwnConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error InternalError) r, + Member FederationSubsystem r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + maybe (throwIfNotOwnConversation lusr dbConv.id_) (pure . GroupConversationCreatedV9) $ + (CreateGroupOwnConversation <$> ownConversationView lusr dbConv <*> pure mempty) + +createGroupConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member FederationSubsystem r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + pure $ + CreateGroupConversation + { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, + failedToAdd = mempty + } + +createProteusSelfConversation :: + ( Member ConversationStore r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + (c, created) <- createProteusSelfConversationLogic lusr + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv + +createOne2OneConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'NotConnected) r, + Member TeamStore r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + ConnId -> + NewOne2OneConv -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversation lusr zcon j = do + (c, created) <- createOne2OneConversationLogic lusr zcon j + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv + +---------------------------------------------------------------------------- +-- Helpers + +createConnectConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (Error UnreachableBackends) r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member (FederationAPIAccess FederatorClient) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Sem r (ConversationResponse Public.OwnConversation) +createConnectConversation lusr conn j = do + (c, created) <- createConnectConversationLogic lusr conn j + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs index f2aab2d82e3..e28425c9061 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs @@ -80,7 +80,7 @@ import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs new file mode 100644 index 00000000000..ec74e2b5267 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs @@ -0,0 +1,325 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ConversationSubsystem.Errors + ( mapErrors, + ConversationSubsystemError (..), + ) +where + +import Data.Tagged +import Galley.Types.Error (InternalError, InvalidInput (..)) +import Imports +import Network.Wai.Utilities.JSONResponse (JSONResponse) +import Polysemy +import Polysemy.Error +import Wire.API.Conversation.Role qualified as ConvRole +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Federation.Error +import Wire.API.Routes.API (ServerEffect (interpretServerEffect)) + +data ConversationSubsystemError + = ConversationSubsystemErrorConvAccessDenied + | ConversationSubsystemErrorNotATeamMember + | ConversationSubsystemErrorperationDenied + | ConversationSubsystemErrorNotConnected + | ConversationSubsystemErrorMLSNotEnabled + | ConversationSubsystemErrorMLSNonEmptyMemberList + | ConversationSubsystemErrorMissingLegalholdConsent + | ConversationSubsystemErrorNonBindingTeam + | ConversationSubsystemErrorNoBindingTeamMembers + | ConversationSubsystemErrorTeamNotFound + | ConversationSubsystemErrorInvalidOperation + | ConversationSubsystemErrorConvNotFound + | ConversationSubsystemErrorChannelsNotEnabled + | ConversationSubsystemErrorNotAnMlsConversation + | ConversationSubsystemErrorMLSLegalholdIncompatible + | ConversationSubsystemErrorMLSIdentityMismatch + | ConversationSubsystemErrorMLSUnsupportedMessage + | ConversationSubsystemErrorMLSStaleMessage + | ConversationSubsystemErrorMLSProposalNotFound + | ConversationSubsystemErrorMLSCommitMissingReferences + | ConversationSubsystemErrorMLSSelfRemovalNotAllowed + | ConversationSubsystemErrorMLSClientSenderUserMismatch + | ConversationSubsystemErrorMLSSubConvClientNotInParent + | ConversationSubsystemErrorMLSInvalidLeafNodeSignature + | ConversationSubsystemErrorMLSClientMismatch + | ConversationSubsystemErrorMLSInvalidLeafNodeIndex + | ConversationSubsystemErrorMLSUnsupportedProposal + | ConversationSubsystemErrorGroupIdVersionNotSupported + | ConversationSubsystemErrorConvMemberNotFound + | ConversationSubsystemErrorHistoryNotSupported + | ConversationSubsystemErrorLSGroupConversationMismatch + | ConversationSubsystemErrorActionDeniedLeaveConversation + | ConversationSubsystemErrorActionDeniedRemoveConversationMember + | ConversationSubsystemErrorActionDeniedDeleteConversation + | ConversationSubsystemErrorBroadcastLimitExceeded + | ConversationSubsystemErrorMLSFederatedResetNotSupported + | ConversationSubsystemErrorMLSSubConvUnsupportedConvType + | ConversationSubsystemErrorTeamMemberNotFound + | ConversationSubsystemErrorAccessDenied + | ConversationSubsystemErrorMLSMissingGroupInfo + | ConversationSubsystemErrorCodeNotFound + | ConversationSubsystemErrorInvalidConversationPassword + | ConversationSubsystemErrorGuestLinksDisabled + | ConversationSubsystemErrorMLSFederatedOne2OneNotSupported + | ConversationSubsystemErrorTooManyMembers + | ConversationSubsystemErrorCreateConversationCodeConflict + | ConversationSubsystemErrorInvalidTarget + | ConversationSubsystemErrorMLSReadReceiptsNotAllowed + | ConversationSubsystemErrorInvalidTargetAccess + | ConversationSubsystemErrorConvInvalidProtocolTransition + | ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied + | ConversationSubsystemErrorActionDeniedAddConversationMember + | ConversationSubsystemErrorActionDeniedModifyOtherConversationMember + | ConversationSubsystemErrorActionDeniedModifyConversationName + | ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer + | ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode + | ConversationSubsystemErrorActionDeniedModifyConversationAccess + | ConversationSubsystemErrorActionDeniedModifyAddPermission + | ConversationSubsystemErrorFederationError FederationError + | ConversationSubsystemErrorUnreachableBackends UnreachableBackends + | ConversationSubsystemErrorInternalError InternalError + | ConversationSubsystemErrorInvalidInput InvalidInput + | ConversationSubsystemErrorMLSProtocolError MLSProtocolError + | ConversationSubsystemErrorGroupInfoDiagnostics GroupInfoDiagnostics + | ConversationSubsystemErrorMLSOutOfSyncError MLSOutOfSyncError + | ConversationSubsystemErrorNonFederatingBackends NonFederatingBackends + | ConversationSubsystemErrorUnreachableBackendsLegacy UnreachableBackendsLegacy + +instance APIError ConversationSubsystemError where + toResponse = + \case + ConversationSubsystemErrorConvAccessDenied -> toResponse $ Tagged @'ConvAccessDenied () + ConversationSubsystemErrorNotATeamMember -> toResponse $ Tagged @'NotATeamMember () + ConversationSubsystemErrorperationDenied -> toResponse $ Tagged @OperationDenied () + ConversationSubsystemErrorNotConnected -> toResponse $ Tagged @'NotConnected () + ConversationSubsystemErrorMLSNotEnabled -> toResponse $ Tagged @'MLSNotEnabled () + ConversationSubsystemErrorMLSNonEmptyMemberList -> toResponse $ Tagged @'MLSNonEmptyMemberList () + ConversationSubsystemErrorMissingLegalholdConsent -> toResponse $ Tagged @'MissingLegalholdConsent () + ConversationSubsystemErrorNonBindingTeam -> toResponse $ Tagged @'NonBindingTeam () + ConversationSubsystemErrorNoBindingTeamMembers -> toResponse $ Tagged @'NoBindingTeamMembers () + ConversationSubsystemErrorTeamNotFound -> toResponse $ Tagged @'TeamNotFound () + ConversationSubsystemErrorInvalidOperation -> toResponse $ Tagged @'InvalidOperation () + ConversationSubsystemErrorConvNotFound -> toResponse $ Tagged @'ConvNotFound () + ConversationSubsystemErrorChannelsNotEnabled -> toResponse $ Tagged @'ChannelsNotEnabled () + ConversationSubsystemErrorNotAnMlsConversation -> toResponse $ Tagged @'NotAnMlsConversation () + ConversationSubsystemErrorMLSLegalholdIncompatible -> toResponse $ Tagged @'MLSLegalholdIncompatible () + ConversationSubsystemErrorMLSIdentityMismatch -> toResponse $ Tagged @'MLSIdentityMismatch () + ConversationSubsystemErrorMLSUnsupportedMessage -> toResponse $ Tagged @'MLSUnsupportedMessage () + ConversationSubsystemErrorMLSStaleMessage -> toResponse $ Tagged @'MLSStaleMessage () + ConversationSubsystemErrorMLSProposalNotFound -> toResponse $ Tagged @'MLSProposalNotFound () + ConversationSubsystemErrorMLSCommitMissingReferences -> toResponse $ Tagged @'MLSCommitMissingReferences () + ConversationSubsystemErrorMLSSelfRemovalNotAllowed -> toResponse $ Tagged @'MLSSelfRemovalNotAllowed () + ConversationSubsystemErrorMLSClientSenderUserMismatch -> toResponse $ Tagged @'MLSClientSenderUserMismatch () + ConversationSubsystemErrorMLSSubConvClientNotInParent -> toResponse $ Tagged @'MLSSubConvClientNotInParent () + ConversationSubsystemErrorMLSInvalidLeafNodeSignature -> toResponse $ Tagged @'MLSInvalidLeafNodeSignature () + ConversationSubsystemErrorMLSClientMismatch -> toResponse $ Tagged @'MLSClientMismatch () + ConversationSubsystemErrorMLSInvalidLeafNodeIndex -> toResponse $ Tagged @'MLSInvalidLeafNodeIndex () + ConversationSubsystemErrorMLSUnsupportedProposal -> toResponse $ Tagged @'MLSUnsupportedProposal () + ConversationSubsystemErrorGroupIdVersionNotSupported -> toResponse $ Tagged @'GroupIdVersionNotSupported () + ConversationSubsystemErrorConvMemberNotFound -> toResponse $ Tagged @'ConvMemberNotFound () + ConversationSubsystemErrorHistoryNotSupported -> toResponse $ Tagged @'HistoryNotSupported () + ConversationSubsystemErrorLSGroupConversationMismatch -> toResponse $ Tagged @MLSGroupConversationMismatch () + ConversationSubsystemErrorActionDeniedLeaveConversation -> toResponse $ Tagged @('ActionDenied ConvRole.LeaveConversation) () + ConversationSubsystemErrorActionDeniedRemoveConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.RemoveConversationMember) () + ConversationSubsystemErrorActionDeniedDeleteConversation -> toResponse $ Tagged @('ActionDenied ConvRole.DeleteConversation) () + ConversationSubsystemErrorBroadcastLimitExceeded -> toResponse $ Tagged @'BroadcastLimitExceeded () + ConversationSubsystemErrorMLSFederatedResetNotSupported -> toResponse $ Tagged @'MLSFederatedResetNotSupported () + ConversationSubsystemErrorMLSSubConvUnsupportedConvType -> toResponse $ Tagged @'MLSSubConvUnsupportedConvType () + ConversationSubsystemErrorTeamMemberNotFound -> toResponse $ Tagged @'TeamMemberNotFound () + ConversationSubsystemErrorAccessDenied -> toResponse $ Tagged @'AccessDenied () + ConversationSubsystemErrorMLSMissingGroupInfo -> toResponse $ Tagged @'MLSMissingGroupInfo () + ConversationSubsystemErrorCodeNotFound -> toResponse $ Tagged @'CodeNotFound () + ConversationSubsystemErrorInvalidConversationPassword -> toResponse $ Tagged @'InvalidConversationPassword () + ConversationSubsystemErrorGuestLinksDisabled -> toResponse $ Tagged @'GuestLinksDisabled () + ConversationSubsystemErrorMLSFederatedOne2OneNotSupported -> toResponse $ Tagged @'MLSFederatedOne2OneNotSupported () + ConversationSubsystemErrorTooManyMembers -> toResponse $ Tagged @'TooManyMembers () + ConversationSubsystemErrorCreateConversationCodeConflict -> toResponse $ Tagged @'CreateConversationCodeConflict () + ConversationSubsystemErrorInvalidTarget -> toResponse $ Tagged @'InvalidTarget () + ConversationSubsystemErrorMLSReadReceiptsNotAllowed -> toResponse $ Tagged @'MLSReadReceiptsNotAllowed () + ConversationSubsystemErrorInvalidTargetAccess -> toResponse $ Tagged @'InvalidTargetAccess () + ConversationSubsystemErrorConvInvalidProtocolTransition -> toResponse $ Tagged @'ConvInvalidProtocolTransition () + ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied -> toResponse $ Tagged @'MLSMigrationCriteriaNotSatisfied () + ConversationSubsystemErrorActionDeniedAddConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.AddConversationMember) () + ConversationSubsystemErrorActionDeniedModifyOtherConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyOtherConversationMember) () + ConversationSubsystemErrorActionDeniedModifyConversationName -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationName) () + ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationMessageTimer) () + ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationReceiptMode) () + ConversationSubsystemErrorActionDeniedModifyConversationAccess -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationAccess) () + ConversationSubsystemErrorActionDeniedModifyAddPermission -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyAddPermission) () + ConversationSubsystemErrorFederationError x -> toResponse x + ConversationSubsystemErrorUnreachableBackends x -> toResponse x + ConversationSubsystemErrorInternalError x -> toResponse x + ConversationSubsystemErrorInvalidInput x -> toResponse x + ConversationSubsystemErrorMLSProtocolError x -> toResponse $ (dynError @(MapError 'MLSProtocolErrorTag)) {eMessage = unTagged x} + ConversationSubsystemErrorGroupInfoDiagnostics x -> toResponse x + ConversationSubsystemErrorMLSOutOfSyncError x -> toResponse x + ConversationSubsystemErrorNonFederatingBackends x -> toResponse x + ConversationSubsystemErrorUnreachableBackendsLegacy x -> toResponse x + +type ConversationSubsystemErrorEffects = + '[ ErrorS 'ConvAccessDenied, + ErrorS 'NotATeamMember, + ErrorS OperationDenied, + ErrorS 'NotConnected, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSNonEmptyMemberList, + ErrorS 'MissingLegalholdConsent, + ErrorS 'NonBindingTeam, + ErrorS 'NoBindingTeamMembers, + ErrorS 'TeamNotFound, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ChannelsNotEnabled, + ErrorS 'NotAnMlsConversation, + ErrorS 'MLSLegalholdIncompatible, + ErrorS 'MLSIdentityMismatch, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MLSCommitMissingReferences, + ErrorS 'MLSSelfRemovalNotAllowed, + ErrorS 'MLSClientSenderUserMismatch, + ErrorS 'MLSSubConvClientNotInParent, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSClientMismatch, + ErrorS 'MLSInvalidLeafNodeIndex, + ErrorS 'MLSUnsupportedProposal, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'ConvMemberNotFound, + ErrorS 'HistoryNotSupported, + ErrorS MLSGroupConversationMismatch, + ErrorS ('ActionDenied ConvRole.LeaveConversation), + ErrorS ('ActionDenied ConvRole.RemoveConversationMember), + ErrorS ('ActionDenied ConvRole.DeleteConversation), + ErrorS 'BroadcastLimitExceeded, + ErrorS 'MLSFederatedResetNotSupported, + ErrorS 'MLSSubConvUnsupportedConvType, + ErrorS 'TeamMemberNotFound, + ErrorS 'AccessDenied, + ErrorS 'MLSMissingGroupInfo, + ErrorS 'CodeNotFound, + ErrorS 'InvalidConversationPassword, + ErrorS 'GuestLinksDisabled, + ErrorS 'MLSFederatedOne2OneNotSupported, + ErrorS 'TooManyMembers, + ErrorS 'CreateConversationCodeConflict, + ErrorS 'InvalidTarget, + ErrorS 'MLSReadReceiptsNotAllowed, + ErrorS 'InvalidTargetAccess, + ErrorS 'ConvInvalidProtocolTransition, + ErrorS 'MLSMigrationCriteriaNotSatisfied, + ErrorS ('ActionDenied ConvRole.AddConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyOtherConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyConversationName), + ErrorS ('ActionDenied ConvRole.ModifyConversationMessageTimer), + ErrorS ('ActionDenied ConvRole.ModifyConversationReceiptMode), + ErrorS ('ActionDenied ConvRole.ModifyConversationAccess), + ErrorS ('ActionDenied ConvRole.ModifyAddPermission), + Error FederationError, + Error UnreachableBackends, + Error InternalError, + Error InvalidInput, + Error AuthenticationError, + Error MLSProtocolError, + Error GroupInfoDiagnostics, + Error MLSOutOfSyncError, + Error MLSProposalFailure, + Error NonFederatingBackends, + Error UnreachableBackendsLegacy + ] + +mapErrors :: + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r + ) => + InterpretersFor ConversationSubsystemErrorEffects r +mapErrors = + mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) + . mapError (ConversationSubsystemErrorNonFederatingBackends) + . interpretServerEffect + . mapError (ConversationSubsystemErrorMLSOutOfSyncError) + . mapError (ConversationSubsystemErrorGroupInfoDiagnostics) + . mapError (ConversationSubsystemErrorMLSProtocolError) + . interpretServerEffect + . mapError (ConversationSubsystemErrorInvalidInput) + . mapError (ConversationSubsystemErrorInternalError) + . mapError (ConversationSubsystemErrorUnreachableBackends) + . mapError (ConversationSubsystemErrorFederationError) + . mapError (const ConversationSubsystemErrorActionDeniedModifyAddPermission) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationAccess) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationName) + . mapError (const ConversationSubsystemErrorActionDeniedModifyOtherConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedAddConversationMember) + . mapError (const ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied) + . mapError (const ConversationSubsystemErrorConvInvalidProtocolTransition) + . mapError (const ConversationSubsystemErrorInvalidTargetAccess) + . mapError (const ConversationSubsystemErrorMLSReadReceiptsNotAllowed) + . mapError (const ConversationSubsystemErrorInvalidTarget) + . mapError (const ConversationSubsystemErrorCreateConversationCodeConflict) + . mapError (const ConversationSubsystemErrorTooManyMembers) + . mapError (const ConversationSubsystemErrorMLSFederatedOne2OneNotSupported) + . mapError (const ConversationSubsystemErrorGuestLinksDisabled) + . mapError (const ConversationSubsystemErrorInvalidConversationPassword) + . mapError (const ConversationSubsystemErrorCodeNotFound) + . mapError (const ConversationSubsystemErrorMLSMissingGroupInfo) + . mapError (const ConversationSubsystemErrorAccessDenied) + . mapError (const ConversationSubsystemErrorTeamMemberNotFound) + . mapError (const ConversationSubsystemErrorMLSSubConvUnsupportedConvType) + . mapError (const ConversationSubsystemErrorMLSFederatedResetNotSupported) + . mapError (const ConversationSubsystemErrorBroadcastLimitExceeded) + . mapError (const ConversationSubsystemErrorActionDeniedDeleteConversation) + . mapError (const ConversationSubsystemErrorActionDeniedRemoveConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedLeaveConversation) + . mapError (const ConversationSubsystemErrorLSGroupConversationMismatch) + . mapError (const ConversationSubsystemErrorHistoryNotSupported) + . mapError (const ConversationSubsystemErrorConvMemberNotFound) + . mapError (const ConversationSubsystemErrorGroupIdVersionNotSupported) + . mapError (const ConversationSubsystemErrorMLSUnsupportedProposal) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeIndex) + . mapError (const ConversationSubsystemErrorMLSClientMismatch) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeSignature) + . mapError (const ConversationSubsystemErrorMLSSubConvClientNotInParent) + . mapError (const ConversationSubsystemErrorMLSClientSenderUserMismatch) + . mapError (const ConversationSubsystemErrorMLSSelfRemovalNotAllowed) + . mapError (const ConversationSubsystemErrorMLSCommitMissingReferences) + . mapError (const ConversationSubsystemErrorMLSProposalNotFound) + . mapError (const ConversationSubsystemErrorMLSStaleMessage) + . mapError (const ConversationSubsystemErrorMLSUnsupportedMessage) + . mapError (const ConversationSubsystemErrorMLSIdentityMismatch) + . mapError (const ConversationSubsystemErrorMLSLegalholdIncompatible) + . mapError (const ConversationSubsystemErrorNotAnMlsConversation) + . mapError (const ConversationSubsystemErrorChannelsNotEnabled) + . mapError (const ConversationSubsystemErrorConvNotFound) + . mapError (const ConversationSubsystemErrorInvalidOperation) + . mapError (const ConversationSubsystemErrorTeamNotFound) + . mapError (const ConversationSubsystemErrorNoBindingTeamMembers) + . mapError (const ConversationSubsystemErrorNonBindingTeam) + . mapError (const ConversationSubsystemErrorMissingLegalholdConsent) + . mapError (const ConversationSubsystemErrorMLSNonEmptyMemberList) + . mapError (const ConversationSubsystemErrorMLSNotEnabled) + . mapError (const ConversationSubsystemErrorNotConnected) + . mapError (const ConversationSubsystemErrorperationDenied) + . mapError (const ConversationSubsystemErrorNotATeamMember) + . mapError (const ConversationSubsystemErrorConvAccessDenied) diff --git a/services/galley/src/Galley/API/Federation/Handlers.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs similarity index 92% rename from services/galley/src/Galley/API/Federation/Handlers.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index b62d7ed3980..34a22f5dd4f 100644 --- a/services/galley/src/Galley/API/Federation/Handlers.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Federation.Handlers where +module Wire.ConversationSubsystem.Federation where import Control.Error hiding (note) import Control.Lens @@ -36,20 +36,6 @@ import Data.Set qualified as Set import Data.Singletons (SingI (..), demote, sing) import Data.Tagged import Data.Text.Lazy qualified as LT -import Galley.API.Action -import Galley.API.MLS -import Galley.API.MLS.Enabled -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled) -import Galley.API.MLS.Message -import Galley.API.MLS.One2One -import Galley.API.MLS.Removal -import Galley.API.MLS.SubConversation hiding (leaveSubConversation) -import Galley.API.MLS.Util -import Galley.API.MLS.Welcome -import Galley.API.Mapping -import Galley.API.Mapping qualified as Mapping -import Galley.API.Message import Galley.Types.Conversations.One2One import Galley.Types.Error import Imports @@ -83,12 +69,24 @@ import Wire.API.Message import Wire.API.Push.V2 (RecipientClients (..)) import Wire.API.Routes.Public.Galley.MLS import Wire.API.ServantProto +import Wire.API.Team.FeatureFlags (FeatureFlags) import Wire.API.User (BaseProtocolTag (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.CodeStore import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.GroupInfo +import Wire.ConversationSubsystem.MLS.GroupInfoCheck (GroupInfoCheckEnabled) +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Message +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.Removal +import Wire.ConversationSubsystem.MLS.SubConversation hiding (leaveSubConversation) +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.MLS.Welcome +import Wire.ConversationSubsystem.Message import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem @@ -97,7 +95,6 @@ import Wire.FederationSubsystem (FederationSubsystem) import Wire.FireAndForget qualified as E import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem -import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -184,28 +181,18 @@ onConversationCreated domain rc = do pushConversationEvent Nothing () event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] pure EmptyResponse -getConversationsV1 :: - ( Member E.ConversationStore r, - Member (Input (Local ())) r - ) => - Domain -> - GetConversationsRequest -> - Sem r GetConversationsResponse -getConversationsV1 domain req = - getConversationsResponseFromV2 <$> Galley.API.Federation.Handlers.getConversations domain req - getConversations :: ( Member E.ConversationStore r, Member (Input (Local ())) r ) => Domain -> GetConversationsRequest -> - Sem r GetConversationsResponseV2 + Sem r GetRemoteConversationViewsResponse getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid loc <- qualifyLocal () - GetConversationsResponseV2 - . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) + GetRemoteConversationViewsResponse + . mapMaybe (conversationToRemote (tDomain loc) ruid) <$> E.getConversations cids -- | Update the local database with information on conversation members joining @@ -226,27 +213,12 @@ onConversationUpdated requestingDomain cu = do void $ updateLocalStateOfRemoteConv rcu Nothing pure EmptyResponse -onConversationUpdatedV0 :: - ( Member BrigAPIAccess r, - Member NotificationSubsystem r, - Member ExternalAccess r, - Member (Input (Local ())) r, - Member E.ConversationStore r, - Member P.TinyLog r - ) => - Domain -> - ConversationUpdateV0 -> - Sem r EmptyResponse -onConversationUpdatedV0 domain cu = - onConversationUpdated domain (conversationUpdateFromV0 cu) - -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: ( Member BackendNotificationQueueAccess r, Member E.ConversationStore r, Member (Error InternalError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, @@ -365,13 +337,14 @@ onMessageSent domain rmUnqualified = do sendMessage :: ( Member BrigAPIAccess r, Member UserClientIndexStore r, + Member (Input IntraListing) r, + Member (Input FeatureFlags) r, Member E.ConversationStore r, Member (Error InvalidInput) r, Member (FederationAPIAccess FederatorClient) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, - Member (Input Opts) r, Member Now r, Member ExternalAccess r, Member TeamSubsystem r, @@ -394,7 +367,6 @@ onUserDeleted :: Member E.FireAndForget r, Member (Error FederationError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, @@ -456,7 +428,6 @@ updateConversation :: Member (Error InvalidInput) r, Member ExternalAccess r, Member (FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -559,6 +530,16 @@ updateConversation origDomain updateRequest = do . runError @UnreachableBackends . fmap ConversationUpdateResponseUpdate +type MLSBundleStaticErrors = + Append + MLSMessageStaticErrors + '[ ErrorS 'MLSWelcomeMismatch, + ErrorS 'MLSIdentityMismatch, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSGroupConversationMismatch + ] + handleMLSMessageErrors :: ( r1 ~ Append @@ -599,8 +580,10 @@ sendMLSCommitBundle :: Member ExternalAccess r, Member (Error FederationError) r, Member (Error InternalError) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member (FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input (Maybe GroupInfoCheckEnabled)) r, @@ -635,25 +618,25 @@ sendMLSCommitBundle remoteDomain msr = handleMLSMessageErrors $ do when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch -- this cannot throw the error since we always pass the sender which is qualified to be remote - runInputConst (fromMaybe def msr.enableOutOfSyncCheck) $ - MLSMessageResponseUpdates - . fmap lcuUpdate - <$> mapToRuntimeError @MLSLegalholdIncompatible - (InternalErrorWithDescription "expected group conversation while handling policy conflicts") - ( postMLSCommitBundle - loc - -- Type application to prevent future changes from introducing errors. - -- It is only safe to assume that we can discard the error when the sender - -- is actually remote. - -- Since `tUntagged` works on local and remote, a future changed may - -- go unchecked without this. - (tUntagged @QRemote sender) - msr.senderClient - ctype - qConvOrSub - Nothing - ibundle - ) + MLSMessageResponseUpdates + . fmap lcuUpdate + <$> mapToRuntimeError @MLSLegalholdIncompatible + (InternalErrorWithDescription "expected group conversation while handling policy conflicts") + ( postMLSCommitBundle + loc + -- Type application to prevent future changes from introducing errors. + -- It is only safe to assume that we can discard the error when the sender + -- is actually remote. + -- Since `tUntagged` works on local and remote, a future changed may + -- go unchecked without this. + (tUntagged @QRemote sender) + msr.senderClient + ctype + qConvOrSub + Nothing + (fromMaybe def msr.enableOutOfSyncCheck) + ibundle + ) sendMLSMessage :: ( Member BackendNotificationQueueAccess r, @@ -663,6 +646,9 @@ sendMLSMessage :: Member (Error FederationError) r, Member (Error InternalError) r, Member (FederationAPIAccess FederatorClient) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, @@ -684,16 +670,16 @@ sendMLSMessage remoteDomain msr = handleMLSMessageErrors $ do msg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage raw (ctype, qConvOrSub) <- getConvFromGroupId msg.groupId when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch - runInputConst (fromMaybe def msr.enableOutOfSyncCheck) $ - MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSMessage - loc - (tUntagged sender) - msr.senderClient - ctype - qConvOrSub - Nothing - msg + MLSMessageResponseUpdates . map lcuUpdate + <$> postMLSMessage + loc + (tUntagged sender) + msr.senderClient + ctype + qConvOrSub + Nothing + (fromMaybe def msr.enableOutOfSyncCheck) + msg getSubConversationForRemoteUser :: ( Member E.ConversationStore r, @@ -760,7 +746,7 @@ deleteSubConversationForRemoteUser domain DeleteSubConversationFedRequest {..} = lconv <- qualifyLocal dscreqConv resetLocalSubConversation qusr lconv dscreqSubConv dsc -getOne2OneConversationV1 :: +getLegacyOne2OneConversation :: ( Member (Input (Local ())) r, Member BrigAPIAccess r, Member (Error InvalidInput) r @@ -768,7 +754,7 @@ getOne2OneConversationV1 :: Domain -> GetOne2OneConversationRequest -> Sem r GetOne2OneConversationResponse -getOne2OneConversationV1 domain (GetOne2OneConversationRequest self other) = +getLegacyOne2OneConversation domain (GetOne2OneConversationRequest self other) = fmap (Imports.fromRight GetOne2OneConversationNotConnected) . runError @(Tagged 'NotConnected ()) $ do diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs index 68bf8c32a3d..2d36e8eeb7c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem.Internal (internalGetClientIdsImpl) where +module Wire.ConversationSubsystem.Internal (internalGetClientIds) where import Data.Id import Galley.Types.Clients (Clients, fromUserClients) @@ -27,14 +27,14 @@ import Wire.BrigAPIAccess import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserClientIndexStore qualified as UserClientIndexStore -internalGetClientIdsImpl :: +internalGetClientIds :: ( Member BrigAPIAccess r, Member UserClientIndexStore r, Member (Input ConversationSubsystemConfig) r ) => [UserId] -> Sem r Clients -internalGetClientIdsImpl users = do +internalGetClientIds users = do isInternal <- inputs (.listClientsUsingBrig) if isInternal then fromUserClients <$> lookupClients users diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9a3d9270bc4..672372cf8bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -19,60 +19,80 @@ module Wire.ConversationSubsystem.Interpreter ( interpretConversationSubsystem, + GroupInfoCheckEnabled (..), + IntraListing (..), + ConversationSubsystemError (..), ) where -import Galley.Types.Error (InternalError, InvalidInput (..)) +import Data.Qualified import Imports +import Network.Wai.Utilities.JSONResponse (JSONResponse) import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.Resource (Resource) +import Polysemy.TinyLog (TinyLog) import Wire.API.Conversation.Config import Wire.API.Error -import Wire.API.Error.Galley import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BrigAPIAccess +import Wire.CodeStore (CodeStore) import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem (ConversationSubsystem (..)) +import Wire.ConversationSubsystem.Action.Notify qualified as ActionNotify +import Wire.ConversationSubsystem.Clients as Clients +import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.CreateInternal qualified as CreateInternal +import Wire.ConversationSubsystem.Errors +import Wire.ConversationSubsystem.Federation qualified as Federation import Wire.ConversationSubsystem.Fetch qualified as Fetch -import Wire.ConversationSubsystem.Internal qualified as Internal +import Wire.ConversationSubsystem.MLS qualified as MLS +import Wire.ConversationSubsystem.MLS.Enabled qualified as MLSEnabled +import Wire.ConversationSubsystem.MLS.GroupInfo qualified as MLSGroupInfo +import Wire.ConversationSubsystem.MLS.GroupInfoCheck (GroupInfoCheckEnabled (..)) +import Wire.ConversationSubsystem.MLS.Message qualified as MLSMessage +import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval +import Wire.ConversationSubsystem.MLS.Reset qualified as MLSReset +import Wire.ConversationSubsystem.MLS.SubConversation qualified as MLSSubConversation +import Wire.ConversationSubsystem.Message (IntraListing (..)) import Wire.ConversationSubsystem.Notify qualified as Notify +import Wire.ConversationSubsystem.One2One qualified as One2One +import Wire.ConversationSubsystem.Query qualified as Query +import Wire.ConversationSubsystem.Update qualified as Update import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationSubsystem (FederationSubsystem) +import Wire.FireAndForget (FireAndForget) +import Wire.HashPassword (HashPassword) import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem as NS +import Wire.Options.Galley (GuestLinkTTLSeconds) +import Wire.ProposalStore (ProposalStore) +import Wire.RateLimit (RateLimit) import Wire.Sem.Now (Now) import Wire.Sem.Random (Random) import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamSubsystem (TeamSubsystem) import Wire.UserClientIndexStore (UserClientIndexStore) +import Wire.UserGroupStore (UserGroupStore) interpretConversationSubsystem :: - ( Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'MLSNotEnabled) r, - Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r, - Member (ErrorS HistoryNotSupported) r, + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r, + Member UserGroupStore r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, + Member HashPassword r, + Member RateLimit r, + Member CodeStore r, + Member FireAndForget r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -84,29 +104,235 @@ interpretConversationSubsystem :: Member TeamCollaboratorsSubsystem r, Member Random r, Member TeamSubsystem r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member (Input ConversationSubsystemConfig) r, + Member (Input (Local ())) r, + Member (Input (Maybe GroupInfoCheckEnabled)) r, + Member ProposalStore r, Member LegalHoldStore r, Member TeamStore r, - Member UserClientIndexStore r + Member ConvStore.MLSCommitLockStore r, + Member FederationSubsystem r, + Member Resource r, + Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member UserClientIndexStore r, + Member (Input FanoutLimit) r, + Member TinyLog r ) => - Sem (ConversationSubsystem : r) a -> - Sem r a + InterpreterFor ConversationSubsystem r interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> - Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + InternalCreateGroupConversation lusr conn newConv -> + mapErrors $ CreateInternal.createGroupConversationGeneric lusr conn newConv + CreateLegacyGroupConversation lusr conn newConv -> + mapErrors $ Create.createLegacyGroupConversation lusr conn newConv + CreateGroupOwnConversation lusr conn newConv -> + mapErrors $ Create.createGroupOwnConversation lusr conn newConv CreateGroupConversation lusr conn newConv -> - CreateInternal.createGroupConversationGeneric lusr conn newConv - CreateOne2OneConversation lusr conn newOne2One -> - CreateInternal.createOne2OneConversationLogic lusr conn newOne2One + mapErrors $ Create.createGroupConversation lusr conn newConv CreateProteusSelfConversation lusr -> - CreateInternal.createProteusSelfConversationLogic lusr + mapErrors $ Create.createProteusSelfConversation lusr + CreateOne2OneConversation lusr zcon j -> + mapErrors $ Create.createOne2OneConversation lusr zcon j CreateConnectConversation lusr conn j -> - CreateInternal.createConnectConversationLogic lusr conn j + mapErrors $ Create.createConnectConversation lusr conn j GetConversations convIds -> - ConvStore.getConversations convIds + mapErrors $ ConvStore.getConversations convIds GetConversationIds lusr maxIds pagingState -> - Fetch.getConversationIdsImpl lusr maxIds pagingState - InternalGetClientIds uids -> - Internal.internalGetClientIdsImpl uids + mapErrors $ Fetch.getConversationIdsImpl lusr maxIds pagingState InternalGetLocalMember cid uid -> - ConvStore.getLocalMember cid uid + mapErrors $ ConvStore.getLocalMember cid uid + PostMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle -> + mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle + PostMLSCommitBundleFromLocalUser v lusr c conn bundle -> + mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle + PostMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg -> + mapErrors $ MLSMessage.postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg + PostMLSMessageFromLocalUser v lusr c conn smsg -> + mapErrors $ MLSMessage.postMLSMessageFromLocalUser v lusr c conn smsg + IsMLSEnabled -> + mapErrors $ MLSEnabled.isMLSEnabled + GetConversationsInternal luser mids mstart msize -> + mapErrors $ Query.getConversationsInternal luser mids mstart msize + RemoveMemberFromLocalConv lcnv lusr con victim -> + mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim + FederationOnConversationCreated domain rc -> + mapErrors $ Federation.onConversationCreated domain rc + FederationGetConversations domain req -> + mapErrors $ Federation.getConversations domain req + FederationLeaveConversation domain lc -> + mapErrors $ Federation.leaveConversation domain lc + FederationSendMessage domain msr -> + mapErrors $ Federation.sendMessage domain msr + FederationUpdateConversation domain uc -> + mapErrors $ Federation.updateConversation domain uc + FederationMlsSendWelcome domain req -> + mapErrors $ Federation.mlsSendWelcome domain req + FederationSendMLSMessage domain msr -> + mapErrors $ Federation.sendMLSMessage domain msr + FederationSendMLSCommitBundle domain msr -> + mapErrors $ Federation.sendMLSCommitBundle domain msr + FederationQueryGroupInfo domain req -> + mapErrors $ Federation.queryGroupInfo domain req + FederationUpdateTypingIndicator domain req -> + mapErrors $ Federation.updateTypingIndicator domain req + FederationOnTypingIndicatorUpdated domain td -> + mapErrors $ Federation.onTypingIndicatorUpdated domain td + FederationGetSubConversationForRemoteUser domain req -> + mapErrors $ Federation.getSubConversationForRemoteUser domain req + FederationDeleteSubConversationForRemoteUser domain req -> + mapErrors $ Federation.deleteSubConversationForRemoteUser domain req + FederationLeaveSubConversation domain lscr -> + mapErrors $ Federation.leaveSubConversation domain lscr + FederationGetLegacyOne2OneConversation domain req -> + mapErrors $ Federation.getLegacyOne2OneConversation domain req + FederationGetOne2OneConversation domain req -> + mapErrors $ Federation.getOne2OneConversation domain req + FederationOnClientRemoved domain req -> + mapErrors $ Federation.onClientRemoved domain req + FederationOnMessageSent domain rm -> + mapErrors $ Federation.onMessageSent domain rm + FederationOnMLSMessageSent domain rmm -> + mapErrors $ Federation.onMLSMessageSent domain rmm + FederationOnConversationUpdated domain cu -> + mapErrors $ Federation.onConversationUpdated domain cu + FederationOnUserDeleted domain udcn -> + mapErrors $ Federation.onUserDeleted domain udcn + PostOtrMessageUnqualified lusr con cnv ignore report msg -> + mapErrors $ Update.postOtrMessageUnqualified lusr con cnv ignore report msg + PostOtrBroadcastUnqualified lusr con ignore report msg -> + mapErrors $ Update.postOtrBroadcastUnqualified lusr con ignore report msg + PostProteusMessage lusr con cnv msg -> + mapErrors $ Update.postProteusMessage lusr con cnv msg + PostProteusBroadcast lusr con msg -> + mapErrors $ Update.postProteusBroadcast lusr con msg + DeleteLocalConversation lusr con lcnv -> + mapErrors $ Update.deleteLocalConversation lusr con lcnv + GetMLSPublicKeys fmt -> + mapErrors $ MLS.getMLSPublicKeys fmt + ResetMLSConversation lusr reset -> + mapErrors $ MLSReset.resetMLSConversation lusr reset + GetSubConversation lusr cnv sub -> + mapErrors $ MLSSubConversation.getSubConversation lusr cnv sub + GetBotConversation bid cnv -> + mapErrors $ Query.getBotConversation bid cnv + GetUnqualifiedOwnConversation lusr cnv -> + mapErrors $ Query.getUnqualifiedOwnConversation lusr cnv + GetOwnConversation lusr qcnv -> + mapErrors $ Query.getOwnConversation lusr qcnv + GetConversation lusr qcnv -> + mapErrors $ Query.getConversation lusr qcnv + InternalGetConversation cnv -> + mapErrors $ ConvStore.getConversation cnv + GetConversationRoles lusr cnv -> + mapErrors $ Query.getConversationRoles lusr cnv + GetGroupInfo lusr qcnv -> + mapErrors $ MLSGroupInfo.getGroupInfo lusr qcnv + ConversationIdsPageFromUnqualified lusr mstart msize -> + mapErrors $ Query.conversationIdsPageFromUnqualified lusr mstart msize + ConversationIdsPaginated listGlobalSelf lself req -> + mapErrors $ Query.conversationIdsPaginated listGlobalSelf lself req + ConversationIdsPageFrom lusr req -> + mapErrors $ Query.conversationIdsPageFrom lusr req + ListConversations luser req -> + mapErrors $ Query.listConversations luser req + GetConversationByReusableCode lusr key value -> + mapErrors $ Query.getConversationByReusableCode lusr key value + GetMLSSelfConversationWithError lusr -> + mapErrors $ Query.getMLSSelfConversationWithError lusr + GetMLSOne2OneOwnConversation lself qother -> + mapErrors $ Query.getMLSOne2OneOwnConversation lself qother + GetMLSOne2OneMLSConversation lself qother -> + mapErrors $ Query.getMLSOne2OneMLSConversation lself qother + GetMLSOne2OneConversation lself qother fmt -> + mapErrors $ Query.getMLSOne2OneConversation lself qother fmt + GetLocalSelf lusr cnv -> + mapErrors $ Query.getLocalSelf lusr cnv + GetSelfMember lusr qcnv -> + mapErrors $ Query.getSelfMember lusr qcnv + GetConversationGuestLinksStatus uid cid -> + mapErrors $ Query.getConversationGuestLinksStatus uid cid + GetCode mcode lusr cnv -> + mapErrors $ Update.getCode mcode lusr cnv + AddQualifiedMembersUnqualified lusr con cnv invite -> + mapErrors $ Update.addQualifiedMembersUnqualified lusr con cnv invite + AddMembers lusr zcon qcnv invite -> + mapErrors $ Update.addMembers lusr zcon qcnv invite + ReplaceMembers lusr zcon qcnv invite -> + mapErrors $ Update.replaceMembers lusr zcon qcnv invite + JoinConversationById lusr con cnv -> + mapErrors $ Update.joinConversationById lusr con cnv + JoinConversationByReusableCode lusr con req -> + mapErrors $ Update.joinConversationByReusableCode lusr con req + CheckReusableCode addr code -> + mapErrors $ Update.checkReusableCode addr code + AddCodeUnqualified mReq usr mbZHost mZcon cnv -> + mapErrors $ Update.addCodeUnqualified mReq usr mbZHost mZcon cnv + RmCodeUnqualified lusr con cnv -> + mapErrors $ Update.rmCodeUnqualified lusr con cnv + MemberTyping lusr con qcnv status -> + mapErrors $ Update.memberTyping lusr con qcnv status + RemoveMemberQualified lusr con qcnv quid -> + mapErrors $ Update.removeMemberQualified lusr con qcnv quid + UpdateOtherMember lusr con qcnv quid update -> + mapErrors $ Update.updateOtherMember lusr con qcnv quid update + UpdateConversationName lusr zcon qcnv rename -> + mapErrors $ Update.updateConversationName lusr zcon qcnv rename + UpdateConversationMessageTimer lusr zcon qcnv update -> + mapErrors $ Update.updateConversationMessageTimer lusr zcon qcnv update + UpdateConversationReceiptMode lusr zcon qcnv update -> + mapErrors $ Update.updateConversationReceiptMode lusr zcon qcnv update + UpdateConversationAccess lusr zcon qcnv update -> + mapErrors $ Update.updateConversationAccess lusr zcon qcnv update + UpdateConversationHistory lusr zcon qcnv update -> + mapErrors $ Update.updateConversationHistory lusr zcon qcnv update + UpdateSelfMember lusr zcon qcnv update -> + mapErrors $ Update.updateSelfMember lusr zcon qcnv update + UpdateConversationProtocolWithLocalUser lusr conn qcnv update -> + mapErrors $ Update.updateConversationProtocolWithLocalUser lusr conn qcnv update + UpdateChannelAddPermission lusr conn qcnv update -> + mapErrors $ Update.updateChannelAddPermission lusr conn qcnv update + PostBotMessageUnqualified bid cnv ignore report msg -> + mapErrors $ Update.postBotMessageUnqualified bid cnv ignore report msg + DeleteSubConversation lusr qcnv sub reset -> + mapErrors $ MLSSubConversation.deleteSubConversation lusr qcnv sub reset + GetSubConversationGroupInfo lusr qcnv sub -> + mapErrors $ MLSSubConversation.getSubConversationGroupInfo lusr qcnv sub + LeaveSubConversation lusr cli qcnv sub -> + mapErrors $ MLSSubConversation.leaveSubConversation lusr cli qcnv sub + SendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData -> + mapErrors $ ActionNotify.sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData + GetPaginatedConversations lusr mids mstart msize -> + mapErrors $ Query.getConversations lusr mids mstart msize + SearchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable -> + mapErrors $ Query.searchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable + InternalGetMember qcnv usr -> + mapErrors $ Query.internalGetMember qcnv usr + GetConversationMeta cnv -> + mapErrors $ Query.getConversationMeta cnv + GetMLSOne2OneConversationInternal lself qother -> + mapErrors $ Query.getMLSOne2OneConversationInternal lself qother + IsMLSOne2OneEstablished lself qother -> + mapErrors $ Query.isMLSOne2OneEstablished lself qother + GetLocalConversationInternal cid -> + mapErrors $ Query.getLocalConversationInternal cid + RemoveClient uid cid -> + mapErrors $ Clients.rmClient uid cid + AddBot lusr zcon b -> + mapErrors $ Update.addBot lusr zcon b + RmBot lusr zcon b -> + mapErrors $ Update.rmBot lusr zcon b + UpdateCellsState cnv state -> + mapErrors $ Update.updateCellsState cnv state + RemoveUser lc includeMain qusr -> + mapErrors $ MLSRemoval.removeUser lc includeMain qusr + InternalUpsertOne2OneConversation req -> + mapErrors $ One2One.internalUpsertOne2OneConversation req + AcceptConv lusr conn cnv -> + mapErrors $ Update.acceptConv lusr conn cnv + BlockConv lusr qcnv -> + mapErrors $ Update.blockConv lusr qcnv + UnblockConv lusr conn qcnv -> + mapErrors $ Update.unblockConv lusr conn qcnv diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs similarity index 96% rename from services/galley/src/Galley/API/LegalHold/Conflicts.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs index 23adf1c22bb..0c45f09b645 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.LegalHold.Conflicts +module Wire.ConversationSubsystem.LegalholdConflicts ( guardQualifiedLegalholdPolicyConflicts, guardLegalholdPolicyConflicts, LegalholdConflicts (LegalholdConflicts), @@ -46,7 +46,6 @@ import Wire.API.Team.Member import Wire.API.User import Wire.API.User.Client as Client import Wire.BrigAPIAccess -import Wire.Options.Galley import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.Util @@ -59,7 +58,7 @@ guardQualifiedLegalholdPolicyConflicts :: ( Member BrigAPIAccess r, Member (Error LegalholdConflicts) r, Member (Input (Local ())) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => @@ -83,7 +82,7 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do guardLegalholdPolicyConflicts :: ( Member BrigAPIAccess r, Member (Error LegalholdConflicts) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => @@ -94,7 +93,7 @@ guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClient guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do opts <- input - case view (settings . featureFlags . to npProject) opts of + case view (to npProject) opts of FeatureLegalHoldDisabledPermanently -> case FutureWork @'LegalholdPlusFederationNotImplemented () of FutureWork () -> -- FUTUREWORK: once we support federation and LH in combination, we still need to run @@ -107,7 +106,7 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do -- | Guard notification handling against legal-hold policy conflicts. -- Ensures that if any user has a LH client then no user can be missing consent. -- See also: "Brig.API.Connection.checkLegalholdPolicyConflict" --- and "Galley.API.Action.checkLHPolicyConflictsLocal". +-- and "Wire.ConversationSubsystem.Action.checkLHPolicyConflictsLocal". guardLegalholdPolicyConflictsUid :: forall r. ( Member BrigAPIAccess r, diff --git a/services/galley/src/Galley/API/MLS.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs similarity index 88% rename from services/galley/src/Galley/API/MLS.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs index 8da6d00620c..a8fedb7fd5d 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs @@ -15,28 +15,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS - ( isMLSEnabled, - assertMLSEnabled, - postMLSMessage, - postMLSCommitBundleFromLocalUser, - postMLSMessageFromLocalUser, - getMLSPublicKeys, +module Wire.ConversationSubsystem.MLS + ( getMLSPublicKeys, formatPublicKeys, ) where import Data.Default -import Galley.API.MLS.Enabled -import Galley.API.MLS.Message import Galley.Types.Error import Imports import Polysemy import Polysemy.Error import Polysemy.Input -import Wire.API.Error +import Wire.API.Error (ErrorS) import Wire.API.Error.Galley import Wire.API.MLS.Keys +import Wire.ConversationSubsystem.MLS.Enabled (getMLSPrivateKeys) getMLSPublicKeys :: ( Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, diff --git a/services/galley/src/Galley/API/MLS/CheckClients.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/CheckClients.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs index 22ff3de4813..388d6a16422 100644 --- a/services/galley/src/Galley/API/MLS/CheckClients.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.CheckClients +module Wire.ConversationSubsystem.MLS.CheckClients ( checkClients, getClientData, ClientData (..), @@ -29,7 +29,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra -import Galley.API.MLS.Commit.Core import Imports import Polysemy import Polysemy.Error @@ -43,6 +42,7 @@ import Wire.API.MLS.LeafNode import Wire.API.User.Client import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Commit.Core import Wire.FederationAPIAccess (FederationAPIAccess) checkClients :: diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Commit/Core.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs index 0318881e606..a51f0adcbcd 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.Core +module Wire.ConversationSubsystem.MLS.Commit.Core ( getCommitData, incrementEpoch, getClientInfo, @@ -31,9 +31,6 @@ where import Control.Comonad import Data.Id import Data.Qualified -import Galley.API.MLS.Conversation -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.Proposal import Galley.Types.Error import Imports import Polysemy @@ -66,6 +63,9 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Proposal import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.LegalHoldStore (LegalHoldStore) diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs index 9aec3fa0ea1..10fa4e6bd58 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.ExternalCommit +module Wire.ConversationSubsystem.MLS.Commit.ExternalCommit ( ExternalCommitAction (..), getExternalCommitData, processExternalCommit, @@ -28,11 +28,6 @@ import Control.Monad.Codensity import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.Commit.Core -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.Proposal -import Galley.API.MLS.Removal -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -51,6 +46,11 @@ import Wire.API.MLS.ProposalTag import Wire.API.MLS.SubConversation import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Commit.Core +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Removal +import Wire.ConversationSubsystem.MLS.Util data ExternalCommitAction = ExternalCommitAction { add :: LeafIndex, diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs index 53c51cfa62a..8abc46eefb0 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.InternalCommit (processInternalCommit) where +module Wire.ConversationSubsystem.MLS.Commit.InternalCommit (processInternalCommit) where import Control.Comonad import Control.Error.Util (hush) @@ -29,14 +29,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra -import Galley.API.Action -import Galley.API.MLS.CheckClients -import Galley.API.MLS.Commit.Core -import Galley.API.MLS.Conversation -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.One2One -import Galley.API.MLS.Proposal -import Galley.API.MLS.Util import Galley.Types.Error import Imports import Polysemy @@ -60,7 +52,14 @@ import Wire.API.MLS.SubConversation import Wire.API.Unreachable import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.CheckClients +import Wire.ConversationSubsystem.MLS.Commit.Core +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.FederationSubsystem import Wire.ProposalStore @@ -78,7 +77,6 @@ processInternalCommit :: Member (ErrorS 'MLSIdentityMismatch) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'GroupIdVersionNotSupported) r, - Member ConversationSubsystem r, Member Resource r, Member Random r, Member (ErrorS MLSInvalidLeafNodeSignature) r, @@ -258,7 +256,6 @@ processInternalCommit senderIdentity con lConvOrSub ciphersuite ciphersuiteUpdat addMembers :: ( HasProposalActionEffects r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r ) => @@ -286,7 +283,6 @@ addMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of removeMembers :: ( HasProposalActionEffects r, - Member ConversationSubsystem r, Member TeamSubsystem r ) => Qualified UserId -> diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/Conversation.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs index 0b979880816..b129d31c00e 100644 --- a/services/galley/src/Galley/API/MLS/Conversation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Conversation +module Wire.ConversationSubsystem.MLS.Conversation ( mkMLSConversation, newMLSConversation, mcConv, diff --git a/services/galley/src/Galley/API/MLS/Enabled.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/Enabled.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs index 158d511e291..1910f5945fb 100644 --- a/services/galley/src/Galley/API/MLS/Enabled.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Enabled where +module Wire.ConversationSubsystem.MLS.Enabled where import Imports hiding (getFirst) import Polysemy @@ -25,7 +25,7 @@ import Wire.API.Error.Galley import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) isMLSEnabled :: (Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r) => Sem r Bool -isMLSEnabled = inputs (isJust) +isMLSEnabled = inputs isJust -- | Fail if MLS is not enabled. Only use this function at the beginning of an -- MLS endpoint, NOT in utility functions. diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/GroupInfo.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs index 69f667cab77..f52928307d2 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.GroupInfo +module Wire.ConversationSubsystem.MLS.GroupInfo ( MLSGroupInfoStaticErrors, getGroupInfo, getGroupInfoFromLocalConv, @@ -26,8 +26,6 @@ where import Data.Id as Id import Data.Json.Util import Data.Qualified -import Galley.API.MLS.Enabled -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -42,6 +40,8 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.MLS.SubConversation import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.FederationAPIAccess qualified as E diff --git a/services/galley/src/Galley/API/MLS/GroupInfoCheck.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/GroupInfoCheck.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs index 667a29dc3fe..d3bdabf3e3b 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfoCheck.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.GroupInfoCheck +module Wire.ConversationSubsystem.MLS.GroupInfoCheck ( checkGroupState, GroupInfoMismatch (..), GroupInfoCheckEnabled (..), @@ -24,7 +24,6 @@ where import Data.Bifunctor import Data.Id -import Galley.API.Teams.Features.Get import Imports import Polysemy import Polysemy.Error @@ -43,7 +42,7 @@ import Wire.API.MLS.Serialisation import Wire.API.Team.Feature import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) data GroupInfoMismatch = GroupInfoMismatch {clients :: [(Int, ClientIdentity)]} diff --git a/services/galley/src/Galley/API/MLS/IncomingMessage.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/IncomingMessage.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs index 3a3fba62514..b88c90fbf7d 100644 --- a/services/galley/src/Galley/API/MLS/IncomingMessage.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.IncomingMessage +module Wire.ConversationSubsystem.MLS.IncomingMessage ( IncomingMessage (..), IncomingMessageContent (..), IncomingPublicMessageContent (..), diff --git a/services/galley/src/Galley/API/MLS/Keys.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/Keys.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs index ddafc4e0e2d..b5a84d89f50 100644 --- a/services/galley/src/Galley/API/MLS/Keys.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Keys (getMLSRemovalKey, SomeKeyPair (..)) where +module Wire.ConversationSubsystem.MLS.Keys (getMLSRemovalKey, SomeKeyPair (..)) where import Control.Error.Util (hush) import Data.Proxy diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs similarity index 90% rename from services/galley/src/Galley/API/MLS/Message.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 6425512192b..1059711effd 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -15,17 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Message - ( IncomingBundle (..), - mkIncomingBundle, - IncomingMessage (..), - mkIncomingMessage, +module Wire.ConversationSubsystem.MLS.Message + ( MLSMessageStaticErrors, postMLSCommitBundle, postMLSCommitBundleFromLocalUser, postMLSMessageFromLocalUser, postMLSMessage, - MLSMessageStaticErrors, - MLSBundleStaticErrors, ) where @@ -40,27 +35,11 @@ import Data.Set qualified as Set import Data.Tagged import Data.Text.Lazy qualified as LT import Data.Tuple.Extra -import Galley.API.Action -import Galley.API.LegalHold.Get (getUserStatus) -import Galley.API.MLS.Commit.Core (getCommitData) -import Galley.API.MLS.Commit.ExternalCommit -import Galley.API.MLS.Commit.InternalCommit -import Galley.API.MLS.Conversation -import Galley.API.MLS.Enabled -import Galley.API.MLS.GroupInfoCheck -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.One2One -import Galley.API.MLS.OutOfSync -import Galley.API.MLS.Propagate -import Galley.API.MLS.Proposal -import Galley.API.MLS.Util -import Galley.API.MLS.Welcome (sendWelcomes) import Galley.Types.Error import Imports import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.Internal import Polysemy.Output import Polysemy.Resource (Resource) import Polysemy.TinyLog @@ -88,7 +67,20 @@ import Wire.API.Team.LegalHold import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Commit.Core (getCommitData) +import Wire.ConversationSubsystem.MLS.Commit.ExternalCommit +import Wire.ConversationSubsystem.MLS.Commit.InternalCommit +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.GroupInfoCheck +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.OutOfSync +import Wire.ConversationSubsystem.MLS.Propagate +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.MLS.Welcome (sendWelcomes) import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem @@ -99,7 +91,7 @@ import Wire.Sem.Now qualified as Now import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, getUserStatus) -- FUTUREWORK -- - Check that the capabilities of a leaf node in an add proposal contains all @@ -116,25 +108,12 @@ type MLSMessageStaticErrors = ErrorS 'MLSStaleMessage, ErrorS 'MLSProposalNotFound, ErrorS 'MissingLegalholdConsent, - ErrorS 'MLSInvalidLeafNodeIndex, - ErrorS 'MLSClientMismatch, - ErrorS 'MLSUnsupportedProposal, ErrorS 'MLSCommitMissingReferences, ErrorS 'MLSSelfRemovalNotAllowed, ErrorS 'MLSClientSenderUserMismatch, - ErrorS 'MLSGroupConversationMismatch, ErrorS 'MLSSubConvClientNotInParent ] -type MLSBundleStaticErrors = - Append - MLSMessageStaticErrors - '[ ErrorS 'MLSWelcomeMismatch, - ErrorS 'MLSIdentityMismatch, - ErrorS 'GroupIdVersionNotSupported, - ErrorS 'MLSInvalidLeafNodeSignature - ] - enableOutOfSyncCheckFromVersion :: Version -> EnableOutOfSyncCheck enableOutOfSyncCheckFromVersion v | v < V13 = DisableOutOfSyncCheck @@ -149,7 +128,6 @@ postMLSMessageFromLocalUser :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, @@ -171,9 +149,8 @@ postMLSMessageFromLocalUser v lusr c conn smsg = do imsg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage smsg (ctype, cnvOrSub) <- getConvFromGroupId imsg.groupId events <- - runInputConst (enableOutOfSyncCheckFromVersion v) $ - map lcuEvent - <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) imsg + map lcuEvent + <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) imsg t <- toUTCTimeMillis <$> Now.get pure $ MLSMessageSendingStatus events t @@ -183,13 +160,12 @@ postMLSCommitBundle :: Member (Error GroupInfoDiagnostics) r, Member (Error MLSOutOfSyncError) r, Member (ErrorS GroupIdVersionNotSupported) r, - Member (Input EnableOutOfSyncCheck) r, Member (Input (Maybe GroupInfoCheckEnabled)) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -202,14 +178,16 @@ postMLSCommitBundle :: ConvType -> Qualified ConvOrSubConvId -> Maybe ConnId -> + EnableOutOfSyncCheck -> IncomingBundle -> Sem r [LocalConversationUpdate] -postMLSCommitBundle loc qusr c ctype qConvOrSub conn bundle = - foldQualified - loc - (postMLSCommitBundleToLocalConv qusr c conn bundle ctype) - (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype) - qConvOrSub +postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle = + runInputConst oosCheck $ + foldQualified + loc + (postMLSCommitBundleToLocalConv qusr c conn bundle ctype) + (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype) + qConvOrSub postMLSCommitBundleFromLocalUser :: ( Member (ErrorS MLSLegalholdIncompatible) r, @@ -221,9 +199,9 @@ postMLSCommitBundleFromLocalUser :: Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -242,9 +220,8 @@ postMLSCommitBundleFromLocalUser v lusr c conn bundle = do (ctype, qConvOrSub) <- getConvFromGroupId ibundle.groupId events <- - runInputConst (enableOutOfSyncCheckFromVersion v) $ - map lcuEvent - <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) ibundle + map lcuEvent + <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) ibundle t <- toUTCTimeMillis <$> Now.get pure $ MLSMessageSendingStatus events t @@ -258,9 +235,9 @@ postMLSCommitBundleToLocalConv :: Member (Input (Maybe GroupInfoCheckEnabled)) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -405,7 +382,7 @@ handleGroupInfoMismatch lConvId bundle m = postMLSCommitBundleToRemoteConv :: ( Member BrigAPIAccess r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, Member (Error FederationError) r, Member (Error MLSProtocolError) r, Member (Error MLSProposalFailure) r, @@ -448,7 +425,7 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle ctype rConvOrSubId = do enableOutOfSyncCheck } case resp of - MLSMessageResponseError e -> rethrowErrors @MLSBundleStaticErrors e + MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e MLSMessageResponseProtocolError e -> throw (mlsProtocolError e) MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e) MLSMessageResponseUnreachableBackends ds -> throw (UnreachableBackends (toList ds)) @@ -470,7 +447,6 @@ postMLSMessage :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (ErrorS 'MLSStaleMessage) r, @@ -478,8 +454,7 @@ postMLSMessage :: Member (ErrorS 'MLSSubConvClientNotInParent) r, Member (ErrorS MLSInvalidLeafNodeSignature) r, Member (Error MLSOutOfSyncError) r, - Member (Error GroupInfoDiagnostics) r, - Member (Input EnableOutOfSyncCheck) r + Member (Error GroupInfoDiagnostics) r ) => Local x -> Qualified UserId -> @@ -487,14 +462,16 @@ postMLSMessage :: ConvType -> Qualified ConvOrSubConvId -> Maybe ConnId -> + EnableOutOfSyncCheck -> IncomingMessage -> Sem r [LocalConversationUpdate] -postMLSMessage loc qusr c ctype qconvOrSub con msg = do - foldQualified - loc - (postMLSMessageToLocalConv qusr c con msg ctype) - (postMLSMessageToRemoteConv loc qusr c con msg) - qconvOrSub +postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg = do + runInputConst oosCheck $ + foldQualified + loc + (postMLSMessageToLocalConv qusr c con msg ctype) + (postMLSMessageToRemoteConv loc qusr c con msg) + qconvOrSub getSenderIdentity :: ( Member (ErrorS 'MLSClientSenderUserMismatch) r, diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Migration.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs index 1db5ce29576..0922d1588f2 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Migration where +module Wire.ConversationSubsystem.MLS.Migration where import Data.Qualified import Data.Set qualified as Set diff --git a/services/galley/src/Galley/API/MLS/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/One2One.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs index 3f8550b4b94..2db148d7aae 100644 --- a/services/galley/src/Galley/API/MLS/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.One2One +module Wire.ConversationSubsystem.MLS.One2One ( localMLSOne2OneConversation, localMLSOne2OneConversationAsRemote, localMLSOne2OneConversationMetadata, @@ -65,7 +65,7 @@ localMLSOne2OneConversation lself (tUntagged -> convId) = -- conversation to be returned to a remote backend. localMLSOne2OneConversationAsRemote :: Local ConvId -> - RemoteConversationV2 + RemoteConversationView localMLSOne2OneConversationAsRemote lcnv = let members = RemoteConvMembers @@ -73,7 +73,7 @@ localMLSOne2OneConversationAsRemote lcnv = others = [] } (metadata, mlsData) = localMLSOne2OneConversationMetadata (tUntagged lcnv) - in RemoteConversationV2 + in RemoteConversationView { id = tUnqualified lcnv, metadata = metadata, members = members, diff --git a/services/galley/src/Galley/API/MLS/OutOfSync.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/OutOfSync.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs index 03556f89ade..b9aaceb5bbd 100644 --- a/services/galley/src/Galley/API/MLS/OutOfSync.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.OutOfSync +module Wire.ConversationSubsystem.MLS.OutOfSync ( checkConversationOutOfSync, updateOutOfSyncFlag, ) @@ -25,7 +25,6 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.CheckClients import Imports import Polysemy import Polysemy.Error @@ -39,6 +38,7 @@ import Wire.API.MLS.SubConversation import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.CheckClients import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Propagate.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs index 8e71e7463e3..8445a089f4b 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Propagate where +module Wire.ConversationSubsystem.MLS.Propagate where import Control.Comonad import Data.Id diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/Proposal.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs index fdff658e2ad..712fd32aee4 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Proposal +module Wire.ConversationSubsystem.MLS.Proposal ( -- * Proposal processing derefOrCheckProposal, checkProposal, @@ -38,7 +38,6 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.IncomingMessage import Galley.Types.Error import Imports import Polysemy @@ -67,6 +66,7 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.IncomingMessage import Wire.ExternalAccess import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.LegalHoldStore (LegalHoldStore) diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Removal.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs index fbdc427bbcf..3daa9b661ed 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Removal +module Wire.ConversationSubsystem.MLS.Removal ( createAndSendRemoveProposals, removeExtraneousClients, removeClient, @@ -31,9 +31,6 @@ import Data.Map qualified as Map import Data.Proxy import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.Conversation -import Galley.API.MLS.Keys -import Galley.API.MLS.Propagate import Imports import Polysemy import Polysemy.Error @@ -54,6 +51,9 @@ import Wire.API.MLS.SubConversation import Wire.BackendNotificationQueueAccess import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Keys +import Wire.ConversationSubsystem.MLS.Propagate import Wire.ExternalAccess import Wire.NotificationSubsystem import Wire.ProposalStore diff --git a/services/galley/src/Galley/API/MLS/Reset.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs similarity index 93% rename from services/galley/src/Galley/API/MLS/Reset.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs index 18955e75c1e..0f88ab79699 100644 --- a/services/galley/src/Galley/API/MLS/Reset.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs @@ -15,14 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Reset (resetMLSConversation) where +module Wire.ConversationSubsystem.MLS.Reset (resetMLSConversation) where import Data.Id import Data.Qualified -import Galley.API.Action -import Galley.API.MLS.Enabled -import Galley.API.MLS.Util -import Galley.API.Update import Galley.Types.Error import Imports import Polysemy @@ -42,7 +38,10 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled) +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.Update import Wire.ExternalAccess (ExternalAccess) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.NotificationSubsystem @@ -52,10 +51,8 @@ import Wire.Sem.Random (Random) import Wire.TeamSubsystem (TeamSubsystem) resetMLSConversation :: - ( Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member Now r, + ( Member Now r, Member (Input (Local ())) r, - Member (ErrorS MLSNotEnabled) r, Member (ErrorS MLSStaleMessage) r, Member (ErrorS (ActionDenied LeaveConversation)) r, Member (ErrorS ConvNotFound) r, @@ -63,6 +60,8 @@ resetMLSConversation :: Member (Error InternalError) r, Member (ErrorS InvalidOperation) r, Member (ErrorS MLSFederatedResetNotSupported) r, + Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (ErrorS MLSNotEnabled) r, Member BackendNotificationQueueAccess r, Member ConversationStore r, Member (FederationAPIAccess FederatorClient) r, @@ -70,7 +69,6 @@ resetMLSConversation :: Member (Error FederationError) r, Member BrigAPIAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member ProposalStore r, Member Random r, Member Resource r, diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs similarity index 94% rename from services/galley/src/Galley/API/MLS/SubConversation.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs index a404476e377..14574b31c26 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.SubConversation +module Wire.ConversationSubsystem.MLS.SubConversation ( getSubConversation, getLocalSubConversation, deleteSubConversation, @@ -35,11 +35,6 @@ import Control.Arrow import Control.Monad.Codensity hiding (reset) import Data.Id import Data.Qualified -import Galley.API.MLS -import Galley.API.MLS.Conversation -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.Removal -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -65,6 +60,11 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.BackendNotificationQueueAccess import Wire.ConversationStore qualified as Conversation import Wire.ConversationStore.MLS.Types as Conversation +import Wire.ConversationSubsystem.MLS.Conversation (mkMLSConversation) +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled) +import Wire.ConversationSubsystem.MLS.GroupInfo (getGroupInfoFromRemoteConv) +import Wire.ConversationSubsystem.MLS.Removal (createAndSendRemoveProposals) +import Wire.ConversationSubsystem.MLS.Util (getLocalConvForUser, withCommitLock) import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.FederationAPIAccess @@ -169,10 +169,12 @@ getSubConversationGroupInfo :: '[ Conversation.ConversationStore, Error FederationError, FederationAPIAccess FederatorClient, - Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)) + Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)), + ErrorS 'MLSNotEnabled, + ErrorS 'ConvNotFound, + ErrorS 'MLSMissingGroupInfo ] - r, - Members MLSGroupInfoStaticErrors r + r ) => Local UserId -> Qualified ConvId -> @@ -187,8 +189,10 @@ getSubConversationGroupInfo lusr qcnvId subconv = do qcnvId getSubConversationGroupInfoFromLocalConv :: - (Member Conversation.ConversationStore r) => - (Members MLSGroupInfoStaticErrors r) => + ( Member Conversation.ConversationStore r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'MLSMissingGroupInfo) r + ) => Qualified UserId -> SubConvId -> Local ConvId -> diff --git a/services/galley/src/Galley/API/MLS/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Util.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs index 742f820b1bb..814603f64ff 100644 --- a/services/galley/src/Galley/API/MLS/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Util where +module Wire.ConversationSubsystem.MLS.Util where import Control.Comonad import Control.Monad.Codensity diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/Welcome.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs index 44484dda0a5..b16bb87e1af 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Welcome +module Wire.ConversationSubsystem.MLS.Welcome ( sendWelcomes, sendLocalWelcomes, ) diff --git a/services/galley/src/Galley/API/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs similarity index 97% rename from services/galley/src/Galley/API/Message.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs index ff384a45fe9..214bdcf6ed8 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Message +module Wire.ConversationSubsystem.Message ( UserType (..), sendLocalMessages, postQualifiedOtrMessage, @@ -24,6 +24,7 @@ module Galley.API.Message legacyClientMismatchStrategy, Unqualify (..), MessageMetadata (..), + IntraListing (..), -- * Only exported for tests checkMessageClients, @@ -48,7 +49,6 @@ import Data.Range import Data.Set qualified as Set import Data.Set.Lens import Data.Time.Clock (UTCTime) -import Galley.API.LegalHold.Conflicts import Galley.Types.Clients qualified as Clients import Imports hiding (forkIO) import Network.AMQP qualified as Q @@ -57,6 +57,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class qualified as Log +import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley @@ -68,7 +69,7 @@ import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Message import Wire.API.Routes.Public.Galley.Messaging -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.API.Team.LegalHold import Wire.API.Team.Member import Wire.API.User.Client @@ -76,22 +77,26 @@ import Wire.API.UserMap (UserMap (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore -import Wire.ConversationSubsystem qualified as ConvSubsystem +import Wire.ConversationSubsystem.Internal qualified as ConvSubsystem +import Wire.ConversationSubsystem.LegalholdConflicts import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.NotificationSubsystem (BotMap, NotificationSubsystem, newMessagePush, runMessagePush) -import Wire.Options.Galley import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.StoredConversation import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, getTeamMembersForFanout) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore data UserType = User | Bot -- FUTUREWORK: there is UserType in Wire.API.User now, should we use that? (there is also UserType variant for searcho/contacts, but there is a good reason for that one.) +newtype IntraListing + = IntraListing {unIntraListing :: Bool} + deriving stock (Eq, Ord, Show) + userToProtectee :: UserType -> UserId -> LegalholdProtectee userToProtectee User user = ProtectedUser user userToProtectee Bot _ = UnprotectedBot @@ -259,14 +264,15 @@ postBroadcast :: Member (ErrorS 'NonBindingTeam) r, Member (ErrorS 'BroadcastLimitExceeded) r, Member ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member P.TinyLog r, Member NotificationSubsystem r, Member (Input FanoutLimit) r, + Member (Input ConversationSubsystemConfig) r, Member TeamSubsystem r, - Member ConvSubsystem.ConversationSubsystem r + Member UserClientIndexStore r ) => Local UserId -> Maybe ConnId -> @@ -354,7 +360,6 @@ postBroadcast lusr con msg = runError $ do maybeFetchAllMembersInTeam :: ( Member (ErrorS 'BroadcastLimitExceeded) r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -372,7 +377,8 @@ postQualifiedOtrMessage :: Member (FederationAPIAccess FederatorClient) r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member (Input Opts) r, + Member (Input IntraListing) r, + Member (Input FeatureFlags) r, Member Now r, Member P.TinyLog r, Member NotificationSubsystem r, @@ -411,7 +417,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = Set.fromList $ map (tUntagged . qualifyAs lcnv) localMemberIds <> map (tUntagged . (.id_)) conv.remoteMembers - isInternal <- view (settings . intraListing) <$> input + IntraListing isInternal <- input -- check if the sender is part of the conversation unless (Set.member sender members) $ @@ -533,7 +539,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = guardQualifiedLegalholdPolicyConflictsWrapper :: ( Member BrigAPIAccess r, Member (Error (MessageNotSent MessageSendingStatus)) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs index afe039381b8..a73b430d57b 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs @@ -19,7 +19,7 @@ module Wire.ConversationSubsystem.One2One ( one2OneConvId, - iUpsertOne2OneConversation, + internalUpsertOne2OneConversation, ) where @@ -51,12 +51,12 @@ newConnectConversationWithRemote creator users = groupId = Nothing } -iUpsertOne2OneConversation :: +internalUpsertOne2OneConversation :: forall r. (Member ConversationStore r) => UpsertOne2OneConversationRequest -> Sem r () -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do +internalUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let dolocal :: Local ConvId -> Sem r () dolocal lconvId = do mbConv <- getConversation (tUnqualified lconvId) diff --git a/services/galley/src/Galley/API/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs similarity index 94% rename from services/galley/src/Galley/API/Query.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 201b7572bd3..ce8009d45bd 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Query +module Wire.ConversationSubsystem.Query ( getBotConversation, getUnqualifiedOwnConversation, getOwnConversation, @@ -27,9 +27,10 @@ module Galley.API.Query getLocalConversationInternal, getConversationRoles, conversationIdsPageFromUnqualified, - conversationIdsPageFromV2, + conversationIdsPaginated, conversationIdsPageFrom, getConversations, + getConversationsInternal, listConversations, iterateConversations, getLocalSelf, @@ -42,8 +43,8 @@ module Galley.API.Query ensureConvAdmin, getMLSSelfConversation, getMLSSelfConversationWithError, - getMLSOne2OneConversationV5, - getMLSOne2OneConversationV6, + getMLSOne2OneOwnConversation, + getMLSOne2OneMLSConversation, getMLSOne2OneConversationInternal, getMLSOne2OneConversation, isMLSOne2OneEstablished, @@ -66,12 +67,6 @@ import Data.Qualified import Data.Range import Data.Set qualified as Set import Data.Tagged -import Galley.API.MLS -import Galley.API.MLS.Enabled -import Galley.API.MLS.One2One -import Galley.API.Mapping -import Galley.API.Mapping qualified as Mapping -import Galley.API.Teams.Features.Get import Galley.Types.Error import Imports import Polysemy @@ -107,7 +102,10 @@ import Wire.CodeStore.Code (Code (codeConversation)) import Wire.CodeStore.Code qualified as Data import Wire.ConversationStore qualified as ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Fetch (getConversationIdsImpl) +import Wire.ConversationSubsystem.MLS +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled, getMLSPrivateKeys, isMLSEnabled) +import Wire.ConversationSubsystem.MLS.One2One (localMLSOne2OneConversation, remoteMLSOne2OneConversation) import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem @@ -119,7 +117,7 @@ import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList import Wire.Util @@ -162,7 +160,7 @@ getUnqualifiedOwnConversation :: Sem r Public.OwnConversation getUnqualifiedOwnConversation lusr cnv = do c <- getConversationAsMember (tUntagged lusr) (qualifyAs lusr cnv) - Mapping.conversationViewV9 lusr c + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr c getUnqualifiedConversation :: forall r. @@ -175,7 +173,7 @@ getUnqualifiedConversation :: ConvId -> Sem r Public.Conversation getUnqualifiedConversation lusr cnv = - Mapping.conversationView (qualifyAs lusr ()) (Just lusr) . (.conv) + conversationView (qualifyAs lusr ()) (Just lusr) . (.conv) <$> getConversationAsViewer (tUntagged lusr) (qualifyAs lusr cnv) getConversation :: @@ -318,9 +316,9 @@ getRemoteConversationsWithFailures :: getRemoteConversationsWithFailures lusr convs = do -- get self member statuses from the database statusMap <- ConversationStore.getRemoteConversationStatus (tUnqualified lusr) convs - let remoteView :: Remote RemoteConversationV2 -> OwnConversation + let remoteView :: Remote RemoteConversationView -> OwnConversation remoteView rconv = - Mapping.remoteConversationView + remoteConversationView lusr ( Map.findWithDefault defMemberStatus @@ -334,14 +332,14 @@ getRemoteConversationsWithFailures lusr convs = do | otherwise = [failedGetConversationLocally (map tUntagged locallyNotFound)] -- request conversations from remote backends - let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetConversationsResponseV2 + let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetRemoteConversationViewsResponse rpc req = do mFedVersion <- getNegotiatedVersion case mFedVersion of Nothing -> error "impossible" Just fedVersion -> if fedVersion < Federation.V2 - then getConversationsResponseToV2 <$> fedClient @'Galley @"get-conversations@v1" req + then getConversationsResponseToView <$> fedClient @'Galley @"get-conversations@v1" req else fedClient @'Galley @"get-conversations" req resp <- E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> @@ -352,8 +350,8 @@ getRemoteConversationsWithFailures lusr convs = do where handleFailure :: (Member P.TinyLog r) => - Either (Remote [ConvId], FederationError) (Remote GetConversationsResponseV2) -> - Sem r (Either FailedGetConversation [Remote RemoteConversationV2]) + Either (Remote [ConvId], FederationError) (Remote GetRemoteConversationViewsResponse) -> + Sem r (Either FailedGetConversation [Remote RemoteConversationView]) handleFailure (Left (rcids, e)) = do P.warn $ Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) @@ -401,14 +399,14 @@ conversationIdsPageFromUnqualified lusr start msize = do -- -- FUTUREWORK: Move the body of this function to 'conversationIdsPageFrom' once -- support for V2 is dropped. -conversationIdsPageFromV2 :: - (Member ConversationSubsystem.ConversationSubsystem r) => +conversationIdsPaginated :: + (Member ConversationStore.ConversationStore r) => ListGlobalSelfConvs -> Local UserId -> Public.GetPaginatedConversationIds -> Sem r Public.ConvIdsPage -conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do - filterOut <$> ConversationSubsystem.getConversationIds lusr gmtprSize gmtprState +conversationIdsPaginated listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do + filterOut <$> getConversationIdsImpl lusr gmtprSize gmtprState where -- MLS self-conversation of this user selfConvId = mlsSelfConvId (tUnqualified lusr) @@ -437,9 +435,8 @@ conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {. conversationIdsPageFrom :: forall r. ( Member ConversationStore.ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -455,7 +452,7 @@ conversationIdsPageFrom lusr state = do -- returned or attempted to be created; in that case we skip anything related -- to it. whenM isMLSEnabled $ void $ getMLSSelfConversation lusr - conversationIdsPageFromV2 ListGlobalSelf lusr state + conversationIdsPaginated ListGlobalSelf lusr state getConversations :: ( Member (Error InternalError) r, @@ -469,7 +466,8 @@ getConversations :: Sem r (Public.ConversationList Public.OwnConversation) getConversations luser mids mstart msize = do ConversationList cs more <- getConversationsInternal luser mids mstart msize - flip ConversationList more <$> mapM (Mapping.conversationViewV9 luser) cs + ownConvs <- for cs (\c -> maybe (throwIfNotOwnConversation luser c.id_) pure $ ownConversationView luser c) + pure $ ConversationList ownConvs more getConversationsInternal :: (Member ConversationStore.ConversationStore r) => @@ -520,7 +518,10 @@ listConversations luser (Public.ListConversations ids) = do localInternalConversations <- ConversationStore.getConversations foundLocalIds >>= filterM (\c -> pure $ isMember (tUnqualified luser) c.localMembers) - localConversations <- mapM (Mapping.conversationViewV9 luser) localInternalConversations + localConversations <- + mapM + (\c -> maybe (throwIfNotOwnConversation luser c.id_) pure (ownConversationView luser c)) + localInternalConversations (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures @@ -711,9 +712,9 @@ getConversationGuestLinksFeatureStatus (Just tid) = getFeatureForTeam tid getMLSSelfConversationWithError :: forall r. ( Member ConversationStore.ConversationStore r, - Member (Error InternalError) r, - Member (ErrorS 'MLSNotEnabled) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (ErrorS MLSNotEnabled) r, + Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -740,7 +741,7 @@ getMLSSelfConversation lusr = do let selfConvId = mlsSelfConvId . tUnqualified $ lusr mconv <- ConversationStore.getConversation selfConvId cnv <- maybe (createMLSSelfConversation lusr) pure mconv - conversationViewV9 lusr cnv + maybe (throwIfNotOwnConversation lusr cnv.id_) pure $ ownConversationView lusr cnv createMLSSelfConversation :: (Member ConversationStore.ConversationStore r) => @@ -767,7 +768,7 @@ createMLSSelfConversation lusr = do -- uses the same function to calculate the conversation ID and corresponding -- group ID, however we /do/ assume that the two backends agree on which of the -- two is responsible for hosting the conversation. -getMLSOne2OneConversationV5 :: +getMLSOne2OneOwnConversation :: ( Member BrigAPIAccess r, Member ConversationStore.ConversationStore r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, @@ -785,7 +786,7 @@ getMLSOne2OneConversationV5 :: Local UserId -> Qualified UserId -> Sem r OwnConversation -getMLSOne2OneConversationV5 lself qother = do +getMLSOne2OneOwnConversation lself qother = do if isLocal lself qother then getMLSOne2OneConversationInternal lself qother else throwS @MLSFederatedOne2OneNotSupported @@ -811,7 +812,7 @@ getMLSOne2OneConversationInternal :: getMLSOne2OneConversationInternal lself qother = (.conversation) <$> getMLSOne2OneConversation lself qother Nothing -getMLSOne2OneConversationV6 :: +getMLSOne2OneMLSConversation :: forall r. ( Member BrigAPIAccess r, Member ConversationStore.ConversationStore r, @@ -829,7 +830,7 @@ getMLSOne2OneConversationV6 :: Local UserId -> Qualified UserId -> Sem r (MLSOne2OneConversation MLSPublicKey) -getMLSOne2OneConversationV6 lself qother = do +getMLSOne2OneMLSConversation lself qother = do assertMLSEnabled ensureConnectedOrSameTeam lself [qother] let convId = one2OneConvId BaseProtocolMLSTag (tUntagged lself) qother @@ -858,16 +859,16 @@ getMLSOne2OneConversation :: Maybe MLSPublicKeyFormat -> Sem r (MLSOne2OneConversation SomeKey) getMLSOne2OneConversation lself qother fmt = do - convWithUnformattedKeys <- getMLSOne2OneConversationV6 lself qother + convWithUnformattedKeys <- getMLSOne2OneMLSConversation lself qother MLSOne2OneConversation convWithUnformattedKeys.conversation <$> formatPublicKeys fmt convWithUnformattedKeys.publicKeys getLocalMLSOne2OneConversation :: ( Member ConversationStore.ConversationStore r, - Member (Error InternalError) r, - Member P.TinyLog r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member (ErrorS MLSNotEnabled) r + Member (ErrorS MLSNotEnabled) r, + Member (Error InternalError) r, + Member P.TinyLog r ) => Local UserId -> Local ConvId -> @@ -877,7 +878,7 @@ getLocalMLSOne2OneConversation lself lconv = do keys <- mlsKeysToPublic <$$> getMLSPrivateKeys conv <- case mconv of Nothing -> pure (localMLSOne2OneConversation lself lconv) - Just conv -> conversationViewV9 lself conv + Just conv -> maybe (throwIfNotOwnConversation lself conv.id_) pure $ ownConversationView lself conv pure $ MLSOne2OneConversation { conversation = conv, diff --git a/services/galley/src/Galley/API/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs similarity index 86% rename from services/galley/src/Galley/API/Update.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 66a7d0030e9..96a798aeca3 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Update +module Wire.ConversationSubsystem.Update ( -- * Managing Conversations acceptConv, blockConv, @@ -29,16 +29,11 @@ module Galley.API.Update joinConversationByReusableCode, joinConversationById, addCodeUnqualified, - addCodeUnqualifiedWithReqBody, rmCodeUnqualified, getCode, - updateUnqualifiedConversationName, updateConversationName, - updateConversationReceiptModeUnqualified, updateConversationReceiptMode, - updateConversationMessageTimerUnqualified, updateConversationMessageTimer, - updateConversationAccessUnqualified, updateConversationAccess, updateConversationHistory, updateChannelAddPermission, @@ -49,16 +44,12 @@ module Galley.API.Update updateCellsState, -- * Managing Members - addMembersUnqualified, - addMembersUnqualifiedV2, + addQualifiedMembersUnqualified, addMembers, replaceMembers, - updateUnqualifiedSelfMember, updateSelfMember, updateOtherMember, - updateOtherMemberUnqualified, removeMemberQualified, - removeMemberUnqualified, removeMemberFromLocalConv, removeMemberFromRemoteConv, @@ -67,7 +58,6 @@ module Galley.API.Update postOtrMessageUnqualified, postProteusBroadcast, postOtrBroadcastUnqualified, - memberTypingUnqualified, memberTyping, -- * External Services @@ -90,13 +80,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Singletons import Data.Vector qualified as V -import Galley.API.Action -import Galley.API.Action.Kick (kickMember) -import Galley.API.Mapping -import Galley.API.Message -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features.Get -import Galley.App import Galley.Types.Error import Imports hiding (forkIO) import Polysemy @@ -126,7 +109,7 @@ import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.Feature -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.API.Team.Member import Wire.API.User.Client import Wire.API.UserGroup @@ -137,7 +120,10 @@ import Wire.CodeStore qualified as E import Wire.CodeStore.Code import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.Action.Kick (kickMember) +import Wire.ConversationSubsystem.Message +import Wire.ConversationSubsystem.Query qualified as Query import Wire.ConversationSubsystem.Util import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem @@ -156,7 +142,7 @@ import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore qualified as E import Wire.UserGroupStore (UserGroupStore, getUserGroupsForConv) @@ -180,7 +166,7 @@ acceptConv lusr conn cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound conv' <- acceptOne2One lusr conv conn - conversationViewV9 lusr conv' + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr conv' blockConv :: ( Member ConversationStore r, @@ -262,7 +248,7 @@ unblockConvUnqualified lusr conn cnv = do unless (convType conv `elem` [ConnectConv, One2OneConv]) $ throwS @'InvalidOperation conv' <- acceptOne2One lusr conv conn - conversationViewV9 lusr conv' + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr conv' unblockRemoteConv :: (Member ConversationStore r) => @@ -291,8 +277,6 @@ type UpdateConversationAccessEffects = E.FederationAPIAccess FederatorClient, FireAndForget, NotificationSubsystem, - ConversationSubsystem, - Input Env, Input ConversationSubsystemConfig, ProposalStore, Random, @@ -322,7 +306,10 @@ updateConversationHistory :: Member (ErrorS ConvNotFound) r, Member (ErrorS HistoryNotSupported) r, Member ConversationStore r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -339,24 +326,6 @@ updateConversationHistory lusr con qcnv update = do (Just con) update.history -updateConversationAccessUnqualified :: - ( Members UpdateConversationAccessEffects r, - Member Now r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationAccessData -> - Sem r (UpdateResult Event) -updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap lcuEvent $ - updateLocalConversationAccessData - (qualifyAs lusr cnv) - (tUntagged lusr) - (Just con) - update - updateConversationReceiptMode :: ( Member BrigAPIAccess r, Member ConversationStore r, @@ -367,9 +336,10 @@ updateConversationReceiptMode :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'MLSReadReceiptsNotAllowed) r, Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member TeamSubsystem r @@ -434,37 +404,16 @@ updateRemoteConversation rcnv lusr mconn action = getUpdateResult $ do ConversationUpdateResponseUnreachableBackends e -> throw e updateLocalStateOfRemoteConv (qualifyAs rcnv convUpdate) mconn >>= note NoChanges -updateConversationReceiptModeUnqualified :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (ErrorS ('ActionDenied 'ModifyConversationReceiptMode)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'MLSReadReceiptsNotAllowed) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member TinyLog r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationReceiptModeUpdate -> - Sem r (UpdateResult Event) -updateConversationReceiptModeUnqualified lusr zcon cnv = updateConversationReceiptMode lusr zcon (tUntagged (qualifyAs lusr cnv)) - updateConversationMessageTimer :: ( Member ConversationStore r, Member (ErrorS ('ActionDenied 'ModifyConversationMessageTimer)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r ) => Local UserId -> @@ -487,22 +436,6 @@ updateConversationMessageTimer lusr zcon qcnv update = (\_ -> throw FederationNotImplemented) qcnv -updateConversationMessageTimerUnqualified :: - ( Member ConversationStore r, - Member (ErrorS ('ActionDenied 'ModifyConversationMessageTimer)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (Error FederationError) r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationMessageTimerUpdate -> - Sem r (UpdateResult Event) -updateConversationMessageTimerUnqualified lusr zcon cnv = updateConversationMessageTimer lusr zcon (tUntagged (qualifyAs lusr cnv)) - deleteLocalConversation :: ( Member CodeStore r, Member ConversationStore r, @@ -511,7 +444,10 @@ deleteLocalConversation :: Member (ErrorS ('ActionDenied 'DeleteConversation)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member ProposalStore r, Member TeamSubsystem r ) => @@ -523,32 +459,6 @@ deleteLocalConversation lusr con lcnv = getUpdateResult . fmap lcuEvent $ updateLocalConversationDelete lcnv (tUntagged lusr) (Just con) -addCodeUnqualifiedWithReqBody :: - forall r. - ( Member CodeStore r, - Member ConversationStore r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'GuestLinksDisabled) r, - Member (ErrorS 'CreateConversationCodeConflict) r, - Member E.ExternalAccess r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member HashPassword r, - Member (Input Opts) r, - Member FeaturesConfigSubsystem r, - Member RateLimit r, - Member TeamSubsystem r - ) => - UserId -> - Maybe Text -> - Maybe ConnId -> - ConvId -> - CreateConversationCodeRequest -> - Sem r AddCodeResult -addCodeUnqualifiedWithReqBody usr mbZHost mZcon cnv req = addCodeUnqualified (Just req) usr mbZHost mZcon cnv - addCodeUnqualified :: forall r. ( Member CodeStore r, @@ -561,7 +471,7 @@ addCodeUnqualified :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member HashPassword r, Member FeaturesConfigSubsystem r, Member RateLimit r, @@ -590,7 +500,7 @@ addCode :: Member HashPassword r, Member NotificationSubsystem r, Member Now r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member FeaturesConfigSubsystem r, Member RateLimit r, Member TeamSubsystem r @@ -612,7 +522,7 @@ addCode lusr mbZHost mZcon lcnv mReq = do key <- E.makeKey (tUnqualified lcnv) E.getCode key >>= \case Nothing -> do - ttl <- realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds . view (settings . guestLinkTTLSeconds) <$> input + ttl <- inputs (realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds) code <- E.generateCode (tUnqualified lcnv) (Timeout ttl) mPw <- for (mReq >>= (.password)) $ HashPassword.hashPassword8 (RateLimitUser (tUnqualified lusr)) E.createCode code mPw @@ -742,7 +652,6 @@ updateConversationProtocolWithLocalUser :: Member ConversationStore r, Member TinyLog r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member Random r, @@ -780,8 +689,9 @@ updateChannelAddPermission :: Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member (Error NonFederatingBackends) r, @@ -824,11 +734,15 @@ joinConversationByReusableCode :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, Member FeaturesConfigSubsystem r, Member HashPassword r, Member RateLimit r, Member TeamSubsystem r, + Member Now r, Member (Input ConversationSubsystemConfig) r ) => Local UserId -> @@ -850,8 +764,12 @@ joinConversationById :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, Member (Input ConversationSubsystemConfig) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -869,9 +787,13 @@ joinConversation :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, Member (Input ConversationSubsystemConfig) r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, Member ConversationStore r, + Member Now r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -927,7 +849,6 @@ addMembers :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -962,7 +883,7 @@ addMembers lusr zcon qcnv (InviteQualified users role) = do getUpdateResult . fmap lcuEvent $ updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) action -addMembersUnqualifiedV2 :: +addQualifiedMembersUnqualified :: ( Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, Member ConversationStore r, @@ -979,7 +900,6 @@ addMembersUnqualifiedV2 :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -997,51 +917,12 @@ addMembersUnqualifiedV2 :: ConvId -> InviteQualified -> Sem r (UpdateResult Event) -addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do +addQualifiedMembersUnqualified lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv getUpdateResult . fmap lcuEvent $ updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role def -addMembersUnqualified :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'AddConversationMember)) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TooManyMembers) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'GroupIdVersionNotSupported) r, - Member (Error UnreachableBackends) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, - Member NotificationSubsystem r, - Member Now r, - Member LegalHoldStore r, - Member ProposalStore r, - Member Random r, - Member TeamStore r, - Member TinyLog r, - Member TeamCollaboratorsSubsystem r, - Member FederationSubsystem r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - ConnId -> - ConvId -> - Invite -> - Sem r (UpdateResult Event) -addMembersUnqualified lusr zcon cnv (Invite users role) = do - let qusers = fmap (tUntagged . qualifyAs lusr) users - addMembers lusr zcon (tUntagged (qualifyAs lusr cnv)) (InviteQualified qusers role) - -- | Replace conversation members by computing the difference between desired and -- current members, then executing removals followed by additions within a commit -- lock. @@ -1073,7 +954,6 @@ replaceMembers :: Member TinyLog r, Member TeamCollaboratorsSubsystem r, Member UserGroupStore r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r @@ -1177,22 +1057,6 @@ updateSelfMember lusr zcon qcnv update = do misConvRoleName = Nothing } -updateUnqualifiedSelfMember :: - ( Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r, - Member E.ExternalAccess r, - Member NotificationSubsystem r, - Member Now r - ) => - Local UserId -> - ConnId -> - ConvId -> - MemberUpdate -> - Sem r () -updateUnqualifiedSelfMember lusr zcon cnv update = do - let lcnv = qualifyAs lusr cnv - updateSelfMember lusr zcon (tUntagged lcnv) update - updateOtherMemberLocalConv :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1201,7 +1065,10 @@ updateOtherMemberLocalConv :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local ConvId -> @@ -1216,28 +1083,6 @@ updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult updateLocalConversationMemberUpdate lcnv (tUntagged lusr) (Just con) $ ConversationMemberUpdate qvictim update -updateOtherMemberUnqualified :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, - Member (ErrorS 'InvalidTarget) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - UserId -> - OtherMemberUpdate -> - Sem r () -updateOtherMemberUnqualified lusr zcon cnv victim update = do - let lcnv = qualifyAs lusr cnv - let lvictim = qualifyAs lusr victim - updateOtherMemberLocalConv lcnv lusr zcon (tUntagged lvictim) update - updateOtherMember :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1246,7 +1091,10 @@ updateOtherMember :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -1269,34 +1117,6 @@ updateOtherMemberRemoteConv :: Sem r () updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented -removeMemberUnqualified :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member ConversationSubsystem r, - Member Now r, - Member ProposalStore r, - Member Random r, - Member TinyLog r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - ConnId -> - ConvId -> - UserId -> - Sem r (Maybe Event) -removeMemberUnqualified lusr con cnv victim = do - let lvictim = qualifyAs lusr victim - lcnv = qualifyAs lusr cnv - removeMemberQualified lusr con (tUntagged lcnv) (tUntagged lvictim) - removeMemberQualified :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, @@ -1307,7 +1127,6 @@ removeMemberQualified :: Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1382,7 +1201,6 @@ removeMemberFromLocalConv :: Member (ErrorS 'InvalidOperation) r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1425,7 +1243,6 @@ removeMemberFromChannel :: Member Now r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Random r, Member TinyLog r, Member (Error FederationError) r, @@ -1462,7 +1279,8 @@ postProteusMessage :: Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member Now r, Member TinyLog r, Member TeamSubsystem r @@ -1486,13 +1304,14 @@ postProteusBroadcast :: Member (ErrorS 'BroadcastLimitExceeded) r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member TinyLog r, Member (Input FanoutLimit) r, Member TeamSubsystem r, - Member ConversationSubsystem r + Member (Input ConversationSubsystemConfig) r, + Member E.UserClientIndexStore r ) => Local UserId -> ConnId -> @@ -1540,7 +1359,8 @@ postBotMessageUnqualified :: Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member TinyLog r, Member Now r, Member TeamSubsystem r @@ -1568,13 +1388,14 @@ postOtrBroadcastUnqualified :: Member (ErrorS 'BroadcastLimitExceeded) r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member TinyLog r, Member (Input FanoutLimit) r, Member TeamSubsystem r, - Member ConversationSubsystem r + Member (Input ConversationSubsystemConfig) r, + Member E.UserClientIndexStore r ) => Local UserId -> ConnId -> @@ -1595,7 +1416,8 @@ postOtrMessageUnqualified :: Member BackendNotificationQueueAccess r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member Now r, Member TinyLog r, Member TeamSubsystem r @@ -1620,7 +1442,10 @@ updateConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -1636,25 +1461,6 @@ updateConversationName lusr zcon qcnv convRename = do qcnv convRename -updateUnqualifiedConversationName :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InvalidInput) r, - Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationRename -> - Sem r (UpdateResult Event) -updateUnqualifiedConversationName lusr zcon cnv rename = do - let lcnv = qualifyAs lusr cnv - updateLocalConversationName lusr zcon lcnv rename - updateLocalConversationName :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1662,7 +1468,10 @@ updateLocalConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -1713,25 +1522,6 @@ memberTyping lusr zcon qcnv ts = do ) qcnv -memberTypingUnqualified :: - ( Member NotificationSubsystem r, - Member (ErrorS 'ConvNotFound) r, - Member (Input (Local ())) r, - Member Now r, - Member ConversationStore r, - Member (E.FederationAPIAccess FederatorClient) r, - Member (Error FederationError) r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - TypingStatus -> - Sem r () -memberTypingUnqualified lusr zcon cnv ts = do - lcnv <- qualifyLocal cnv - memberTyping lusr zcon (tUntagged lcnv) ts - addBot :: forall r. ( Member E.UserClientIndexStore r, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 16f70e955ca..78d70193979 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -24,7 +24,6 @@ import Control.Lens (view, (^.)) import Control.Monad.Extra (allM, anyM) import Control.Monad.Trans.Maybe import Data.Bifunctor -import Data.Code qualified as Code import Data.Default import Data.Domain (Domain) import Data.Id as Id @@ -34,7 +33,7 @@ import Data.List.Extra (chunksOf, nubOrd) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map -import Data.Misc (PlainTextPassword6, PlainTextPassword8) +import Data.Misc (PlainTextPassword8) import Data.Qualified import Data.Set qualified as Set import Data.Singletons @@ -42,11 +41,14 @@ import Data.Text qualified as T import Data.Time import Galley.Types.Conversations.Roles import Galley.Types.Error -import Imports hiding (forkIO) +import Imports import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -71,10 +73,8 @@ import Wire.API.Team.Collaborator qualified as CollaboratorPermission (Collabora import Wire.API.Team.FeatureFlags import Wire.API.Team.Member import Wire.API.Team.Member qualified as Mem -import Wire.API.Team.Member.Error import Wire.API.Team.Role import Wire.API.User hiding (userId) -import Wire.API.User.Auth.ReAuth import Wire.API.VersionInfo import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess @@ -94,10 +94,19 @@ import Wire.Sem.Now qualified as Now import Wire.StoredConversation as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven, getLHStatus) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList +throwIfNotOwnConversation :: (Member TinyLog r, Member (Error InternalError) r) => Local UserId -> ConvId -> Sem r a +throwIfNotOwnConversation luid cid = do + P.err . msg $ + val "User " + +++ idToText (tUnqualified luid) + +++ val " is not a member of conv " + +++ idToText cid + throw BadMemberState + data NoChanges = NoChanges ensureAccessRole :: @@ -195,20 +204,6 @@ ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: - ( Member (ErrorS 'NotConnected) r, - Member BrigAPIAccess r - ) => - UserId -> - [UserId] -> - Sem r () -ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do - (connsFrom, connsTo) <- - getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) - unless (length connsFrom == length uids && length connsTo == length uids) $ - throwS @'NotConnected - ensureConnectedToRemotes :: ( Member BrigAPIAccess r, Member (ErrorS 'NotConnected) r @@ -222,18 +217,6 @@ ensureConnectedToRemotes u remotes = do when (length acceptedConns /= length remotes) $ throwS @'NotConnected -ensureReAuthorised :: - ( Member BrigAPIAccess r, - Member (Error AuthenticationError) r - ) => - UserId -> - Maybe PlainTextPassword6 -> - Maybe Code.Value -> - Maybe VerificationAction -> - Sem r () -ensureReAuthorised u secret mbAction mbCode = - reauthUser u (ReAuthUser secret mbAction mbCode) >>= fromEither - ensureManageChannelsPermission :: (Member (ErrorS 'ConvNotFound) r) => StoredConversation -> TeamMember -> Sem r () ensureManageChannelsPermission conv tm = do unless (hasManageChannelsPermission conv tm) $ throwS @'ConvNotFound @@ -323,72 +306,6 @@ checkGroupIdSupport loc conv joinAction = void $ runMaybeT $ do failOnFirstError :: (Member (ErrorS GroupIdVersionNotSupported) r) => [Either e x] -> Sem r () failOnFirstError = traverse_ $ either (\_ -> throwS @GroupIdVersionNotSupported) pure --- | Same as 'permissionCheck', but for a statically known permission. -permissionCheckS :: - forall teamAssociation perm (p :: perm) r. - ( SingKind perm, - IsPerm teamAssociation (Demote perm), - ( Member (ErrorS (PermError p)) r, - Member (ErrorS 'NotATeamMember) r - ) - ) => - Sing p -> - Maybe teamAssociation -> - Sem r teamAssociation -permissionCheckS p = - \case - Just m -> do - if m `hasPermission` fromSing p - then pure m - else throwS @(PermError p) - -- FUTUREWORK: factor `noteS` out of this function. - Nothing -> throwS @'NotATeamMember - --- | If a team member is not given throw 'notATeamMember'; if the given team --- member does not have the given permission, throw 'operationDenied'. --- Otherwise, return the team member. -permissionCheck :: - ( IsPerm teamAssociation perm, - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r - ) - ) => - perm -> - Maybe teamAssociation -> - Sem r teamAssociation --- FUTUREWORK: factor `noteS` out of this function. -permissionCheck p = \case - Just m -> do - if m `hasPermission` p - then pure m - else throwS @OperationDenied - -- FUTUREWORK: factor `noteS` out of this function. - Nothing -> throwS @'NotATeamMember - -assertTeamExists :: - ( Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ) => - TeamId -> - Sem r () -assertTeamExists tid = do - teamExists <- isJust <$> getTeam tid - if teamExists - then pure () - else throwS @'TeamNotFound - -assertOnTeam :: - ( Member (ErrorS 'NotATeamMember) r, - Member TeamSubsystem r - ) => - UserId -> - TeamId -> - Sem r () -assertOnTeam uid tid = - TeamSubsystem.internalGetTeamMember uid tid >>= \case - Nothing -> throwS @'NotATeamMember - Just _ -> pure () - -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: ( Member ConversationStore r, @@ -997,38 +914,6 @@ userLHEnabled = \case UserLegalHoldDisabled -> False UserLegalHoldNoConsent -> False -data ConsentGiven = ConsentGiven | ConsentNotGiven - deriving (Eq, Ord, Show) - -consentGiven :: UserLegalHoldStatus -> ConsentGiven -consentGiven = \case - UserLegalHoldDisabled -> ConsentGiven - UserLegalHoldPending -> ConsentGiven - UserLegalHoldEnabled -> ConsentGiven - UserLegalHoldNoConsent -> ConsentNotGiven - -checkConsent :: - (Member TeamSubsystem r) => - Map UserId TeamId -> - UserId -> - Sem r ConsentGiven -checkConsent teamsOfUsers other = do - consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other - --- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user --- doesn't belong to a team. -getLHStatus :: - (Member TeamSubsystem r) => - Maybe TeamId -> - UserId -> - Sem r UserLegalHoldStatus -getLHStatus teamOfUser other = do - case teamOfUser of - Nothing -> pure defUserLegalHoldStatus - Just team -> do - mMember <- TeamSubsystem.internalGetTeamMember other team - pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember - anyLegalholdActivated :: ( Member (Input ConversationSubsystemConfig) r, Member TeamStore r, @@ -1075,31 +960,6 @@ allLegalholdConsentGiven uids = do eitherTeamMemberAndLHAllowedOrDefLHStatus teamsPage uid = do fromMaybe (consentGiven defUserLegalHoldStatus == ConsentGiven) <$> (for (Map.lookup uid teamsPage) isTeamLegalholdWhitelisted) --- | Add to every uid the legalhold status -getLHStatusForUsers :: - (Member TeamStore r, Member TeamSubsystem r) => - [UserId] -> - Sem r [(UserId, UserLegalHoldStatus)] -getLHStatusForUsers uids = - mconcat - <$> for - (chunksOf 32 uids) - ( \uidsChunk -> do - teamsOfUsers <- getUsersTeams uidsChunk - for uidsChunk $ \uid -> do - (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid - ) - -getTeamMembersForFanout :: - ( Member (Input FanoutLimit) r, - Member TeamSubsystem r - ) => - TeamId -> - Sem r TeamMemberList -getTeamMembersForFanout tid = do - lim <- input - TeamSubsystem.internalGetTeamMembersWithLimit tid (Just lim) - ensureMemberLimit :: ( Foldable f, ( Member (ErrorS 'TooManyMembers) r, @@ -1173,39 +1033,6 @@ notifyConversationUpdated lusr conn j conv = do } ] --- | Convert a local conversation member (as stored in the DB) to a publicly --- facing 'Member' structure. -localMemberToPublic :: Local x -> LocalMember -> Public.Member -localMemberToPublic loc lm = - Public.Member - { memId = tUntagged . qualifyAs loc $ lm.id_, - memService = lm.service, - memOtrMutedStatus = msOtrMutedStatus st, - memOtrMutedRef = msOtrMutedRef st, - memOtrArchived = msOtrArchived st, - memOtrArchivedRef = msOtrArchivedRef st, - memHidden = msHidden st, - memHiddenRef = msHiddenRef st, - memConvRoleName = lm.convRoleName - } - where - st = lm.status - --- | View for a given user of a stored conversation. --- --- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe Public.OwnConversation -conversationViewMaybe luid remoteOthers localOthers conv = do - let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers - self <- localMemberToPublic luid <$> listToMaybe selfs - let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - Public.OwnConversation - (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata - (OwnConvMembers self others) - conv.protocol - notifyConversationCreated :: ( Member NotificationSubsystem r, Member ConversationStore r, diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs index d8824e685c2..2b5da0c95fe 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs @@ -19,7 +19,8 @@ module Wire.FeaturesConfigSubsystem where -import Data.Id (TeamId, UserId) +import Data.Id (ConvId, TeamId, UserId) +import Data.Proxy (Proxy) import Data.Qualified (Local) import Imports import Polysemy @@ -35,5 +36,27 @@ data FeaturesConfigSubsystem m a where GetAllTeamFeaturesForTeamMember :: Local UserId -> TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForTeam :: TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForServer :: FeaturesConfigSubsystem m AllTeamFeatures + GuardSecondFactorDisabled :: + UserId -> + ConvId -> + FeaturesConfigSubsystem m () + FeatureEnabledForTeam :: + forall cfg m. + (GetFeatureConfig cfg) => + Proxy cfg -> + TeamId -> + FeaturesConfigSubsystem m Bool + GetAllTeamFeaturesForUser :: + UserId -> + FeaturesConfigSubsystem m AllTeamFeatures + GetSingleFeatureForUser :: + forall cfg m. + (GetFeatureConfig cfg) => + UserId -> + FeaturesConfigSubsystem m (LockableFeature cfg) + GetFeatureInternal :: + (GetFeatureConfig cfg) => + TeamId -> + FeaturesConfigSubsystem m (LockableFeature cfg) makeSem ''FeaturesConfigSubsystem diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs index d3842f68bf5..70936a806e0 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs @@ -5,24 +5,31 @@ module Wire.FeaturesConfigSubsystem.Interpreter where +import Control.Error (hush) import Data.Aeson.Types qualified as A import Data.Id import Data.Qualified (tUnqualified) import Data.SOP +import Data.Tagged import Data.Text.Lazy qualified as LT import Imports import Polysemy import Polysemy.Error import Polysemy.Input +import Wire.API.Conversation (ConversationMetadata (..)) import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.ConversationStore qualified as ConversationStore import Wire.FeaturesConfigSubsystem import Wire.FeaturesConfigSubsystem.Types import Wire.FeaturesConfigSubsystem.Utils +import Wire.LegalHoldStore (LegalHoldStore) import Wire.TeamFeatureStore import Wire.TeamFeatureStore.Error (TeamFeatureStoreError (..)) +import Wire.TeamStore qualified as TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem @@ -30,8 +37,11 @@ runFeaturesConfigSubsystem :: forall r a. ( Member TeamFeatureStore r, Member TeamSubsystem r, + Member TeamStore.TeamStore r, + Member ConversationStore.ConversationStore r, Member (Error TeamFeatureStoreError) r, Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'AccessDenied) r, GetFeatureConfigEffects r ) => Sem (FeaturesConfigSubsystem : r) a -> @@ -54,6 +64,16 @@ runFeaturesConfigSubsystem = interpret $ \case getAllTeamFeaturesImpl tid GetAllTeamFeaturesForServer -> getAllTeamFeaturesForServerImpl + GuardSecondFactorDisabled uid cid -> + guardSecondFactorDisabledImpl uid cid + FeatureEnabledForTeam (Proxy :: Proxy cfg) tid -> + featureEnabledForTeamImpl @cfg tid + GetAllTeamFeaturesForUser uid -> + getAllTeamFeaturesForUserImpl uid + GetSingleFeatureForUser uid -> + getSingleFeatureForUserImpl uid + GetFeatureInternal tid -> + getFeatureInternalImpl tid -- Internal helpers @@ -129,3 +149,138 @@ parseDbFeatureOrThrow feat = mapError (TeamFeatureStoreErrorInternalError . LT.pack) . fromEither $ A.parseEither (const (parseDbFeature feat)) () + +getFeatureInternalImpl :: + ( GetFeatureConfig cfg, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member TeamSubsystem r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r (LockableFeature cfg) +getFeatureInternalImpl tid = do + TeamSubsystem.assertTeamExists tid + getFeatureForTeamImpl tid + +getTeamAndCheckMembership :: + ( Member TeamStore.TeamStore r, + Member (ErrorS 'NotATeamMember) r, + Member TeamSubsystem r + ) => + UserId -> + Sem r (Maybe TeamId) +getTeamAndCheckMembership uid = do + mTid <- TeamStore.getOneUserTeam uid + for_ mTid $ \tid -> do + zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid + void $ maybe (throwS @'NotATeamMember) pure zusrMembership + TeamSubsystem.assertTeamExists tid + pure mTid + +getAllTeamFeatures :: + forall r. + ( Member TeamFeatureStore r, + Member LegalHoldStore r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r AllTeamFeatures +getAllTeamFeatures tid = getAllTeamFeaturesImpl tid + +getAllTeamFeaturesForUserImpl :: + forall r. + ( Member (ErrorS 'NotATeamMember) r, + Member TeamStore.TeamStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member (Error TeamFeatureStoreError) r, + GetFeatureConfigEffects r + ) => + UserId -> + Sem r AllTeamFeatures +getAllTeamFeaturesForUserImpl uid = do + mTid <- getTeamAndCheckMembership uid + case mTid of + Nothing -> hsequence' $ hcpure (Proxy @(GetAllTeamFeaturesForUserConstraints r)) $ Comp $ getFeatureForUser uid + Just tid -> getAllTeamFeatures tid + +getSingleFeatureForUserImpl :: + forall cfg r. + ( GetFeatureConfig cfg, + Member (ErrorS 'NotATeamMember) r, + Member (Error TeamFeatureStoreError) r, + Member TeamStore.TeamStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member BrigAPIAccess r, + Member LegalHoldStore r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r + ) => + UserId -> + Sem r (LockableFeature cfg) +getSingleFeatureForUserImpl uid = do + mTid <- getTeamAndCheckMembership uid + getFeatureForTeamUserImpl @cfg uid mTid + +-- | If second factor auth is enabled, make sure that end-points that don't support it, but +-- should, are blocked completely. (This is a workaround until we have 2FA for those +-- end-points as well.) +-- +-- This function exists to resolve a cyclic dependency. +guardSecondFactorDisabledImpl :: + forall r. + ( Member (ErrorS 'AccessDenied) r, + Member (Error TeamFeatureStoreError) r, + Member ConversationStore.ConversationStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member BrigAPIAccess r, + Member LegalHoldStore r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r + ) => + UserId -> + ConvId -> + Sem r () +guardSecondFactorDisabledImpl uid cid = do + mTid <- fmap hush . runError @() $ do + convData <- ConversationStore.getConversationMetadata cid >>= note () + tid <- note () convData.cnvmTeam + mapError (unTagged @'TeamNotFound @()) $ TeamSubsystem.assertTeamExists tid + pure tid + + tf <- getFeatureForTeamUserImpl @SndFactorPasswordChallengeConfig uid mTid + case tf.status of + FeatureStatusDisabled -> pure () + FeatureStatusEnabled -> throwS @'AccessDenied + +featureEnabledForTeamImpl :: + forall cfg r. + ( GetFeatureConfig cfg, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r Bool +featureEnabledForTeamImpl tid = + (==) FeatureStatusEnabled + . (.status) + <$> getFeatureInternalImpl @cfg tid diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index f70fa3addf8..e3fa6bc3bc4 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -22,6 +22,7 @@ module Wire.GalleyAPIAccess where import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) +import Data.LegalHold (UserLegalHoldStatus) import Data.Qualified import Data.Range import Imports @@ -104,6 +105,9 @@ data GalleyAPIAccess m a where GetTeam :: TeamId -> GalleyAPIAccess m Team.TeamData + FindTeam :: + TeamId -> + GalleyAPIAccess m (Maybe Team.TeamData) GetTeamName :: TeamId -> GalleyAPIAccess m Team.TeamName @@ -166,5 +170,7 @@ data GalleyAPIAccess m a where GetConversationConfig :: GalleyAPIAccess m ConversationSubsystemConfig GuardLegalHold :: LegalholdProtectee -> UserClients -> GalleyAPIAccess m () + GetUserLHStatus :: Maybe TeamId -> UserId -> GalleyAPIAccess m UserLegalHoldStatus + GetUsersLHStatus :: [UserId] -> GalleyAPIAccess m [(UserId, UserLegalHoldStatus)] makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 3479c082df8..ae8f54d772d 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -27,6 +27,7 @@ import Data.Coerce (coerce) import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) +import Data.LegalHold (UserLegalHoldStatus) import Data.Qualified import Data.Range import Imports @@ -38,6 +39,7 @@ import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog (TinyLog, debug) import Servant.API (toHeader) import System.Logger.Message import Util.Options @@ -66,7 +68,8 @@ import Wire.Rpc interpretGalleyAPIAccessToRpc :: ( Member (Error ParseException) r, Member Rpc r, - Member (Error ClientError) r + Member (Error ClientError) r, + Member TinyLog r ) => Set Version -> Endpoint -> @@ -89,6 +92,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = SelectTeamMembers tid uids -> selectTeamMembers tid uids GetTeamId id' -> getTeamId id' GetTeam id' -> getTeam id' + FindTeam id' -> findTeam id' GetTeamName id' -> getTeamName id' GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' GetTeamSearchVisibility id' -> getTeamSearchVisibility id' @@ -109,6 +113,8 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamContacts uid -> getTeamContacts uid GetConversationConfig -> getConversationConfig GuardLegalHold protectee userClient -> guardLegalhold protectee userClient + GetUserLHStatus mtid uid -> getUserLHStatus mtid uid + GetUsersLHStatus uids -> getUsersLHStatus uids getUserLegalholdStatus :: ( Member (Error ParseException) r, @@ -132,7 +138,7 @@ galleyRequest req = do ep <- input rpcWithRetries "galley" ep req --- | Calls 'Galley.API.createSelfConversationH'. +-- | Calls 'Wire.ConversationSubsystem.createSelfConversationH'. createSelfConv :: ( Member Rpc r, Member (Input Endpoint) r @@ -148,7 +154,7 @@ createSelfConv v u = do . zUser u . expect2xx --- | Calls 'Galley.API.getConversationH'. +-- | Calls 'Wire.ConversationSubsystem.getConversationH'. getConv :: ( Member (Error ParseException) r, Member Rpc r, @@ -175,7 +181,7 @@ getConv v usr lcnv = do . zUser usr . expect [status200, status404] --- | Calls 'Galley.API.getTeamConversationH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamConversationH'. getTeamConv :: ( Member (Error ParseException) r, Member Rpc r, @@ -204,7 +210,7 @@ getTeamConv v usr tid cnv = do . zUser usr . expect [status200, status404] --- | Calls 'Galley.API.addClientH'. +-- | Calls 'Wire.ConversationSubsystem.addClientH'. newClient :: ( Member Rpc r, Member (Input Endpoint) r @@ -219,7 +225,7 @@ newClient u c = do . zUser u . expect2xx --- | Calls 'Galley.API.canUserJoinTeamH'. +-- | Calls 'Wire.ConversationSubsystem.canUserJoinTeamH'. checkUserCanJoinTeam :: ( Member Rpc r, Member (Input Endpoint) r @@ -239,7 +245,7 @@ checkUserCanJoinTeam tid = do . paths ["i", "teams", toByteString' tid, "members", "check"] . header "Content-Type" "application/json" --- | Calls 'Galley.API.uncheckedAddTeamMemberH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedAddTeamMemberH'. addTeamMember :: ( Member Rpc r, Member (Input Endpoint) r @@ -265,7 +271,7 @@ addTeamMember u tid minvmeta role = do . expect [status200, status403] . lbytes (encode bdy) --- | Calls 'Galley.API.createBindingTeamH'. +-- | Calls 'Wire.ConversationSubsystem.createBindingTeamH'. createTeam :: ( Member Rpc r, Member (Input Endpoint) r @@ -285,7 +291,7 @@ createTeam u t teamid = do . expect2xx . lbytes (encode t) --- | Calls 'Galley.API.uncheckedGetTeamMemberH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedGetTeamMemberH'. getTeamMember :: ( Member (Error ParseException) r, Member Rpc r, @@ -306,7 +312,7 @@ getTeamMember u tid = do . zUser u . expect [status200, status404] --- | Calls 'Galley.API.uncheckedGetTeamMembersH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedGetTeamMembersH'. -- -- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which -- means that only the first 2000 members of a team (according to some arbitrary order) will @@ -393,7 +399,7 @@ memberIsTeamOwner tid uid = do . paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] pure $ responseStatus r /= status403 --- | Calls 'Galley.API.getBindingTeamIdH'. +-- | Calls 'Wire.ConversationSubsystem.getBindingTeamIdH'. getTeamId :: ( Member (Error ParseException) r, Member Rpc r, @@ -412,7 +418,7 @@ getTeamId u = do . paths ["i", "users", toByteString' u, "team"] . expect [status200, status404] --- | Calls 'Galley.API.getTeamInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeam :: ( Member (Error ParseException) r, Member Rpc r, @@ -428,7 +434,26 @@ getTeam tid = do . paths ["i", "teams", toByteString' tid] . expect2xx --- | Calls 'Galley.API.getTeamInternalH'. +-- | Like 'getTeam' but returns 'Nothing' on 404 instead of throwing. +findTeam :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r + ) => + TeamId -> + Sem r (Maybe Team.TeamData) +findTeam tid = do + rs <- galleyRequest req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBodyOrThrow "galley" rs + _ -> pure Nothing + where + req = + method GET + . paths ["i", "teams", toByteString' tid] + . expect [status200, status404] + +-- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeamName :: ( Member (Error ParseException) r, Member Rpc r, @@ -444,7 +469,7 @@ getTeamName tid = do . paths ["i", "teams", toByteString' tid, "name"] . expect2xx --- | Calls 'Galley.API.getTeamFeatureStatusH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: ( Member (Error ParseException) r, Member Rpc r, @@ -460,7 +485,7 @@ getTeamLegalHoldStatus tid = do . paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] . expect2xx --- | Calls 'Galley.API.getSearchVisibilityInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getSearchVisibilityInternalH'. getTeamSearchVisibility :: ( Member (Error ParseException) r, Member Rpc r, @@ -541,7 +566,7 @@ getConfiguredFeatureFlags = do . expect2xx ) --- | Calls 'Galley.API.updateTeamStatusH'. +-- | Calls 'Wire.ConversationSubsystem.updateTeamStatusH'. changeTeamStatus :: ( Member Rpc r, Member (Input Endpoint) r @@ -748,3 +773,48 @@ guardLegalhold protectee userClients = do . paths ["i", "guard-legalhold-policy-conflicts"] . header "Content-Type" "application/json" . lbytes (encode $ GuardLegalholdPolicyConflicts protectee userClients) + +getUserLHStatus :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + Maybe TeamId -> + UserId -> + Sem r UserLegalHoldStatus +getUserLHStatus mtid uid = do + debug $ + remote "galley" + . field "user" (toByteString uid) + . msg (val "Get user legalhold status") + galleyRequest req >>= decodeBodyOrThrow "galley" + where + req = + method GET + . paths ["i", "users", toByteString' uid, "lh-status"] + . maybe id (queryItem "team_id" . toByteString') mtid + . expect2xx + +getUsersLHStatus :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + [UserId] -> + Sem r [(UserId, UserLegalHoldStatus)] +getUsersLHStatus uids = do + debug $ + remote "galley" + . msg (val "Get users legalhold status") + let bdy = UserIds uids + entries :: [UserLegalHoldStatusEntry] <- galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" + pure $ map (\e -> (e.ulhseUser, e.ulhseStatus)) entries + where + req bdy = + method POST + . paths ["i", "users", "lh-status"] + . header "Content-Type" "application/json" + . lbytes (encode bdy) + . expect2xx diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 45d06de2cae..9fa3d151686 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -122,7 +122,7 @@ createMeetingImpl zUser newMeeting = do } -- Create and store the conversation via ConversationSubsystem - storedConv <- ConversationSubsystem.createGroupConversation zUser Nothing newConv + storedConv <- ConversationSubsystem.internalCreateGroupConversation zUser Nothing newConv -- Store meeting (trial status is provided by caller) storedMeeting <- diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index c93258449c8..adb170507d4 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -23,7 +23,6 @@ import Data.Aeson import Data.Id import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty -import Data.Proxy import Data.Range import Data.Set qualified as Set import Data.Time.Clock.DiffTime @@ -38,6 +37,7 @@ import Polysemy.TinyLog qualified as P import System.Logger.Class as Log import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 +import Wire.API.Team.FeatureFlags (defaultFanoutLimit) import Wire.API.Team.HardTruncationLimit (HardTruncationLimit) import Wire.GundeckAPIAccess (GundeckAPIAccess) import Wire.GundeckAPIAccess qualified as GundeckAPIAccess @@ -75,9 +75,6 @@ defaultNotificationSubsystemConfig :: RequestId -> NotificationSubsystemConfig defaultNotificationSubsystemConfig reqId = NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay reqId -defaultFanoutLimit :: Range 1 HardTruncationLimit Int32 -defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) - defaultChunkSize :: Natural defaultChunkSize = 128 diff --git a/libs/wire-subsystems/src/Wire/Options/Galley.hs b/libs/wire-subsystems/src/Wire/Options/Galley.hs index 8383ee97e4f..6b30fff0976 100644 --- a/libs/wire-subsystems/src/Wire/Options/Galley.hs +++ b/libs/wire-subsystems/src/Wire/Options/Galley.hs @@ -56,21 +56,22 @@ module Wire.Options.Galley logNetStrings, logFormat, guestLinkTTLSeconds, - defGuestLinkTTLSeconds, passwordHashingOptions, passwordHashingRateLimit, checkGroupInfo, meetings, validityPeriod, postgresMigration, - GuestLinkTTLSeconds (..), PostgresMigrationOpts (..), StorageLocation (..), + GuestLinkTTLSeconds (..), + defGuestLinkTTLSeconds, + conversationCodeURISettings, ) where import Control.Lens hiding (Level, (.=)) -import Data.Aeson +import Data.Aeson (FromJSON (..)) import Data.Aeson.TH (deriveFromJSON) import Data.Domain (Domain) import Data.Id (TeamId) @@ -86,7 +87,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Routes.Version import Wire.API.Team.FeatureFlags import Wire.API.Team.Member -import Wire.Options.Keys +import Wire.Options.Keys (MLSPrivateKeyPaths) import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter (RateLimitConfig) @@ -102,6 +103,10 @@ instance FromJSON GuestLinkTTLSeconds where then pure $ GuestLinkTTLSeconds n else fail "GuestLinkTTLSeconds must be in (0, 31536000]" +-- | Default guest link TTL in days. 365 days if not set. +defGuestLinkTTLSeconds :: GuestLinkTTLSeconds +defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year + data Settings = Settings { -- | Number of connections for the HTTP client pool _httpPoolSize :: !Int, @@ -184,10 +189,6 @@ makeLenses ''MeetingsConfig defConcurrentDeletionEvents :: Int defConcurrentDeletionEvents = 128 --- | Default guest link TTL in days. 365 days if not set. -defGuestLinkTTLSeconds :: GuestLinkTTLSeconds -defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year - data JournalOpts = JournalOpts { -- | SQS queue name to send team events _queueName :: !Text, @@ -241,3 +242,13 @@ data Opts = Opts deriveFromJSON toOptionFieldName ''Opts makeLenses ''Opts + +conversationCodeURISettings :: (Applicative m) => Opts -> m (Either HttpsUrl (Map Text HttpsUrl)) +conversationCodeURISettings opts = + case (opts._settings._conversationCodeURI, opts._settings._multiIngress) of + (Nothing, Nothing) -> error errMsg + (Nothing, Just mi) -> pure (Right mi) + (Just uri, Nothing) -> pure (Left uri) + (Just _, Just _) -> error errMsg + where + errMsg = "Either conversationCodeURI or multiIngress needs to be set." diff --git a/libs/wire-subsystems/src/Wire/StoredConversation.hs b/libs/wire-subsystems/src/Wire/StoredConversation.hs index 5af3bb2bac0..1fdbe37284e 100644 --- a/libs/wire-subsystems/src/Wire/StoredConversation.hs +++ b/libs/wire-subsystems/src/Wire/StoredConversation.hs @@ -30,9 +30,11 @@ import Data.Time (UTCTime) import Data.UUID.Tagged qualified as U import Imports import Wire.API.Conversation +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.CellsState import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role +import Wire.API.Federation.API.Galley import Wire.API.History import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group.Serialisation qualified as MLS @@ -352,6 +354,135 @@ defAccess One2OneConv (Just []) = [PrivateAccess] defAccess RegularConv (Just []) = defRegularConvAccess defAccess _ (Just xs@(_ : _)) = xs +-- MAPPING ------------------------------------------------------------------- + +-- | View for a given user of a stored conversation. +-- +-- Throws @BadMemberState@ when the user is not part of the conversation. +ownConversationView :: + Local UserId -> + StoredConversation -> + Maybe OwnConversation +ownConversationView luid conv = do + let remoteOthers = map remoteMemberToOther $ conv.remoteMembers + localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers + conversationViewWithCachedOthers remoteOthers localOthers conv luid + +conversationView :: + Local x -> + Maybe (Local UserId) -> + StoredConversation -> + Conversation +conversationView l luid conv = + let remoteMembers = map remoteMemberToOther $ conv.remoteMembers + localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers + selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) + mSelf = localMemberToPublic l <$> listToMaybe selfs + others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers + in Conversation + { members = ConvMembers mSelf others, + qualifiedId = (tUntagged . qualifyAs l $ conv.id_), + metadata = conv.metadata, + protocol = conv.protocol + } + +-- | Like 'conversationView' but optimized for situations which could benefit +-- from pre-computing the list of @OtherMember@s in the conversation. For +-- instance, creating @ConversationView@ for more than 1 member of the same conversation. +conversationViewWithCachedOthers :: + [OtherMember] -> + [OtherMember] -> + StoredConversation -> + Local UserId -> + Maybe OwnConversation +conversationViewWithCachedOthers remoteOthers localOthers conv luid = do + conversationViewMaybe luid remoteOthers localOthers conv + +-- | View for a given user of a stored conversation. +-- +-- Returns 'Nothing' if the user is not part of the conversation. +conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation +conversationViewMaybe luid remoteOthers localOthers conv = do + let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers + self <- localMemberToPublic luid <$> listToMaybe selfs + let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers + pure $ + OwnConversation + (tUntagged . qualifyAs luid $ conv.id_) + conv.metadata + (OwnConvMembers self others) + conv.protocol + +-- | View for a local user of a remote conversation. +remoteConversationView :: + Local UserId -> + MemberStatus -> + Remote RemoteConversationView -> + OwnConversation +remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = + let mems = rconv.members + others = mems.others + self = + localMemberToPublic + uid + LocalMember + { id_ = tUnqualified uid, + service = Nothing, + status = status, + convRoleName = mems.selfRole + } + in OwnConversation + (Qualified rconv.id rDomain) + rconv.metadata + (OwnConvMembers self others) + rconv.protocol + +-- | Convert a local conversation member (as stored in the DB) to a publicly +-- facing 'Member' structure. +localMemberToPublic :: Local x -> LocalMember -> Public.Member +localMemberToPublic loc lm = + Public.Member + { memId = tUntagged . qualifyAs loc $ lm.id_, + memService = lm.service, + memOtrMutedStatus = msOtrMutedStatus st, + memOtrMutedRef = msOtrMutedRef st, + memOtrArchived = msOtrArchived st, + memOtrArchivedRef = msOtrArchivedRef st, + memHidden = msHidden st, + memHiddenRef = msHiddenRef st, + memConvRoleName = lm.convRoleName + } + where + st = lm.status + +-- | Convert a local conversation to a structure to be returned to a remote +-- backend. +-- +-- This returns 'Nothing' if the given remote user is not part of the conversation. +conversationToRemote :: + Domain -> + Remote UserId -> + StoredConversation -> + Maybe RemoteConversationView +conversationToRemote localDomain ruid conv = do + let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) + lothers = conv.localMembers + selfRole' <- (.convRoleName) <$> listToMaybe selfs + let others' = + map (localMemberToOther localDomain) lothers + <> map remoteMemberToOther rothers + pure $ + RemoteConversationView + { id = conv.id_, + metadata = conv.metadata, + members = + RemoteConvMembers + { selfRole = selfRole', + others = others' + }, + protocol = conv.protocol + } + -- BotMember ------------------------------------------------------------------ -- | For now we assume bots to always be local diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index c42d8c58d1e..d7e7b9e4682 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -286,7 +286,7 @@ logInvitationRequest context action = -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- --- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. +-- There is some code duplication with 'Wire.ConversationSubsystem.Teams.ensureNotElevated'. ensurePermissionToAddUser :: ( Member (Error TeamInvitationSubsystemError) r, Member TeamSubsystem r diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem.hs index 7c7213aee72..cd4fa9a7cac 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem.hs @@ -20,13 +20,30 @@ module Wire.TeamSubsystem where import Data.Id +import Data.LegalHold +import Data.Map qualified as Map import Data.Qualified import Data.Range +import Data.Singletons (Demote, Sing, SingKind, fromSing) import Imports import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Team.LegalHold (UserLegalHoldStatusResponse) import Wire.API.Team.Member +import Wire.API.Team.Member.Error import Wire.API.Team.Member.Info (TeamMemberInfoList) +data PermissionCheckArgs teamAssociation where + PermissionCheckArgs :: + forall k (p :: k) teamAssociation. + ( SingKind k, + IsPerm teamAssociation (Demote k) + ) => + Sing p -> + Maybe teamAssociation -> + PermissionCheckArgs teamAssociation + data TeamSubsystem m a where InternalGetTeamMember :: UserId -> TeamId -> TeamSubsystem m (Maybe TeamMember) InternalGetTeamMembersWithLimit :: TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> TeamSubsystem m TeamMemberList @@ -35,5 +52,95 @@ data TeamSubsystem m a where InternalGetTeamAdmins :: TeamId -> TeamSubsystem m TeamMemberList InternalGetOneUserTeam :: UserId -> TeamSubsystem m (Maybe TeamId) InternalFinalizeDeleteTeam :: Local UserId -> Maybe ConnId -> TeamId -> TeamSubsystem m () + GetUserStatus :: + Local UserId -> + TeamId -> + UserId -> + TeamSubsystem m UserLegalHoldStatusResponse + GetTeamMembersForFanout :: + TeamId -> + TeamSubsystem m TeamMemberList + AssertTeamExists :: + TeamId -> + TeamSubsystem m () + GetLHStatusForUsers :: + [UserId] -> + TeamSubsystem m [(UserId, UserLegalHoldStatus)] + GetLHStatus :: + Maybe TeamId -> + UserId -> + TeamSubsystem m UserLegalHoldStatus makeSem ''TeamSubsystem + +assertOnTeam :: + ( Member (ErrorS 'NotATeamMember) r, + Member TeamSubsystem r + ) => + UserId -> + TeamId -> + Sem r () +assertOnTeam uid tid = + internalGetTeamMember uid tid >>= \case + Nothing -> throwS @'NotATeamMember + Just _ -> pure () + +-- | If a team member is not given throw 'notATeamMember'; if the given team +-- member does not have the given permission, throw 'operationDenied'. +-- Otherwise, return the team member. +permissionCheck :: + ( IsPerm teamAssociation perm, + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r + ) + ) => + perm -> + Maybe teamAssociation -> + Sem r teamAssociation +-- FUTUREWORK: factor `noteS` out of this function. +permissionCheck p = \case + Just m -> do + if m `hasPermission` p + then pure m + else throwS @OperationDenied + -- FUTUREWORK: factor `noteS` out of this function. + Nothing -> throwS @'NotATeamMember + +-- | Same as 'permissionCheck', but for a statically known permission. +permissionCheckS :: + forall teamAssociation perm (p :: perm) r. + ( SingKind perm, + IsPerm teamAssociation (Demote perm), + ( Member (ErrorS (PermError p)) r, + Member (ErrorS 'NotATeamMember) r + ) + ) => + Sing p -> + Maybe teamAssociation -> + Sem r teamAssociation +permissionCheckS p = + \case + Just m -> do + if m `hasPermission` fromSing p + then pure m + else throwS @(PermError p) + -- FUTUREWORK: factor `noteS` out of this function. + Nothing -> throwS @'NotATeamMember + +data ConsentGiven = ConsentGiven | ConsentNotGiven + deriving (Eq, Ord, Show) + +consentGiven :: UserLegalHoldStatus -> ConsentGiven +consentGiven = \case + UserLegalHoldDisabled -> ConsentGiven + UserLegalHoldPending -> ConsentGiven + UserLegalHoldEnabled -> ConsentGiven + UserLegalHoldNoConsent -> ConsentNotGiven + +checkConsent :: + (Member TeamSubsystem r) => + Map UserId TeamId -> + UserId -> + Sem r ConsentGiven +checkConsent teamsOfUsers other = do + consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs index 0f4e4342cc7..31ff34a8863 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs @@ -19,11 +19,18 @@ module Wire.TeamSubsystem.GalleyAPI where import Imports import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.TeamSubsystem -interpretTeamSubsystemToGalleyAPI :: (Member GalleyAPIAccess r) => InterpreterFor TeamSubsystem r +interpretTeamSubsystemToGalleyAPI :: + ( Member GalleyAPIAccess r, + Member (ErrorS 'TeamMemberNotFound) r, + Member (ErrorS 'TeamNotFound) r + ) => + InterpreterFor TeamSubsystem r interpretTeamSubsystemToGalleyAPI = interpret $ \case InternalGetTeamMember userId teamId -> GalleyAPIAccess.getTeamMember userId teamId InternalGetTeamMembersWithLimit teamId maxResults -> GalleyAPIAccess.getTeamMembersWithLimit teamId maxResults @@ -32,3 +39,17 @@ interpretTeamSubsystemToGalleyAPI = interpret $ \case InternalGetTeamAdmins teamId -> GalleyAPIAccess.getTeamAdmins teamId InternalGetOneUserTeam userId -> GalleyAPIAccess.getTeamId userId InternalFinalizeDeleteTeam lusr mcon teamId -> GalleyAPIAccess.finalizeDeleteTeam lusr mcon teamId + GetUserStatus lusr tid uid -> do + GalleyAPIAccess.getTeamMember uid tid >>= \case + Nothing -> throwS @'TeamMemberNotFound + Just _ -> do + GalleyAPIAccess.getUserLegalholdStatus lusr tid >>= \case + Nothing -> throwS @'TeamNotFound + Just status -> pure status + GetTeamMembersForFanout tid -> + GalleyAPIAccess.getTeamMembersWithLimit tid Nothing + AssertTeamExists tid -> do + found <- isJust <$> GalleyAPIAccess.findTeam tid + unless found $ throwS @'TeamNotFound + GetLHStatusForUsers uids -> GalleyAPIAccess.getUsersLHStatus uids + GetLHStatus mtid uid -> GalleyAPIAccess.getUserLHStatus mtid uid diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs index 749bfd978d3..f598ec35d74 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs @@ -18,22 +18,34 @@ module Wire.TeamSubsystem.Interpreter where import Control.Lens (view, (%~), (^.)) +import Data.ByteString.Conversion (toByteString') import Data.Default import Data.Id import Data.Json.Util -import Data.LegalHold (UserLegalHoldStatus (..)) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra qualified as List import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map qualified as Map import Data.Qualified import Data.Time +import Galley.Types.Error import Imports import Polysemy +import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog qualified as P +import System.Logger.Class qualified as Log +import Wire.API.Error +import Wire.API.Error.Galley import Wire.API.Event.Conversation qualified as Conv import Wire.API.Event.Team +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.API.Team.HardTruncationLimit +import Wire.API.Team.LegalHold +import Wire.API.Team.LegalHold qualified as Public import Wire.API.Team.Member import Wire.API.Team.Member.Info (TeamMemberInfoList (TeamMemberInfoList)) +import Wire.API.User.Client.Prekey import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.ConversationStore @@ -42,6 +54,7 @@ import Wire.ExternalAccess import Wire.ExternalAccess qualified as ExternalAccess import Wire.LegalHoldStore (LegalHoldStore) import Wire.LegalHoldStore qualified as LH +import Wire.LegalHoldStore qualified as LegalHoldData import Wire.NotificationSubsystem import Wire.Sem.Now import Wire.Sem.Now qualified as Now @@ -65,7 +78,12 @@ interpretTeamSubsystem :: Member Now r, Member SparAPIAccess r, Member ConversationStore r, - Member TeamJournal r + Member TeamJournal r, + Member (Input FanoutLimit) r, + Member (Error InternalError) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member P.TinyLog r ) => TeamSubsystemConfig -> InterpreterFor TeamSubsystem r @@ -79,23 +97,23 @@ interpretTeamSubsystemWithInputConfig :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input TeamSubsystemConfig) r, + Member (Input FanoutLimit) r, Member Now r, Member SparAPIAccess r, Member ConversationStore r, - Member TeamJournal r + Member TeamJournal r, + Member (Error InternalError) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member P.TinyLog r ) => InterpreterFor TeamSubsystem r interpretTeamSubsystemWithInputConfig = interpret $ \case - InternalGetTeamMember uid tid -> do - tms <- TeamStore.getTeamMember tid uid - for tms $ \tm -> do - hasImplicitConsent <- LH.isTeamLegalholdWhitelisted tid - pure $ if hasImplicitConsent then grantImplicitConsent tm else tm - InternalGetTeamMembersWithLimit tid maxResults -> do - tmList <- TeamStore.getTeamMembersWithLimit tid (fromMaybe hardTruncationLimitRange maxResults) - ms <- adjustMembersForImplicitConsent tid (tmList ^. teamMembers) - pure $ newTeamMemberList ms (tmList ^. teamMemberListType) + InternalGetTeamMember uid tid -> + internalGetTeamMemberImpl uid tid + InternalGetTeamMembersWithLimit tid maxResults -> + internalGetTeamMembersWithLimitImpl tid maxResults InternalSelectTeamMemberInfos tid uids -> TeamMemberInfoList <$> TeamStore.selectTeamMemberInfos tid uids InternalSelectTeamMembers tid uids -> do tms <- TeamStore.selectTeamMembers tid uids @@ -106,9 +124,20 @@ interpretTeamSubsystemWithInputConfig = >>= TeamStore.selectTeamMembers tid >>= adjustMembersForImplicitConsent tid pure $ newTeamMemberList admins ListComplete - InternalGetOneUserTeam uid -> TeamStore.getOneUserTeam uid + InternalGetOneUserTeam uid -> + TeamStore.getOneUserTeam uid InternalFinalizeDeleteTeam luid mcon tid -> internalFinalizeDeleteTeamImpl luid mcon tid + GetUserStatus lzusr tid uid -> + getUserStatusImpl lzusr tid uid + AssertTeamExists tid -> + assertTeamExistsImpl tid + GetTeamMembersForFanout tid -> + getTeamMembersForFanoutImpl tid + GetLHStatus teamOfUser other -> + getLHStatusImpl teamOfUser other + GetLHStatusForUsers uids -> + getLHStatusForUsersImpl uids adjustMembersForImplicitConsent :: (Member LegalHoldStore r) => TeamId -> [TeamMember] -> Sem r [TeamMember] adjustMembersForImplicitConsent tid ms = do @@ -123,6 +152,31 @@ grantImplicitConsent = UserLegalHoldPending -> UserLegalHoldPending UserLegalHoldEnabled -> UserLegalHoldEnabled +internalGetTeamMemberImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + UserId -> + TeamId -> + Sem r (Maybe TeamMember) +internalGetTeamMemberImpl uid tid = do + tms <- TeamStore.getTeamMember tid uid + for tms $ \tm -> do + hasImplicitConsent <- LH.isTeamLegalholdWhitelisted tid + pure $ if hasImplicitConsent then grantImplicitConsent tm else tm + +internalGetTeamMembersWithLimitImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + TeamId -> + Maybe FanoutLimit -> + Sem r TeamMemberList +internalGetTeamMembersWithLimitImpl tid maxResults = do + tmList <- TeamStore.getTeamMembersWithLimit tid (fromMaybe hardTruncationLimitRange maxResults) + ms <- adjustMembersForImplicitConsent tid (tmList ^. teamMembers) + pure $ newTeamMemberList ms (tmList ^. teamMemberListType) + -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. internalFinalizeDeleteTeamImpl :: forall r. @@ -204,3 +258,98 @@ internalFinalizeDeleteTeamImpl lusr zcon tid = do let ee' = map (,e) bots let pp' = (p {conn = zcon}) : pp pure (pp', ee' ++ ee) + +-- | Learn whether a user has LH enabled and fetch pre-keys. +-- Note that this is accessible to ANY authenticated user, even ones outside the team +getUserStatusImpl :: + forall r. + ( Member (Error InternalError) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member LegalHoldData.LegalHoldStore r, + Member TeamStore r, + Member P.TinyLog r + ) => + Local UserId -> + TeamId -> + UserId -> + Sem r Public.UserLegalHoldStatusResponse +getUserStatusImpl _lzusr tid uid = do + teamMember <- noteS @'TeamMemberNotFound =<< internalGetTeamMemberImpl uid tid + let status = view legalHoldStatus teamMember + (mlk, lcid) <- case status of + UserLegalHoldNoConsent -> pure (Nothing, Nothing) + UserLegalHoldDisabled -> pure (Nothing, Nothing) + UserLegalHoldPending -> makeResponseDetails + UserLegalHoldEnabled -> makeResponseDetails + pure $ UserLegalHoldStatusResponse status mlk lcid + where + makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails = do + mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid + lastKey <- case mLastKey of + Nothing -> do + P.err + . Log.msg + $ "expected to find a prekey for user: " + <> toByteString' uid + <> " but none was found" + throw NoPrekeyForUser + Just lstKey -> pure lstKey + let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey + pure (Just lastKey, Just clientId) + +assertTeamExistsImpl :: + ( Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) => + TeamId -> + Sem r () +assertTeamExistsImpl tid = do + teamExists <- isJust <$> TeamStore.getTeam tid + if teamExists + then pure () + else throwS @'TeamNotFound + +getTeamMembersForFanoutImpl :: + ( Member TeamStore r, + Member LegalHoldStore r, + Member (Input FanoutLimit) r + ) => + TeamId -> + Sem r TeamMemberList +getTeamMembersForFanoutImpl tid = do + lim <- input + internalGetTeamMembersWithLimitImpl tid (Just lim) + +-- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user +-- doesn't belong to a team. +getLHStatusImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + Maybe TeamId -> + UserId -> + Sem r UserLegalHoldStatus +getLHStatusImpl teamOfUser other = do + case teamOfUser of + Nothing -> pure defUserLegalHoldStatus + Just team -> do + mMember <- internalGetTeamMemberImpl other team + pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember + +-- | Add to every uid the legalhold status +getLHStatusForUsersImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + [UserId] -> + Sem r [(UserId, UserLegalHoldStatus)] +getLHStatusForUsersImpl uids = + mconcat + <$> for + (List.chunksOf 32 uids) + ( \uidsChunk -> do + teamsOfUsers <- TeamStore.getUsersTeams uidsChunk + for uidsChunk $ \uid -> do + (uid,) <$> getLHStatusImpl (Map.lookup uid teamsOfUsers) uid + ) diff --git a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs index f0bde2b2248..1ba2898ecaa 100644 --- a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs +++ b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs @@ -17,21 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.UserClientIndexStore - ( -- * UserClientIndexStore Effect - UserClientIndexStore (..), - - -- * Create client - createClient, - - -- * Get client - getClients, - - -- * Delete client - deleteClient, - deleteClients, - ) -where +module Wire.UserClientIndexStore where import Data.Id import Galley.Types.Clients diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs similarity index 56% rename from services/galley/test/unit/Test/Galley/API/Message.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs index 18c9512c665..55e9b03d7c6 100644 --- a/services/galley/test/unit/Test/Galley/API/Message.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Galley.API.Message where +module Wire.ConversationSubsystem.MessageSpec where import Control.Lens import Data.Domain @@ -23,27 +23,23 @@ import Data.Id import Data.Map qualified as Map import Data.Set qualified as Set import Data.Set.Lens -import Data.UUID.Types -import Galley.API.Message +import Data.UUID qualified as UUID import Imports -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck ((===), (==>)) import Wire.API.Message import Wire.API.User.Client (QualifiedUserClients (..)) +import Wire.ConversationSubsystem.Message -tests :: TestTree -tests = - testGroup - "Galley.API.Message" - [ testGroup - "checkMessageClients" - [ checkMessageClientSuccess, - checkMessageClientEverythingReported, - checkMessageClientRedundantSender, - checkMessageClientMissingSubsetOfStrategy - ], - testBuildFailedToSend - ] +spec :: Spec +spec = describe "Galley.API.Message" do + describe "checkMessageClients" do + checkMessageClientSuccess + checkMessageClientEverythingReported + checkMessageClientRedundantSender + checkMessageClientMissingSubsetOfStrategy + testBuildFailedToSend flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) flatten = @@ -57,8 +53,8 @@ type QualifiedUserClient = (Domain, UserId, ClientId) recipientSetToMap :: Set QualifiedUserClient -> Map (Domain, UserId) (Set ClientId) recipientSetToMap = Set.foldr (\(d, u, c) m -> Map.insertWith Set.union (d, u) (Set.singleton c) m) mempty -checkMessageClientSuccess :: TestTree -checkMessageClientSuccess = testProperty "success" $ +checkMessageClientSuccess :: Spec +checkMessageClientSuccess = prop "success" $ \(sender :: QualifiedUserClient) (msg :: Map QualifiedUserClient ByteString) (strat :: ClientMismatchStrategy) -> let expectedRecipients = Map.keysSet msg expectedRecipientMap = recipientSetToMap expectedRecipients @@ -66,8 +62,8 @@ checkMessageClientSuccess = testProperty "success" $ checkMessageClients sender expectedRecipientMap msg strat === (True, msg, QualifiedMismatch mempty mempty mempty) -checkMessageClientRedundantSender :: TestTree -checkMessageClientRedundantSender = testProperty "sender should be part of redundant" $ +checkMessageClientRedundantSender :: Spec +checkMessageClientRedundantSender = prop "sender should be part of redundant" $ \(msg0 :: Map QualifiedUserClient ByteString) (sender :: QualifiedUserClient) (strat :: ClientMismatchStrategy) -> let msg = Map.insert sender "msg to self" msg0 expectedRecipients = Map.keysSet msg0 @@ -79,8 +75,8 @@ checkMessageClientRedundantSender = testProperty "sender should be part of redun -- expected'' are used along with msg to generate expected, this ensures that we -- don't always get a disjoint set between the intended recipietns and expected -- recipients. -checkMessageClientEverythingReported :: TestTree -checkMessageClientEverythingReported = testProperty "all intended and expected recipients should be part of valid and extras" $ +checkMessageClientEverythingReported :: Spec +checkMessageClientEverythingReported = prop "all intended and expected recipients should be part of valid and extras" $ \(sender :: QualifiedUserClient) (expected' :: Set QualifiedUserClient) (msg0 :: Map QualifiedUserClient ByteString) (msg' :: Map QualifiedUserClient ByteString) -> let expectedRecipients = Map.keysSet msg0 <> expected' expectedRecipientMap = recipientSetToMap expectedRecipients @@ -92,8 +88,8 @@ checkMessageClientEverythingReported = testProperty "all intended and expected r in validRecipients <> extraRecipients === intendedRecipients <> expectedRecipients -checkMessageClientMissingSubsetOfStrategy :: TestTree -checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should be a subset of the clients determined by the strategy" $ +checkMessageClientMissingSubsetOfStrategy :: Spec +checkMessageClientMissingSubsetOfStrategy = prop "missing clients should be a subset of the clients determined by the strategy" $ \(sender :: QualifiedUserClient) (expected' :: Set QualifiedUserClient) (msg0 :: Map QualifiedUserClient ByteString) (msg' :: Map QualifiedUserClient ByteString) (strat :: ClientMismatchStrategy) -> let expected = Map.keysSet msg0 <> expected' expectedMap = recipientSetToMap expected @@ -103,52 +99,38 @@ checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should missing = flatten . qualifiedUserClients $ qmMissing mismatch in Set.isSubsetOf missing stratClients -testBuildFailedToSend :: TestTree -testBuildFailedToSend = - testGroup - "build failed to send map for post message qualified" - [ testProperty - "Empty case - trivial" - $ collectFailedToSend [] - === mempty, - testProperty - "Empty case - single empty map" - $ collectFailedToSend [mempty] - === mempty, - testProperty - "Empty case - multiple empty maps" - $ collectFailedToSend [mempty, mempty] - === mempty, - testProperty - "Single domain" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty] - === Map.singleton (Domain "foo") mempty, - testProperty - "Single domain duplicated" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] - === Map.singleton (Domain "foo") mempty, - testProperty - "Mutliple domains in multiple maps" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] - === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], - testProperty - "Mutliple domains in single map" - $ collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] - === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], - testProperty - "Single domain duplicated with unique sub-maps" - $ collectFailedToSend - [ Map.singleton (Domain "foo") $ Map.singleton idA mempty, - Map.singleton (Domain "foo") $ Map.singleton idB mempty - ] - === Map.singleton - (Domain "foo") - ( Map.fromList - [ (idA, mempty), - (idB, mempty) - ] - ) - ] +testBuildFailedToSend :: Spec +testBuildFailedToSend = describe "build failed to send map for post message qualified" do + prop "Empty case - trivial" $ + collectFailedToSend [] === mempty + prop "Empty case - single empty map" $ + collectFailedToSend [mempty] === mempty + prop "Empty case - multiple empty maps" $ + collectFailedToSend [mempty, mempty] === mempty + prop "Single domain" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty + prop "Single domain duplicated" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty + prop "Mutliple domains in multiple maps" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)] + prop "Mutliple domains in single map" $ + collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)] + prop "Single domain duplicated with unique sub-maps" $ + collectFailedToSend + [ Map.singleton (Domain "foo") $ Map.singleton idA mempty, + Map.singleton (Domain "foo") $ Map.singleton idB mempty + ] + === Map.singleton + (Domain "foo") + ( Map.fromList + [ (idA, mempty), + (idB, mempty) + ] + ) where - idA = Id $ fromJust $ Data.UUID.Types.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa" - idB = Id $ fromJust $ Data.UUID.Types.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" + idA = Id $ fromJust $ UUID.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa" + idB = Id $ fromJust $ UUID.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs similarity index 80% rename from services/galley/test/unit/Test/Galley/API/One2One.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs index 88a0df0ff57..20c6658d77c 100644 --- a/services/galley/test/unit/Test/Galley/API/One2One.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs @@ -16,36 +16,33 @@ -- with this program. If not, see . -- | Tests for one-to-one conversations -module Test.Galley.API.One2One where +module Wire.ConversationSubsystem.One2OneSpec where import Data.Id import Data.List.Extra import Data.Qualified import Imports -import Test.Tasty -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck import Wire.API.User import Wire.ConversationSubsystem.One2One (one2OneConvId) -tests :: TestTree -tests = - testGroup - "one2OneConvId" - [ testProperty "symmetry" one2OneConvIdSymmetry, - testCase "non-collision" one2OneConvIdNonCollision - ] +spec :: Spec +spec = describe "one2OneConvId" do + prop "symmetry" one2OneConvIdSymmetry + it "non-collision" one2OneConvIdNonCollision one2OneConvIdSymmetry :: BaseProtocolTag -> Qualified UserId -> Qualified UserId -> Property one2OneConvIdSymmetry proto quid1 quid2 = one2OneConvId proto quid1 quid2 === one2OneConvId proto quid2 quid1 -- | Make sure that we never get the same conversation ID for a pair of -- (assumingly) distinct qualified user IDs -one2OneConvIdNonCollision :: Assertion +one2OneConvIdNonCollision :: IO () one2OneConvIdNonCollision = do let len = 10_000 -- A generator of lists of length 'len' of qualified user ID pairs let gen = vectorOf len arbitrary quids <- nubOrd <$> generate gen let hashes = nubOrd (fmap (uncurry (one2OneConvId BaseProtocolProteusTag)) quids) - length hashes @?= length quids + length hashes `shouldBe` length quids diff --git a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs index 5c45b433bc6..78ff882c602 100644 --- a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs @@ -25,6 +25,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range (checked, unsafeRange) import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock import Imports @@ -36,6 +37,8 @@ import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample, ioProperty, (.&&.), (===), (==>)) import Text.Email.Parser (unsafeEmailAddress) +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Meeting qualified as API import Wire.API.Team.Feature import Wire.API.Team.Member (TeamMember, mkTeamMember) @@ -68,6 +71,8 @@ type TestStack = State UTCTime, Random, State StdGen, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, Embed IO ] @@ -81,6 +86,11 @@ interpretFeaturesConfigSubsystemPure configs = interpret $ \case GetAllTeamFeaturesForTeamMember _luid _tid -> pure def GetAllTeamFeaturesForTeam _tid -> pure def GetAllTeamFeaturesForServer -> pure def + GuardSecondFactorDisabled _ _ -> error "not implemented" + FeatureEnabledForTeam _ _ -> error "not implemented" + GetAllTeamFeaturesForUser _ -> error "not implemented" + GetSingleFeatureForUser _ -> error "not implemented" + GetFeatureInternal _ -> error "not implemented" runTestStack :: UTCTime -> @@ -91,6 +101,9 @@ runTestStack :: IO (Either MeetingError a) runTestStack now gen teams configs = runM + . fmap (either (error . show) (either (error . show) Imports.id)) + . runError @(Tagged 'TeamNotFound ()) + . runError @(Tagged 'TeamMemberNotFound ()) . evalState gen . randomToStatefulStdGen . evalState now diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index d64f1e10b5b..88624c7019f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -59,6 +59,7 @@ import Data.Map.Lazy qualified as LM import Data.Map.Strict qualified as M import Data.Proxy import Data.Qualified +import Data.Tagged (Tagged) import Data.Time import Data.Type.Equality import Data.Vector qualified as Vector @@ -77,6 +78,9 @@ import System.Logger qualified as Log import Test.QuickCheck import Type.Reflection import Wire.API.Allowlists (AllowlistEmailDomains) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Federation.API import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -96,10 +100,13 @@ import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Config import Wire.AuthenticationSubsystem.Cookie.Limit import Wire.AuthenticationSubsystem.Interpreter +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BlockListStore +import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ClientStore import Wire.ClientSubsystem import Wire.ClientSubsystem.Interpreter +import Wire.ConversationSubsystem (ConversationSubsystem) import Wire.DeleteQueue import Wire.DeleteQueue.InMemory import Wire.DomainRegistrationStore qualified as DRS @@ -132,6 +139,7 @@ import Wire.TeamCollaboratorsSubsystem import Wire.TeamCollaboratorsSubsystem.Interpreter import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem.GalleyAPI +import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserGroupStore (UserGroupStore) import Wire.UserKeyStore import Wire.UserStore @@ -242,7 +250,8 @@ data MiniBackendParams r = MiniBackendParams teams :: Map TeamId [TeamMember], galleyConfigs :: AllTeamFeatures, usrCfg :: UserSubsystemConfig, - appCfg :: AppSubsystemConfig + appCfg :: AppSubsystemConfig, + conversationCfg :: ConversationSubsystemConfig } -- | `MiniBackendLowerEffects` is not a long, flat list, but a tree of effects. This way we @@ -253,7 +262,13 @@ data MiniBackendParams r = MiniBackendParams -- organize along effect types ("all `State`s"), but the domain ("everything about block -- lists"). type MiniBackendLowerEffects = - '[ TeamSubsystem, + '[ ClientSubsystem, + Input ConversationSubsystemConfig, + BrigAPIAccess, + UserClientIndexStore, + BackendNotificationQueueAccess, + ConversationSubsystem, + TeamSubsystem, EmailSubsystem, NotificationSubsystem, VerificationCodeSubsystem, @@ -281,7 +296,9 @@ type MiniBackendLowerEffects = Events, CryptoSign, Random, - Now + Now, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound ] `Append` InputEffects `Append` '[ Metrics @@ -305,6 +322,10 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . stateEffectsInterpreters mb . ignoreMetrics . inputEffectsInterpreters usrCfg appCfg localBackend.teamIdps + . fmap (either (error . show) Imports.id) + . runError @(Tagged 'TeamNotFound ()) + . fmap (either (error . show) Imports.id) + . runError @(Tagged 'TeamMemberNotFound ()) . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) . runRandomPure . runCryptoSignUnsafe @@ -334,6 +355,29 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . inMemoryNotificationSubsystemInterpreter . noopEmailSubsystemInterpreter . interpretTeamSubsystemToGalleyAPI + . mockConversationSubsystem + . mockBackendNotificationQueueAccess + . mockUserClientIndexStore + . mockBrigAPIAccess + . runInputConst conversationCfg + . runClientSubsystem undefined undefined + where + -- Mock BrigAPIAccess interpreter for tests + mockBrigAPIAccess :: forall r'. InterpreterFor BrigAPIAccess r' + mockBrigAPIAccess = interpret $ \case + _ -> error "Unimplemented BrigAPIAccess operation in mock" + -- Mock UserClientIndexStore interpreter for tests + mockUserClientIndexStore :: forall r'. InterpreterFor UserClientIndexStore r' + mockUserClientIndexStore = interpret $ \case + _ -> error "Unimplemented UserClientIndexStore operation in mock" + -- Mock BackendNotificationQueueAccess interpreter for tests + mockBackendNotificationQueueAccess :: forall r'. InterpreterFor BackendNotificationQueueAccess r' + mockBackendNotificationQueueAccess = interpret $ \case + _ -> error "Unimplemented BackendNotificationQueueAccess operation in mock" + -- Mock ConversationSubsystem interpreter for tests + mockConversationSubsystem :: forall r'. InterpreterFor ConversationSubsystem r' + mockConversationSubsystem = interpretH $ \case + _ -> error "Unimplemented ConversationSubsystem operation in mock" type StateEffects = '[ State [Push], @@ -643,6 +687,14 @@ interpretFederationStackState localBackend backends teams usrCfg = localBackend = localBackend, galleyConfigs = def, appCfg = def, + conversationCfg = + ConversationSubsystemConfig + { listClientsUsingBrig = False, + legalholdDefaults = def, + mlsKeys = Nothing, + maxConvSize = 10, + federationProtocols = Nothing + }, .. } @@ -705,6 +757,14 @@ interpretNoFederationStackState localBackend teams galleyConfigs usrCfg = localBackend = localBackend, galleyConfigs = galleyConfigs, appCfg = def, + conversationCfg = + ConversationSubsystemConfig + { listClientsUsingBrig = False, + legalholdDefaults = def, + mlsKeys = Nothing, + maxConvSize = 10, + federationProtocols = Nothing + }, .. } diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs index 74230077f5a..e0dfadc71cc 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs @@ -41,8 +41,8 @@ type ConversationMembers = Map ConvId (Set UserId) inMemoryConversationSubsystemInterpreter :: (Member (State (Map ConvId StoredConversation)) r, Member (State ConversationMembers) r, Member Random r) => InterpreterFor ConversationSubsystem r -inMemoryConversationSubsystemInterpreter = interpret $ \case - CreateGroupConversation lusr _mconn newConv -> do +inMemoryConversationSubsystemInterpreter = interpretH $ \case + InternalCreateGroupConversation lusr _mconn newConv -> do cid <- Random.newId let conv = StoredConversation @@ -71,8 +71,8 @@ inMemoryConversationSubsystemInterpreter = interpret $ \case } modify (Map.insert cid conv) modify (Map.insert cid (Set.singleton (tUnqualified lusr))) - pure conv + pureT conv InternalGetLocalMember cid uid -> do members <- gets (Map.lookup cid) - pure $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing + pureT $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing _ -> error "ConversationSubsystem: not implemented in mock" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 2f08144ef81..4d79967500b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -56,6 +56,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case (\members -> any (\member -> member ^. userId == uid) members) teams GetTeam _ -> error "GetTeam not implemented in miniGalleyAPIAccess" + FindTeam _ -> error "FindTeam not implemented in miniGalleyAPIAccess" GetTeamName _ -> error "GetTeamName not implemented in miniGalleyAPIAccess" GetTeamLegalHoldStatus _ -> error "GetTeamLegalHoldStatus not implemented in miniGalleyAPIAccess" GetUserLegalholdStatus _ _ -> error "GetUserLegalholdStatus not implemented in miniGalleyAPIAccess" @@ -92,6 +93,8 @@ miniGalleyAPIAccess teams configs = interpret $ \case maxConvSize = 500, listClientsUsingBrig = False } + GetUserLHStatus _ _ -> error "GetUserLHStatus not implemented in miniGalleyAPIAccess" + GetUsersLHStatus _ -> error "GetUsersLHStatus not implemented in miniGalleyAPIAccess" GuardLegalHold {} -> pure () -- this is called but the result is not needed in unit tests diff --git a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs index 31ebb431d53..fba4f321bd2 100644 --- a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs @@ -6,6 +6,7 @@ import Data.LegalHold (UserLegalHoldStatus (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.IO qualified as TL @@ -14,6 +15,7 @@ import Data.X509.CertificateStore qualified as X509 import Imports import Network.Mail.Mime (Address (..), Mail (..), Part (..), PartContent (..)) import Polysemy +import Polysemy.Error (runError) import Polysemy.State import SAML2.WebSSO import System.FilePath @@ -23,6 +25,8 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Email.Parser (unsafeEmailAddress) import URI.ByteString +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Locale import Wire.API.Password import Wire.API.Routes.Internal.Brig (IdpChangedNotification (..)) @@ -347,6 +351,8 @@ runInterpreters :: Logger (Logger.Msg -> Logger.Msg), EmailSending, State [Mail], + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, Embed IO ] a -> @@ -355,6 +361,9 @@ runInterpreters users teamMap teamTemplates branding action = do lr <- newLogRecorder (mails, res) <- runM + . fmap (either (error . show) (either (error . show) Imports.id)) + . runError @(Tagged 'TeamNotFound ()) + . runError @(Tagged 'TeamMemberNotFound ()) . runState @[Mail] [] -- Use runState to capture and return the Mail state . recordingEmailSendingInterpreter . recordLogs lr diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 3cdf8408a41..6861f097797 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -75,10 +75,10 @@ runDependenciesSafe :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UGS.UserGroupSubsystemError (Either ScimSubsystemError a) + Either UGS.LocalErrors (Either ScimSubsystemError a) runDependenciesSafe initialUsers initialTeams = run - . runError + . UGS.runLocalErrors . UGS.interpretDependencies initialUsers initialTeams . UGS.interpretUserGroupSubsystem . mockBrigAPIAccess initialUsers diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs similarity index 54% rename from services/galley/test/unit/Test/Galley/Mapping.hs rename to libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs index 575995457a1..eaee1a974f4 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs @@ -18,86 +18,77 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Galley.Mapping where +module Wire.StoredConversationSpec where import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.API.Mapping -import Galley.Types.Error (InternalError) import Imports -import Polysemy (Sem) -import Polysemy qualified as P -import Polysemy.Error qualified as P -import Polysemy.TinyLog qualified as P -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Arbitrary (..), Gen, listOf, (==>)) import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), - RemoteConversationV2 (..), + RemoteConversationView (..), ) -import Wire.Sem.Logger qualified as P import Wire.StoredConversation -run :: Sem '[P.TinyLog, P.Error InternalError] a -> Either InternalError a -run = P.run . P.runError . P.discardLogs - -tests :: TestTree -tests = - testGroup - "ConversationMapping" - [ testProperty "conversation view V9 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (conversationViewV9 luid c)), - testProperty "conversation view V10 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (pure $ conversationView (qualifyAs luid ()) (Just luid) c)), - testProperty "self user in conversation view is correct" $ - \(ConvWithLocalUser c luid) -> - fmap (memId . cmSelf . cnvMembers) (run (conversationViewV9 luid c)) - == Right (tUntagged luid), - testProperty "conversation view metadata is correct" $ - \(ConvWithLocalUser c luid) -> - fmap cnvMetadata (run (conversationViewV9 luid c)) - == Right c.metadata, - testProperty "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c luid) -> case run $ conversationViewV9 luid c of - Left _ -> False - Right cnv -> - tUntagged luid - `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)), - testProperty "conversation view contains all users" $ - \(ConvWithLocalUser c luid) -> - fmap (sort . cnvUids) (run (conversationViewV9 luid c)) - == Right (sort (convUids (tDomain luid) c)), - testProperty "conversation view for an invalid user is empty" $ - \(RandomConversation c) luid -> - notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> - isLeft (run (conversationViewV9 luid c)), - testProperty "remote conversation view for a valid user is non-empty" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - isJust (conversationToRemote dom ruid c), - testProperty "self user role in remote conversation view is correct" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (selfRole . (.members)) (conversationToRemote dom ruid c) - == Just roleNameWireMember, - testProperty "remote conversation view metadata is correct" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (.metadata) (conversationToRemote dom ruid c) - == Just c.metadata, - testProperty "remote conversation view does not contain self" $ - \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of - Nothing -> False - Just rcnv -> - tUntagged ruid - `notElem` map omQualifiedId rcnv.members.others - ] +spec :: Spec +spec = describe "ConversationMapping" do + prop "conversation view V9 for a valid user is non-empty" $ + \(ConvWithLocalUser c luid) -> isJust (ownConversationView luid c) + prop "conversation view V10 for a valid user is non-empty" $ + \(ConvWithLocalUser c luid) -> isJust (pure $ conversationView (qualifyAs luid ()) (Just luid) c) + prop "self user in conversation view is correct" $ + \(ConvWithLocalUser c luid) -> + fmap (memId . cmSelf . cnvMembers) (ownConversationView luid c) + == Just (tUntagged luid) + prop "conversation view metadata is correct" $ + \(ConvWithLocalUser c luid) -> + fmap cnvMetadata (ownConversationView luid c) + == Just c.metadata + prop "other members in conversation view do not contain self" $ + \(ConvWithLocalUser c luid) -> case ownConversationView luid c of + Nothing -> False + Just cnv -> + tUntagged luid + `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)) + prop "conversation view contains all users" $ + \(ConvWithLocalUser c luid) -> + fmap (sort . cnvUids) (ownConversationView luid c) + == Just (sort (convUids (tDomain luid) c)) + prop "conversation view for an invalid user is empty" $ + \(RandomConversation c) luid -> + notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> + isNothing (ownConversationView luid c) + prop "remote conversation view for a valid user is non-empty" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) + /= dom + ==> isJust (conversationToRemote dom ruid c) + prop "self user role in remote conversation view is correct" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) + /= dom + ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) + == Just roleNameWireMember + prop "remote conversation view metadata is correct" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) + /= dom + ==> fmap (.metadata) (conversationToRemote dom ruid c) + == Just c.metadata + prop "remote conversation view does not contain self" $ + \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of + Nothing -> False + Just rcnv -> + tUntagged ruid + `notElem` map omQualifiedId rcnv.members.others cnvUids :: OwnConversation -> [Qualified UserId] cnvUids c = diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index dd2cf24f721..ce135460d02 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -26,6 +26,7 @@ import Data.Id import Data.LegalHold import Data.Map qualified as Map import Data.Qualified +import Data.Tagged (Tagged) import Data.Text.Encoding import Data.Time import Imports @@ -38,6 +39,8 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.EnterpriseLogin +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Team.Invitation import Wire.API.Team.Member import Wire.API.Team.Permission @@ -62,8 +65,7 @@ import Wire.UserSubsystem import Wire.Util type AllEffects = - [ Error TeamInvitationSubsystemError, - EnterpriseLoginSubsystem, + [ EnterpriseLoginSubsystem, TinyLog, TeamSubsystem, GalleyAPIAccess, @@ -75,6 +77,9 @@ type AllEffects = State (Map (InvitationCode) StoredInvitation), Now, State UTCTime, + Error TeamInvitationSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, EmailSubsystem, State (Map EmailAddress [SentMail]), UserSubsystem, @@ -89,7 +94,7 @@ data RunAllEffectsArgs = RunAllEffectsArgs } deriving (Eq, Show) -runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationSubsystemError a +runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either LocalErrors a runAllEffects args = run . runInMemoryUserKeyStoreIntepreterWithStoredUsers args.initialUsers @@ -97,6 +102,7 @@ runAllEffects args = . inMemoryUserSubsystemInterpreter . evalState mempty . noopEmailSubsystemInterpreter + . runLocalErrors . evalState defaultTime . interpretNowAsState . evalState mempty @@ -109,7 +115,26 @@ runAllEffects args = . interpretTeamSubsystemToGalleyAPI . discardTinyLogs . enterpriseLoginSubsystemTestInterpreter args.constGuardResult - . runError + +data LocalErrors + = ETeamMemberNotFound + | ETeamNotFound + | ESubsystem TeamInvitationSubsystemError + deriving stock (Eq, Show) + +runLocalErrors :: + Sem (Error TeamInvitationSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a -> + Sem r (Either LocalErrors a) +runLocalErrors = fmap toLocalErrors . runError . runError . runError + where + toLocalErrors :: + Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either TeamInvitationSubsystemError a)) -> + Either LocalErrors a + toLocalErrors = \case + Right (Right (Right a)) -> Right a + Right (Right (Left e)) -> Left (ESubsystem e) + Right (Left _) -> Left ETeamMemberNotFound + Left _ -> Left ETeamNotFound spec :: Spec spec = do @@ -192,7 +217,7 @@ spec = do -- run the test -- - outcome :: Either TeamInvitationSubsystemError () + outcome :: Either LocalErrors () outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do void $ inviteUser inviterLuid tid invReq @@ -201,11 +226,11 @@ spec = do teamNotAllowedOrWrongTeamIdFails = outcome === case domRegUpd.teamInvite of Allowed -> Right () - NotAllowed -> Left TeamInvitationNotAllowedForEmail + NotAllowed -> Left (ESubsystem TeamInvitationNotAllowedForEmail) Team allowedTid -> if allowedTid == tid then Right () - else Left TeamInvitationNotAllowedForEmail + else Left (ESubsystem TeamInvitationNotAllowedForEmail) backendRedirectOrNoRegistrationFails = case domRegUpd.domainRedirect of Backend _ _ -> @@ -213,7 +238,7 @@ spec = do teamNotAllowedOrWrongTeamIdFails NoRegistration -> if isJust preExistingPersonalAccount - then outcome === Left TeamInvitationNotAllowedForEmail + then outcome === Left (ESubsystem TeamInvitationNotAllowedForEmail) else teamNotAllowedOrWrongTeamIdFails _ -> teamNotAllowedOrWrongTeamIdFails @@ -283,7 +308,7 @@ spec = do constGuardResult = Nothing } - outcome :: Either TeamInvitationSubsystemError () + outcome :: Either LocalErrors () outcome = runAllEffects interpreterArgs . runTeamInvitationSubsystem config $ do void $ inviteUser inviterLuid tid invitationRequest - in pure $ outcome === Left TeamInvitationBlockedDomain + in pure $ outcome === Left (ESubsystem TeamInvitationBlockedDomain) diff --git a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs index c4288743fee..404c0931af3 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs @@ -33,6 +33,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.UUID qualified as UUID import Data.Vector qualified as V import Imports @@ -46,6 +47,8 @@ import System.Timeout (timeout) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Pagination import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll), Route (RouteAny)) import Wire.API.Team.Member as TM @@ -80,26 +83,34 @@ type AllDependencies = BackgroundJobsPublisher.BackgroundJobsPublisher, State [Push], Random.Random, - Error UserGroupSubsystemError + Error UserGroupSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound ] -runDependenciesFailOnError :: (HasCallStack) => [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies (IO ()) -> IO () -runDependenciesFailOnError usrs team = either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team +runDependenciesFailOnError :: + (HasCallStack) => + [StoredUser] -> + Map TeamId [TeamMember] -> + Sem AllDependencies (IO ()) -> + IO () +runDependenciesFailOnError usrs team = + either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team runDependencies :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UserGroupSubsystemError a + Either LocalErrors a runDependencies initialUsers initialTeams = - run . runError . interpretDependencies initialUsers initialTeams + run . runLocalErrors . interpretDependencies initialUsers initialTeams interpretDependencies :: forall r a. [StoredUser] -> Map TeamId [TeamMember] -> Sem (AllDependencies `Append` r) a -> - Sem ('[Error UserGroupSubsystemError] `Append` r) a + Sem ('[Error UserGroupSubsystemError, ErrorS 'TeamMemberNotFound, ErrorS 'TeamNotFound] `Append` r) a interpretDependencies initialUsers initialTeams = Random.randomToNull . evalState mempty @@ -116,10 +127,10 @@ runDependenciesWithReturnState :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UserGroupSubsystemError ([Push], a) + Either LocalErrors ([Push], a) runDependenciesWithReturnState initialUsers initialTeams = run - . runError + . runLocalErrors . Random.randomToNull . runState mempty . noopBackgroundJobsPublisher @@ -131,6 +142,26 @@ runDependenciesWithReturnState initialUsers initialTeams = . interpretTeamSubsystemToGalleyAPI . runInMemoryUserSubsytemInterpreter initialUsers mempty +data LocalErrors + = ETeamMemberNotFound + | ETeamNotFound + | ESubsystem UserGroupSubsystemError + deriving stock (Eq, Show) + +runLocalErrors :: + Sem (Error UserGroupSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a -> + Sem r (Either LocalErrors a) +runLocalErrors = fmap toLocalErrors . runError . runError . runError + where + toLocalErrors :: + Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either UserGroupSubsystemError a)) -> + Either LocalErrors a + toLocalErrors = \case + Right (Right (Right a)) -> Right a + Right (Right (Left e)) -> Left (ESubsystem e) + Right (Left _) -> Left ETeamMemberNotFound + Left _ -> Left ETeamNotFound + expectRight :: (Show err) => Either err Property -> Property expectRight = \case Left err -> counterexample ("Unexpected error: " <> show err) False @@ -231,7 +262,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins should be able to create a group" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -243,7 +274,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team members are allowed in the group" $ \team otherUsers newUserGroupName -> let othersWithoutTeamMembers = filter (\u -> u.teamId /= Just team.tid) otherUsers in notNull othersWithoutTeamMembers - ==> expectLeft UserGroupMemberIsNotInTheSameTeam + ==> expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam) . runDependencies (allUsers team <> otherUsers) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -535,7 +566,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins should be able to update a group" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName newUserGroupName2 -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -603,7 +634,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins can delete user groups" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) groupName -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -662,7 +693,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do newGroupName (team2 :: ArbitraryTeam) (addOrRemove :: Bool) -> - expectLeft UserGroupMemberIsNotInTheSameTeam + expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -675,7 +706,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do newGroupName (team2 :: ArbitraryTeam) (addOrRemove :: Bool) -> - expectLeft UserGroupNotFound + expectLeft (ESubsystem UserGroupNotFound) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 8ba7efffdaa..dd2e897a6c3 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -104,6 +104,7 @@ common common-all , bytestring-conversion , case-insensitive , cassandra-util + , comonad , conduit , constraints , containers @@ -142,6 +143,7 @@ common common-all , imports , iproute , iso639 + , kan-extensions , lens , lens-aeson , lrucaching @@ -255,12 +257,47 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem + Wire.ConversationSubsystem.Action + Wire.ConversationSubsystem.Action.Kick + Wire.ConversationSubsystem.Action.Leave + Wire.ConversationSubsystem.Action.Notify + Wire.ConversationSubsystem.Action.Reset + Wire.ConversationSubsystem.Clients + Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.CreateInternal + Wire.ConversationSubsystem.Errors + Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Fetch Wire.ConversationSubsystem.Internal Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.LegalholdConflicts + Wire.ConversationSubsystem.Message + Wire.ConversationSubsystem.MLS + Wire.ConversationSubsystem.MLS.CheckClients + Wire.ConversationSubsystem.MLS.Commit.Core + Wire.ConversationSubsystem.MLS.Commit.ExternalCommit + Wire.ConversationSubsystem.MLS.Commit.InternalCommit + Wire.ConversationSubsystem.MLS.Conversation + Wire.ConversationSubsystem.MLS.Enabled + Wire.ConversationSubsystem.MLS.GroupInfo + Wire.ConversationSubsystem.MLS.GroupInfoCheck + Wire.ConversationSubsystem.MLS.IncomingMessage + Wire.ConversationSubsystem.MLS.Keys + Wire.ConversationSubsystem.MLS.Message + Wire.ConversationSubsystem.MLS.Migration + Wire.ConversationSubsystem.MLS.One2One + Wire.ConversationSubsystem.MLS.OutOfSync + Wire.ConversationSubsystem.MLS.Propagate + Wire.ConversationSubsystem.MLS.Proposal + Wire.ConversationSubsystem.MLS.Removal + Wire.ConversationSubsystem.MLS.Reset + Wire.ConversationSubsystem.MLS.SubConversation + Wire.ConversationSubsystem.MLS.Util + Wire.ConversationSubsystem.MLS.Welcome Wire.ConversationSubsystem.Notify Wire.ConversationSubsystem.One2One + Wire.ConversationSubsystem.Query + Wire.ConversationSubsystem.Update Wire.ConversationSubsystem.Util Wire.CustomBackendStore Wire.CustomBackendStore.Cassandra @@ -536,6 +573,8 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec Wire.ClientSubsystem.InterpreterSpec + Wire.ConversationSubsystem.MessageSpec + Wire.ConversationSubsystem.One2OneSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec Wire.FederationSubsystem.InternalsSpec Wire.HashPassword.InterpreterSpec @@ -585,6 +624,7 @@ test-suite wire-subsystems-tests Wire.RateLimited.InterpreterSpec Wire.SAMLEmailSubsystem.InterpreterSpec Wire.ScimSubsystem.InterpreterSpec + Wire.StoredConversationSpec Wire.TeamCollaboratorsSubsystem.InterpreterSpec Wire.TeamInvitationSubsystem.InterpreterSpec Wire.UserGroupSubsystem.InterpreterSpec diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 20dc97d1263..981ae2139f6 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -26,7 +26,9 @@ import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control import Data.Domain (Domain) +import Data.Id (TeamId) import Data.Map.Strict qualified as Map +import Data.Misc (HttpsUrl) import HTTP2.Client.Manager import Hasql.Pool qualified as Hasql import Hasql.Pool.Extended @@ -43,9 +45,13 @@ import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..)) import System.Logger.Extended qualified as Log import Util.Options +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.BackgroundWorker.Options +import Wire.Options.Galley (GuestLinkTTLSeconds, conversationCodeURISettings) import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (RateLimitEnv, newRateLimitEnv) type IsWorking = Bool @@ -87,7 +93,17 @@ data Env = Env gundeckEndpoint :: Endpoint, sparEndpoint :: Endpoint, galleyEndpoint :: Endpoint, - brigEndpoint :: Endpoint + brigEndpoint :: Endpoint, + maxTeamSize :: !Word32, + maxFanoutSize :: !(Maybe FanoutLimit), + exposeInvitationURLsTeamAllowlist :: !(Maybe [TeamId]), + intraListing :: !Bool, + federationProtocols :: !(Maybe [ProtocolTag]), + guestLinkTTLSeconds :: !(Maybe GuestLinkTTLSeconds), + passwordHashingOptions :: !PasswordHashingOptions, + checkGroupInfo :: !(Maybe Bool), + convCodeURI :: Either HttpsUrl (Map Text HttpsUrl), + passwordHashingRateLimitEnv :: RateLimitEnv } data BackendNotificationMetrics = BackendNotificationMetrics @@ -138,6 +154,14 @@ mkEnv opts galleyOpts = do galleyEndpoint = opts.galley gundeckEndpoint = opts.gundeck sparEndpoint = opts.spar + maxTeamSize = galleyOpts._settings._maxTeamSize + maxFanoutSize = galleyOpts._settings._maxFanoutSize + exposeInvitationURLsTeamAllowlist = galleyOpts._settings._exposeInvitationURLsTeamAllowlist + intraListing = galleyOpts._settings._intraListing + federationProtocols = galleyOpts._settings._federationProtocols + guestLinkTTLSeconds = galleyOpts._settings._guestLinkTTLSeconds + passwordHashingOptions = galleyOpts._settings._passwordHashingOptions + checkGroupInfo = galleyOpts._settings._checkGroupInfo workerRunningGauge <- mkWorkerRunningGauge hasqlPool <- initPostgresPool opts.postgresqlPool galleyOpts._postgresql galleyOpts._postgresqlPassword amqpJobsPublisherChannel <- @@ -146,6 +170,8 @@ mkEnv opts galleyOpts = do amqpBackendNotificationsChannel <- mkRabbitMqChannelMVar logger (Just "background-worker-backend-notifications") $ either id demoteOpts opts.rabbitmq.unRabbitMqOpts + convCodeURI <- conversationCodeURISettings galleyOpts + passwordHashingRateLimitEnv <- newRateLimitEnv galleyOpts._settings._passwordHashingRateLimit pure Env {..} initHttp2Manager :: IO Http2Manager diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 4c13bf2d047..842dec6ec80 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,6 +22,7 @@ where import Bilge qualified import Bilge.Retry +import Cassandra (ClientState) import Control.Monad.Catch import Control.Retry import Data.ByteString qualified as BS @@ -32,27 +33,33 @@ import Data.Qualified import Data.Tagged (Tagged) import Data.Text qualified as T import Data.Text.Lazy qualified as TL -import Galley.Types.Error (InternalError, InvalidInput, internalErrorDescription, legalHoldServiceUnavailable) +import Galley.Types.Error (InternalError, internalErrorDescription, legalHoldServiceUnavailable) import Hasql.Pool (UsageError) +import Hasql.Pool qualified as Hasql import Imports import Network.HTTP.Client qualified as Http +import Network.Wai.Utilities.JSONResponse (JSONResponse (..)) import OpenSSL.Session qualified as SSL import Polysemy import Polysemy.Async (asyncToIOFinal) import Polysemy.Conc import Polysemy.Error import Polysemy.Input +import Polysemy.Resource (resourceToIOFinal) import Polysemy.TinyLog qualified as P import Ssl.Util import System.Logger as Logger import System.Logger.Class qualified as Log import URI.ByteString (uriPath) import Wire.API.BackgroundJobs (Job (..)) -import Wire.API.Conversation.Config (ConversationSubsystemConfig) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Error (APIError (toResponse), DynError (..)) import Wire.API.Error.Galley import Wire.API.Federation.Error (FederationError) +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Team.Collaborator (TeamCollaboratorsError) -import Wire.API.Team.FeatureFlags (FeatureDefaults (FeatureLegalHoldDisabledPermanently)) +import Wire.API.Team.Feature (LegalholdConfig) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults (FeatureLegalHoldDisabledPermanently), currentFanoutLimit) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BackgroundJobsRunner (runJob) @@ -60,23 +67,32 @@ import Wire.BackgroundJobsRunner.Interpreter hiding (runJob) import Wire.BackgroundWorker.Env (AppT, Env (..)) import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError) +import Wire.CodeStore.Cassandra (interpretCodeStoreToCassandra) +import Wire.CodeStore.DualWrite (interpretCodeStoreToCassandraAndPostgres) +import Wire.CodeStore.Postgres (interpretCodeStoreToPostgres) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (..), interpretConversationSubsystem) import Wire.ExternalAccess.External import Wire.FeaturesConfigSubsystem (getAllTeamFeaturesForServer) import Wire.FeaturesConfigSubsystem.Interpreter (runFeaturesConfigSubsystem) import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist (..)) import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) +import Wire.FederationSubsystem.Interpreter (runFederationSubsystem) import Wire.FireAndForget (interpretFireAndForget) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) import Wire.GundeckAPIAccess +import Wire.HashPassword.Interpreter (runHashPassword) import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.NotificationSubsystem.Interpreter +import Wire.Options.Galley (GuestLinkTTLSeconds) import Wire.ParseException import Wire.PostgresMigrationOpts +import Wire.ProposalStore.Cassandra (interpretProposalStoreToCassandra) +import Wire.RateLimit (RateLimitExceeded) +import Wire.RateLimit.Interpreter (interpretRateLimit) import Wire.Rpc import Wire.Sem.Concurrency (ConcurrencySafety (Unsafe)) import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) @@ -174,45 +190,53 @@ dispatchJob job = do let makeReq fpr url rb = makeVerifiedRequestIO env.logger extEnv fpr url rb makeReqFresh fpr url rb = makeVerifiedRequestFreshManagerIO env.logger fpr url rb in LegalHoldEnv {makeVerifiedRequest = makeReq, makeVerifiedRequestFreshManager = makeReqFresh} + convCodesStoreInterpreter = + case env.postgresMigration.conversationCodes of + CassandraStorage -> interpretCodeStoreToCassandra + MigrationToPostgresql -> interpretCodeStoreToCassandraAndPostgres + PostgresqlStorage -> interpretCodeStoreToPostgres runFinal @IO . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO . asyncToIOFinal . interpretRace . runDelay + . resourceToIOFinal . runError + . mapError @DynError (.eMessage) + . mapError @JSONResponse (T.pack . show . (.value)) + . mapError @ConversationSubsystemError toResponse . mapError @ClientError (T.pack . displayException) . mapError @FederationError (T.pack . displayException) . mapError @UsageError (T.pack . show) . mapError @ParseException (T.pack . displayException) - . mapError (const ("Invalid input" :: Text) :: InvalidInput -> Text) . mapError @MigrationError (T.pack . show) . mapError @InternalError (TL.toStrict . internalErrorDescription) . mapError @UnreachableBackends (T.pack . show) . mapError @TeamCollaboratorsError (const ("Team collaborators error" :: Text)) . mapError @TeamFeatureStoreError (const ("Team feature store error" :: Text)) - . mapError @(Tagged HistoryNotSupported ()) (const ("History not supported" :: Text)) - . mapError @(Tagged OperationDenied ()) (const ("Operation denied" :: Text)) . mapError @(Tagged 'NotATeamMember ()) (const ("Not a team member" :: Text)) . mapError @(Tagged 'ConvAccessDenied ()) (const ("Conversation access denied" :: Text)) - . mapError @(Tagged 'NotConnected ()) (const ("Not connected" :: Text)) - . mapError @(Tagged 'MLSNotEnabled ()) (const ("MLS not enabled" :: Text)) - . mapError @(Tagged 'MLSNonEmptyMemberList ()) (const ("MLS non-empty member list" :: Text)) - . mapError @(Tagged 'MissingLegalholdConsent ()) (const ("Missing legalhold consent" :: Text)) - . mapError @(Tagged 'NonBindingTeam ()) (const ("Non-binding team" :: Text)) - . mapError @(Tagged 'NoBindingTeamMembers ()) (const ("No binding team members" :: Text)) . mapError @(Tagged 'TeamNotFound ()) (const ("Team not found" :: Text)) - . mapError @(Tagged 'InvalidOperation ()) (const ("Invalid operation" :: Text)) - . mapError @(Tagged 'ConvNotFound ()) (const ("Conversation not found" :: Text)) - . mapError @(Tagged 'ChannelsNotEnabled ()) (const ("Channels not enabled" :: Text)) - . mapError @(Tagged 'NotAnMlsConversation ()) (const ("Not an MLS conversation" :: Text)) + . mapError @(Tagged 'TeamMemberNotFound ()) (const ("Team member not found" :: Text)) + . mapError @(Tagged 'AccessDenied ()) (const ("Access denied" :: Text)) + . mapError @NonFederatingBackends (const ("Non federating backends" :: Text)) + . mapError @UnreachableBackendsLegacy (const ("Unreachable backends legacy" :: Text)) + . mapError @RateLimitExceeded (const ("Rate limit exceeded" :: Text)) . interpretTinyLog env job.requestId job.jobId - . runInputConst env.hasqlPool - . runInputConst (toLocalUnsafe env.federationDomain ()) - . runInputConst (FeatureLegalHoldDisabledPermanently) - . runInputConst env.cassandraGalley - . runInputConst legalHoldEnv - . runInputConst (ExposeInvitationURLsAllowlist []) + . runInputConst @Hasql.Pool env.hasqlPool + . runInputConst @(Local ()) (toLocalUnsafe env.federationDomain ()) + . runInputConst @(FeatureDefaults LegalholdConfig) FeatureLegalHoldDisabledPermanently + . runInputConst @ClientState env.cassandraGalley + . runInputConst @LegalHoldEnv legalHoldEnv + . runInputConst @ExposeInvitationURLsAllowlist (ExposeInvitationURLsAllowlist $ fromMaybe [] env.exposeInvitationURLsTeamAllowlist) + . runInputConst @(Either HttpsUrl (Map Text HttpsUrl)) env.convCodeURI + . runInputConst @IntraListing (IntraListing env.intraListing) + . runInputConst @(Maybe GroupInfoCheckEnabled) (GroupInfoCheckEnabled <$> env.checkGroupInfo) + . runInputConst @(Maybe GuestLinkTTLSeconds) env.guestLinkTTLSeconds + . runInputConst @FanoutLimit (currentFanoutLimit env.maxTeamSize env.maxFanoutSize) + . interpretMLSCommitLockStoreToCassandra env.cassandraGalley + . interpretProposalStoreToCassandra . interpretServiceStoreToCassandra env.cassandraBrig . interpretUserGroupStoreToPostgres . interpretTeamFeatureStoreToCassandra @@ -235,12 +259,20 @@ dispatchJob job = do . interpretBrigAccess env.brigEndpoint . interpretGalleyAPIAccessToRpc mempty env.galleyEndpoint . runInputSem getConversationSubsystemConfig + . runInputSem @(Maybe (MLSKeysByPurpose MLSPrivateKeys)) (inputs @ConversationSubsystemConfig (.mlsKeys)) . runInputSem getConfiguredFeatureFlags + . runHashPassword env.passwordHashingOptions + . interpretRateLimit env.passwordHashingRateLimitEnv + . convCodesStoreInterpreter . interpretExternalAccess extEnv . interpretSparAPIAccessToRpc env.sparEndpoint . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) . interpretFederationAPIAccess federationAPIAccessConfig . interpretTeamSubsystem teamSubsystemConfig + . ( \m -> do + p <- inputs @ConversationSubsystemConfig (.federationProtocols) + runFederationSubsystem p m + ) . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer . interpretTeamCollaboratorsSubsystem @@ -252,6 +284,7 @@ dispatchJob job = do Sem r ConversationSubsystemConfig getConversationSubsystemConfig = getConversationConfig + backendQueueEnv :: Env -> BackendNotificationQueueAccess.Env backendQueueEnv env = BackendNotificationQueueAccess.Env { channelMVar = env.amqpBackendNotificationsChannel, diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 30a9c045733..a3730bdaf27 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -57,7 +57,7 @@ import Test.Hspec import Test.QuickCheck import Test.Wire.Util import UnliftIO.Async -import Util.Options +import Util.Options (Endpoint (..), PasswordHashingOptions (..)) import Wire.API.Conversation.Action import Wire.API.Federation.API import Wire.API.Federation.API.Brig @@ -70,6 +70,7 @@ import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Options import Wire.BackgroundWorker.Util import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (newRateLimitEnv) spec :: Spec spec = do @@ -371,7 +372,17 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined - + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = PasswordHashingScrypt + checkGroupInfo = Nothing + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domains <- runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) @@ -412,6 +423,17 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = PasswordHashingScrypt + checkGroupInfo = Nothing + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domainsThread <- async $ runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 9810b9c2659..6aa6afa8c91 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -26,11 +26,12 @@ import Data.Range import Imports import Network.HTTP.Client hiding (Proxy) import System.Logger.Class qualified as Logger -import Util.Options (Endpoint (..)) +import Util.Options (Endpoint (..), PasswordHashingOptions (..)) import Wire.BackgroundWorker.Env hiding (federatorInternal) import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (RateLimitConfig (..), TokenBucketConfig (..), newRateLimitEnv) testEnv :: IO Env testEnv = do @@ -68,8 +69,30 @@ testEnv = do brigEndpoint = undefined sparEndpoint = Endpoint "localhost" 0 galleyEndpoint = undefined + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = PasswordHashingScrypt + checkGroupInfo = Nothing + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig pure Env {..} +defTestRateLimitConfig :: RateLimitConfig +defTestRateLimitConfig = + RateLimitConfig + { ipv4CidrBlock = 32, + ipv6CidrBlock = 128, + ipAddressExceptions = [], + maxRateLimitedKeys = 1000, + ipAddrLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000}, + userLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000}, + internalLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000} + } + runTestAppT :: AppT IO a -> Int -> IO a runTestAppT app port = do baseEnv <- testEnv diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index a5eb8d4f30b..270f1a7affa 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -42,6 +42,7 @@ import Data.ZAuth.CryptoSign (CryptoSign, runCryptoSign) import Hasql.Pool (UsageError) import Hasql.Pool qualified as Hasql import Imports +import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Async import Polysemy.Conc @@ -50,6 +51,8 @@ import Polysemy.Error (Error, errorToIOFinal, mapError, runError) import Polysemy.Input (Input, runInputConst) import Polysemy.Internal.Kind import Polysemy.TinyLog (TinyLog) +import Wire.API.Error (ErrorS, errorToWai) +import Wire.API.Error.Galley import Wire.API.Federation.Client qualified import Wire.API.Federation.Error import Wire.API.Team.Collaborator @@ -209,6 +212,9 @@ type BrigLowerLevelEffects = Error VerificationCodeSubsystemError, Error PropertySubsystemError, Error RateLimitExceeded, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, + Error Wai.Error, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, DomainVerificationChallengeStore, DomainRegistrationStore, @@ -437,6 +443,9 @@ runBrigToIO e (AppT ma) = do . interpretDomainRegistrationStoreToCassandra e.casClient . interpretDomainVerificationChallengeStoreToCassandra e.casClient e.settings.challengeTTL . interpretFederationAPIAccess federationApiAccessConfig + . mapError StdError -- Wai.Error + . mapError (const $ errorToWai @'TeamNotFound) -- ErrorS 'TeamNotFound + . mapError (const $ errorToWai @'TeamMemberNotFound) -- ErrorS 'TeamMemberNotFound . mapError rateLimitExceededToHttpError . mapError propertySubsystemErrorToHttpError . mapError verificationCodeSubsystemErrorToHttpError diff --git a/services/galley/default.nix b/services/galley/default.nix index 2aff9179654..716691efcad 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -18,7 +18,6 @@ , cassandra-util , cassava , cereal -, comonad , conduit , containers , cookie @@ -34,7 +33,6 @@ , galley-types , gitignoreSource , hasql-pool -, hex , hs-opentelemetry-instrumentation-wai , hs-opentelemetry-sdk , HsOpenSSL @@ -88,7 +86,6 @@ , tasty-ant-xml , tasty-cannon , tasty-hunit -, tasty-quickcheck , temporary , text , time @@ -103,8 +100,6 @@ , uri-bytestring , utf8-string , uuid -, uuid-types -, vector , wai , wai-extra , wai-middleware-gunzip @@ -134,16 +129,13 @@ mkDerivation { bytestring-conversion cassandra-util cassava - comonad containers data-default errors exceptions extended - extra galley-types hasql-pool - hex hs-opentelemetry-instrumentation-wai hs-opentelemetry-sdk HsOpenSSL @@ -169,11 +161,9 @@ mkDerivation { servant servant-server singletons - sop-core split ssl-util stm - tagged text time tinylog @@ -184,7 +174,6 @@ mkDerivation { uri-bytestring utf8-string uuid - vector wai wai-extra wai-middleware-gunzip @@ -277,24 +266,6 @@ mkDerivation { wire-subsystems yaml ]; - testHaskellDepends = [ - base - containers - extra - galley-types - imports - lens - polysemy - polysemy-wire-zoo - tasty - tasty-hunit - tasty-quickcheck - types-common - uuid-types - wire-api - wire-api-federation - wire-subsystems - ]; description = "Conversations"; license = lib.licenses.agpl3Only; } diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 8f706554d45..760d46ae5de 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -73,46 +73,12 @@ library -- cabal-fmt: expand src exposed-modules: - Galley.API.Action - Galley.API.Action.Kick - Galley.API.Action.Leave - Galley.API.Action.Notify - Galley.API.Action.Reset - Galley.API.Clients - Galley.API.Create Galley.API.CustomBackend Galley.API.Federation - Galley.API.Federation.Handlers Galley.API.Internal Galley.API.LegalHold - Galley.API.LegalHold.Conflicts - Galley.API.LegalHold.Get Galley.API.LegalHold.Team - Galley.API.Mapping Galley.API.Meetings - Galley.API.Message - Galley.API.MLS - Galley.API.MLS.CheckClients - Galley.API.MLS.Commit.Core - Galley.API.MLS.Commit.ExternalCommit - Galley.API.MLS.Commit.InternalCommit - Galley.API.MLS.Conversation - Galley.API.MLS.Enabled - Galley.API.MLS.GroupInfo - Galley.API.MLS.GroupInfoCheck - Galley.API.MLS.IncomingMessage - Galley.API.MLS.Keys - Galley.API.MLS.Message - Galley.API.MLS.Migration - Galley.API.MLS.One2One - Galley.API.MLS.OutOfSync - Galley.API.MLS.Propagate - Galley.API.MLS.Proposal - Galley.API.MLS.Removal - Galley.API.MLS.Reset - Galley.API.MLS.SubConversation - Galley.API.MLS.Util - Galley.API.MLS.Welcome Galley.API.Public.Bot Galley.API.Public.Conversation Galley.API.Public.CustomBackend @@ -126,13 +92,10 @@ library Galley.API.Public.TeamConversation Galley.API.Public.TeamMember Galley.API.Public.TeamNotification - Galley.API.Query Galley.API.Teams Galley.API.Teams.Export Galley.API.Teams.Features - Galley.API.Teams.Features.Get Galley.API.Teams.Notifications - Galley.API.Update Galley.App Galley.Cassandra Galley.Effects.Queue @@ -241,16 +204,13 @@ library , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 , cassava >=0.5.2 - , comonad , containers >=0.5 , data-default , errors >=2.0 , exceptions >=0.4 , extended - , extra >=1.3 , galley-types >=0.65.0 , hasql-pool - , hex , hs-opentelemetry-instrumentation-wai , hs-opentelemetry-sdk , HsOpenSSL >=0.11 @@ -276,11 +236,9 @@ library , servant , servant-server , singletons - , sop-core , split >=0.2 , ssl-util >=0.1 , stm >=2.4 - , tagged , text >=0.11 , time >=1.4 , tinylog >=0.10 @@ -291,7 +249,6 @@ library , uri-bytestring >=0.2 , utf8-string , uuid >=1.3 - , vector , wai >=3.0 , wai-extra >=3.0 , wai-middleware-gunzip >=0.0.2 @@ -520,35 +477,3 @@ executable galley-schema if flag(static) ld-options: -static - -test-suite galley-tests - import: common-all - type: exitcode-stdio-1.0 - main-is: ../unit.hs - other-modules: - Paths_galley - Run - Test.Galley.API.Message - Test.Galley.API.One2One - Test.Galley.Mapping - - ghc-options: -threaded -with-rtsopts=-N -Wno-x-partial - hs-source-dirs: test/unit - build-depends: - , base - , containers - , extra >=1.3 - , galley - , galley-types - , imports - , lens - , polysemy - , polysemy-wire-zoo - , tasty - , tasty-hunit - , tasty-quickcheck - , types-common - , uuid-types - , wire-api - , wire-api-federation - , wire-subsystems diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs deleted file mode 100644 index 638e2b56cfe..00000000000 --- a/services/galley/src/Galley/API/Create.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.Create where - -import Data.Id -import Data.Qualified -import Data.Set qualified as Set -import Galley.API.Mapping -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import Wire.API.Conversation (CreateGroupConversation (..), CreateGroupOwnConversation (..), NewConv, NewOne2OneConv) -import Wire.API.Conversation qualified as Public -import Wire.API.Error.Galley (UnreachableBackendsLegacy (..)) -import Wire.API.Event.Conversation (Connect) -import Wire.API.FederationStatus (RemoteDomains (..)) -import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import Wire.API.User (baseProtocolToProtocol) -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) - ----------------------------------------------------------------------------- --- API Handlers - -createGroupConversationUpToV3 :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error UnreachableBackendsLegacy) r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - Created <$> conversationViewV9 lusr dbConv - -createGroupOwnConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member FederationSubsystem r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) - -createGroupConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member FederationSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - pure $ - CreateGroupConversation - { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, - failedToAdd = mempty - } - -createProteusSelfConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c - -createOne2OneConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - NewOne2OneConv -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversation lusr zcon j = do - (c, created) <- ConversationSubsystem.createOne2OneConversation lusr zcon j - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c - ----------------------------------------------------------------------------- --- Helpers - -createConnectConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Connect -> - Sem r (ConversationResponse Public.OwnConversation) -createConnectConversation lusr conn j = do - (c, created) <- ConversationSubsystem.createConnectConversation lusr conn j - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 560000626df..d1e47cae92a 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -17,15 +17,19 @@ module Galley.API.Federation where -import Galley.API.Federation.Handlers +import Data.Domain import Galley.App +import Imports import Polysemy import Servant (ServerT) import Servant.API import Wire.API.Federation.API +import Wire.API.Federation.API.Common (EmptyResponse (..)) +import Wire.API.Federation.API.Galley import Wire.API.Federation.Endpoint import Wire.API.Federation.Version import Wire.API.Routes.Named +import Wire.ConversationSubsystem as ConversationSubsystem type FederationAPI = "federation" :> FedApi 'Galley @@ -33,26 +37,42 @@ type FederationAPI = "federation" :> FedApi 'Galley federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = - Named @"on-conversation-created" onConversationCreated - :<|> Named @"get-conversations@v1" getConversationsV1 - :<|> Named @"get-conversations" getConversations - :<|> Named @"leave-conversation" leaveConversation - :<|> Named @"send-message" sendMessage - :<|> Named @"update-conversation" updateConversation - :<|> Named @"mls-welcome" mlsSendWelcome - :<|> Named @"send-mls-message" sendMLSMessage - :<|> Named @"send-mls-commit-bundle" sendMLSCommitBundle - :<|> Named @"query-group-info" queryGroupInfo - :<|> Named @"update-typing-indicator" updateTypingIndicator - :<|> Named @"on-typing-indicator-updated" onTypingIndicatorUpdated - :<|> Named @"get-sub-conversation" getSubConversationForRemoteUser - :<|> Named @"delete-sub-conversation" deleteSubConversationForRemoteUser - :<|> Named @"leave-sub-conversation" leaveSubConversation - :<|> Named @"get-one2one-conversation@v1" getOne2OneConversationV1 - :<|> Named @"get-one2one-conversation" getOne2OneConversation - :<|> Named @"on-client-removed" onClientRemoved - :<|> Named @"on-message-sent" onMessageSent - :<|> Named @"on-mls-message-sent" onMLSMessageSent + Named @"on-conversation-created" federationOnConversationCreated + :<|> Named @"get-conversations@v1" federationGetLegacyConversations + :<|> Named @"get-conversations" federationGetConversations + :<|> Named @"leave-conversation" federationLeaveConversation + :<|> Named @"send-message" federationSendMessage + :<|> Named @"update-conversation" federationUpdateConversation + :<|> Named @"mls-welcome" federationMlsSendWelcome + :<|> Named @"send-mls-message" federationSendMLSMessage + :<|> Named @"send-mls-commit-bundle" federationSendMLSCommitBundle + :<|> Named @"query-group-info" federationQueryGroupInfo + :<|> Named @"update-typing-indicator" federationUpdateTypingIndicator + :<|> Named @"on-typing-indicator-updated" federationOnTypingIndicatorUpdated + :<|> Named @"get-sub-conversation" federationGetSubConversationForRemoteUser + :<|> Named @"delete-sub-conversation" federationDeleteSubConversationForRemoteUser + :<|> Named @"leave-sub-conversation" federationLeaveSubConversation + :<|> Named @"get-one2one-conversation@v1" federationGetLegacyOne2OneConversation + :<|> Named @"get-one2one-conversation" federationGetOne2OneConversation + :<|> Named @"on-client-removed" federationOnClientRemoved + :<|> Named @"on-message-sent" federationOnMessageSent + :<|> Named @"on-mls-message-sent" federationOnMLSMessageSent :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 - :<|> Named @"on-conversation-updated" onConversationUpdated - :<|> Named @"on-user-deleted-conversations" onUserDeleted + :<|> Named @"on-conversation-updated" federationOnConversationUpdated + :<|> Named @"on-user-deleted-conversations" federationOnUserDeleted + +onConversationUpdatedV0 :: + (Member ConversationSubsystem r) => + Domain -> + ConversationUpdateV0 -> + Sem r EmptyResponse +onConversationUpdatedV0 domain cu = + federationOnConversationUpdated domain (conversationUpdateFromV0 cu) + +federationGetLegacyConversations :: + (Member ConversationSubsystem r) => + Domain -> + GetConversationsRequest -> + Sem r GetConversationsResponse +federationGetLegacyConversations domain req = + getConversationsResponseFromView <$> ConversationSubsystem.federationGetConversations domain req diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 280fc91d94b..221da66c5b2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -37,22 +37,15 @@ import Data.Qualified import Data.Range import Data.Singletons import Data.Time -import Galley.API.Action -import Galley.API.Clients qualified as Clients -import Galley.API.Create qualified as Create import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) -import Galley.API.LegalHold.Conflicts -import Galley.API.MLS.Removal import Galley.API.Public.Servant -import Galley.API.Query qualified as Query import Galley.API.Teams import Galley.API.Teams qualified as Teams import Galley.API.Teams.Features -import Galley.API.Teams.Features.Get -import Galley.API.Update qualified as Update import Galley.App import Galley.Monad import Galley.Queue qualified as Q +import Galley.Types.Clients import Galley.Types.Error import Imports hiding (head) import Network.AMQP qualified as Q @@ -73,7 +66,6 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig.EJPD @@ -82,31 +74,28 @@ import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiTablePaging qualified as MTP import Wire.API.Team.Feature -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FeatureFlags) +import Wire.API.Team.LegalHold (UserLegalHoldStatusEntry (..)) import Wire.API.User (UserIds (cUsers)) import Wire.API.User.Client import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) -import Wire.ConversationStore +import Wire.ConversationStore hiding (getConversations) import Wire.ConversationStore qualified as ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.One2One -import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem as Conv +import Wire.ConversationSubsystem.LegalholdConflicts (LegalholdConflicts, LegalholdConflictsOldClients) import Wire.CustomBackendStore -import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem import Wire.FederationSubsystem (getFederationStatus) import Wire.LegalHoldStore as LegalHoldStore import Wire.ListItems import Wire.NotificationSubsystem -import Wire.Options.Galley hiding (brig) -import Wire.ProposalStore (ProposalStore) +import Wire.Options.Galley qualified import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -import Wire.Sem.Random (Random) import Wire.ServiceStore import Wire.StoredConversation import Wire.StoredConversation qualified as Data @@ -114,7 +103,7 @@ import Wire.TeamStore import Wire.TeamStore qualified as E import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -import Wire.UserClientIndexStore +import Wire.UserClientIndexStore as UserClientIndexStore import Wire.UserList import Wire.Util @@ -123,13 +112,13 @@ internalAPI = hoistAPI @InternalAPIBase Imports.id $ mkNamedAPI @"status" (pure ()) <@> mkNamedAPI @"delete-user" rmUser - <@> mkNamedAPI @"connect" Create.createConnectConversation + <@> mkNamedAPI @"connect" createConnectConversation <@> mkNamedAPI @"get-conversation-clients" iGetMLSClientListForConv <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH <@> legalholdWhitelistedTeamsAPI <@> iTeamsAPI <@> miscAPI - <@> mkNamedAPI @"upsert-one2one" iUpsertOne2OneConversation + <@> mkNamedAPI @"upsert-one2one" internalUpsertOne2OneConversation <@> featureAPI <@> federationAPI <@> conversationAPI @@ -145,23 +134,20 @@ getConversationConfigH = input iEJPDAPI :: API IEJPDAPI GalleyEffects iEJPDAPI = mkNamedAPI @"get-conversations-by-user" ejpdGetConvInfo --- | An unpaginated, internal http interface to `Query.conversationIdsPageFrom`. Used for +-- | An unpaginated, internal http interface to `conversationIdsPageFrom`. Used for -- EJPD reports. Called locally with very little data for each conv, so we don't expect -- pagination to ever be needed. ejpdGetConvInfo :: forall r. ( Member ConversationStore r, Member ConversationSubsystem r, - Member (Error InternalError) r, - Member (Input (Local ())) r, - Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member P.TinyLog r + Member (Input (Local ())) r ) => UserId -> Sem r [EJPDConvInfo] ejpdGetConvInfo uid = do luid <- qualifyLocal uid - firstPage <- Query.conversationIdsPageFrom luid initialPageRequest + firstPage <- conversationIdsPageFrom luid initialPageRequest getPages luid firstPage where initialPageRequest = mkPageRequest (MTP.MultiTablePagingState MTP.PagingLocals Nothing) @@ -184,7 +170,7 @@ ejpdGetConvInfo uid = do renderedPage <- mapMaybe mk <$> ConversationStore.getConversations (fst $ partitionQualified luid convids) if MTP.mtpHasMore page then do - newPage <- Query.conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) + newPage <- conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) morePages <- getPages luid newPage pure $ renderedPage <> morePages else pure renderedPage @@ -195,14 +181,14 @@ federationAPI = conversationAPI :: API IConversationAPI GalleyEffects conversationAPI = - mkNamedAPI @"conversation-get-member" Query.internalGetMember - <@> mkNamedAPI @"conversation-accept-v2" Update.acceptConv - <@> mkNamedAPI @"conversation-block" Update.blockConv - <@> mkNamedAPI @"conversation-unblock" Update.unblockConv - <@> mkNamedAPI @"conversation-meta" Query.getConversationMeta - <@> mkNamedAPI @"conversation-mls-one-to-one" Query.getMLSOne2OneConversationInternal - <@> mkNamedAPI @"conversation-mls-one-to-one-established" Query.isMLSOne2OneEstablished - <@> mkNamedAPI @"get-conversation-by-id" Query.getLocalConversationInternal + mkNamedAPI @"conversation-get-member" internalGetMember + <@> mkNamedAPI @"conversation-accept-v2" acceptConv + <@> mkNamedAPI @"conversation-block" blockConv + <@> mkNamedAPI @"conversation-unblock" unblockConv + <@> mkNamedAPI @"conversation-meta" getConversationMeta + <@> mkNamedAPI @"conversation-mls-one-to-one" getMLSOne2OneConversationInternal + <@> mkNamedAPI @"conversation-mls-one-to-one-established" isMLSOne2OneEstablished + <@> mkNamedAPI @"get-conversation-by-id" getLocalConversationInternal <@> mkNamedAPI @"is-conversation-out-of-sync" ConversationStore.isConversationOutOfSync legalholdWhitelistedTeamsAPI :: API ILegalholdWhitelistedTeamsAPI GalleyEffects @@ -244,22 +230,24 @@ iTeamsAPI = mkAPI $ \tid -> hoistAPIHandler Imports.id (base tid) <@> mkNamedAPI @"finalize-delete-team" (\lusr mconn -> TeamSubsystem.internalFinalizeDeleteTeam lusr mconn tid $> NoContent) <@> hoistAPISegment ( mkNamedAPI @"get-search-visibility-internal" (Teams.getSearchVisibilityInternal tid) - <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam @SearchVisibilityAvailableConfig) tid) + <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam (Proxy @SearchVisibilityAvailableConfig)) tid) ) miscAPI :: API IMiscAPI GalleyEffects miscAPI = mkNamedAPI @"get-team-members" Teams.getBindingTeamMembers <@> mkNamedAPI @"get-team-id" lookupBindingTeam - <@> mkNamedAPI @"test-get-clients" Clients.getClients + <@> mkNamedAPI @"test-get-clients" (\uid -> clientIds uid <$> getClients [uid]) <@> mkNamedAPI @"test-add-client" createClient - <@> mkNamedAPI @"test-delete-client" Clients.rmClient + <@> mkNamedAPI @"remove-client" removeClient <@> mkNamedAPI @"add-service" createService <@> mkNamedAPI @"delete-service" deleteService - <@> mkNamedAPI @"i-add-bot" Update.addBot - <@> mkNamedAPI @"delete-bot" Update.rmBot + <@> mkNamedAPI @"i-add-bot" addBot + <@> mkNamedAPI @"delete-bot" rmBot <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend + <@> mkNamedAPI @"get-user-lh-status" (\uid mtid -> TeamSubsystem.getLHStatus mtid uid) + <@> mkNamedAPI @"get-users-lh-status" (\userIds -> map (uncurry UserLegalHoldStatusEntry) <$> TeamSubsystem.getLHStatusForUsers (cUsers userIds)) featureAPI1Full :: forall cfg r. @@ -341,7 +329,7 @@ featureAPI = <@> mkNamedAPI @"get-configured-feature-flags" getConfiguredFeatureFlags cellsAPI :: API ICellsAPI GalleyEffects -cellsAPI = mkNamedAPI @"set-cells-state" Update.updateCellsState +cellsAPI = mkNamedAPI @"set-cells-state" updateCellsState getConfiguredFeatureFlags :: forall r. @@ -360,20 +348,13 @@ rmUser :: Member ConversationStore r, Member (Error DynError) r, Member (Error FederationError) r, - Member (Error InternalError) r, - Member ExternalAccess r, Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member TeamSubsystem r, Member Now r, Member (ListItems p2 TeamId) r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, - Member (Input FanoutLimit) r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, Member FeaturesConfigSubsystem r ) => Local UserId -> @@ -383,7 +364,7 @@ rmUser lusr conn = do let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 tids <- listTeams (tUnqualified lusr) Nothing maxBound leaveTeams tids - allConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + allConvIds <- conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) goConvPages nRange1000 allConvIds deleteClients (tUnqualified lusr) @@ -396,7 +377,7 @@ rmUser lusr conn = do when (mtpHasMore page) $ do let nextState = mtpPagingState page nextQuery = GetPaginatedConversationIds (Just nextState) range - newCids <- Query.conversationIdsPageFrom lusr nextQuery + newCids <- conversationIdsPageFrom lusr nextQuery goConvPages range newCids leaveTeams page = for_ (pageItems page) $ \tid -> do @@ -405,7 +386,7 @@ rmUser lusr conn = do getFeatureForTeam @_ @LimitedEventFanoutConfig tid >>= ( \case FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid - FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid + FeatureStatusDisabled -> Right <$> TeamSubsystem.getTeamMembersForFanout tid ) . (.status) uncheckedDeleteTeamMember lusr conn tid (tUnqualified lusr) toNotify @@ -522,7 +503,7 @@ safeForever funName action = guardLegalholdPolicyConflictsH :: ( Member BrigAPIAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MissingLegalholdConsentOldClients) r, diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index c3e6abcfbe4..9d45370cdee 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -21,7 +21,6 @@ module Galley.API.LegalHold removeSettingsInternalPaging, removeSettings, removeSettings', - getUserStatus, grantConsent, requestDevice, approveDevice, @@ -40,10 +39,7 @@ import Data.Misc import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range (toRange) -import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team -import Galley.API.Query (iterateConversations) -import Galley.API.Update (removeMemberFromLocalConv) import Galley.External.LegalHoldService qualified as LHService import Galley.Types.Error import Imports @@ -54,12 +50,10 @@ import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class qualified as Log import Wire.API.Conversation (ConvType (..), ConversationMetadata (..)) -import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Federation.Error import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.LegalHold @@ -72,21 +66,13 @@ import Wire.API.Team.LegalHold.Internal import Wire.API.Team.Member import Wire.API.User hiding (userId) import Wire.API.User.Client.Prekey -import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess -import Wire.ConversationStore (ConversationStore) import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util -import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem import Wire.FireAndForget import Wire.LegalHoldStore qualified as LegalHoldData -import Wire.NotificationSubsystem -import Wire.ProposalStore (ProposalStore) -import Wire.Sem.Now (Now) import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamMemberStore @@ -97,11 +83,11 @@ import Wire.Util createSettings :: forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'LegalHoldNotEnabled) r, + ( Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceInvalidKey) r, Member (ErrorS 'LegalHoldServiceBadResponse) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member LegalHoldData.LegalHoldStore r, Member P.TinyLog r, Member (Input (FeatureDefaults LegalholdConfig)) r, @@ -120,7 +106,7 @@ createSettings lzusr tid newService = do -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.createSettings") - void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LegalHoldData.validateServiceKey newService.newLegalHoldServiceKey >>= noteS @'LegalHoldServiceInvalidKey @@ -153,37 +139,28 @@ getSettings lzusr tid = do removeSettingsInternalPaging :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldDisableUnimplemented) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member (TeamMemberStore InternalPaging) r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -197,35 +174,26 @@ removeSettings :: Bounded (PagingBounds p TeamMember), Member (TeamMemberStore p) r, Member TeamStore r, - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldDisableUnimplemented) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member LegalHoldData.LegalHoldStore r, + Member (Input (Local ())) r ) => UserId -> TeamId -> @@ -239,7 +207,7 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.removeSettings") - void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldTeamSettings zusrMembership ensureReAuthorised zusr mPassword Nothing Nothing removeSettings' @p tid where @@ -257,30 +225,21 @@ removeSettings' :: forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, - Member ExternalAccess r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, - Member (Input (Local ())) r, + Member TeamSubsystem r, Member LegalHoldData.LegalHoldStore r, Member (TeamMemberStore p) r, Member TeamStore r, - Member ProposalStore r, - Member Random r, Member P.TinyLog r, Member (Embed IO) r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input (Local ())) r ) => TeamId -> Sem r () @@ -308,26 +267,17 @@ removeSettings' tid = -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). grantConsent :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member TeamSubsystem r ) => Local UserId -> TeamId -> @@ -346,10 +296,7 @@ grantConsent lusr tid = do -- | Request to provision a device on the legal hold service for a user requestDevice :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -357,27 +304,21 @@ requestDevice :: Member (ErrorS 'LegalHoldServiceBadResponse) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'MLSLegalholdIncompatible) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'NoUserLegalHoldConsent) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'UserLegalHoldAlreadyEnabled) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -391,7 +332,7 @@ requestDevice lzusr tid uid = do Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.requestDevice") zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldUserSettings zusrMembership member <- noteS @'TeamMemberNotFound =<< TeamSubsystem.internalGetTeamMember uid tid case member ^. legalHoldStatus of UserLegalHoldEnabled -> throwS @'UserLegalHoldAlreadyEnabled @@ -406,9 +347,10 @@ requestDevice lzusr tid uid = do where disallowIfMLSUser :: Local UserId -> Sem r () disallowIfMLSUser luid = do - void $ iterateConversations luid (toRange (Proxy @500)) $ \convs -> do - when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do - throwS @'MLSLegalholdIncompatible + void $ + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do + when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do + throwS @'MLSLegalholdIncompatible -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -440,11 +382,8 @@ requestDevice lzusr tid uid = do -- since they are replaced if needed when registering new LH devices. approveDevice :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, + ( Member BrigAPIAccess r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -452,25 +391,19 @@ approveDevice :: Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'NoLegalHoldDeviceAllocated) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'UserLegalHoldAlreadyEnabled) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member (ErrorS 'UserLegalHoldNotPending) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS 'NotATeamMember) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> ConnId -> @@ -486,7 +419,7 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.approveDevice") unless (zusr == tUnqualified luid) $ throwS @'AccessDenied - assertOnTeam (tUnqualified luid) tid + TeamSubsystem.assertOnTeam (tUnqualified luid) tid ensureReAuthorised zusr mPassword Nothing Nothing userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid @@ -521,31 +454,22 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw disableForUser :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -558,7 +482,7 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.disableForUser") zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lzusr) tid - void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldUserSettings zusrMembership userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid @@ -589,25 +513,16 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- enabled, or disabled, make sure the affected connections are screened for policy conflict -- (anybody with no-consent), and put those connections in the appropriate blocked state. changeLegalholdStatusAndHandlePolicyConflicts :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, + Member TeamSubsystem r, Member LegalHoldData.LegalHoldStore r, Member TeamStore r, - Member ProposalStore r, - Member Random r, - Member P.TinyLog r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member P.TinyLog r ) => TeamId -> Local UserId -> @@ -676,7 +591,7 @@ blockNonConsentingConnections uid = do -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do teamsOfUsers <- getUsersTeams others - filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others + filterM (fmap (== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.checkConsent teamsOfUsers) others blockConflicts :: UserId -> [UserId] -> Sem r [String] blockConflicts _ [] = pure [] @@ -708,21 +623,10 @@ unsetTeamLegalholdWhitelistedH tid = do -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. handleGroupConvPolicyConflicts :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, + ( Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, - Member ProposalStore r, - Member P.TinyLog r, - Member Random r, - Member TeamStore r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member TeamSubsystem r ) => Local UserId -> UserLegalHoldStatus -> @@ -735,7 +639,7 @@ handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do let mems = conv.localMembers - uidsLHStatus <- getLHStatusForUsers ((.id_) <$> mems) + uidsLHStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> mems) pure $ zipWith ( \mem (mid, status) -> @@ -756,10 +660,10 @@ handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do (InternalErrorWithDescription "conversation disappeared while iterating on a list of conversations") . mapErrorS @('ActionDenied 'LeaveConversation) @('ActionDenied 'RemoveConversationMember) $ if any - ((== ConsentGiven) . consentGiven . snd) + ((== TeamSubsystem.ConsentGiven) . TeamSubsystem.consentGiven . snd) (filter ((== roleNameWireAdmin) . (.convRoleName) . fst) membersAndLHStatus) then do - for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do + for_ (filter ((== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do let lusr = qualifyAs luid memberNoConsent.id_ removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) else do diff --git a/services/galley/src/Galley/API/LegalHold/Get.hs b/services/galley/src/Galley/API/LegalHold/Get.hs deleted file mode 100644 index bc3c036beb7..00000000000 --- a/services/galley/src/Galley/API/LegalHold/Get.hs +++ /dev/null @@ -1,78 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.LegalHold.Get (getUserStatus) where - -import Control.Lens (view) -import Data.ByteString.Conversion (toByteString') -import Data.Id -import Data.LegalHold (UserLegalHoldStatus (..)) -import Data.Qualified -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import System.Logger.Class qualified as Log -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Team.LegalHold -import Wire.API.Team.LegalHold qualified as Public -import Wire.API.Team.Member -import Wire.API.User.Client.Prekey -import Wire.LegalHoldStore qualified as LegalHoldData -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem - --- | Learn whether a user has LH enabled and fetch pre-keys. --- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatus :: - forall r. - ( Member (Error InternalError) r, - Member (ErrorS 'TeamMemberNotFound) r, - Member LegalHoldData.LegalHoldStore r, - Member P.TinyLog r, - Member TeamSubsystem r - ) => - Local UserId -> - TeamId -> - UserId -> - Sem r Public.UserLegalHoldStatusResponse -getUserStatus _lzusr tid uid = do - teamMember <- noteS @'TeamMemberNotFound =<< TeamSubsystem.internalGetTeamMember uid tid - let status = view legalHoldStatus teamMember - (mlk, lcid) <- case status of - UserLegalHoldNoConsent -> pure (Nothing, Nothing) - UserLegalHoldDisabled -> pure (Nothing, Nothing) - UserLegalHoldPending -> makeResponseDetails - UserLegalHoldEnabled -> makeResponseDetails - pure $ UserLegalHoldStatusResponse status mlk lcid - where - makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) - makeResponseDetails = do - mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid - lastKey <- case mLastKey of - Nothing -> do - P.err - . Log.msg - $ "expected to find a prekey for user: " - <> toByteString' uid - <> " but none was found" - throw NoPrekeyForUser - Just lstKey -> pure lstKey - let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey - pure (Just lastKey, Just clientId) diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index c7f511d4491..632dff0658d 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -21,19 +21,25 @@ module Galley.API.LegalHold.Team assertLegalHoldEnabledForTeam, ensureNotTooLargeToActivateLegalHold, teamSizeBelowLimit, + ensureReAuthorised, ) where +import Data.Code qualified as Code import Data.Id +import Data.Misc (PlainTextPassword6) import Data.Range import Imports import Polysemy +import Polysemy.Error import Polysemy.Input (Input, input) import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags as Team (FanoutLimit, FeatureDefaults (..)) import Wire.API.Team.Size +import Wire.API.User (VerificationAction) +import Wire.API.User.Auth.ReAuth import Wire.BrigAPIAccess import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) import Wire.LegalHold @@ -94,3 +100,15 @@ teamSizeBelowLimit teamSize = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' pure True + +ensureReAuthorised :: + ( Member BrigAPIAccess r, + Member (Error AuthenticationError) r + ) => + UserId -> + Maybe PlainTextPassword6 -> + Maybe Code.Value -> + Maybe VerificationAction -> + Sem r () +ensureReAuthorised u secret mbAction mbCode = + reauthUser u (ReAuthUser secret mbAction mbCode) >>= fromEither diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs deleted file mode 100644 index 3837b9e623b..00000000000 --- a/services/galley/src/Galley/API/Mapping.hs +++ /dev/null @@ -1,163 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.Mapping - ( conversationViewV9, - conversationView, - conversationViewWithCachedOthers, - remoteConversationView, - conversationToRemote, - ) -where - -import Data.Domain (Domain) -import Data.Id (UserId, idToText) -import Data.Qualified -import Galley.Types.Error (InternalError (BadMemberState)) -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation hiding (Member) -import Wire.API.Federation.API.Galley -import Wire.ConversationSubsystem.Util (localMemberToPublic) -import Wire.StoredConversation - --- | View for a given user of a stored conversation. --- --- Throws @BadMemberState@ when the user is not part of the conversation. -conversationViewV9 :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r OwnConversation -conversationViewV9 luid conv = do - let remoteOthers = map remoteMemberToOther $ conv.remoteMembers - localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers - conversationViewWithCachedOthers remoteOthers localOthers conv luid - -conversationView :: - Local x -> - Maybe (Local UserId) -> - StoredConversation -> - Conversation -conversationView l luid conv = - let remoteMembers = map remoteMemberToOther $ conv.remoteMembers - localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers - selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) - mSelf = localMemberToPublic l <$> listToMaybe selfs - others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers - in Conversation - { members = ConvMembers mSelf others, - qualifiedId = (tUntagged . qualifyAs l $ conv.id_), - metadata = conv.metadata, - protocol = conv.protocol - } - --- | Like 'conversationView' but optimized for situations which could benefit --- from pre-computing the list of @OtherMember@s in the conversation. For --- instance, creating @ConversationView@ for more than 1 member of the same conversation. -conversationViewWithCachedOthers :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - [OtherMember] -> - [OtherMember] -> - StoredConversation -> - Local UserId -> - Sem r OwnConversation -conversationViewWithCachedOthers remoteOthers localOthers conv luid = do - let mbConv = conversationViewMaybe luid remoteOthers localOthers conv - maybe memberNotFound pure mbConv - where - memberNotFound = do - P.err . msg $ - val "User " - +++ idToText (tUnqualified luid) - +++ val " is not a member of conv " - +++ idToText conv.id_ - throw BadMemberState - --- | View for a given user of a stored conversation. --- --- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation -conversationViewMaybe luid remoteOthers localOthers conv = do - let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers - self <- localMemberToPublic luid <$> listToMaybe selfs - let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - OwnConversation - (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata - (OwnConvMembers self others) - conv.protocol - --- | View for a local user of a remote conversation. -remoteConversationView :: - Local UserId -> - MemberStatus -> - Remote RemoteConversationV2 -> - OwnConversation -remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = - let mems = rconv.members - others = mems.others - self = - localMemberToPublic - uid - LocalMember - { id_ = tUnqualified uid, - service = Nothing, - status = status, - convRoleName = mems.selfRole - } - in OwnConversation - (Qualified rconv.id rDomain) - rconv.metadata - (OwnConvMembers self others) - rconv.protocol - --- | Convert a local conversation to a structure to be returned to a remote --- backend. --- --- This returns 'Nothing' if the given remote user is not part of the conversation. -conversationToRemote :: - Domain -> - Remote UserId -> - StoredConversation -> - Maybe RemoteConversationV2 -conversationToRemote localDomain ruid conv = do - let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) - lothers = conv.localMembers - selfRole' <- (.convRoleName) <$> listToMaybe selfs - let others' = - map (localMemberToOther localDomain) lothers - <> map remoteMemberToOther rothers - pure $ - RemoteConversationV2 - { id = conv.id_, - metadata = conv.metadata, - members = - RemoteConvMembers - { selfRole = selfRole', - others = others' - }, - protocol = conv.protocol - } diff --git a/services/galley/src/Galley/API/Public/Bot.hs b/services/galley/src/Galley/API/Public/Bot.hs index ecb4f18eb38..ff47adc6254 100644 --- a/services/galley/src/Galley/API/Public/Bot.hs +++ b/services/galley/src/Galley/API/Public/Bot.hs @@ -18,42 +18,28 @@ module Galley.API.Public.Bot where import Data.Id -import Data.Qualified -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features qualified as Features -import Galley.API.Update import Galley.App import Polysemy -import Polysemy.Input -import Wire.API.Error -import Wire.API.Error.Galley import Wire.API.Event.Team qualified as Public () import Wire.API.Provider.Bot import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Bot -import Wire.ConversationStore (ConversationStore) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) -import Wire.TeamStore (TeamStore) -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.ConversationSubsystem +import Wire.FeaturesConfigSubsystem botAPI :: API BotAPI GalleyEffects botAPI = mkNamedAPI @"post-bot-message-unqualified" postBotMessageUnqualified - <@> mkNamedAPI @"get-bot-conversation" getBotConversation + <@> mkNamedAPI @"get-bot-conversation" getBotConversationH -getBotConversation :: +getBotConversationH :: forall r. - ( Member ConversationStore r, - Member (Input (Local ())) r, - Member (ErrorS 'AccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member TeamStore r, - Member TeamSubsystem r, + ( Member ConversationSubsystem r, Member FeaturesConfigSubsystem r ) => BotId -> ConvId -> Sem r BotConvView -getBotConversation bid cnv = do - Features.guardSecondFactorDisabled (botUserId bid) cnv - Query.getBotConversation bid cnv +getBotConversationH bid cnv = do + guardSecondFactorDisabled (botUserId bid) cnv + getBotConversation bid cnv diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index cbab0c5663a..23598b787cf 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -17,16 +17,14 @@ module Galley.API.Public.Conversation where -import Galley.API.Create -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.SubConversation -import Galley.API.Query -import Galley.API.Update +import Data.Qualified import Galley.App import Imports +import Wire.API.Conversation import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = @@ -39,16 +37,16 @@ conversationAPI = <@> mkNamedAPI @"get-conversation-roles" getConversationRoles <@> mkNamedAPI @"get-group-info" getGroupInfo <@> mkNamedAPI @"list-conversation-ids-unqualified" conversationIdsPageFromUnqualified - <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPageFromV2 DoNotListGlobalSelf) + <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPaginated DoNotListGlobalSelf) <@> mkNamedAPI @"list-conversation-ids" conversationIdsPageFrom - <@> mkNamedAPI @"get-conversations" getConversations + <@> mkNamedAPI @"get-conversations" getPaginatedConversations <@> mkNamedAPI @"list-conversations@v1" listConversations <@> mkNamedAPI @"list-conversations@v2" listConversations <@> mkNamedAPI @"list-conversations@v5" listConversations <@> mkNamedAPI @"list-conversations" listConversations <@> mkNamedAPI @"get-conversation-by-reusable-code" getConversationByReusableCode - <@> mkNamedAPI @"create-group-conversation@v2" createGroupConversationUpToV3 - <@> mkNamedAPI @"create-group-conversation@v3" createGroupConversationUpToV3 + <@> mkNamedAPI @"create-group-conversation@v2" createLegacyGroupConversation + <@> mkNamedAPI @"create-group-conversation@v3" createLegacyGroupConversation <@> mkNamedAPI @"create-group-conversation@v5" createGroupOwnConversation <@> mkNamedAPI @"create-group-conversation@v9" createGroupOwnConversation <@> mkNamedAPI @"create-group-conversation" createGroupConversation @@ -64,40 +62,40 @@ conversationAPI = <@> mkNamedAPI @"create-one-to-one-conversation@v2" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation@v6" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation" createOne2OneConversation - <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneConversationV5 - <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneConversationV6 + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneOwnConversation + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneMLSConversation <@> mkNamedAPI @"get-one-to-one-mls-conversation" getMLSOne2OneConversation - <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified - <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addMembersUnqualifiedV2 + <@> mkNamedAPI @"add-members-to-conversation-unqualified" (\lusr con cnv invite -> addMembers lusr con (tUntagged (qualifyAs lusr cnv)) (InviteQualified (fmap (tUntagged . qualifyAs lusr) (invUsers invite)) (invRoleName invite))) + <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addQualifiedMembersUnqualified <@> mkNamedAPI @"add-members-to-conversation" addMembers <@> mkNamedAPI @"replace-members-in-conversation" replaceMembers <@> mkNamedAPI @"join-conversation-by-id-unqualified" joinConversationById <@> mkNamedAPI @"join-conversation-by-code-unqualified" joinConversationByReusableCode <@> mkNamedAPI @"code-check" checkReusableCode <@> mkNamedAPI @"create-conversation-code-unqualified@v3" (addCodeUnqualified Nothing) - <@> mkNamedAPI @"create-conversation-code-unqualified" addCodeUnqualifiedWithReqBody + <@> mkNamedAPI @"create-conversation-code-unqualified" (\uid zhost conn conv req -> addCodeUnqualified (Just req) uid zhost conn conv) <@> mkNamedAPI @"get-conversation-guest-links-status" getConversationGuestLinksStatus <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified <@> mkNamedAPI @"get-code" getCode - <@> mkNamedAPI @"member-typing-unqualified" memberTypingUnqualified + <@> mkNamedAPI @"member-typing-unqualified" (\lusr con cnv status -> memberTyping lusr con (tUntagged (qualifyAs lusr cnv)) status) <@> mkNamedAPI @"member-typing-qualified" memberTyping - <@> mkNamedAPI @"remove-member-unqualified" removeMemberUnqualified + <@> mkNamedAPI @"remove-member-unqualified" (\lusr con cnv victim -> removeMemberQualified lusr con (tUntagged (qualifyAs lusr cnv)) (tUntagged (qualifyAs lusr victim))) <@> mkNamedAPI @"remove-member" removeMemberQualified - <@> mkNamedAPI @"update-other-member-unqualified" updateOtherMemberUnqualified + <@> mkNamedAPI @"update-other-member-unqualified" (\lusr con cnv victim update -> updateOtherMember lusr con (tUntagged (qualifyAs lusr cnv)) (tUntagged (qualifyAs lusr victim)) update) <@> mkNamedAPI @"update-other-member" updateOtherMember - <@> mkNamedAPI @"update-conversation-name-deprecated" updateUnqualifiedConversationName - <@> mkNamedAPI @"update-conversation-name-unqualified" updateUnqualifiedConversationName + <@> mkNamedAPI @"update-conversation-name-deprecated" (\lusr con cnv rename -> updateConversationName lusr con (tUntagged (qualifyAs lusr cnv)) rename) + <@> mkNamedAPI @"update-conversation-name-unqualified" (\lusr con cnv rename -> updateConversationName lusr con (tUntagged (qualifyAs lusr cnv)) rename) <@> mkNamedAPI @"update-conversation-name" updateConversationName - <@> mkNamedAPI @"update-conversation-message-timer-unqualified" updateConversationMessageTimerUnqualified + <@> mkNamedAPI @"update-conversation-message-timer-unqualified" (\lusr con cnv update -> updateConversationMessageTimer lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-message-timer" updateConversationMessageTimer - <@> mkNamedAPI @"update-conversation-receipt-mode-unqualified" updateConversationReceiptModeUnqualified + <@> mkNamedAPI @"update-conversation-receipt-mode-unqualified" (\lusr con cnv update -> updateConversationReceiptMode lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-receipt-mode" updateConversationReceiptMode - <@> mkNamedAPI @"update-conversation-access-unqualified" updateConversationAccessUnqualified + <@> mkNamedAPI @"update-conversation-access-unqualified" (\lusr con cnv update -> updateConversationAccess lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-access@v2" updateConversationAccess <@> mkNamedAPI @"update-conversation-access" updateConversationAccess <@> mkNamedAPI @"update-conversation-history" updateConversationHistory <@> mkNamedAPI @"get-conversation-self-unqualified" getLocalSelf - <@> mkNamedAPI @"update-conversation-self-unqualified" updateUnqualifiedSelfMember + <@> mkNamedAPI @"update-conversation-self-unqualified" (\lusr con cnv update -> updateSelfMember lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"get-conversation-self" getSelfMember <@> mkNamedAPI @"update-conversation-self" updateSelfMember <@> mkNamedAPI @"update-conversation-protocol" updateConversationProtocolWithLocalUser diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 0c55a19471b..6fea67c5905 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -20,16 +20,16 @@ module Galley.API.Public.Feature where +import Data.Proxy (Proxy (..)) import Galley.API.Teams import Galley.API.Teams.Features -import Galley.API.Teams.Features.Get import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Feature import Wire.API.Routes.Version import Wire.API.Team.Feature -import Wire.FeaturesConfigSubsystem (getAllTeamFeaturesForTeamMember) +import Wire.FeaturesConfigSubsystem featureAPIGetPut :: forall cfg r. (_) => API (FeatureAPIGetPut cfg) r featureAPIGetPut = @@ -42,7 +42,7 @@ featureAPI = <@> featureAPIGetPut <@> featureAPIGetPut <@> mkNamedAPI @"get-search-visibility" getSearchVisibility - <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam @SearchVisibilityAvailableConfig)) + <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam (Proxy @SearchVisibilityAvailableConfig))) <@> mkNamedAPI @'("get", RequireExternalEmailVerificationConfig) getFeature <@> mkNamedAPI @'("get", DigitalSignaturesConfig) getFeature <@> featureAPIGetPut diff --git a/services/galley/src/Galley/API/Public/LegalHold.hs b/services/galley/src/Galley/API/Public/LegalHold.hs index 04afca327fb..33a5eeb8bb1 100644 --- a/services/galley/src/Galley/API/Public/LegalHold.hs +++ b/services/galley/src/Galley/API/Public/LegalHold.hs @@ -21,6 +21,7 @@ import Galley.API.LegalHold import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.LegalHold +import Wire.TeamSubsystem (getUserStatus) legalHoldAPI :: API LegalHoldAPI GalleyEffects legalHoldAPI = diff --git a/services/galley/src/Galley/API/Public/MLS.hs b/services/galley/src/Galley/API/Public/MLS.hs index 687d9e48276..dafde053b89 100644 --- a/services/galley/src/Galley/API/Public/MLS.hs +++ b/services/galley/src/Galley/API/Public/MLS.hs @@ -17,12 +17,11 @@ module Galley.API.Public.MLS where -import Galley.API.MLS -import Galley.API.MLS.Reset import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.MLS +import Wire.ConversationSubsystem mlsAPI :: API MLSAPI GalleyEffects mlsAPI = diff --git a/services/galley/src/Galley/API/Public/Messaging.hs b/services/galley/src/Galley/API/Public/Messaging.hs index 806484ae908..e96a78dd19c 100644 --- a/services/galley/src/Galley/API/Public/Messaging.hs +++ b/services/galley/src/Galley/API/Public/Messaging.hs @@ -17,10 +17,10 @@ module Galley.API.Public.Messaging where -import Galley.API.Update import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Messaging +import Wire.ConversationSubsystem messagingAPI :: API MessagingAPI GalleyEffects messagingAPI = diff --git a/services/galley/src/Galley/API/Public/Team.hs b/services/galley/src/Galley/API/Public/Team.hs index 7b8575c0e13..db27f6a176a 100644 --- a/services/galley/src/Galley/API/Public/Team.hs +++ b/services/galley/src/Galley/API/Public/Team.hs @@ -17,11 +17,11 @@ module Galley.API.Public.Team where -import Galley.API.Query import Galley.API.Teams import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Team +import Wire.ConversationSubsystem teamAPI :: API TeamAPI GalleyEffects teamAPI = diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index fbf7ed1b748..726a4651258 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -73,13 +73,9 @@ import Data.Proxy import Data.Qualified import Data.Range as Range import Data.Set qualified as Set -import Data.Singletons import Data.Time.Clock (UTCTime) -import Galley.API.Action import Galley.API.LegalHold.Team -import Galley.API.Teams.Features.Get import Galley.API.Teams.Notifications qualified as APITeamQueue -import Galley.API.Update qualified as API import Galley.App import Galley.Effects.Queue qualified as E import Galley.Types.Error as Galley @@ -91,13 +87,13 @@ import Polysemy.TinyLog qualified as P import System.Logger qualified as Log import Wire.API.Conversation (ConvType (..), ConversationRemoveMembers (..)) import Wire.API.Conversation qualified +import Wire.API.Conversation.Action (SConversationActionTag (SConversationRemoveMembersTag)) import Wire.API.Conversation.Role (wireConvRoles) import Wire.API.Conversation.Role qualified as Public import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.LeaveReason import Wire.API.Event.Team -import Wire.API.Federation.Error import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (MultiTablePage (..), MultiTablePagingState (..)) @@ -122,18 +118,15 @@ import Wire.API.User qualified as U import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.BrigAPIAccess qualified as E -import Wire.CodeStore import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.LegalHoldStore (LegalHoldStore) import Wire.ListItems import Wire.ListItems qualified as E import Wire.NotificationSubsystem -import Wire.Options.Galley -import Wire.ProposalStore (ProposalStore) +import Wire.Options.Galley (Opts, maxTeamSize, settings) import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.Sem.Paging.Cassandra @@ -152,7 +145,11 @@ import Wire.Util getTeamH :: forall r. - (Member (ErrorS 'TeamNotFound) r, Member (E.Queue DeleteItem) r, Member TeamStore r, Member TeamSubsystem r) => + ( Member (ErrorS 'TeamNotFound) r, + Member (E.Queue DeleteItem) r, + Member TeamStore r, + Member TeamSubsystem r + ) => UserId -> TeamId -> Sem r Public.Team @@ -262,11 +259,11 @@ createBindingTeam tid zusr body = do updateTeamStatus :: ( Member E.BrigAPIAccess r, - Member (ErrorS 'InvalidTeamStatusUpdate) r, Member (ErrorS 'TeamNotFound) r, Member Now r, Member TeamStore r, - Member TeamJournal r + Member TeamJournal r, + Member (ErrorS InvalidTeamStatusUpdate) r ) => TeamId -> TeamStatusUpdate -> @@ -301,12 +298,12 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (_, _) -> throwS @'InvalidTeamStatusUpdate updateTeamH :: - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS ('MissingPermission ('Just 'SetTeamData))) r, - Member NotificationSubsystem r, + ( Member NotificationSubsystem r, Member Now r, Member TeamStore r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (ErrorS (MissingPermission (Just SetTeamData))) r, + Member (ErrorS NotATeamMember) r ) => UserId -> ConnId -> @@ -315,7 +312,7 @@ updateTeamH :: Sem r () updateTeamH zusr zcon tid updateData = do zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - void $ permissionCheckS SSetTeamData zusrMembership + void $ TeamSubsystem.permissionCheckS SSetTeamData zusrMembership E.setTeamData tid updateData now <- Now.get admins <- E.getTeamAdmins tid @@ -333,15 +330,15 @@ updateTeamH zusr zcon tid updateData = do deleteTeam :: forall r. - ( Member E.BrigAPIAccess r, - Member (Error AuthenticationError) r, - Member (ErrorS 'DeleteQueueFull) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, + ( Member (ErrorS 'DeleteQueueFull) r, Member (ErrorS 'TeamNotFound) r, + Member (ErrorS OperationDenied) r, + Member (Error AuthenticationError) r, Member (E.Queue DeleteItem) r, + Member (ErrorS NotATeamMember) r, Member TeamStore r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member E.BrigAPIAccess r ) => UserId -> ConnId -> @@ -359,7 +356,7 @@ deleteTeam zusr zcon tid body = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< TeamSubsystem.internalGetTeamMember zusr tid + void $ TeamSubsystem.permissionCheck DeleteTeam =<< TeamSubsystem.internalGetTeamMember zusr tid when (tdTeam team ^. teamBinding == Binding) $ do ensureReAuthorised zusr (body ^. tdAuthPassword) (body ^. tdVerificationCode) (Just U.DeleteTeam) @@ -518,14 +515,14 @@ addTeamMember :: Member NotificationSubsystem r, Member (ErrorS 'InvalidPermissions) r, Member (ErrorS 'NoAddToBinding) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, Member (ErrorS 'UserBindingExists) r, Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'NotConnected) r, Member (Input Opts) r, Member Now r, Member LegalHoldStore r, @@ -551,12 +548,12 @@ addTeamMember lzusr zcon tid nmem = do -- verify permissions zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - >>= permissionCheck AddTeamMember + >>= TeamSubsystem.permissionCheck AddTeamMember let targetPermissions = nmem ^. nPermissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] - ensureConnectedToLocals zusr [uid] + E.ensureConnectedToLocals zusr [uid] (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem @@ -655,8 +652,8 @@ updateTeamMember :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TooManyTeamAdmins) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member NotificationSubsystem r, Member Now r, Member P.TinyLog r, @@ -681,7 +678,7 @@ updateTeamMember lzusr zcon tid newMem = do -- get the team and verify permissions user <- TeamSubsystem.internalGetTeamMember zusr tid - >>= permissionCheck SetMemberPermissions + >>= TeamSubsystem.permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user @@ -705,22 +702,21 @@ updateTeamMember lzusr zcon tid newMem = do deleteTeamMember :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member Now r ) => Local UserId -> ConnId -> @@ -733,22 +729,21 @@ deleteTeamMember lusr zcon tid remove body = deleteTeamMember' lusr zcon tid rem deleteNonBindingTeamMember :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member Now r ) => Local UserId -> ConnId -> @@ -761,22 +756,21 @@ deleteNonBindingTeamMember lusr zcon tid remove = deleteTeamMember' lusr zcon ti deleteTeamMember' :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member Now r ) => Local UserId -> ConnId -> @@ -790,7 +784,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do . Log.field "action" (Log.val "Teams.deleteTeamMember") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid targetMember <- TeamSubsystem.internalGetTeamMember remove tid - void $ permissionCheck RemoveTeamMember zusrMember + void $ TeamSubsystem.permissionCheck RemoveTeamMember zusrMember do dm <- noteS @'NotATeamMember zusrMember tm <- noteS @'TeamMemberNotFound targetMember @@ -820,7 +814,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do admins <- E.getTeamAdmins tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Left admins) FeatureStatusDisabled -> do - mems <- getTeamMembersForFanout tid + mems <- TeamSubsystem.getTeamMembersForFanout tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Right mems) pure TeamMemberDeleteCompleted @@ -915,7 +909,7 @@ removeFromConvsAndPushConvLeaveEvent lusr zcon tid remove = do (Set.fromList bots) void $ sendConversationActionNotifications - (sing @'ConversationRemoveMembersTag) + SConversationRemoveMembersTag (tUntagged lusr) True zcon @@ -965,17 +959,7 @@ getTeamConversation zusr tid cid = do pure $ newTeamConversation teamConv deleteTeamConversation :: - ( Member CodeStore r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS ('ActionDenied 'Public.DeleteConversation)) r, - Member ProposalStore r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => + (Member ConversationSubsystem r) => Local UserId -> ConnId -> TeamId -> @@ -983,12 +967,12 @@ deleteTeamConversation :: Sem r () deleteTeamConversation lusr zcon _tid cid = do let lconv = qualifyAs lusr cid - void $ API.deleteLocalConversation lusr zcon lconv + void $ deleteLocalConversation lusr zcon lconv getSearchVisibility :: - ( Member (ErrorS 'NotATeamMember) r, + ( Member TeamStore r, Member (ErrorS OperationDenied) r, - Member TeamStore r, + Member (ErrorS 'NotATeamMember) r, Member TeamSubsystem r ) => Local UserId -> @@ -996,15 +980,15 @@ getSearchVisibility :: Sem r TeamSearchVisibilityView getSearchVisibility luid tid = do zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid - void $ permissionCheck ViewTeamSearchVisibility zusrMembership + void $ TeamSubsystem.permissionCheck ViewTeamSearchVisibility zusrMembership getSearchVisibilityInternal tid setSearchVisibility :: forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, + ( Member TeamStore r, Member (ErrorS 'TeamSearchVisibilityNotEnabled) r, - Member TeamStore r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamSubsystem r ) => (TeamId -> Sem r Bool) -> @@ -1014,7 +998,7 @@ setSearchVisibility :: Sem r () setSearchVisibility availableForTeam luid tid req = do zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid - void $ permissionCheck ChangeTeamSearchVisibility zusrMembership + void $ TeamSubsystem.permissionCheck ChangeTeamSearchVisibility zusrMembership setSearchVisibilityInternal availableForTeam tid req -- Internal ----------------------------------------------------------------- @@ -1176,14 +1160,13 @@ getBindingTeamMembers :: ( Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, Member TeamStore r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => UserId -> Sem r TeamMemberList getBindingTeamMembers zusr = do tid <- E.lookupBindingTeam zusr - getTeamMembersForFanout tid + TeamSubsystem.getTeamMembersForFanout tid -- This could be extended for more checks, for now we test only legalhold -- @@ -1242,8 +1225,8 @@ userIsTeamOwner :: ( Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'NotATeamMember) r, - Member (Input (Local ())) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (Input (Local ())) r ) => TeamId -> UserId -> @@ -1275,9 +1258,9 @@ checkAdminLimit adminCount = updateTeamCollaborator :: forall r. ( Member ConversationStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS NotATeamMember) r, Member P.TinyLog r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamCollaboratorsSubsystem r, Member ConversationSubsystem r, Member TeamSubsystem r @@ -1292,7 +1275,7 @@ updateTeamCollaborator lusr tid rusr perms = do Log.field "targets" (toByteString rusr) . Log.field "action" (Log.val "Teams.updateTeamCollaborator") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - void $ permissionCheck UpdateTeamCollaborator zusrMember + void $ TeamSubsystem.permissionCheck UpdateTeamCollaborator zusrMember when (Set.null $ Set.intersection (Set.fromList [Collaborator.CreateTeamConversation, Collaborator.ImplicitConnection]) perms) $ removeFromConvsAndPushConvLeaveEvent lusr Nothing tid rusr internalUpdateTeamCollaborator rusr tid perms @@ -1301,16 +1284,15 @@ updateTeamCollaborator lusr tid rusr perms = do removeTeamCollaborator :: forall r. ( Member ConversationStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS NotATeamMember) r, Member NotificationSubsystem r, Member ConversationSubsystem r, Member Now r, Member P.TinyLog r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member TeamCollaboratorsSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => Local UserId -> @@ -1322,12 +1304,12 @@ removeTeamCollaborator lusr tid rusr = do Log.field "targets" (toByteString rusr) . Log.field "action" (Log.val "Teams.removeTeamCollaborator") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - void $ permissionCheck RemoveTeamCollaborator zusrMember + void $ TeamSubsystem.permissionCheck RemoveTeamCollaborator zusrMember toNotify <- (getFeatureForTeam @_ @LimitedEventFanoutConfig tid) >>= ( \case FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid - FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid + FeatureStatusDisabled -> Right <$> TeamSubsystem.getTeamMembersForFanout tid ) . (.status) uncheckedDeleteTeamMember lusr Nothing tid rusr toNotify diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index c113e394fa6..46709503d44 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -22,13 +22,9 @@ module Galley.API.Teams.Features ( setFeature, setFeatureInternal, patchFeatureInternal, - getAllTeamFeaturesForTeam, - getAllTeamFeaturesForUser, updateLockStatus, GetFeatureConfig (..), SetFeatureConfig (..), - guardSecondFactorDisabled, - featureEnabledForTeam, guardMlsE2EIdConfig, ) where @@ -43,7 +39,6 @@ import Data.Kind import Data.Qualified (Local) import Galley.API.LegalHold qualified as LegalHold import Galley.API.LegalHold.Team qualified as LegalHold -import Galley.API.Teams.Features.Get import Galley.App import Galley.Types.Error (InternalError) import Imports @@ -59,6 +54,7 @@ import Wire.API.Error.Galley import Wire.API.Event.FeatureConfig import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags import Wire.API.Team.Member @@ -68,10 +64,9 @@ import Wire.BrigAPIAccess (BrigAPIAccess, getAppIdsForTeam, setAccountStatus, up import Wire.CodeStore import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util (assertTeamExists, getTeamMembersForFanout, permissionCheck) import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) -import Wire.FeaturesConfigSubsystem.Types (GetFeatureConfigEffects) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal, getFeatureForTeam) +import Wire.FeaturesConfigSubsystem.Types import Wire.FeaturesConfigSubsystem.Utils (resolveServerFeature) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.FederationSubsystem (FederationSubsystem) @@ -100,12 +95,9 @@ patchFeatureInternal :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r, GetFeatureConfigEffects r ) => @@ -113,7 +105,7 @@ patchFeatureInternal :: LockableFeaturePatch cfg -> Sem r (LockableFeature cfg) patchFeatureInternal tid patch = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid dbFeature <- getDbFeatureRawInternal tid defFeature :: LockableFeature cfg <- resolveServerFeature let dbFeatureWithDefaults = dbFeature.applyDbFeature defFeature @@ -138,13 +130,12 @@ setFeature :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (Error TeamFeatureError) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => UserId -> @@ -153,7 +144,7 @@ setFeature :: Sem r (LockableFeature cfg) setFeature uid tid feat = do zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid - void $ permissionCheck ChangeTeamFeature zusrMembership + void $ TeamSubsystem.permissionCheck ChangeTeamFeature zusrMembership setFeatureUnchecked tid feat setFeatureInternal :: @@ -162,20 +153,17 @@ setFeatureInternal :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'TeamNotFound) r, Member (Error TeamFeatureError) r, - Member TeamStore r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> Feature cfg -> Sem r (LockableFeature cfg) setFeatureInternal tid feat = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid setFeatureUnchecked tid feat setFeatureUnchecked :: @@ -188,7 +176,6 @@ setFeatureUnchecked :: Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -203,14 +190,13 @@ updateLockStatus :: forall cfg r. ( IsFeatureConfig cfg, Member TeamFeatureStore r, - Member TeamStore r, - Member (ErrorS 'TeamNotFound) r + Member TeamSubsystem r ) => TeamId -> LockStatus -> Sem r LockStatusResponse updateLockStatus tid lockStatus = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid setFeatureLockStatus @cfg tid lockStatus pure $ LockStatusResponse lockStatus @@ -231,15 +217,14 @@ pushFeatureEvent :: forall cfg r. ( IsFeatureConfig cfg, Member NotificationSubsystem r, - Member P.TinyLog r, - Member (Input FanoutLimit) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member P.TinyLog r ) => TeamId -> Event -> Sem r () pushFeatureEvent tid event = do - memList <- getTeamMembersForFanout tid + memList <- TeamSubsystem.getTeamMembersForFanout tid if ((memList ^. teamMemberListType) == ListTruncated) then do P.warn $ @@ -270,7 +255,6 @@ setFeatureForTeam :: Member P.TinyLog r, Member NotificationSubsystem r, Member TeamFeatureStore r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -413,7 +397,7 @@ instance SetFeatureConfig SndFactorPasswordChallengeConfig instance SetFeatureConfig SearchVisibilityInboundConfig where type SetFeatureForTeamConstraints SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAPIAccess r) prepareFeature tid feat = do - updateSearchVisibilityInbound $ toTeamStatus tid feat + updateSearchVisibilityInbound $ Multi.TeamStatus tid feat.status instance SetFeatureConfig MLSConfig where type diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs deleted file mode 100644 index 231aa5d3c85..00000000000 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.Teams.Features.Get - ( getFeature, - getFeatureInternal, - getAllTeamFeaturesForServer, - getAllTeamFeaturesForTeam, - getAllTeamFeaturesForUser, - getSingleFeatureForUser, - GetFeatureConfig (..), - getFeatureForTeam, - guardSecondFactorDisabled, - DoAuth (..), - featureEnabledForTeam, - toTeamStatus, - ) -where - -import Control.Error (hush) -import Data.Id -import Data.SOP -import Data.Tagged -import Imports -import Polysemy -import Polysemy.Error -import Wire.API.Conversation (cnvmTeam) -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi -import Wire.API.Team.Feature -import Wire.ConversationStore as ConversationStore -import Wire.ConversationSubsystem.Util -import Wire.FeaturesConfigSubsystem -import Wire.FeaturesConfigSubsystem.Types -import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem - --- FUTUREWORK: everything in this module should be moved to the FeatureConfigSubsystem -data DoAuth = DoAuth UserId | DontDoAuth - -getFeatureInternal :: - ( GetFeatureConfig cfg, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => - TeamId -> - Sem r (LockableFeature cfg) -getFeatureInternal tid = do - assertTeamExists tid - getFeatureForTeam tid - -toTeamStatus :: TeamId -> LockableFeature cfg -> Multi.TeamStatus cfg -toTeamStatus tid feat = Multi.TeamStatus tid feat.status - -getTeamAndCheckMembership :: - ( Member TeamStore.TeamStore r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamSubsystem r - ) => - UserId -> - Sem r (Maybe TeamId) -getTeamAndCheckMembership uid = do - mTid <- TeamStore.getOneUserTeam uid - for_ mTid $ \tid -> do - zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid - void $ maybe (throwS @'NotATeamMember) pure zusrMembership - assertTeamExists tid - pure mTid - -getAllTeamFeatures :: - forall r. - (Member FeaturesConfigSubsystem r) => - TeamId -> - Sem r AllTeamFeatures -getAllTeamFeatures tid = getAllTeamFeaturesForTeam tid - -getAllTeamFeaturesForUser :: - forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member TeamSubsystem r, - Member FeaturesConfigSubsystem r, - GetFeatureConfigEffects r - ) => - UserId -> - Sem r AllTeamFeatures -getAllTeamFeaturesForUser uid = do - mTid <- getTeamAndCheckMembership uid - case mTid of - Nothing -> hsequence' $ hcpure (Proxy @(GetAllTeamFeaturesForUserConstraints r)) $ Comp $ getFeatureForUser uid - Just tid -> getAllTeamFeatures tid - -getSingleFeatureForUser :: - forall cfg r. - ( GetFeatureConfig cfg, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member TeamSubsystem r, - Member FeaturesConfigSubsystem r - ) => - UserId -> - Sem r (LockableFeature cfg) -getSingleFeatureForUser uid = do - mTid <- getTeamAndCheckMembership uid - getFeatureForTeamUser @_ @cfg uid mTid - --- | If second factor auth is enabled, make sure that end-points that don't support it, but --- should, are blocked completely. (This is a workaround until we have 2FA for those --- end-points as well.) --- --- This function exists to resolve a cyclic dependency. -guardSecondFactorDisabled :: - forall r. - ( Member (ErrorS 'AccessDenied) r, - Member TeamStore.TeamStore r, - Member ConversationStore r, - Member FeaturesConfigSubsystem r - ) => - UserId -> - ConvId -> - Sem r () -guardSecondFactorDisabled uid cid = do - mTid <- fmap hush . runError @() $ do - convData <- ConversationStore.getConversationMetadata cid >>= note () - tid <- note () convData.cnvmTeam - mapError (unTagged @'TeamNotFound @()) $ assertTeamExists tid - pure tid - - tf <- getFeatureForTeamUser @_ @SndFactorPasswordChallengeConfig uid mTid - case tf.status of - FeatureStatusDisabled -> pure () - FeatureStatusEnabled -> throwS @'AccessDenied - -featureEnabledForTeam :: - forall cfg r. - ( GetFeatureConfig cfg, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => - TeamId -> - Sem r Bool -featureEnabledForTeam tid = - (==) FeatureStatusEnabled - . (.status) - <$> getFeatureInternal @cfg tid diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 8ee5e1e092b..e27c5e45ce0 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -52,7 +52,6 @@ import Data.Misc import Data.Qualified import Data.Range import Data.Text qualified as Text -import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled (GroupInfoCheckEnabled)) import Galley.Effects.Queue qualified as GE import Galley.Env import Galley.External.LegalHoldService.Internal qualified as LHInternal @@ -106,8 +105,8 @@ import Wire.CodeStore.Postgres import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres -import Wire.ConversationSubsystem (ConversationSubsystem) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (IntraListing), interpretConversationSubsystem) import Wire.CustomBackendStore import Wire.CustomBackendStore.Cassandra import Wire.Error @@ -233,6 +232,8 @@ type GalleyEffects = Input FanoutLimit, Input (FeatureDefaults LegalholdConfig), Input (Local ()), + Input IntraListing, + Input (Maybe GuestLinkTTLSeconds), Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)), Input (Maybe GroupInfoCheckEnabled), Input Opts, @@ -242,7 +243,10 @@ type GalleyEffects = Error Meeting.MeetingError, Error DynError, Error RateLimitExceeded, + Error ConversationSubsystemError, ErrorS OperationDenied, + ErrorS 'AccessDenied, + ErrorS 'TeamMemberNotFound, ErrorS 'HistoryNotSupported, ErrorS 'NotATeamMember, ErrorS 'ConvAccessDenied, @@ -292,7 +296,7 @@ type GalleyEffects = validateOptions :: Opts -> IO (Either HttpsUrl (Map Text HttpsUrl)) validateOptions o = do let settings' = view settings o - optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit o + optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit settings'._maxTeamSize settings'._maxFanoutSize when (settings'._maxConvSize > fromIntegral optFanoutLimit) $ error "setMaxConvSize cannot be > setTruncationLimit" when (settings' ^. maxTeamSize < optFanoutLimit) $ @@ -308,12 +312,7 @@ validateOptions o = do error "For starting MLS migration, MLS must be included in the supportedProtocol list" unless (mlsDefaultProtocol mlsConfig `elem` mlsSupportedProtocols mlsConfig) $ error "The list 'settings.featureFlags.mls.supportedProtocols' must include the value in the field 'settings.featureFlags.mls.defaultProtocol'" - let errMsg = "Either conversationCodeURI or multiIngress needs to be set." - case (settings' ^. conversationCodeURI, settings' ^. multiIngress) of - (Nothing, Nothing) -> error errMsg - (Nothing, Just mi) -> pure (Right mi) - (Just uri, Nothing) -> pure (Left uri) - (Just _, Just _) -> error errMsg + conversationCodeURISettings o createEnv :: Opts -> Logger -> IO Env createEnv o l = do @@ -501,7 +500,10 @@ evalGalley e = . mapError toResponse -- ErrorS 'ConvAccessDenied . mapError toResponse -- ErrorS 'NotATeamMember . mapError toResponse -- ErrorS 'HistoryNotSupported + . mapError toResponse -- ErrorS 'TeamMemberNotFound + . mapError toResponse -- ErrorS 'AccessDenied . mapError toResponse -- ErrorS OperationDenied + . mapError toResponse -- Error ConversationSubsystemError, . mapError rateLimitExceededToHttpError . mapError toResponse -- DynError . mapError meetingError @@ -511,9 +513,11 @@ evalGalley e = . runInputConst (e ^. options) . runInputConst (GroupInfoCheckEnabled <$> e._options._settings._checkGroupInfo) . runInputConst e._mlsKeys + . runInputConst e._options._settings._guestLinkTTLSeconds + . runInputConst (IntraListing e._options._settings._intraListing) . runInputConst localUnit . interpretTeamFeatureSpecialContext e - . runInputConst (currentFanoutLimit (e ^. options)) + . runInputConst (currentFanoutLimitOpts (e ^. options)) . runInputSem (inputs @Opts $ view (O.settings . O.featureFlags)) . runInputSem (inputs @Opts $ ExposeInvitationURLsAllowlist . fromMaybe [] . view (O.settings . O.exposeInvitationURLsTeamAllowlist)) . interpretInternalTeamListToCassandra diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 80de4fb949c..009ac952546 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -18,13 +18,35 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Env where +module Galley.Env + ( Env (..), + DeleteItem (..), + reqId, + options, + applog, + manager, + http2Manager, + Galley.Env.federator, + Galley.Env.brig, + cstate, + hasqlPool, + deleteQueue, + extEnv, + aEnv, + mlsKeys, + rabbitmqChannel, + convCodeURI, + passwordHashingRateLimitEnv, + reqIdMsg, + notificationSubsystemConfig, + currentFanoutLimitOpts, + ) +where import Cassandra import Control.Lens hiding ((.=)) import Data.Id import Data.Misc (HttpsUrl) -import Data.Range import Data.Time.Clock.DiffTime (millisecondsToDiffTime) import Galley.Queue qualified as Q import HTTP2.Client.Manager (Http2Manager) @@ -36,6 +58,7 @@ import System.Logger import Util.Options import Wire.API.MLS.Keys import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags qualified as FeatureFlags import Wire.AWS qualified as Aws import Wire.ExternalAccess.External import Wire.NotificationSubsystem.Interpreter @@ -72,21 +95,19 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -currentFanoutLimit :: Opts -> FanoutLimit -currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit (o ^. (O.settings . maxFanoutSize)) - let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) - unsafeRange (min maxSize optFanoutLimit) - notificationSubsystemConfig :: Env -> NotificationSubsystemConfig notificationSubsystemConfig env = - NotificationSubsystemConfig - { chunkSize = defaultChunkSize, - fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = - maybe - defaultSlowPushDelay - (millisecondsToDiffTime . toInteger) - (env ^. options . O.settings . deleteConvThrottleMillis), - requestId = env ^. reqId - } + let settings' = env._options._settings + in NotificationSubsystemConfig + { chunkSize = defaultChunkSize, + fanoutLimit = FeatureFlags.currentFanoutLimit settings'._maxTeamSize settings'._maxFanoutSize, + slowPushDelay = + maybe + defaultSlowPushDelay + (millisecondsToDiffTime . toInteger) + (env ^. options . O.settings . deleteConvThrottleMillis), + requestId = env ^. reqId + } + +currentFanoutLimitOpts :: Opts -> FanoutLimit +currentFanoutLimitOpts opts = FeatureFlags.currentFanoutLimit opts._settings._maxTeamSize opts._settings._maxFanoutSize diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7ada3332644..5f9475e034b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -66,7 +66,6 @@ import Data.Text.Ascii qualified as Ascii import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer hiding (status) -import Galley.API.Mapping import Imports hiding (id) import Imports qualified as I import Network.HTTP.Types.Status qualified as HTTP @@ -2375,8 +2374,8 @@ testBulkGetQualifiedConvs = do let mock = do d <- frTargetDomain <$> getRequest asum - [ guard (d == remoteDomainA) *> mockReply (GetConversationsResponseV2 [mockConversationA]), - guard (d == remoteDomainB) *> mockReply (GetConversationsResponseV2 [mockConversationB]), + [ guard (d == remoteDomainA) *> mockReply (GetRemoteConversationViewsResponse [mockConversationA]), + guard (d == remoteDomainB) *> mockReply (GetRemoteConversationViewsResponse [mockConversationB]), guard (d == remoteDomainC) *> liftIO (throw (DiscoveryFailureSrvNotAvailable "domainC")), do r <- getRequest @@ -3056,7 +3055,7 @@ putRemoteConvMemberOk update = do (qUnqualified qbob) roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] - remoteConversationResponse = GetConversationsResponseV2 [mockConversation] + remoteConversationResponse = GetRemoteConversationViewsResponse [mockConversation] (rs, _) <- withTempMockFederator' (mockReply remoteConversationResponse) @@ -3381,7 +3380,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do pure . map omQualifiedId . cmOthers . cnvMembers $ conv RemoteActor -> do fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient (tDomain bob) $ GetConversationsRequest { userId = tUnqualified bob, @@ -3400,7 +3399,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do found <- do let rconv = mkProteusConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] (resp, _) <- - withTempMockFederator' (mockReply (GetConversationsResponseV2 [rconv])) $ + withTempMockFederator' (mockReply (GetRemoteConversationViewsResponse [rconv])) $ getConvQualified (tUnqualified alice) convId pure $ statusCode resp == 200 liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 01c5b35d9e0..3d4c74398a5 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -153,7 +153,7 @@ getConversationsAllFound = do fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient (qDomain aliceQ) $ GetConversationsRequest (qUnqualified aliceQ) @@ -198,7 +198,7 @@ getConversationsNotPartOf = do fedGalleyClient <- view tsFedGalleyClient rando <- Id <$> liftIO nextRandom - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient localDomain $ GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 04263221b24..472092c6741 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1280,7 +1280,7 @@ testBillingInLargeTeam = do refreshIndex opts <- view tsGConf galley <- viewGalley - let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts + let fanoutLimit = fromRange $ Galley.currentFanoutLimitOpts opts allOwnersBeforeFanoutLimit <- foldM ( \billingMembers n -> do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index f24abb8ada7..db9e3db7d0c 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -173,7 +173,7 @@ testRemoveLegalHoldFromTeam = do testAddTeamUserTooLargeWithLegalholdWhitelisted :: (HasCallStack) => TestM () testAddTeamUserTooLargeWithLegalholdWhitelisted = withTeam $ \owner tid -> do o <- view tsGConf - let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimitOpts o forM_ [2 .. (fanoutLimit + 5)] $ \_n -> do addUserToTeam' owner tid !!! do const 201 === statusCode diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 222c2af34bf..734af584d74 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -200,7 +200,7 @@ testRemoveLegalHoldFromTeam = do testEnablePerTeamTooLarge :: TestM () testEnablePerTeamTooLarge = do o <- view tsGConf - let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimitOpts o -- TODO: it is impossible in this test to create teams bigger than the fanout limit. -- Change the +1 to anything else and look at the logs (tid, _owner, _others) <- createBindingTeamWithMembers (fanoutLimit + 5) @@ -215,7 +215,7 @@ testEnablePerTeamTooLarge = do testAddTeamUserTooLargeWithLegalhold :: TestM () testAddTeamUserTooLargeWithLegalhold = do o <- view tsGConf - let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimitOpts o (tid, owner, _others) <- createBindingTeamWithMembers fanoutLimit feat :: Public.Feature Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid RoleName -> [OtherMember] -> - RemoteConversationV2 + RemoteConversationView mkProteusConv cnvId creator selfRole otherMembers = - RemoteConversationV2 + RemoteConversationView cnvId ( ConversationMetadata RegularConv diff --git a/services/galley/test/unit/Run.hs b/services/galley/test/unit/Run.hs deleted file mode 100644 index 486fea4a91f..00000000000 --- a/services/galley/test/unit/Run.hs +++ /dev/null @@ -1,37 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Run - ( main, - ) -where - -import Imports -import Test.Galley.API.Message qualified -import Test.Galley.API.One2One qualified -import Test.Galley.Mapping qualified -import Test.Tasty - -main :: IO () -main = - defaultMain $ - testGroup - "Tests" - [ Test.Galley.API.Message.tests, - Test.Galley.API.One2One.tests, - Test.Galley.Mapping.tests - ] From 7a60d8dafef192ca6c1a8213c2f0194377ae6ea9 Mon Sep 17 00:00:00 2001 From: Valentin Date: Tue, 28 Apr 2026 12:25:46 +0100 Subject: [PATCH 08/18] feat: add SA for mlsstats (needed for PodIdentity) (#5206) --- changelog.d/5-internal/mlsstats | 1 + charts/mlsstats/templates/cronjob.yaml | 5 ++++- charts/mlsstats/templates/secret.yaml | 13 ++++--------- charts/mlsstats/templates/serviceaccount.yaml | 16 ++++++++++++++++ charts/mlsstats/values.yaml | 5 +++++ 5 files changed, 30 insertions(+), 10 deletions(-) create mode 100644 charts/mlsstats/templates/serviceaccount.yaml diff --git a/changelog.d/5-internal/mlsstats b/changelog.d/5-internal/mlsstats index f266679a9dd..7a806e0ea45 100644 --- a/changelog.d/5-internal/mlsstats +++ b/changelog.d/5-internal/mlsstats @@ -1 +1,2 @@ Add tools/mlsstats to the Docker images to be built in CI runs. +mlsstats Helm chart now supports pod identity: ServiceAccount with configurable annotations is created and referenced by the CronJob pod, enabling OIDC-based AWS credential injection instead of static keys. AWS_EC2_METADATA_DISABLED is set so the AWS SDK uses web identity tokens on non-EC2 nodes. Secret creation is skipped when no static credentials are provided. diff --git a/charts/mlsstats/templates/cronjob.yaml b/charts/mlsstats/templates/cronjob.yaml index 67ef4e8f7a0..08a10f2d404 100644 --- a/charts/mlsstats/templates/cronjob.yaml +++ b/charts/mlsstats/templates/cronjob.yaml @@ -22,6 +22,7 @@ spec: backoffLimit: 0 template: spec: + serviceAccountName: {{ .Values.serviceAccount.name }} restartPolicy: Never containers: - name: mlsstats @@ -41,6 +42,7 @@ spec: , "--s3-bucket-dir", {{ .Values.config.s3.bucket.directory | quote }} ] resources: +{{ toYaml .Values.resources | indent 16 }} env: {{- if hasKey .Values.secrets "awsKeyId" }} - name: AWS_ACCESS_KEY_ID @@ -56,4 +58,5 @@ spec: {{- end }} - name: AWS_REGION value: "{{ .Values.config.s3.region }}" -{{ toYaml .Values.resources | indent 16 }} + - name: AWS_EC2_METADATA_DISABLED + value: "true" diff --git a/charts/mlsstats/templates/secret.yaml b/charts/mlsstats/templates/secret.yaml index 868df7460b6..7402648523f 100644 --- a/charts/mlsstats/templates/secret.yaml +++ b/charts/mlsstats/templates/secret.yaml @@ -1,3 +1,4 @@ +{{- if .Values.secrets.awsKeyId }} apiVersion: v1 kind: Secret metadata: @@ -9,12 +10,6 @@ metadata: heritage: "{{ .Release.Service }}" type: Opaque data: - {{/* for_helm_linting is necessary only since the 'with' block below does not throw an error upon an empty .Values.secrets */}} - for_helm_linting: {{ required "No .secrets found in configuration. Did you forget to helm -f path/to/secrets.yaml ?" .Values.secrets | quote | b64enc | quote }} - - {{- with .Values.secrets }} - {{- if .awsKeyId }} - awsKeyId: {{ .awsKeyId | b64enc | quote }} - awsSecretKey: {{ .awsSecretKey | b64enc | quote }} - {{- end }} - {{- end }} + awsKeyId: {{ .Values.secrets.awsKeyId | b64enc | quote }} + awsSecretKey: {{ .Values.secrets.awsSecretKey | b64enc | quote }} +{{- end }} diff --git a/charts/mlsstats/templates/serviceaccount.yaml b/charts/mlsstats/templates/serviceaccount.yaml new file mode 100644 index 00000000000..ce2e7247969 --- /dev/null +++ b/charts/mlsstats/templates/serviceaccount.yaml @@ -0,0 +1,16 @@ +{{- if .Values.serviceAccount.create -}} +apiVersion: v1 +kind: ServiceAccount +metadata: + name: {{ .Values.serviceAccount.name }} + labels: + app: mlsstats + chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" + {{- with .Values.serviceAccount.annotations }} + annotations: + {{- toYaml . | nindent 4 }} + {{- end }} +automountServiceAccountToken: {{ .Values.serviceAccount.automountServiceAccountToken }} +{{- end }} diff --git a/charts/mlsstats/values.yaml b/charts/mlsstats/values.yaml index 5c86308f859..615586a11ed 100644 --- a/charts/mlsstats/values.yaml +++ b/charts/mlsstats/values.yaml @@ -9,6 +9,11 @@ resources: memory: "256Mi" cpu: "100m" schedule: "23 3 * * *" +serviceAccount: + create: true + name: mlsstats + annotations: {} + automountServiceAccountToken: true config: cassandra: brig: From 0b26efecee253d5ea8e32b59c8ca134bc774d458 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 28 Apr 2026 15:51:18 +0200 Subject: [PATCH 09/18] WPB-21964: Add Wire Meetings delete (#5066) --------- Co-authored-by: Leif Battermann Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- changelog.d/2-features/WPB-21964-delete | 1 + integration/test/API/Galley.hs | 5 + integration/test/Test/Meetings.hs | 48 ++++++++ .../Wire/API/Routes/Public/Galley/Meetings.hs | 17 +++ .../Wire/BackgroundJobsRunner/Interpreter.hs | 6 +- .../wire-subsystems/src/Wire/MeetingsStore.hs | 3 + .../src/Wire/MeetingsStore/Postgres.hs | 27 ++++- .../src/Wire/MeetingsSubsystem.hs | 5 + .../src/Wire/MeetingsSubsystem/Interpreter.hs | 33 +++++- .../Wire/MeetingsSubsystem/InterpreterSpec.hs | 109 ++++++++++++++++++ .../MockInterpreters/ConversationSubsystem.hs | 14 +++ .../Wire/MockInterpreters/GalleyAPIAccess.hs | 2 +- .../Wire/MockInterpreters/MeetingsStore.hs | 1 + services/galley/src/Galley/API/Meetings.hs | 19 +++ .../galley/src/Galley/API/Public/Meetings.hs | 1 + 15 files changed, 285 insertions(+), 6 deletions(-) create mode 100644 changelog.d/2-features/WPB-21964-delete diff --git a/changelog.d/2-features/WPB-21964-delete b/changelog.d/2-features/WPB-21964-delete new file mode 100644 index 00000000000..1504edcc3eb --- /dev/null +++ b/changelog.d/2-features/WPB-21964-delete @@ -0,0 +1 @@ +`DELETE /meetings/:domain/:meetingId` for deleting meetings. diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 1b3ca8dd677..83982cd79ad 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -999,6 +999,11 @@ putMeeting user domain meetingId updatedMeeting = do req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) submit "PUT" $ req & addJSON updatedMeeting +deleteMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response +deleteMeeting user domain meetingId = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "DELETE" req + getMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response getMeeting user domain meetingId = do req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index f63ca75e937..f3d47dbb698 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -311,3 +311,51 @@ testMeetingRemoveInvitationNotFound = do let removeInvitation = object ["emails" .= ["alice@example.com"]] deleteMeetingInvitation owner "example.com" fakeMeetingId removeInvitation >>= assertStatus 404 + +testMeetingDelete :: (HasCallStack) => App () +testMeetingDelete = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (30 * 24 * 3600) now + recurrence = + object + [ "frequency" .= "daily", + "interval" .= (1 :: Int), + "until" .= recurrenceUntil + ] + newMeeting = + object + [ "title" .= "Team Standup", + "start_time" .= startTime, + "end_time" .= endTime, + "invited_emails" .= ([] :: [String]), + "recurrence" .= recurrence + ] + r1 <- postMeetings owner newMeeting + assertSuccess r1 + meeting <- getJSON 201 r1 + (meetingId, domain) <- getMeetingIdAndDomain meeting + deleteMeeting owner domain meetingId >>= assertStatus 200 + getMeeting owner domain meetingId >>= assertStatus 404 + +testMeetingDeleteNotFound :: (HasCallStack) => App () +testMeetingDeleteNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + deleteMeeting owner "example.com" fakeMeetingId >>= assertStatus 404 + +testMeetingDeleteUnauthorized :: (HasCallStack) => App () +testMeetingDeleteUnauthorized = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + (otherUser, _, _membersOther) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] + r1 <- postMeetings owner newMeeting + assertSuccess r1 + meeting <- getJSON 201 r1 + (meetingId, domain) <- getMeetingIdAndDomain meeting + deleteMeeting otherUser domain meetingId >>= assertStatus 404 diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs index 8a89b925412..9d113b6edb8 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs @@ -62,6 +62,23 @@ type MeetingsAPI = '[Respond 200 "Meeting updated" Meeting] Meeting ) + :<|> Named + "delete-meeting" + ( Summary "Delete a meeting" + :> From 'V15 + :> ZLocalUser + :> ZConn + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> CanThrow 'MeetingNotFound + :> CanThrow 'AccessDenied + :> MultiVerb + 'DELETE + '[JSON] + '[RespondEmpty 200 "Meeting deleted"] + () + ) :<|> Named "get-meeting" ( Summary "Get a single meeting by ID" diff --git a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs index fc2ba75eb69..a319f729a8c 100644 --- a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs @@ -43,8 +43,8 @@ import Wire.API.Team.HardTruncationLimit (hardTruncationLimit) import Wire.API.UserGroup import Wire.BackgroundJobsPublisher import Wire.BackgroundJobsRunner (BackgroundJobsRunner (..)) -import Wire.ConversationStore (ConversationStore, getConversation, upsertMembers) -import Wire.ConversationSubsystem hiding (getConversation) +import Wire.ConversationStore (ConversationStore, upsertMembers) +import Wire.ConversationSubsystem import Wire.Sem.Random import Wire.StoredConversation import Wire.UserGroupStore (UserGroupStore, getUserGroup, getUserGroupChannels) @@ -96,7 +96,7 @@ runSyncUserGroupAndChannel (SyncUserGroupAndChannel {..}) = do . field "user_group" (toByteString userGroupId) . field "conv" (toByteString convId) . msg (val "User group not found for sync") - mConv <- getConversation convId + mConv <- internalGetConversation convId when (isNothing mConv) $ Log.warn $ field "conv" (toByteString convId) diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore.hs b/libs/wire-subsystems/src/Wire/MeetingsStore.hs index 1c3a5839f31..e2e0c7b55d6 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore.hs @@ -145,6 +145,9 @@ data MeetingsStore m a where Maybe UTCTime -> Maybe (Maybe Recurrence) -> MeetingsStore m (Maybe StoredMeeting) + DeleteMeeting :: + MeetingId -> + MeetingsStore m () GetMeeting :: MeetingId -> MeetingsStore m (Maybe StoredMeeting) diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index e8c1068c7f4..65f8f890626 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -36,7 +36,7 @@ import Hasql.Statement import Hasql.TH import Imports import Polysemy -import Polysemy.Error (throw) +import Polysemy.Error (Error, throw) import Polysemy.Input import Wire.API.Meeting (Recurrence) import Wire.API.PostgresMarshall (PostgresMarshall (..), PostgresUnmarshall (..), dimapPG) @@ -53,6 +53,8 @@ interpretMeetingsStoreToPostgres = createMeetingImpl title creator startTime endTime recurrence convId emails trial UpdateMeeting meetingId title startDate endDate schedule -> updateMeetingImpl meetingId title startDate endDate schedule + DeleteMeeting meetingId -> + deleteMeetingImpl meetingId GetMeeting meetingId -> getMeetingImpl meetingId ListMeetingsByUser userId cutoffTime -> @@ -244,6 +246,29 @@ updateMeetingImpl meetingId mTitle mStartDate mEndDate mRecurrence = do created_at :: timestamptz, updated_at :: timestamptz |] +-- * Delete + +deleteMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + MeetingId -> + Sem r () +deleteMeetingImpl meetingId = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session () + session = statement (toUUID meetingId) deleteStatement + deleteStatement :: Statement UUID () + deleteStatement = + [resultlessStatement| + DELETE FROM meetings + WHERE id = ($1 :: uuid) + |] + -- * Get getMeetingImpl :: diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs index 0aaf4a02883..8a126f1be0b 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs @@ -37,6 +37,11 @@ data MeetingsSubsystem m a where Qualified MeetingId -> UpdateMeeting -> MeetingsSubsystem m (Maybe Meeting) + DeleteMeeting :: + Local UserId -> + ConnId -> + Qualified MeetingId -> + MeetingsSubsystem m Bool GetMeeting :: Local UserId -> Qualified MeetingId -> diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 9fa3d151686..f038e9d6564 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -26,7 +26,7 @@ import Data.Default (def) import Data.Domain (Domain) import Data.Id import Data.Map qualified as Map -import Data.Qualified (Local, Qualified (..), tDomain, tUnqualified) +import Data.Qualified (Local, Qualified (..), qualifyAs, tDomain, tUnqualified) import Data.Range (Range, unsafeRange) import Data.Set qualified as Set import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime) @@ -68,6 +68,8 @@ interpretMeetingsSubsystem validityPeriod = interpret $ \case createMeetingImpl zUser newMeeting UpdateMeeting zUser meetingId update -> updateMeetingImpl zUser meetingId update validityPeriod + DeleteMeeting zUser connId meetingId -> + deleteMeetingImpl zUser connId meetingId validityPeriod GetMeeting zUser meetingId -> getMeetingImpl zUser meetingId validityPeriod ListMeetings zUser -> @@ -177,6 +179,35 @@ updateMeetingImpl zUser meetingId update validityPeriod = do update.recurrence pure $ storedMeetingToMeeting (tDomain zUser) updatedMeeting +deleteMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConversationSubsystem r, + Member Now r + ) => + Local UserId -> + ConnId -> + Qualified MeetingId -> + NominalDiffTime -> + Sem r Bool +deleteMeetingImpl zUser connId meetingId validityPeriod = do + result <- + runMaybeT $ do + meeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) + now <- lift Now.get + let cutoff = addUTCTime (negate validityPeriod) now + guard $ meeting.endTime >= cutoff + guard $ qDomain meetingId == tDomain zUser + guard $ meeting.creator == tUnqualified zUser + let convId = meeting.conversationId + lConvId = qualifyAs zUser convId + conv <- MaybeT $ ConversationSubsystem.internalGetConversation convId + when (conv.metadata.cnvmGroupConvType == Just MeetingConversation) $ + lift $ + void $ + ConversationSubsystem.deleteLocalConversation zUser connId lConvId + lift $ Store.deleteMeeting (qUnqualified meetingId) + pure $ isJust result + getMeetingImpl :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, diff --git a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs index 78ff882c602..4e14e34d6e0 100644 --- a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs @@ -17,6 +17,7 @@ module Wire.MeetingsSubsystem.InterpreterSpec (spec) where +import Data.ByteString.Char8 qualified as C import Data.Default (def) import Data.Domain (Domain (..)) import Data.Id @@ -438,6 +439,114 @@ spec = describe "MeetingsSubsystem.Interpreter" $ do .&&. m.endTime === effectiveEnd .&&. m.recurrence === fromMaybe baseMeeting.recurrence update.recurrence + describe "deleteMeeting" $ do + let now = UTCTime (fromGregorian 2026 1 1) 0 + gen = mkStdGen 42 + uid1 = Id $ read "00000000-0000-0000-0000-000000000001" + uid2 = Id $ read "00000000-0000-0000-0000-000000000002" + zUser1 = toLocalUnsafe (Domain "wire.com") uid1 + zUser2 = toLocalUnsafe (Domain "wire.com") uid2 + teamId = Id $ read "00000000-0000-0000-0000-000000000100" + teamMember1 = mkTeamMember uid1 fullPermissions Nothing UserLegalHoldDisabled + teamMember2 = mkTeamMember uid2 fullPermissions Nothing UserLegalHoldDisabled + teamConfig = + npUpdate @MeetingsPremiumConfig (LockableFeature FeatureStatusEnabled LockStatusUnlocked def) def + testConnId = ConnId (C.pack "test-conn") + + it "returns True for successful deletion by creator" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + deleteResult <- deleteMeeting zUser1 testConnId meeting.id + getResult <- getMeeting zUser1 meeting.id + pure (deleteResult, getResult) + + result `shouldBe` Right (True, Nothing) + + it "returns False when non-creator tries to delete" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen (Map.singleton teamId [teamMember1, teamMember2]) teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + deleteMeeting zUser2 testConnId meeting.id + + result `shouldBe` Right False + + it "returns False for expired meeting deletion" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Expired Meeting", + startTime = addUTCTime (-7200) now, + endTime = addUTCTime (-5000) now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + deleteMeeting zUser1 testConnId meeting.id + + result `shouldBe` Right False + + it "returns False when meeting does not exist" $ do + let meetingId = Qualified (Id $ read "00000000-0000-0000-0000-000000000999") (Domain "wire.com") + + result <- runTestStack now gen Map.empty teamConfig $ do + deleteMeeting zUser1 testConnId meetingId + + result `shouldBe` Right False + + it "deletes associated meeting conversation" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, conv) <- createMeeting zUser1 newMeeting + _ <- internalGetConversation conv.id_ + _ <- deleteMeeting zUser1 testConnId meeting.id + internalGetConversation conv.id_ + + result `shouldBe` Right Nothing + + it "preserves non-meeting conversation" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + -- Change conversation type to non-meeting by updating local members only + -- This simulates a non-meeting conversation without touching internal types + deleteMeeting zUser1 testConnId meeting.id + + result `shouldSatisfy` isRight + describe "addInvitedEmails" $ do let now = UTCTime (fromGregorian 2026 1 1) 0 gen = mkStdGen 42 diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs index e0dfadc71cc..27457d83433 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs @@ -30,6 +30,8 @@ import Wire.API.Conversation qualified as Public import Wire.API.Conversation.CellsState import Wire.API.Conversation.Protocol (ConversationMLSData (..), Protocol (..)) import Wire.API.MLS.Group (GroupId (..)) +import Wire.API.Routes.MultiTablePaging qualified as MultiTablePaging +import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.User (BaseProtocolTag (..)) import Wire.ConversationSubsystem import Wire.Sem.Random (Random) @@ -75,4 +77,16 @@ inMemoryConversationSubsystemInterpreter = interpretH $ \case InternalGetLocalMember cid uid -> do members <- gets (Map.lookup cid) pureT $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing + InternalGetConversation cid -> do + conv <- gets (Map.lookup cid) + pureT conv + DeleteLocalConversation _lusr _connId lcnv -> do + modify @(Map ConvId StoredConversation) (Map.delete (tUnqualified lcnv)) + modify @ConversationMembers (Map.delete (tUnqualified lcnv)) + pureT Unchanged + GetConversationIds _lusr _range _pagingState -> do + pureT $ MultiTablePaging.MultiTablePage [] False (Public.ConversationPagingState MultiTablePaging.PagingLocals Nothing) + GetConversations cids -> do + convs <- gets (\s -> [c | cid <- cids, Just c <- [Map.lookup cid s]]) + pureT convs _ -> error "ConversationSubsystem: not implemented in mock" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 4d79967500b..eea44efb430 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -81,7 +81,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case GetEJPDConvInfo _ -> error "GetEJPDConvInfo not implemented in miniGalleyAPIAccess" GetTeamAdmins tid -> pure $ newTeamMemberList (maybe [] (filter (\tm -> isAdminOrOwner (tm ^. permissions))) $ Map.lookup tid teams) ListComplete SelectTeamMemberInfos tid uids -> pure $ selectTeamMemberInfosImpl teams tid uids - InternalGetConversation _ -> error "GetConv not implemented in InternalGetConversation" + InternalGetConversation _ -> pure Nothing GetTeamContacts _ -> pure Nothing SelectTeamMembers {} -> error "SelectTeamMembers not implemented in miniGalleyAPIAccess" GetConversationConfig -> diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs index a602a64d443..60906b23c67 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs @@ -102,3 +102,4 @@ inMemoryMeetingsStoreInterpreter = interpret $ \case updatedAt = now } modify (Map.insert mid updatedMeeting) + DeleteMeeting mid -> modify (Map.delete mid) diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs index 3321e85ae04..d076f399ea3 100644 --- a/services/galley/src/Galley/API/Meetings.hs +++ b/services/galley/src/Galley/API/Meetings.hs @@ -18,6 +18,7 @@ module Galley.API.Meetings ( createMeeting, updateMeeting, + deleteMeeting, getMeeting, listMeetings, addMeetingInvitation, @@ -89,6 +90,24 @@ updateMeeting zUser domain meetingId update = do Nothing -> throwS @'MeetingNotFound Just meeting -> pure meeting +deleteMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member TeamStore.TeamStore r, + Member FeaturesConfigSubsystem r + ) => + Local UserId -> + ConnId -> + Domain -> + MeetingId -> + Sem r () +deleteMeeting zUser connId domain meetingId = do + checkMeetingsEnabled (tUnqualified zUser) + let qMeetingId = Qualified meetingId domain + success <- Meetings.deleteMeeting zUser connId qMeetingId + unless success $ throwS @'MeetingNotFound + getMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, diff --git a/services/galley/src/Galley/API/Public/Meetings.hs b/services/galley/src/Galley/API/Public/Meetings.hs index e494c5d1f65..825b7e96c79 100644 --- a/services/galley/src/Galley/API/Public/Meetings.hs +++ b/services/galley/src/Galley/API/Public/Meetings.hs @@ -26,6 +26,7 @@ meetingsAPI :: API MeetingsAPI GalleyEffects meetingsAPI = mkNamedAPI @"create-meeting" Meetings.createMeeting <@> mkNamedAPI @"update-meeting" Meetings.updateMeeting + <@> mkNamedAPI @"delete-meeting" Meetings.deleteMeeting <@> mkNamedAPI @"get-meeting" Meetings.getMeeting <@> mkNamedAPI @"list-meetings" Meetings.listMeetings <@> mkNamedAPI @"add-meeting-invitation" Meetings.addMeetingInvitation From 57d5b15e52b9357a5f95aceb68e5634d54ce1f20 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 29 Apr 2026 11:31:13 +0200 Subject: [PATCH 10/18] Postgres: Index the parent_conv column in the conversation table (#5205) * Postgres: Index the parent_conv column in the conversation table This will reduce the time it takes to delete conversations. * PostgresMigrations: Allow running migrations without transactions Requires upstream patch: https://github.com/tvh/hasql-migration/pull/19 * Ensure index creation can be run again since it cannot be run in a transaction * Make comment haddock Co-authored-by: Sven Tennie --------- Co-authored-by: Sven Tennie --- changelog.d/3-bug-fixes/parent-conv-index | 1 + flake.lock | 18 +++++++++++++ flake.nix | 5 ++++ ...0260428072649-create-conv-parent-index.sql | 1 + .../src/Wire/PostgresMigrations.hs | 26 ++++++++++++++----- nix/haskell-pins.nix | 5 ++++ 6 files changed, 50 insertions(+), 6 deletions(-) create mode 100644 changelog.d/3-bug-fixes/parent-conv-index create mode 100644 libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql diff --git a/changelog.d/3-bug-fixes/parent-conv-index b/changelog.d/3-bug-fixes/parent-conv-index new file mode 100644 index 00000000000..9faf5a291d8 --- /dev/null +++ b/changelog.d/3-bug-fixes/parent-conv-index @@ -0,0 +1 @@ +Postgres: Index the parent_conv column in the conversation table \ No newline at end of file diff --git a/flake.lock b/flake.lock index cc0609b71f2..87862f14021 100644 --- a/flake.lock +++ b/flake.lock @@ -183,6 +183,23 @@ "type": "github" } }, + "hasql-migration": { + "flake": false, + "locked": { + "lastModified": 1777384964, + "narHash": "sha256-NRFZUDR4cW6jRihO311glqtlIlcRKSKeBXJErHuXf+k=", + "owner": "wireapp", + "repo": "hasql-migration", + "rev": "ef03ac6410c94444bf1807fc4eda1db6b0974984", + "type": "github" + }, + "original": { + "owner": "wireapp", + "ref": "allow-no-transaction", + "repo": "hasql-migration", + "type": "github" + } + }, "hedis": { "flake": false, "locked": { @@ -321,6 +338,7 @@ "cql": "cql", "cql-io": "cql-io", "flake-utils": "flake-utils", + "hasql-migration": "hasql-migration", "hedis": "hedis", "hspec-wai": "hspec-wai", "http-client": "http-client", diff --git a/flake.nix b/flake.nix index 1b65360f4a1..b5c9a151a50 100644 --- a/flake.nix +++ b/flake.nix @@ -85,6 +85,11 @@ url = "github:brendanhay/amazonka?rev=a7d699be1076e2aad05a1930ca3937ffea954ad8"; flake = false; }; + + hasql-migration = { + url = "github:wireapp/hasql-migration?ref=allow-no-transaction"; + flake = false; + }; }; outputs = inputs@{ nixpkgs, nixpkgs_24_11, nixpkgs-unstable, flake-utils, tom-bombadil, sbomnix, ... }: diff --git a/libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql b/libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql new file mode 100644 index 00000000000..a77c81bcfaf --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql @@ -0,0 +1 @@ +CREATE INDEX CONCURRENTLY IF NOT EXISTS conversation_parent_conv_idx ON conversation (parent_conv); diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs index df3313ccc76..283bdb67d47 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs @@ -22,6 +22,7 @@ module Wire.PostgresMigrations where import Control.Exception import Data.FileEmbed +import Data.Set qualified as Set import Hasql.Migration import Hasql.Pool import Hasql.Session @@ -33,6 +34,10 @@ import System.Logger qualified as Log allMigrations :: [MigrationCommand] allMigrations = map (uncurry MigrationScript) $(makeRelativeToProject "postgres-migrations" >>= embedDir) +-- | Scripts which cannot be run in a transaction +nonTransactionMigrations :: Set ScriptName +nonTransactionMigrations = Set.fromList ["20260428072649-create-conv-parent-index.sql"] + data PostgresMigrationError = PostgresMigrationError MigrationError deriving (Show) @@ -42,12 +47,15 @@ runAllMigrations :: Pool -> Logger -> IO () runAllMigrations pool logger = do let session = do Log.info logger $ Log.msg (Log.val "Running migrations") - transaction Serializable Write $ do - forM_ (MigrationInitialization : allMigrations) $ \migrationCmd -> do - mErr <- runMigration migrationCmd - case mErr of - Nothing -> pure () - Just err -> throw $ PostgresMigrationError err + forM_ (MigrationInitialization : allMigrations) $ \migrationCmd -> do + mErr <- + if maybe False (`Set.member` nonTransactionMigrations) (migrationScriptName migrationCmd) + then runMigrationWithoutTransactions migrationCmd + else transaction Serializable Write $ runMigration migrationCmd + + case mErr of + Nothing -> pure () + Just err -> throw $ PostgresMigrationError err Log.info logger $ Log.msg (Log.val "Migrations completed successfully") either throwIO pure =<< use pool session @@ -58,6 +66,12 @@ migrationName = \case MigrationScript name _ -> Log.field "migration" name MigrationValidation cmd -> Log.field "type" ("validation" :: ByteString) . migrationName cmd +migrationScriptName :: MigrationCommand -> Maybe ScriptName +migrationScriptName = \case + MigrationScript name _ -> Just name + MigrationInitialization -> Nothing + MigrationValidation _ -> Nothing + -- | Only to be used to reset the development DB resetSchema :: Pool -> Logger -> IO () resetSchema pool logger = do diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index 79f352ca20f..c7fced9fddb 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -162,6 +162,11 @@ let amazonka-test = "lib/amazonka-test"; }; }; + + # PR: https://github.com/tvh/hasql-migration/pull/19 + hasql-migration = { + src = inputs.hasql-migration; + }; }; hackagePins = { From 55844e9907dadc6c97cc2cfc2236b148505233b1 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 30 Apr 2026 10:03:59 +0200 Subject: [PATCH 11/18] PostgresMigrations: Ensure only a migration runs once at a time, even when not using transactions (#5209) * PostgresMigrations: Ensure only a migration runs once at a time, even when not using transactions * changelog * Fix typo Co-authored-by: Sven Tennie --------- Co-authored-by: Sven Tennie --- changelog.d/3-bug-fixes/parent-conv-index | 2 +- .../src/Wire/PostgresMigrations.hs | 29 +++++++++++++++++-- 2 files changed, 27 insertions(+), 4 deletions(-) diff --git a/changelog.d/3-bug-fixes/parent-conv-index b/changelog.d/3-bug-fixes/parent-conv-index index 9faf5a291d8..8301bc54b4d 100644 --- a/changelog.d/3-bug-fixes/parent-conv-index +++ b/changelog.d/3-bug-fixes/parent-conv-index @@ -1 +1 @@ -Postgres: Index the parent_conv column in the conversation table \ No newline at end of file +Postgres: Index the parent_conv column in the conversation table (#5205, ##) \ No newline at end of file diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs index 283bdb67d47..699c014f785 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs @@ -22,10 +22,14 @@ module Wire.PostgresMigrations where import Control.Exception import Data.FileEmbed +import Data.Hashable qualified as Hashable import Data.Set qualified as Set import Hasql.Migration import Hasql.Pool import Hasql.Session +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Hasql +import Hasql.TH (resultlessStatement) import Hasql.Transaction.Sessions import Imports import System.Logger (Logger) @@ -49,9 +53,20 @@ runAllMigrations pool logger = do Log.info logger $ Log.msg (Log.val "Running migrations") forM_ (MigrationInitialization : allMigrations) $ \migrationCmd -> do mErr <- - if maybe False (`Set.member` nonTransactionMigrations) (migrationScriptName migrationCmd) - then runMigrationWithoutTransactions migrationCmd - else transaction Serializable Write $ runMigration migrationCmd + case migrationScriptName migrationCmd of + (Just name) + | name `Set.member` nonTransactionMigrations -> do + -- Locking the migration makes sure that only one process is + -- running this migration at a time. Without this `CREATE + -- INDEX CONCURRENTLY` can deadlock with other processes + -- causing a silent failure. + let lockId = fromIntegral $ Hashable.hash name + Session.statement lockId lockNonTransactionMigration + migRes <- runMigrationWithoutTransactions migrationCmd + Session.statement lockId unlockNonTransactionMigration + pure migRes + _ -> + transaction Serializable Write $ runMigration migrationCmd case mErr of Nothing -> pure () @@ -59,6 +74,14 @@ runAllMigrations pool logger = do Log.info logger $ Log.msg (Log.val "Migrations completed successfully") either throwIO pure =<< use pool session + where + lockNonTransactionMigration :: Hasql.Statement Int64 () + lockNonTransactionMigration = + [resultlessStatement|SELECT (1 :: integer) FROM (SELECT pg_advisory_lock($1 :: bigint))|] + + unlockNonTransactionMigration :: Hasql.Statement Int64 () + unlockNonTransactionMigration = + [resultlessStatement|SELECT (1 :: integer) FROM (SELECT pg_advisory_unlock($1 :: bigint))|] migrationName :: MigrationCommand -> (Log.Msg -> Log.Msg) migrationName = \case From 1c3f20e7f15ae091e68e1298722d09a04a0aceb0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 30 Apr 2026 15:26:47 +0200 Subject: [PATCH 12/18] PostgresMigrations: Don't block on migration lock (#5211) This causes deadlocks with another process running the same migration of `CREATE INDEX CONCURRENTLY` because this query waits on all transactions to be complete. Co-authored-by: Sven Tennie --- changelog.d/3-bug-fixes/parent-conv-index | 2 +- .../src/Wire/PostgresMigrations.hs | 37 ++++++++++++++----- 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/changelog.d/3-bug-fixes/parent-conv-index b/changelog.d/3-bug-fixes/parent-conv-index index 8301bc54b4d..6f5eaa0ccf4 100644 --- a/changelog.d/3-bug-fixes/parent-conv-index +++ b/changelog.d/3-bug-fixes/parent-conv-index @@ -1 +1 @@ -Postgres: Index the parent_conv column in the conversation table (#5205, ##) \ No newline at end of file +Postgres: Index the parent_conv column in the conversation table (#5205, #5209, ##) \ No newline at end of file diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs index 699c014f785..9681b98bd30 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs @@ -29,11 +29,12 @@ import Hasql.Pool import Hasql.Session import Hasql.Session qualified as Session import Hasql.Statement qualified as Hasql -import Hasql.TH (resultlessStatement) +import Hasql.TH import Hasql.Transaction.Sessions import Imports import System.Logger (Logger) import System.Logger qualified as Log +import UnliftIO.Retry allMigrations :: [MigrationCommand] allMigrations = map (uncurry MigrationScript) $(makeRelativeToProject "postgres-migrations" >>= embedDir) @@ -55,16 +56,12 @@ runAllMigrations pool logger = do mErr <- case migrationScriptName migrationCmd of (Just name) - | name `Set.member` nonTransactionMigrations -> do + | name `Set.member` nonTransactionMigrations -> -- Locking the migration makes sure that only one process is -- running this migration at a time. Without this `CREATE -- INDEX CONCURRENTLY` can deadlock with other processes -- causing a silent failure. - let lockId = fromIntegral $ Hashable.hash name - Session.statement lockId lockNonTransactionMigration - migRes <- runMigrationWithoutTransactions migrationCmd - Session.statement lockId unlockNonTransactionMigration - pure migRes + withLock name $ runMigrationWithoutTransactions migrationCmd _ -> transaction Serializable Write $ runMigration migrationCmd @@ -75,14 +72,34 @@ runAllMigrations pool logger = do either throwIO pure =<< use pool session where - lockNonTransactionMigration :: Hasql.Statement Int64 () - lockNonTransactionMigration = - [resultlessStatement|SELECT (1 :: integer) FROM (SELECT pg_advisory_lock($1 :: bigint))|] + -- We must use `try` instead of blocking on the lock because running `CREATE + -- INDEX CONCURRENTLY` requires all transactions to be complete and blocking + -- on the lock causes an implicit transaction to be blocked, which means we + -- would end up in a deadlock. + tryLockNonTransactionMigration :: Hasql.Statement Int64 Bool + tryLockNonTransactionMigration = + [singletonStatement|SELECT (pg_try_advisory_lock($1 :: bigint) :: bool)|] unlockNonTransactionMigration :: Hasql.Statement Int64 () unlockNonTransactionMigration = [resultlessStatement|SELECT (1 :: integer) FROM (SELECT pg_advisory_unlock($1 :: bigint))|] + -- We don't have to use 'bracket' here because failing in the session should + -- cause the session to drop and any acquired locks get automatically + -- released. + withLock :: ScriptName -> Session a -> Session a + withLock name migration = do + let lockId = fromIntegral $ Hashable.hash name + + void . retrying (constantDelay 1_000_000) (const $ pure . not) $ \_ -> + Session.statement lockId tryLockNonTransactionMigration + + migRes <- migration + + Session.statement lockId unlockNonTransactionMigration + + pure migRes + migrationName :: MigrationCommand -> (Log.Msg -> Log.Msg) migrationName = \case MigrationInitialization -> Log.field "migration" ("Initialize Migration Schema" :: ByteString) From d408e68d33566ada88c5ccf49f1ee60e09890abb Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 5 May 2026 14:32:21 +0200 Subject: [PATCH 13/18] WPB-21359 fix: Inconsistent notifications are sent to local and remote members when they're removed from MLS conversations (#5210) --- changelog.d/3-bug-fixes/WPB-21359 | 1 + integration/test/MLS/Util.hs | 5 +++-- integration/test/Test/MLS.hs | 10 ++++++++++ .../src/Wire/ConversationStore/MLS/Types.hs | 4 ++++ .../Wire/ConversationSubsystem/MLS/Message.hs | 18 ++++++++++-------- 5 files changed, 28 insertions(+), 10 deletions(-) create mode 100644 changelog.d/3-bug-fixes/WPB-21359 diff --git a/changelog.d/3-bug-fixes/WPB-21359 b/changelog.d/3-bug-fixes/WPB-21359 new file mode 100644 index 00000000000..4c0a7892df3 --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-21359 @@ -0,0 +1 @@ +Fix: Inconsistent removal messages across local and federated conversation members diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index a30031f6362..cdbd6fcee2c 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -682,7 +682,8 @@ consumingMessages mlsProtocol mp = Codensity $ \k -> do -- at this point we know that every new user has been added to the -- conversation - for_ (zip clients wss) $ \((cid, t), ws) -> case t of + let cssNoToBeRemoved = filter (\((ci, _), _) -> ci `Set.notMember` conv.membersToBeRemoved) (zip clients wss) + for_ cssNoToBeRemoved $ \((cid, t), ws) -> case t of MLSNotificationMessageTag -> when (conv.epoch > 0) $ void $ @@ -717,7 +718,7 @@ consumeMessageNoExternal cs cid mp = consumeMessageWithPredicate isNewMLSMessage where -- the backend (correctly) reacts to a commit removing someone from a parent conversation with a -- remove proposal, however, we don't want to consume this here - isNewMLSMessageNotifButNoProposal :: Value -> App Bool + isNewMLSMessageNotifButNoProposal :: (HasCallStack) => Value -> App Bool isNewMLSMessageNotifButNoProposal n = do isRelevantNotif <- isNewMLSMessageNotif n &&~ isNotifConvId mp.convId n if isRelevantNotif diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index de871aae26e..567168f1200 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -1209,3 +1209,13 @@ testGroupIdParseError = do resp.json %. "label" `shouldMatch` "mls-protocol-error" msg <- resp.json %. "message" & asString assertBool "unexpected error message" $ "Could not parse group ID:" `isPrefixOf` msg + +testFederatedRemove :: (HasCallStack) => App () +testFederatedRemove = do + [alice, amy, bob] <- createAndConnectUsers [OwnDomain, OwnDomain, OtherDomain] + [alice1, amy1, bob1] <- traverse (createMLSClient def) [alice, amy, bob] + traverse_ (uploadNewKeyPackage def) [amy1, bob1] + convId <- createNewGroup def alice1 + + void $ createAddCommit alice1 convId [amy, bob] >>= sendAndConsumeCommitBundle + void $ createRemoveCommit alice1 convId [amy1, bob1] >>= sendAndConsumeCommitBundle diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs b/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs index 2573cfdd0fd..f3e620ed1de 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs @@ -174,6 +174,10 @@ cmSingleton cid idx = (cidQualifiedUser cid) (Map.singleton (ciClient cid) idx) +-- | Construct the subset of the first client map consisting of users that are present in the second. +cmIntersect :: ClientMap a -> ClientMap b -> ClientMap a +cmIntersect (ClientMap m1) (ClientMap m2) = ClientMap (Map.intersection m1 m2) + -- | Inform a handler for 'POST /conversations/list-ids' if the MLS global team -- conversation and the MLS self-conversation should be included in the -- response. diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 1059711effd..dde9267c7e8 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -297,7 +297,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do senderIdentity <- getSenderIdentity qusr c bundle.sender lConvOrSub - (events, newClients) <- handleGroupInfoMismatch lConvOrSubId bundle $ lowerCodensity $ do + (events, newClients, lConvOrSub') <- handleGroupInfoMismatch lConvOrSubId bundle $ lowerCodensity $ do (events, newClients) <- case senderIdentity.index of Just _ -> do -- extract added/removed clients from bundle @@ -341,11 +341,16 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do action bundle.commit.value.path pure ([], mempty) - lift $ do + lConvOrSub' <- lift $ do updateOutOfSyncFlag senderIdentity.client lConvOrSub storeGroupInfo convOrSub.id (GroupInfoData bundle.groupInfo.raw) - propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage convOrSub.members - pure (events, newClients) + -- reload conversation from db to make sure we have an up-to-date list of members + lConvOrSub' <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId + let convOrSub' = tUnqualified lConvOrSub' + mems = cmIntersect (void convOrSub.members) convOrSub'.members + propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage mems + pure lConvOrSub' + pure (events, newClients, lConvOrSub') -- send welcome messages for_ bundle.welcome $ \welcome -> @@ -353,11 +358,8 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do -- send application message for_ bundle.appMessage $ \msg -> do - -- reload conversation from db to make sure we have an up-to-date list of members - lConvOrSub' <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId let convOrSub' = tUnqualified lConvOrSub' - propagateMessage qusr (Just c) lConvOrSub' conn msg.rawMessage $ - void convOrSub'.members + propagateMessage qusr (Just c) lConvOrSub' conn msg.rawMessage convOrSub'.members pure events From b4c8558c5549dc3e47052c70dfd50970692b8d82 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 5 May 2026 17:16:48 +0200 Subject: [PATCH 14/18] WPB-25109: Move meetings feature check from galley service layer into the MeetingsSubsystem interpreter (#5214) --- changelog.d/5-internal/WPB-25109 | 1 + .../src/Wire/MeetingsSubsystem/Interpreter.hs | 51 ++++++- .../Wire/MeetingsSubsystem/InterpreterSpec.hs | 125 ++++++++++++++++++ services/galley/src/Galley/API/Meetings.hs | 67 ++-------- services/galley/src/Galley/App.hs | 1 + 5 files changed, 183 insertions(+), 62 deletions(-) create mode 100644 changelog.d/5-internal/WPB-25109 diff --git a/changelog.d/5-internal/WPB-25109 b/changelog.d/5-internal/WPB-25109 new file mode 100644 index 00000000000..760cc4d6672 --- /dev/null +++ b/changelog.d/5-internal/WPB-25109 @@ -0,0 +1 @@ +Move meetings feature check from galley service layer into the MeetingsSubsystem interpreter, ensuring the check is enforced consistently within the subsystem. \ No newline at end of file diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index f038e9d6564..a37eb03b338 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -37,7 +37,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Meeting qualified as API import Wire.API.Routes.MultiTablePaging qualified as MultiTablePaging -import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsPremiumConfig) +import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsConfig, MeetingsPremiumConfig) import Wire.API.User (BaseProtocolTag (BaseProtocolMLSTag), EmailAddress) import Wire.ConversationSubsystem (ConversationSubsystem) import Wire.ConversationSubsystem qualified as ConversationSubsystem @@ -50,9 +50,23 @@ import Wire.StoredConversation import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -data MeetingError = InvalidTimes | EmptyUpdate +data MeetingError = InvalidTimes | EmptyUpdate | MeetingsFeatureDisabled deriving stock (Eq, Show) +checkMeetingsEnabled :: + ( Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r + ) => + Maybe TeamId -> + Sem r () +checkMeetingsEnabled maybeTeamId = do + case maybeTeamId of + Nothing -> pure () + Just teamId -> do + meetingFeature <- getFeatureForTeam @_ @MeetingsConfig teamId + unless (meetingFeature.status == FeatureStatusEnabled) $ + throw MeetingsFeatureDisabled + interpretMeetingsSubsystem :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, @@ -90,12 +104,14 @@ createMeetingImpl :: API.NewMeeting -> Sem r (API.Meeting, StoredConversation) createMeetingImpl zUser newMeeting = do + -- Look up user's team once and reuse for both checks + conversationTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled conversationTeamId -- Validate that endTime > startTime when (newMeeting.endTime <= newMeeting.startTime) $ throw InvalidTimes -- Determine trial status based on team membership and premium feature - conversationTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) trial <- case conversationTeamId of Nothing -> pure True -- Personal users create trial meetings Just teamId -> do @@ -146,6 +162,8 @@ createMeetingImpl zUser newMeeting = do updateMeetingImpl :: ( Member Store.MeetingsStore r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, Member (Error MeetingError) r, Member Now r ) => @@ -155,6 +173,8 @@ updateMeetingImpl :: NominalDiffTime -> Sem r (Maybe API.Meeting) updateMeetingImpl zUser meetingId update validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId when (isNothing update.title && isNothing update.startTime && isNothing update.endTime && isNothing update.recurrence) $ throw EmptyUpdate @@ -182,6 +202,9 @@ updateMeetingImpl zUser meetingId update validityPeriod = do deleteMeetingImpl :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -190,6 +213,8 @@ deleteMeetingImpl :: NominalDiffTime -> Sem r Bool deleteMeetingImpl zUser connId meetingId validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId result <- runMaybeT $ do meeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) @@ -211,6 +236,9 @@ deleteMeetingImpl zUser connId meetingId validityPeriod = do getMeetingImpl :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -218,6 +246,8 @@ getMeetingImpl :: NominalDiffTime -> Sem r (Maybe API.Meeting) getMeetingImpl zUser meetingId validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId -- Get meeting from store runMaybeT $ do storedMeeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) @@ -255,12 +285,17 @@ storedMeetingToMeeting domain sm = listMeetingsImpl :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> NominalDiffTime -> Sem r [API.Meeting] listMeetingsImpl zUser validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId now <- Now.get let cutoff = addUTCTime (negate validityPeriod) now -- List all meetings created by the user @@ -319,6 +354,9 @@ getAllMemberMeetings zUser cutoff = do addInvitedEmailsImpl :: ( Member Store.MeetingsStore r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -327,6 +365,8 @@ addInvitedEmailsImpl :: NominalDiffTime -> Sem r Bool addInvitedEmailsImpl zUser meetingId emails validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId result <- runMaybeT $ do storedMeeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) @@ -341,6 +381,9 @@ addInvitedEmailsImpl zUser meetingId emails validityPeriod = do removeInvitedEmailsImpl :: ( Member Store.MeetingsStore r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -349,6 +392,8 @@ removeInvitedEmailsImpl :: NominalDiffTime -> Sem r Bool removeInvitedEmailsImpl zUser meetingId emails validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId result <- runMaybeT $ do storedMeeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) diff --git a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs index 4e14e34d6e0..8bb558b8998 100644 --- a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs @@ -751,3 +751,128 @@ spec = describe "MeetingsSubsystem.Interpreter" $ do removeInvitedEmails zUser1 nonExistentId [email1] result `shouldBe` Right False + + describe "checkMeetingsEnabled" $ do + let now = UTCTime (fromGregorian 2026 1 1) 0 + gen = mkStdGen 42 + uidPersonal = Id $ read "00000000-0000-0000-0000-000000000001" + uidTeam = Id $ read "00000000-0000-0000-0000-000000000002" + zUserPersonal = toLocalUnsafe (Domain "wire.com") uidPersonal + zUserTeam = toLocalUnsafe (Domain "wire.com") uidTeam + teamId = Id $ read "00000000-0000-0000-0000-000000000100" + teamMember = mkTeamMember uidTeam fullPermissions Nothing UserLegalHoldDisabled + meetingsEnabled = + npUpdate @MeetingsConfig (LockableFeature FeatureStatusEnabled LockStatusUnlocked def) def + meetingsDisabled = + npUpdate @MeetingsConfig (LockableFeature FeatureStatusDisabled LockStatusUnlocked def) def + newMeeting = + API.NewMeeting + { title = fromJust $ checked "Test Meeting", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + it "allows operations for personal user even when meetings disabled" $ do + result <- + runTestStack now gen Map.empty meetingsDisabled $ + createMeeting zUserPersonal newMeeting + + result `shouldSatisfy` isRight + + it "allows operations for team user with meetings enabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ + createMeeting zUserTeam newMeeting + + result `shouldSatisfy` isRight + + it "throws MeetingsFeatureDisabled on createMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + createMeeting zUserTeam newMeeting + + result `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on getMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + getMeeting zUserTeam meeting.id + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on updateMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + updateMeeting zUserTeam meeting.id (API.UpdateMeeting Nothing Nothing (Just (unsafeRange "Updated")) Nothing) + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on deleteMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + deleteMeeting zUserTeam (ConnId "test-conn") meeting.id + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on listMeetings for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + listMeetings zUserTeam + + result `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on addInvitedEmails for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + addInvitedEmails zUserTeam meeting.id [unsafeEmailAddress "test" "example.com"] + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on removeInvitedEmails for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + removeInvitedEmails zUserTeam meeting.id [unsafeEmailAddress "test" "example.com"] + + result2 `shouldBe` Left MeetingsFeatureDisabled diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs index d076f399ea3..e4e99e2b772 100644 --- a/services/galley/src/Galley/API/Meetings.hs +++ b/services/galley/src/Galley/API/Meetings.hs @@ -34,48 +34,20 @@ import Polysemy import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Meeting -import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsConfig) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) import Wire.MeetingsSubsystem qualified as Meetings -import Wire.TeamStore qualified as TeamStore - --- | Check if meetings feature is enabled for the user (if they're in a team) -checkMeetingsEnabled :: - ( Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r - ) => - UserId -> - Sem r () -checkMeetingsEnabled userId = do - maybeTeamId <- TeamStore.getOneUserTeam userId - case maybeTeamId of - Nothing -> pure () -- Personal users can use meetings - Just teamId -> do - meetingFeature <- getFeatureForTeam @_ @MeetingsConfig teamId - unless (meetingFeature.status == FeatureStatusEnabled) $ - throwS @'InvalidOperation createMeeting :: - ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'InvalidOperation) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => + (Member Meetings.MeetingsSubsystem r) => Local UserId -> NewMeeting -> Sem r Meeting createMeeting lUser newMeeting = do - checkMeetingsEnabled (tUnqualified lUser) (meeting, _conversation) <- Meetings.createMeeting lUser newMeeting pure meeting updateMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> @@ -83,7 +55,6 @@ updateMeeting :: UpdateMeeting -> Sem r Meeting updateMeeting zUser domain meetingId update = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain maybeMeeting <- Meetings.updateMeeting zUser qMeetingId update case maybeMeeting of @@ -92,10 +63,7 @@ updateMeeting zUser domain meetingId update = do deleteMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> ConnId -> @@ -103,24 +71,19 @@ deleteMeeting :: MeetingId -> Sem r () deleteMeeting zUser connId domain meetingId = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.deleteMeeting zUser connId qMeetingId unless success $ throwS @'MeetingNotFound getMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> MeetingId -> Sem r Meeting getMeeting zUser domain meetingId = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain maybeMeeting <- Meetings.getMeeting zUser qMeetingId case maybeMeeting of @@ -128,23 +91,14 @@ getMeeting zUser domain meetingId = do Just meeting -> pure meeting listMeetings :: - ( Member Meetings.MeetingsSubsystem r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r - ) => + (Member Meetings.MeetingsSubsystem r) => Local UserId -> Sem r [Meeting] -listMeetings lUser = do - checkMeetingsEnabled (tUnqualified lUser) - Meetings.listMeetings lUser +listMeetings lUser = Meetings.listMeetings lUser addMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> @@ -152,17 +106,13 @@ addMeetingInvitation :: MeetingEmailsInvitation -> Sem r () addMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.addInvitedEmails zUser qMeetingId emails unless success $ throwS @'MeetingNotFound removeMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> @@ -170,7 +120,6 @@ removeMeetingInvitation :: MeetingEmailsInvitation -> Sem r () removeMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.removeInvitedEmails zUser qMeetingId emails unless success $ throwS @'MeetingNotFound diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index e27c5e45ce0..34a064be715 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -581,3 +581,4 @@ meetingError = \case Meeting.InvalidTimes -> Servant.Tagged @'InvalidOperation () Meeting.EmptyUpdate -> Servant.Tagged @'InvalidOperation () + Meeting.MeetingsFeatureDisabled -> Servant.Tagged @'InvalidOperation () From 57d02a6040bd48fc0e7fdbe402c833eb6e877a96 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 7 May 2026 18:20:18 +0200 Subject: [PATCH 15/18] [WPB-25136] Do not count apps as paying users. (#5213) * Refactor: de-duplicate rpc calls to fetch team size. * Refactor: move local function from top-level into where clause. This way it's clear that it may not work for related use cases. * Refactor: lint. * Haddocks. * Extend TeamSize type to contain one Natural per user type. * Tune ES query. * De-obfuscate tuned ES query. --- ...PB-25136-do-not-count-apps-as-paying-users | 1 + ...PB-25136-do-not-count-apps-as-paying-users | 1 + integration/test/API/Brig.hs | 6 + integration/test/API/BrigInternal.hs | 5 + integration/test/Test/Apps.hs | 34 +++++- .../proto/TeamEvents.proto | 13 +++ libs/wire-api/src/Wire/API/Team/Size.hs | 51 +++++++-- libs/wire-api/src/Wire/API/User/Search.hs | 3 + .../Test/Wire/API/Golden/Manual/TeamSize.hs | 6 +- .../test/golden/testObject_TeamSize_1.json | 4 +- .../test/golden/testObject_TeamSize_2.json | 4 +- .../test/golden/testObject_TeamSize_3.json | 4 +- .../Wire/IndexedUserStore/ElasticSearch.hs | 60 ++++++++-- libs/wire-subsystems/src/Wire/TeamJournal.hs | 18 ++- .../src/Wire/UserSubsystem/Interpreter.hs | 4 +- .../Wire/MockInterpreters/IndexedUserStore.hs | 14 ++- services/brig/test/integration/API/Team.hs | 2 +- .../galley/src/Galley/API/LegalHold/Team.hs | 10 +- services/galley/src/Galley/API/Teams.hs | 105 ++++++++++-------- 19 files changed, 259 insertions(+), 86 deletions(-) create mode 100644 changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users create mode 100644 changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users diff --git a/changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users b/changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users new file mode 100644 index 00000000000..940164d7ee0 --- /dev/null +++ b/changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users @@ -0,0 +1 @@ +`GET /teams/:tid/size` response body lists `teamSizeRegulars`, `teamSizeApps`. diff --git a/changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users b/changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users new file mode 100644 index 00000000000..0783281d1b5 --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users @@ -0,0 +1 @@ +Do not count apps as paying users. diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index d5cc1d33bf9..56b0d0b5867 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -932,6 +932,12 @@ activateSend domain email locale = do req <- rawBaseRequest domain Brig Versioned $ joinHttpPath ["activate", "send"] submit "POST" $ req & addJSONObject (["email" .= email] <> maybeToList (((.=) "locale") <$> locale)) +-- https://staging-nginz-https.zinfra.io/v16/api/swagger-ui/#/default/get-team-size +getTeamSize :: (HasCallStack, MakesValue user) => user -> String -> App Response +getTeamSize user tid = do + req <- baseRequest user Brig Versioned $ joinHttpPath ["teams", tid, "size"] + submit "GET" req + acceptTeamInvitation :: (HasCallStack, MakesValue user) => user -> String -> Maybe String -> App Response acceptTeamInvitation user code mPw = do req <- baseRequest user Brig Versioned $ joinHttpPath ["teams", "invitations", "accept"] diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index ff9ab3d1357..4a0051e8907 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -186,6 +186,11 @@ refreshIndex domain = do res <- submit "POST" req res.status `shouldMatchInt` 200 +getTeamSize :: (HasCallStack, MakesValue caller) => caller -> String -> App Response +getTeamSize caller tid = do + req <- baseRequest caller Brig Unversioned $ joinHttpPath ["i", "teams", tid, "size"] + submit "GET" req + addFederationRemoteTeam :: (HasCallStack, MakesValue domain, MakesValue remoteDomain, MakesValue team) => domain -> remoteDomain -> team -> App () addFederationRemoteTeam domain remoteDomain team = do void $ addFederationRemoteTeam' domain remoteDomain team >>= getBody 200 diff --git a/integration/test/Test/Apps.hs b/integration/test/Test/Apps.hs index 72eaa5e637f..cdce0eb5b77 100644 --- a/integration/test/Test/Apps.hs +++ b/integration/test/Test/Apps.hs @@ -19,7 +19,7 @@ module Test.Apps where -import API.Brig +import API.Brig as Brig import qualified API.BrigInternal as BrigI import API.Common import API.Galley @@ -28,6 +28,7 @@ import Data.Aeson.QQ.Simple import MLS.Util import Notifications import SetupHelpers +import System.Random (randomRIO) import Testlib.Prelude testCreateGetApp :: (HasCallStack) => Domain -> App () @@ -561,3 +562,34 @@ testAppReceivesMemberJoinNotification = do memberJoinApp <- awaitMatch isTeamMemberJoinNotif wsApp memberJoinApp %. "payload.0.team" `shouldMatch` tid memberJoinApp %. "payload.0.data.user" `shouldMatch` objId newMember + +testTeamSizeWithApps :: (HasCallStack) => TaggedBool "test internal api" -> App () +testTeamSizeWithApps (TaggedBool testInternalApi) = do + domain <- make OwnDomain + numRegulars <- liftIO $ randomRIO (1 :: Int, 3) + numApps <- liftIO $ randomRIO (1 :: Int, 3) + + (owner, tid, extraMembers) <- createTeam domain (numRegulars + 1) + + apps <- replicateM numApps $ bindResponse (createApp owner tid def) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + let checkSize :: (HasCallStack) => Int -> Int -> App () + checkSize wantRegulars wantApps = + (if testInternalApi then BrigI.getTeamSize else Brig.getTeamSize) owner tid `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "teamSize" `shouldMatchInt` (1 + wantRegulars + wantApps) + resp.json %. "teamSizeRegulars" `shouldMatchInt` (1 + wantRegulars) + resp.json %. "teamSizeApps" `shouldMatchInt` wantApps + + BrigI.refreshIndex domain + eventually $ do + checkSize numRegulars numApps + + deleteTeamMember tid owner (head apps) >>= assertSuccess + deleteTeamMember tid owner (head extraMembers) >>= assertSuccess + + BrigI.refreshIndex domain + eventually $ do + checkSize (numRegulars - 1) (numApps - 1) diff --git a/libs/types-common-journal/proto/TeamEvents.proto b/libs/types-common-journal/proto/TeamEvents.proto index 8dc80757cd8..8bd25c21cc8 100644 --- a/libs/types-common-journal/proto/TeamEvents.proto +++ b/libs/types-common-journal/proto/TeamEvents.proto @@ -13,6 +13,19 @@ message TeamEvent { required int32 member_count = 1; repeated bytes billing_user = 2; optional string currency = 3; // ISO_4217 + + // the following fields are at the end of the declaration + // for backwards compatibility. + // + // this declaration is used to generate producer code, so it + // is ok and desirable to make this fields mandatory (they + // are guaranteed to be present). + // + // for backwards compatibility, clients should make these + // fields optional, and fall back to using `member_count` if + // they are missing. + required int32 member_count_regular = 4; + required int32 member_count_app = 5; } enum EventType { diff --git a/libs/wire-api/src/Wire/API/Team/Size.hs b/libs/wire-api/src/Wire/API/Team/Size.hs index 65f6c23b0d7..d751769a903 100644 --- a/libs/wire-api/src/Wire/API/Team/Size.hs +++ b/libs/wire-api/src/Wire/API/Team/Size.hs @@ -16,30 +16,67 @@ -- with this program. If not, see . module Wire.API.Team.Size - ( TeamSize (TeamSize), + ( TeamSize (..), + teamSizeTotal, + updateTeamSize, ) where import Control.Lens ((?~)) import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A import Data.OpenApi qualified as S import Data.Schema import Imports import Numeric.Natural import Test.QuickCheck (arbitrarySizedNatural) +import Wire.API.User.Search import Wire.Arbitrary -newtype TeamSize = TeamSize Natural +data TeamSize = TeamSize + { regulars :: Natural, + apps :: Natural + } deriving (Show, Eq) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TeamSize) +-- | Total team members (regulars + apps). +teamSizeTotal :: TeamSize -> Natural +teamSizeTotal ts = ts.regulars + ts.apps + +-- Increase or decrease a team size component, depending on user type. + +-- If the result of a decrease is <0, it is set to 1 (regulars) or 0 +-- (apps). This handles corner cases where ES reports lower numbers +-- from the past. +updateTeamSize :: UserTypeFilter -> TeamSize -> Int -> TeamSize +updateTeamSize = go + where + go :: UserTypeFilter -> TeamSize -> Int -> TeamSize + go UserTypeFilterRegular (TeamSize rs as) n = TeamSize (upd 1 rs n) as + go UserTypeFilterApp (TeamSize rs as) n = TeamSize rs (upd 0 as n) + + upd :: Int -> Natural -> Int -> Natural + upd low n i = fromIntegral . max low $ fromIntegral n + i + instance ToSchema TeamSize where schema = - objectWithDocModifier (description ?~ "A simple object with a total number of team members.") $ - TeamSize <$> (unTeamSize .= fieldWithDocModifier "teamSize" (description ?~ "Team size.") schema) + objectWithDocModifier (description ?~ "Team member counts broken down by user type.") $ + fromTeamSize .= tripleSchema `withParser` validate where - unTeamSize :: TeamSize -> Natural - unTeamSize (TeamSize n) = n + fromTeamSize :: TeamSize -> (Natural, Natural, Maybe Natural) + fromTeamSize ts = (ts.regulars, ts.apps, Just (teamSizeTotal ts)) + tripleSchema :: ObjectSchema SwaggerDoc (Natural, Natural, Maybe Natural) + tripleSchema = + (,,) + <$> (\(r, _, _) -> r) .= fieldWithDocModifier "teamSizeRegulars" (description ?~ "Number of regular users in team.") schema + <*> (\(_, a, _) -> a) .= fieldWithDocModifier "teamSizeApps" (description ?~ "Number of apps in team.") schema + <*> (\(_, _, t) -> t) .= maybe_ (optFieldWithDocModifier "teamSize" (description ?~ "Total team members (teamSizeRegulars + teamSizeApps).") schema) + validate :: (Natural, Natural, Maybe Natural) -> A.Parser TeamSize + validate (r, a, Nothing) = pure TeamSize {regulars = r, apps = a} + validate (r, a, Just t) + | r + a == t = pure TeamSize {regulars = r, apps = a} + | otherwise = fail $ "teamSize (" <> show t <> ") != regulars + apps (" <> show (r + a) <> ")" instance Arbitrary TeamSize where - arbitrary = TeamSize <$> arbitrarySizedNatural + arbitrary = TeamSize <$> arbitrarySizedNatural <*> arbitrarySizedNatural diff --git a/libs/wire-api/src/Wire/API/User/Search.hs b/libs/wire-api/src/Wire/API/User/Search.hs index 07a5c27cd29..13325e91915 100644 --- a/libs/wire-api/src/Wire/API/User/Search.hs +++ b/libs/wire-api/src/Wire/API/User/Search.hs @@ -317,6 +317,9 @@ instance FromByteString RoleFilter where parts <- C8.split ',' <$> parser RoleFilter <$> traverse (maybe (fail "Invalid role") pure . fromByteString) parts +-- In some places, we don't have bots as an option, so we don't want +-- to use 'UserType'. Once bots are removed from the picture, +-- 'UserType' and 'UserTypeFilter' will be the same ething. data UserTypeFilter = UserTypeFilterRegular | UserTypeFilterApp deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserTypeFilter) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs index 8686e290a49..8137fe05501 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs @@ -21,10 +21,10 @@ import Imports import Wire.API.Team.Size testObject_TeamSize_1 :: TeamSize -testObject_TeamSize_1 = TeamSize 0 +testObject_TeamSize_1 = TeamSize 0 0 testObject_TeamSize_2 :: TeamSize -testObject_TeamSize_2 = TeamSize 100 +testObject_TeamSize_2 = TeamSize 100 400 testObject_TeamSize_3 :: TeamSize -testObject_TeamSize_3 = TeamSize (fromIntegral $ maxBound @Word64) +testObject_TeamSize_3 = TeamSize (fromIntegral $ maxBound @Word64) (fromIntegral $ maxBound @Word64) diff --git a/libs/wire-api/test/golden/testObject_TeamSize_1.json b/libs/wire-api/test/golden/testObject_TeamSize_1.json index c883020b742..92dda71f2da 100644 --- a/libs/wire-api/test/golden/testObject_TeamSize_1.json +++ b/libs/wire-api/test/golden/testObject_TeamSize_1.json @@ -1,3 +1,5 @@ { - "teamSize": 0 + "teamSize": 0, + "teamSizeApps": 0, + "teamSizeRegulars": 0 } diff --git a/libs/wire-api/test/golden/testObject_TeamSize_2.json b/libs/wire-api/test/golden/testObject_TeamSize_2.json index b33bf1f3bd8..5b9794591db 100644 --- a/libs/wire-api/test/golden/testObject_TeamSize_2.json +++ b/libs/wire-api/test/golden/testObject_TeamSize_2.json @@ -1,3 +1,5 @@ { - "teamSize": 100 + "teamSize": 500, + "teamSizeApps": 400, + "teamSizeRegulars": 100 } diff --git a/libs/wire-api/test/golden/testObject_TeamSize_3.json b/libs/wire-api/test/golden/testObject_TeamSize_3.json index 2e47b19f3e7..421801b4b47 100644 --- a/libs/wire-api/test/golden/testObject_TeamSize_3.json +++ b/libs/wire-api/test/golden/testObject_TeamSize_3.json @@ -1,3 +1,5 @@ { - "teamSize": 1.8446744073709551615e19 + "teamSize": 3.689348814741910323e19, + "teamSizeApps": 1.8446744073709551615e19, + "teamSizeRegulars": 1.8446744073709551615e19 } diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index a4a9a903052..156f8f6e479 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -23,11 +23,13 @@ import Control.Error (lastMay) import Control.Exception (throwIO) import Data.Aeson import Data.Aeson.Key qualified as Key +import Data.Aeson.Types (parseMaybe) import Data.ByteString qualified as LBS import Data.ByteString.Builder import Data.ByteString.Conversion import Data.Id import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as M import Data.Text qualified as Text import Data.Text.Ascii import Data.Text.Encoding qualified as Text @@ -35,6 +37,7 @@ import Database.Bloodhound qualified as ES import Imports import Network.HTTP.Client import Network.HTTP.Types +import Numeric.Natural (Natural) import Polysemy import Wire.API.Team.Role (roleName) import Wire.API.Team.Size (TeamSize (TeamSize)) @@ -81,18 +84,49 @@ getTeamSizeImpl :: TeamId -> Sem r TeamSize getTeamSizeImpl cfg tid = do - let indexName = cfg.conn.indexName - countResEither <- embed $ ES.runBH cfg.conn.env $ ES.countByIndex indexName (ES.CountQuery query) - countRes <- either (liftIO . throwIO . IndexLookupError) pure countResEither - pure . TeamSize $ ES.crCount countRes + r <- embed $ ES.runBH cfg.conn.env $ do + res <- ES.searchByType cfg.conn.indexName mappingName search + liftIO $ ES.parseEsResponse res + result <- either (embed . throwIO . IndexLookupError) pure (r :: Either ES.EsError (ES.SearchResult UserDoc)) + let aggs = fromMaybe mempty (ES.aggregations result) + getCount name = maybe 0 (.filterDocCount) $ M.lookup name aggs >>= parseMaybe (parseJSON @FilterResult) + pure $ TeamSize (getCount "regulars") (getCount "apps") where - query = - ES.TermQuery - ES.Term - { ES.termField = "team", - ES.termValue = idToText tid + teamQ = termQ "team" (idToText tid) + + -- Regular users: type = "regular" or type field absent (legacy documents) + regularQuery = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = + [ teamQ, + ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ termQ "type" "regular", + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = [ES.QueryExistsQuery (ES.FieldName "type")] + } + ] + } + ] } - Nothing + + appQuery = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = [teamQ, termQ "type" "app"] + } + + search = + (ES.mkSearch Nothing Nothing) + { ES.size = ES.Size 0, + ES.aggBody = + Just $ + ES.mkAggregations "regulars" (ES.FilterAgg (ES.FilterAggregation (ES.Filter regularQuery) Nothing)) + <> ES.mkAggregations "apps" (ES.FilterAgg (ES.FilterAggregation (ES.Filter appQuery) Nothing)) + } upsertImpl :: forall r. @@ -647,3 +681,9 @@ mappingName = ES.MappingName "user" boolQuery :: ES.BoolQuery boolQuery = ES.mkBoolQuery [] [] [] [] + +-- | (or can something like this be found in bloodhound?) +newtype FilterResult = FilterResult {filterDocCount :: Natural} + +instance FromJSON FilterResult where + parseJSON = withObject "FilterResult" $ \o -> FilterResult <$> o .: "doc_count" diff --git a/libs/wire-subsystems/src/Wire/TeamJournal.hs b/libs/wire-subsystems/src/Wire/TeamJournal.hs index c8e6ba64a00..9ae5ec1044a 100644 --- a/libs/wire-subsystems/src/Wire/TeamJournal.hs +++ b/libs/wire-subsystems/src/Wire/TeamJournal.hs @@ -27,11 +27,11 @@ import Data.ProtoLens (defMessage) import Data.Text (pack) import Data.Time.Clock.POSIX import Imports hiding (head) -import Numeric.Natural import Polysemy import Proto.TeamEvents (TeamEvent, TeamEvent'EventData, TeamEvent'EventType (..)) import Proto.TeamEvents_Fields qualified as T import Wire.API.Team (TeamCreationTime (..)) +import Wire.API.Team.Size import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.TeamStore @@ -52,7 +52,7 @@ teamActivate :: Member TeamJournal r ) => TeamId -> - Natural -> + TeamSize -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Sem r () @@ -65,7 +65,7 @@ teamUpdate :: Member TeamJournal r ) => TeamId -> - Natural -> + TeamSize -> [UserId] -> Sem r () teamUpdate tid teamSize billingUserIds = @@ -111,9 +111,15 @@ journalEvent typ tid dat tim = do ---------------------------------------------------------------------------- -- utils -evData :: Natural -> [UserId] -> Maybe Currency.Alpha -> TeamEvent'EventData -evData memberCount billingUserIds cur = +evData :: TeamSize -> [UserId] -> Maybe Currency.Alpha -> TeamEvent'EventData +evData teamSize@(TeamSize regulars apps) billingUserIds cur = defMessage - & T.memberCount .~ fromIntegral memberCount + & T.memberCount .~ memberCountTotal & T.billingUser .~ (toBytes <$> billingUserIds) & T.maybe'currency .~ (pack . show <$> cur) + & T.memberCountRegular .~ memberCountRegulars + & T.memberCountApp .~ memberCountApps + where + memberCountTotal, memberCountRegulars, memberCountApps :: Int32 + (memberCountTotal, memberCountRegulars, memberCountApps) = + (fromIntegral $ teamSizeTotal teamSize, fromIntegral regulars, fromIntegral apps) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index ac8347ed4ed..42ec197d844 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -66,7 +66,7 @@ import Wire.API.Team.Member.Info (TeamMemberInfo (..), TeamMemberInfoList (membe import Wire.API.Team.Permission qualified as Permission import Wire.API.Team.Role (Role, defaultRole, permissionsToRole) import Wire.API.Team.SearchVisibility -import Wire.API.Team.Size (TeamSize (TeamSize)) +import Wire.API.Team.Size import Wire.API.User as User import Wire.API.User.RichInfo import Wire.API.User.Search @@ -251,7 +251,7 @@ internalFindTeamInvitationImpl (Just e) c = NotAllowed -> throwGuardFailed TeamInviteSetToNotAllowed maxSize <- maxTeamSize <$> input - (TeamSize teamSize) <- IndexedUserStore.getTeamSize tid + teamSize <- teamSizeTotal <$> IndexedUserStore.getTeamSize tid when (teamSize >= fromIntegral maxSize) $ throw UserSubsystemTooManyTeamMembers -- FUTUREWORK: The above can easily be done/tested in the intra call. diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs index a61614d1385..b77869840fe 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -28,6 +30,7 @@ import Imports import Polysemy import Polysemy.State import Wire.API.Team.Size +import Wire.API.User import Wire.API.User.Search import Wire.IndexedUserStore import Wire.UserSearch.Types @@ -84,10 +87,13 @@ inMemoryIndexedUserStoreInterpreter = error "IndexedUserStore: unimplemented in memory interpreter" GetTeamSize tid -> gets $ \index -> - TeamSize - . fromIntegral - . length - $ Map.filter (\(doc, _) -> doc.udTeam == Just tid) index.docs + let regulars = help [Just UserTypeRegular, Nothing] + apps = help [Just UserTypeApp] + help allowedTypes = + fromIntegral + . length + $ Map.filter (\(doc, _) -> doc.udTeam == Just tid && doc.udType `elem` allowedTypes) index.docs + in TeamSize {..} upsertImpl :: (Member (State UserIndex) r) => ES.DocId -> UserDoc -> ES.VersionControl -> Sem r () upsertImpl docId userDoc versionControl = diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 174eb48a4b8..66e1ead9e28 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -154,7 +154,7 @@ testTeamSize brig req = do void $ get (req tid uid) Sem r () ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- getSize tid - unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ + teamSize <- getSize tid + unlessM (teamSizeBelowLimit teamSize) $ throwS @'CannotEnableLegalHoldServiceLargeTeam teamSizeBelowLimit :: ( Member (Input FanoutLimit) r, Member (Input (FeatureDefaults LegalholdConfig)) r ) => - Int -> + TeamSize -> Sem r Bool -teamSizeBelowLimit teamSize = do - limit <- fromIntegral . fromRange <$> input @FanoutLimit +teamSizeBelowLimit (fromIntegral . teamSizeTotal -> teamSize) = do + limit :: Int <- fromIntegral . fromRange <$> input @FanoutLimit let withinLimit = teamSize <= limit featureLegalHold <- input @(FeatureDefaults LegalholdConfig) case featureLegalHold of diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 726a4651258..ee41c15cdaa 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -115,6 +115,7 @@ import Wire.API.Team.SearchVisibility import Wire.API.Team.SearchVisibility qualified as Public import Wire.API.Team.Size import Wire.API.User qualified as U +import Wire.API.User.Search import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.BrigAPIAccess qualified as E @@ -281,12 +282,12 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. - (TeamSize possiblyStaleSize) <- E.getSize tid - let size = - if possiblyStaleSize == 0 - then 1 - else possiblyStaleSize - Journal.teamActivate tid size c teamCreationTime + -- We could also write `updateTeamSize 1 size 0` here, but it seems clearer to do it + -- inline. + teamSize <- do + (TeamSize numRegulars numApps) <- E.getSize tid + pure $ TeamSize (max 1 numRegulars) numApps + Journal.teamActivate tid teamSize c teamCreationTime runJournal _ _ = throwS @'InvalidTeamStatusUpdate validateTransition :: (Member (ErrorS 'InvalidTeamStatusUpdate) r) => (TeamStatus, TeamStatus) -> Sem r Bool validateTransition = \case @@ -554,8 +555,6 @@ addTeamMember lzusr zcon tid nmem = do ensureNonBindingTeam tid ensureUnboundUsers [uid] E.ensureConnectedToLocals zusr [uid] - (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem -- This function is "unchecked" because there is no need to check for user binding (invite only). @@ -581,11 +580,9 @@ uncheckedAddTeamMember :: NewTeamMember -> Sem r () uncheckedAddTeamMember tid nmem = do - (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) - (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem + newTeamSize <- addTeamMemberInternal tid Nothing Nothing nmem owners <- E.getBillingTeamMembers tid - Journal.teamUpdate tid (sizeBeforeAdd + 1) owners + Journal.teamUpdate tid newTeamSize owners uncheckedUpdateTeamMember :: forall r. @@ -627,9 +624,9 @@ uncheckedUpdateTeamMember mlzusr mZcon tid newMem = do E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions when (team ^. teamBinding == Binding) $ do - (TeamSize size) <- E.getSize tid + teamSize <- E.getSize tid owners <- E.getBillingTeamMembers tid - Journal.teamUpdate tid size owners + Journal.teamUpdate tid teamSize owners now <- Now.get let event = newEvent tid now (EdMemberUpdate targetId (Just targetPermissions)) @@ -794,18 +791,19 @@ deleteTeamMember' lusr zcon tid remove mBody = do then do body <- mBody & note (InvalidPayload "missing request body") ensureReAuthorised (tUnqualified lusr) (body ^. tmdAuthPassword) Nothing Nothing - (TeamSize sizeBeforeDelete) <- E.getSize tid - -- TeamSize is 'Natural' and subtracting from 0 is an error - -- TeamSize could be reported as 0 if team members are added and removed very quickly, - -- which happens in tests - let sizeAfterDelete = - if sizeBeforeDelete == 0 - then 0 - else sizeBeforeDelete - 1 + uType <- + E.getUser remove <&> \case + Just u | u.userType == U.UserTypeApp -> UserTypeFilterApp + _ -> UserTypeFilterRegular + teamSizeAfterDelete <- do + before <- E.getSize tid + pure $ updateTeamSize uType before (-1) E.deleteUser remove - E.deleteApp tid remove + case uType of + UserTypeFilterRegular -> pure () + UserTypeFilterApp -> E.deleteApp tid remove owners <- E.getBillingTeamMembers tid - Journal.teamUpdate tid sizeAfterDelete $ filter (/= remove) owners + Journal.teamUpdate tid teamSizeAfterDelete $ filter (/= remove) owners pure TeamMemberDeleteAccepted else do (feat :: LockableFeature LimitedEventFanoutConfig) <- getFeatureForTeam tid @@ -1070,20 +1068,6 @@ ensureNotElevated targetPermissions member = ) $ throwS @'InvalidPermissions -ensureNotTooLarge :: - ( Member E.BrigAPIAccess r, - Member (ErrorS 'TooManyTeamMembers) r, - Member (Input Opts) r - ) => - TeamId -> - Sem r TeamSize -ensureNotTooLarge tid = do - o <- input - (TeamSize size) <- E.getSize tid - unless (size < fromIntegral (o ^. settings . maxTeamSize)) $ - throwS @'TooManyTeamMembers - pure $ TeamSize size - -- | Ensure that a team doesn't exceed the member count limit for the LegalHold -- feature. A team with more members than the fanout limit is too large, because -- the fanout limit would prevent turning LegalHold feature _off_ again (for @@ -1102,7 +1086,7 @@ ensureNotTooLargeForLegalHold :: Member FeaturesConfigSubsystem r ) => TeamId -> - Int -> + TeamSize -> Sem r () ensureNotTooLargeForLegalHold tid teamSize = whenM (isLegalHoldEnabledForTeam tid) $ @@ -1113,12 +1097,17 @@ addTeamMemberInternal :: ( Member E.BrigAPIAccess r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, + Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, Member NotificationSubsystem r, Member (Input Opts) r, Member Now r, + Member LegalHoldStore r, Member TeamNotificationStore r, Member TeamStore r, - Member P.TinyLog r + Member P.TinyLog r, + Member (Input FanoutLimit) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member FeaturesConfigSubsystem r ) => TeamId -> Maybe UserId -> @@ -1129,7 +1118,14 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do P.debug $ Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") - sizeBeforeAdd <- ensureNotTooLarge tid + sizeAfterAdd <- do + n <- ensureNotTooLarge tid + uType <- + E.getUser (new ^. userId) <&> \case + Just u | u.userType == U.UserTypeApp -> UserTypeFilterApp + _ -> UserTypeFilterRegular + pure $ updateTeamSize uType n 1 + ensureNotTooLargeForLegalHold tid sizeAfterAdd admins <- E.getTeamAdmins tid let admins' = [new ^. userId | isAdminOrOwner (new ^. M.permissions)] <> admins @@ -1154,7 +1150,21 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do ] APITeamQueue.pushTeamEvent tid e - pure sizeBeforeAdd + pure sizeAfterAdd + where + ensureNotTooLarge :: + ( Member E.BrigAPIAccess r, + Member (ErrorS 'TooManyTeamMembers) r, + Member (Input Opts) r + ) => + TeamId -> + Sem r TeamSize + ensureNotTooLarge teamid = do + o <- input + teamSize <- E.getSize teamid + unless (teamSizeTotal teamSize < fromIntegral (o ^. settings . maxTeamSize)) $ + throwS @'TooManyTeamMembers + pure teamSize getBindingTeamMembers :: ( Member (ErrorS 'TeamNotFound) r, @@ -1195,8 +1205,15 @@ canUserJoinTeam :: canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do - (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) + sizeBeforeJoin <- E.getSize tid + let uType = + -- We do not have a `UserId` to check here. Also, + -- `canUserJoinTeam` is called by Brig during user + -- registration via invitation (POST /register), where apps + -- never go. So it is safe to assume "regular" + UserTypeFilterRegular + let sizeAfterJoin = updateTeamSize uType sizeBeforeJoin 1 + ensureNotTooLargeForLegalHold tid sizeAfterJoin -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternal :: From 7dcede438e0d3f85726f35746325269b2e947012 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 8 May 2026 09:48:30 +0200 Subject: [PATCH 16/18] [WPB-20053] Consolidate brig/galley api access effects from spar into wire-subsystems. (#5189) --- ...ess-effects-from-spar-into-wire-subsystems | 3 + integration/test/Testlib/JSON.hs | 2 +- libs/wire-subsystems/default.nix | 3 + .../wire-subsystems/src/Wire/BrigAPIAccess.hs | 109 ++--- .../src/Wire/BrigAPIAccess/Rpc.hs | 440 ++++++++++++++++- .../src/Wire/GalleyAPIAccess.hs | 8 + .../src/Wire/GalleyAPIAccess/Rpc.hs | 38 ++ .../src/Wire/ParseException.hs | 2 + libs/wire-subsystems/src/Wire/RpcException.hs | 74 +++ .../Wire/MockInterpreters/GalleyAPIAccess.hs | 2 + libs/wire-subsystems/wire-subsystems.cabal | 2 + .../Wire/BackgroundWorker/Jobs/Registry.hs | 2 + services/galley/src/Galley/App.hs | 3 + services/spar/default.nix | 2 + services/spar/spar.cabal | 10 +- services/spar/src/Spar/API.hs | 96 ++-- services/spar/src/Spar/App.hs | 56 +-- .../spar/src/Spar/CanonicalInterpreter.hs | 21 +- services/spar/src/Spar/Error.hs | 52 +- services/spar/src/Spar/Intra/Brig.hs | 463 ------------------ services/spar/src/Spar/Intra/Galley.hs | 131 ----- .../src/Spar/Intra/{BrigApp.hs => RpcApp.hs} | 96 +++- services/spar/src/Spar/Scim.hs | 8 +- services/spar/src/Spar/Scim/Auth.hs | 49 +- services/spar/src/Spar/Scim/User.hs | 140 +++--- services/spar/src/Spar/Sem/BrigAccess.hs | 89 ---- services/spar/src/Spar/Sem/BrigAccess/Http.hs | 68 --- services/spar/src/Spar/Sem/GalleyAccess.hs | 45 -- .../spar/src/Spar/Sem/GalleyAccess/Http.hs | 53 -- services/spar/src/Spar/Sem/Utils.hs | 79 +-- services/spar/test-integration/Main.hs | 2 - .../test-integration/Test/Spar/APISpec.hs | 27 +- .../test-integration/Test/Spar/DataSpec.hs | 2 +- .../Test/Spar/Intra/BrigSpec.hs | 65 --- .../Test/Spar/Scim/UserSpec.hs | 66 +-- services/spar/test-integration/Util/Core.hs | 4 +- services/spar/test-integration/Util/Scim.hs | 2 +- .../spar/test/Test/Spar/Intra/BrigSpec.hs | 2 +- services/spar/test/Test/Spar/Saml/IdPSpec.hs | 55 +-- services/spar/test/Test/Spar/Scim/UserSpec.hs | 39 +- 40 files changed, 987 insertions(+), 1423 deletions(-) create mode 100644 changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems create mode 100644 libs/wire-subsystems/src/Wire/RpcException.hs delete mode 100644 services/spar/src/Spar/Intra/Brig.hs delete mode 100644 services/spar/src/Spar/Intra/Galley.hs rename services/spar/src/Spar/Intra/{BrigApp.hs => RpcApp.hs} (71%) delete mode 100644 services/spar/src/Spar/Sem/BrigAccess.hs delete mode 100644 services/spar/src/Spar/Sem/BrigAccess/Http.hs delete mode 100644 services/spar/src/Spar/Sem/GalleyAccess.hs delete mode 100644 services/spar/src/Spar/Sem/GalleyAccess/Http.hs delete mode 100644 services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs diff --git a/changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems b/changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems new file mode 100644 index 00000000000..19f25df9a93 --- /dev/null +++ b/changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems @@ -0,0 +1,3 @@ +Consolidate brig/galley api access effects from spar into wire-subsystems. + +NB: calls to internal galley end-points were *sometimes* propagating unexpected errors (eg. 400) to the client, sometimes they were turned into a fixed 5xx error. we now consistently do the latter, which is more accurate (we don't want this to ever happen). diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index d7688a7a0f6..04ae74ef192 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -243,7 +243,7 @@ lookupField :: lookupField val selector = do v <- make val vp <- prettyJSON v - addFailureContext ("Loooking up (nested) field " <> selector <> " of object:\n" <> vp) $ do + addFailureContext ("Looking up (nested) field " <> selector <> " of object:\n" <> vp) $ do let keys = splitOn "." selector case keys of (k : ks) -> go k ks v diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 88cd2d1e2e9..24131b80a51 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -30,6 +30,7 @@ , constraints , containers , contravariant +, cookie , cql , crypton , crypton-pem @@ -171,6 +172,7 @@ mkDerivation { constraints containers contravariant + cookie cql crypton crypton-pem @@ -298,6 +300,7 @@ mkDerivation { constraints containers contravariant + cookie cql crypton crypton-pem diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index 1f9dabb13b6..ceec1624944 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -17,69 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.BrigAPIAccess - ( -- * Brig access effect - BrigAPIAccess (..), - - -- * Connections - getConnectionsUnqualified, - getConnectionsUnqualifiedBidi, - getConnections, - putConnectionInternal, - - -- * Users - reauthUser, - lookupActivatedUsers, - getUser, - getUsers, - deleteUser, - getContactList, - getRichInfoMultiUser, - getUserExportData, - updateSearchIndex, - getAccountsBy, - getUsersByVariousKeys, - - -- * Teams - getSize, - - -- * Clients - lookupClients, - lookupClientsFull, - notifyClientsAboutLegalHoldRequest, - getLegalHoldAuthToken, - addLegalHoldClientToUser, - removeLegalHoldClientFromUser, - OpaqueAuthToken (..), - - -- * MLS - getLocalMLSClients, - getLocalMLSClient, - - -- * Features - getAccountConferenceCallingConfigClient, - updateSearchVisibilityInbound, - - -- * Bots - deleteBot, - getAppIdsForTeam, - - -- * User Groups - createGroupInternal, - getGroupInternal, - getGroupsInternal, - updateGroup, - deleteGroupInternal, - deleteApp, - DeleteGroupManagedError (..), - - -- * Account status - setAccountStatus, - - -- * Assertions - ensureConnectedToLocals, - ) -where +module Wire.BrigAPIAccess where import Data.Aeson import Data.ByteString.Conversion @@ -93,18 +31,23 @@ import Network.HTTP.Types.Status import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error +import SAML2.WebSSO qualified as SAML +import Web.Cookie (SetCookie) import Web.Scim.Filter qualified as Scim import Wire.API.Connection import Wire.API.Error import Wire.API.Error.Galley +import Wire.API.Locale import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export import Wire.API.Team.Feature +import Wire.API.Team.Role (Role) import Wire.API.Team.Size import Wire.API.User +import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Auth.ReAuth import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -180,6 +123,46 @@ data BrigAPIAccess m a where DeleteApp :: TeamId -> UserId -> BrigAPIAccess m () GetAppIdsForTeam :: TeamId -> BrigAPIAccess m [UserId] SetAccountStatus :: UserId -> AccountStatus -> BrigAPIAccess m () + -- SAML / SCIM user management (migrated from Spar.Sem.BrigAccess) + CreateSAML :: + SAML.UserRef -> + UserId -> + TeamId -> + Name -> + ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> + Maybe Locale -> + Role -> + BrigAPIAccess m UserId + CreateNoSAML :: + Text -> + EmailAddress -> + UserId -> + TeamId -> + Name -> + Maybe Locale -> + Role -> + BrigAPIAccess m UserId + UpdateEmail :: UserId -> EmailAddress -> EmailActivation -> BrigAPIAccess m () + GetAccount :: HavePendingInvitations -> UserId -> BrigAPIAccess m (Maybe User) + GetAccountByHandle :: Handle -> BrigAPIAccess m (Maybe User) + GetByEmail :: EmailAddress -> BrigAPIAccess m (Maybe User) + SetName :: UserId -> Name -> BrigAPIAccess m () + SetHandle :: UserId -> Handle -> BrigAPIAccess m () + SetManagedBy :: UserId -> ManagedBy -> BrigAPIAccess m () + SetSSOId :: UserId -> UserSSOId -> BrigAPIAccess m () + SetRichInfo :: UserId -> RichInfo -> BrigAPIAccess m () + SetLocale :: UserId -> Maybe Locale -> BrigAPIAccess m () + GetRichInfo :: UserId -> BrigAPIAccess m RichInfo + CheckHandleAvailable :: Handle -> BrigAPIAccess m Bool + SsoLogin :: UserId -> Maybe CookieLabel -> BrigAPIAccess m SetCookie + GetStatus :: UserId -> BrigAPIAccess m AccountStatus + GetStatusMaybe :: UserId -> BrigAPIAccess m (Maybe AccountStatus) + SetStatus :: UserId -> AccountStatus -> BrigAPIAccess m () + GetDefaultUserLocale :: BrigAPIAccess m Locale + CheckAdminGetTeamId :: UserId -> BrigAPIAccess m (Either Wai.Error TeamId) + SendSAMLIdPChangedEmail :: IdpChangedNotification -> BrigAPIAccess m () makeSem ''BrigAPIAccess diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs index 32703e2f923..f4bd3d9ea47 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs @@ -22,7 +22,7 @@ import Control.Monad.Catch (throwM) import Data.Aeson import Data.ByteString.Char8 qualified as BSC import Data.ByteString.Conversion -import Data.Handle (Handle) +import Data.Handle import Data.HavePendingInvitations (HavePendingInvitations (..)) import Data.Id import Data.Misc @@ -39,37 +39,44 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog +import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Logger import Util.Options +import Web.Cookie (SetCookie, parseSetCookie) import Web.HttpApiData import Web.Scim.Filter as Scim import Wire.API.Connection import Wire.API.Error.Galley +import Wire.API.Locale import Wire.API.MLS.CipherSuite -import Wire.API.Routes.Internal.Brig (CreateGroupInternalRequest (..), GetBy, UpdateGroupInternalRequest (..)) +import Wire.API.Routes.Internal.Brig (CreateGroupInternalRequest (..), GetBy, IdpChangedNotification (..), UpdateGroupInternalRequest (..)) import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.Team.LegalHold.Internal +import Wire.API.Team.Role (Role) import Wire.API.Team.Size -import Wire.API.User (AccountStatus (..), AccountStatusUpdate (..), EmailAddress, UpdateConnectionsInternal, User, UserIds (..), UserSet (..)) +import Wire.API.User hiding (DeleteUser (..)) +import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth +import Wire.API.User.Auth.Sso qualified as Sso import Wire.API.User.Client import Wire.API.User.Client.Prekey -import Wire.API.User.Profile (ManagedBy) import Wire.API.User.RichInfo import Wire.API.UserGroup (NewUserGroup, UserGroup) import Wire.API.UserGroup.Pagination import Wire.BrigAPIAccess (BrigAPIAccess (..), DeleteGroupManagedError (..), OpaqueAuthToken (..)) import Wire.ParseException import Wire.Rpc +import Wire.RpcException interpretBrigAccess :: ( Member TinyLog r, Member Rpc r, - Member (Error ParseException) r + Member (Error ParseException) r, + Member (Error RpcException) r ) => Endpoint -> Sem (BrigAPIAccess ': r) a -> @@ -136,12 +143,54 @@ interpretBrigAccess brigEndpoint = updateGroup req DeleteGroupInternal managedBy teamId groupId -> deleteGroupInternal managedBy teamId groupId - DeleteApp teamId userId -> - deleteApp teamId userId GetAppIdsForTeam teamId -> getAppIdsForTeam teamId SetAccountStatus uid status -> setAccountStatus uid status + DeleteApp teamId uid -> + deleteApp teamId uid + CreateSAML uref buid teamid name managedBy handle richInfo mLocale role -> + createSAML uref buid teamid name managedBy handle richInfo mLocale role + CreateNoSAML extId email uid teamid uname locale role -> + createNoSAML extId email uid teamid uname locale role + UpdateEmail uid email activation -> + updateEmail uid email activation + GetAccount havePending uid -> + getAccount havePending uid + GetAccountByHandle handle -> + getByHandle handle + GetByEmail email -> + getByEmail email + SetName uid name -> + setName uid name + SetHandle uid handle -> + setHandle uid handle + SetManagedBy uid managedBy -> + setManagedBy uid managedBy + SetSSOId uid ssoId -> + setSSOId uid ssoId + SetRichInfo uid richInfo -> + setRichInfo uid richInfo + SetLocale uid mLocale -> + setLocale uid mLocale + GetRichInfo uid -> + getRichInfo uid + CheckHandleAvailable handle -> + checkHandleAvailable handle + SsoLogin uid mLabel -> + ssoLogin uid mLabel + GetStatus uid -> + getStatus uid + GetStatusMaybe uid -> + getStatusMaybe uid + SetStatus uid status -> + setStatus uid status + GetDefaultUserLocale -> + getDefaultUserLocale + CheckAdminGetTeamId uid -> + checkAdminGetTeamId uid + SendSAMLIdPChangedEmail notif -> + sendSAMLIdPChangedEmail notif brigRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) brigRequest req = do @@ -713,11 +762,11 @@ deleteApp :: TeamId -> UserId -> Sem r () -deleteApp teamId userId = do +deleteApp teamId uid = do void $ brigRequest $ method DELETE - . paths ["i", "teams", toByteString' teamId, "apps", toByteString' userId] + . paths ["i", "teams", toByteString' teamId, "apps", toByteString' uid] . expect2xx getAppIdsForTeam :: @@ -750,3 +799,376 @@ is2xx = statusIs2xx . statusCode statusIs2xx :: Int -> Bool statusIs2xx s = s >= 200 && s < 300 + +-- SAML / SCIM user management (migrated from Spar.Intra.Brig) + +createSAML :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + SAML.UserRef -> + UserId -> + TeamId -> + Name -> + ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> + Maybe Locale -> + Role -> + Sem r UserId +createSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do + let newUser = + NewUserSpar + { newUserSparUUID = buid, + newUserSparDisplayName = name, + newUserSparSSOId = UserSSOId uref, + newUserSparTeamId = teamid, + newUserSparManagedBy = managedBy, + newUserSparHandle = handle, + newUserSparRichInfo = richInfo, + newUserSparLocale = mLocale, + newUserSparRole = role + } + resp <- brigRequest $ method POST . path "/i/users/spar" . json newUser + if statusCode resp `elem` [200, 201] + then userId . selfUser <$> decodeBodyOrThrow @SelfProfile "brig" resp + else rethrow "brig" resp + +createNoSAML :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + Text -> + EmailAddress -> + UserId -> + TeamId -> + Name -> + Maybe Locale -> + Role -> + Sem r UserId +createNoSAML extId email uid teamid uname locale role = do + let newUser = NewUserScimInvitation teamid uid extId locale uname email role + resp <- + brigRequest $ + method POST + . paths ["/i/teams", toByteString' teamid, "invitations"] + . json newUser + if statusCode resp `elem` [200, 201] + then userId <$> decodeBodyOrThrow @User "brig" resp + else + rethrow "brig" resp + +updateEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + EmailAddress -> + EmailActivation -> + Sem r () +updateEmail buid email activation = do + resp <- + brigRequest $ + method PUT + . path "/i/self/email" + . header "Z-User" (toByteString' buid) + . query + [ ("activation", Just (toByteString' activation)), + ("validate", Just (fromBool validate)), + ("activate", Just (fromBool activate)) + ] + . json (EmailUpdate email) + case statusCode resp of + 204 -> pure () + 202 -> pure () + _ -> rethrow "brig" resp + where + (validate, activate) = case activation of + AutoActivate -> (False, True) + SendActivationEmail -> (True, False) + + fromBool :: Bool -> ByteString + fromBool True = "true" + fromBool False = "false" + +getAccount :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + HavePendingInvitations -> + UserId -> + Sem r (Maybe User) +getAccount havePending buid = do + resp <- + brigRequest $ + method GET + . paths ["/i/users"] + . query + [ ("ids", Just $ toByteString' buid), + ( "includePendingInvitations", + Just . toByteString' $ + case havePending of + WithPendingInvitations -> True + NoPendingInvitations -> False + ) + ] + case statusCode resp of + 200 -> + decodeBodyOrThrow @[User] "brig" resp >>= \case + [account] -> + pure $ + if userDeleted account + then Nothing + else Just account + _ -> pure Nothing + 404 -> pure Nothing + _ -> rethrow "brig" resp + +getByHandle :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + Handle -> + Sem r (Maybe User) +getByHandle handle = do + resp <- + brigRequest $ + method GET + . path "/i/users" + . queryItem "handles" (toByteString' handle) + . queryItem "includePendingInvitations" "true" + case statusCode resp of + 200 -> listToMaybe <$> decodeBodyOrThrow @[User] "brig" resp + 404 -> pure Nothing + _ -> rethrow "brig" resp + +getByEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + EmailAddress -> + Sem r (Maybe User) +getByEmail email = do + resp <- + brigRequest $ + method GET + . path "/i/users" + . queryItem "email" (toByteString' email) + . queryItem "includePendingInvitations" "true" + case statusCode resp of + 200 -> do + macc <- listToMaybe <$> decodeBodyOrThrow @[User] "brig" resp + case userEmail =<< macc of + Just email' | email' == email -> pure macc + _ -> pure Nothing + 404 -> pure Nothing + _ -> rethrow "brig" resp + +setName :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + Name -> + Sem r () +setName buid (Name name) = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "name"] + . json (NameUpdate name) + if statusCode resp < 300 + then pure () + else rethrow "brig" resp + +setHandle :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + Handle -> + Sem r () +setHandle buid handle = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "handle"] + . json (HandleUpdate (fromHandle handle)) + case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of + (200, Nothing) -> pure () + _ -> rethrow "brig" resp + +setManagedBy :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + ManagedBy -> + Sem r () +setManagedBy buid managedBy = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "managed-by"] + . json (ManagedByUpdate managedBy) + unless (statusCode resp == 200) $ + rethrow "brig" resp + +setSSOId :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + UserSSOId -> + Sem r () +setSSOId buid ssoId = do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "sso-id"] + . json ssoId + unless (statusCode resp == 200) $ + rethrow "brig" resp + +setRichInfo :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + RichInfo -> + Sem r () +setRichInfo buid richInfo = do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "rich-info"] + . json (RichInfoUpdate $ unRichInfo richInfo) + unless (statusCode resp == 200) $ + rethrow "brig" resp + +setLocale :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + Maybe Locale -> + Sem r () +setLocale buid = \case + Just locale -> do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "locale"] + . json (LocaleUpdate locale) + unless (statusCode resp == 200) $ + rethrow "brig" resp + Nothing -> do + resp <- + brigRequest $ + method DELETE + . paths ["i", "users", toByteString' buid, "locale"] + unless (statusCode resp == 200) $ + rethrow "brig" resp + +getRichInfo :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r RichInfo +getRichInfo buid = do + resp <- + brigRequest $ + method GET + . paths ["/i/users", toByteString' buid, "rich-info"] + if statusCode resp == 200 + then decodeBodyOrThrow "brig" resp + else rethrow "brig" resp + +checkHandleAvailable :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + Handle -> + Sem r Bool +checkHandleAvailable hnd = do + resp <- + brigRequest $ + method HEAD + . paths ["/i/users/handles", toByteString' hnd] + case statusCode resp of + 200 -> pure False -- handle exists + 404 -> pure True -- 404: handle not found + _ -> rethrow "brig" resp + +ssoLogin :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Maybe CookieLabel -> + Sem r SetCookie +ssoLogin buid mlabel = do + resp <- + brigRequest $ + method POST + . path "/i/sso-login" + . json (Sso.SsoLogin buid mlabel) + . queryItem "persist" "true" + case statusCode resp of + 200 -> + case getHeader "Set-Cookie" resp of + Nothing -> throw $ ParseException "brig" "Missing Set-Cookie header in SSO login response" + Just cky -> pure $ parseSetCookie cky + _ -> rethrow "brig" resp + +getStatusRaw :: + (Member Rpc r, Member (Input Endpoint) r) => + UserId -> + Sem r ResponseLBS +getStatusRaw uid = + brigRequest $ + check [status200, status404] + . method GET + . paths ["/i/users", toByteString' uid, "status"] + +getStatus :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r AccountStatus +getStatus uid = do + resp <- getStatusRaw uid + case statusCode resp of + 200 -> fromAccountStatusResp <$> decodeBodyOrThrow @AccountStatusResp "brig" resp + _ -> rethrow "brig" resp + +getStatusMaybe :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r (Maybe AccountStatus) +getStatusMaybe uid = do + resp <- getStatusRaw uid + case statusCode resp of + 200 -> Just . fromAccountStatusResp <$> decodeBodyOrThrow @AccountStatusResp "brig" resp + 404 -> pure Nothing + _ -> rethrow "brig" resp + +setStatus :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + AccountStatus -> + Sem r () +setStatus uid status = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' uid, "status"] + . json (AccountStatusUpdate status) + unless (statusCode resp == 200) $ + rethrow "brig" resp + +getDefaultUserLocale :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + Sem r Locale +getDefaultUserLocale = do + resp <- brigRequest $ method GET . path "/i/users/locale" + case statusCode resp of + 200 -> luLocale <$> decodeBodyOrThrow @LocaleUpdate "brig" resp + _ -> rethrow "brig" resp + +checkAdminGetTeamId :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r (Either Wai.Error TeamId) +checkAdminGetTeamId uid = do + resp <- + brigRequest $ + check [status200, status403] + . method GET + . paths ["/i/users", toByteString' uid, "check-admin-get-team-id"] + case statusCode resp of + 200 -> Right <$> decodeBodyOrThrow "brig" resp + _ -> rethrow "brig" resp + +sendSAMLIdPChangedEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + IdpChangedNotification -> + Sem r () +sendSAMLIdPChangedEmail notif = do + resp <- + brigRequest $ + method POST + . path "/i/idp/send-idp-changed-email" + . json notif + unless (statusCode resp == 200) $ + rethrow "brig" resp diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index e3fa6bc3bc4..65d16aeb063 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -172,5 +172,13 @@ data GalleyAPIAccess m a where GuardLegalHold :: LegalholdProtectee -> UserClients -> GalleyAPIAccess m () GetUserLHStatus :: Maybe TeamId -> UserId -> GalleyAPIAccess m UserLegalHoldStatus GetUsersLHStatus :: [UserId] -> GalleyAPIAccess m [(UserId, UserLegalHoldStatus)] + UpdateTeamMember :: + UserId -> + TeamId -> + Role -> + GalleyAPIAccess m () + IsEmailValidationEnabledTeam :: + TeamId -> + GalleyAPIAccess m Bool makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index ae8f54d772d..91267f7cc84 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -115,6 +115,8 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GuardLegalHold protectee userClient -> guardLegalhold protectee userClient GetUserLHStatus mtid uid -> getUserLHStatus mtid uid GetUsersLHStatus uids -> getUsersLHStatus uids + UpdateTeamMember uid tid role -> updateTeamMember uid tid role + IsEmailValidationEnabledTeam tid -> isEmailValidationEnabledTeam tid getUserLegalholdStatus :: ( Member (Error ParseException) r, @@ -818,3 +820,39 @@ getUsersLHStatus uids = do . header "Content-Type" "application/json" . lbytes (encode bdy) . expect2xx + +updateTeamMember :: + ( Member Rpc r, + Member (Input Endpoint) r + ) => + UserId -> + TeamId -> + Role -> + Sem r () +updateTeamMember uid tid role = do + let reqBody = mkNewTeamMember uid (rolePermissions role) Nothing + void $ + galleyRequest $ + method PUT + . paths ["i", "teams", toByteString' tid, "members"] + . header "Content-Type" "application/json" + . lbytes (encode reqBody) + +isEmailValidationEnabledTeam :: + ( Member Rpc r, + Member (Input Endpoint) r + ) => + TeamId -> + Sem r Bool +isEmailValidationEnabledTeam tid = do + rs <- galleyRequest req + pure + ( Bilge.statusCode rs == 200 + && ( ((.status) <$> responseJsonMaybe @(LockableFeature RequireExternalEmailVerificationConfig) rs) + == Just FeatureStatusEnabled + ) + ) + where + req = + method GET + . paths ["i", "teams", toByteString' tid, "features", featureNameBS @RequireExternalEmailVerificationConfig] diff --git a/libs/wire-subsystems/src/Wire/ParseException.hs b/libs/wire-subsystems/src/Wire/ParseException.hs index 525fe80cfb5..1d836548ddf 100644 --- a/libs/wire-subsystems/src/Wire/ParseException.hs +++ b/libs/wire-subsystems/src/Wire/ParseException.hs @@ -15,6 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +-- | See also: "Wire.RpcException" (some of the uses of ParseException +-- should probably be RpcExceptions instead). module Wire.ParseException where import Data.Text qualified as Text diff --git a/libs/wire-subsystems/src/Wire/RpcException.hs b/libs/wire-subsystems/src/Wire/RpcException.hs new file mode 100644 index 00000000000..04a28a63a24 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/RpcException.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +-- 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 . + +-- | See also: "Wire.ParseException" +module Wire.RpcException where + +import Bilge +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Lazy qualified as LText +import Imports +import Network.HTTP.Types.Status qualified as Http +import Network.Wai.Utilities.Error qualified as Wai +import Polysemy +import Polysemy.Error + +data RpcException + = RpcExceptionWai + { service :: Text, + waiError :: Wai.Error + } + | RpcExceptionInternal + { service :: Text, + status :: Int, + message :: Text + } + deriving (Eq, Show) + +instance Exception RpcException + +rpcExcepctionToWaiError :: RpcException -> Wai.Error +rpcExcepctionToWaiError (RpcExceptionWai {..}) = + waiError {Wai.message = "[" <> LText.fromStrict service <> "] " <> (Wai.message waiError)} +rpcExcepctionToWaiError (RpcExceptionInternal {..}) = + Wai.mkError + Http.status502 + "internal-error" + ( LText.fromStrict $ + "Could not parse " + <> service + <> " response body: " + <> message + <> " (status: " + <> Text.pack (show status) + <> ")" + ) + +-- | If a call to another backend service fails, just respond with whatever it said. +rethrow :: (HasCallStack, Member (Error RpcException) r) => Text -> ResponseLBS -> Sem r a +rethrow serviceName resp = throw err + where + err :: RpcException + err = maybe fallback (RpcExceptionWai serviceName) (responseJsonMaybe resp) + + fallback :: RpcException + fallback = RpcExceptionInternal serviceName (Bilge.statusCode resp) (maybe "" (decodeUtf8 . LBS.toStrict) (responseBody resp)) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index eea44efb430..2e0186e9499 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -96,6 +96,8 @@ miniGalleyAPIAccess teams configs = interpret $ \case GetUserLHStatus _ _ -> error "GetUserLHStatus not implemented in miniGalleyAPIAccess" GetUsersLHStatus _ -> error "GetUsersLHStatus not implemented in miniGalleyAPIAccess" GuardLegalHold {} -> pure () + UpdateTeamMember {} -> error "UpdateTeamMember not implemented in miniGalleyAPIAccess" + IsEmailValidationEnabledTeam {} -> error "IsEmailValidationEnabledTeam not implemented in miniGalleyAPIAccess" -- this is called but the result is not needed in unit tests selectTeamMemberInfosImpl :: Map TeamId [TeamMember] -> TeamId -> [UserId] -> TeamMemberInfoList diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index dd2e897a6c3..6aa8541f47a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -109,6 +109,7 @@ common common-all , constraints , containers , contravariant + , cookie , cql , crypton , crypton-pem @@ -391,6 +392,7 @@ library Wire.RateLimit Wire.RateLimit.Interpreter Wire.Rpc + Wire.RpcException Wire.SAMLEmailSubsystem Wire.SAMLEmailSubsystem.Interpreter Wire.ScimSubsystem diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 842dec6ec80..e595330f457 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -94,6 +94,7 @@ import Wire.ProposalStore.Cassandra (interpretProposalStoreToCassandra) import Wire.RateLimit (RateLimitExceeded) import Wire.RateLimit.Interpreter (interpretRateLimit) import Wire.Rpc +import Wire.RpcException import Wire.Sem.Concurrency (ConcurrencySafety (Unsafe)) import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) import Wire.Sem.Delay (runDelay) @@ -206,6 +207,7 @@ dispatchJob job = do . mapError @DynError (.eMessage) . mapError @JSONResponse (T.pack . show . (.value)) . mapError @ConversationSubsystemError toResponse + . mapError @RpcException (T.pack . displayException) . mapError @ClientError (T.pack . displayException) . mapError @FederationError (T.pack . displayException) . mapError @UsageError (T.pack . show) diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 34a064be715..cc38ae92501 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -148,6 +148,7 @@ import Wire.ProposalStore.Cassandra import Wire.RateLimit import Wire.RateLimit.Interpreter import Wire.Rpc +import Wire.RpcException import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO import Wire.Sem.Delay @@ -264,6 +265,7 @@ type GalleyEffects = ErrorS 'NotATeamMember, ErrorS 'MeetingNotFound, ErrorS 'InvalidOperation, + Error RpcException, Input ClientState, Input Hasql.Pool, Input Env, @@ -483,6 +485,7 @@ evalGalley e = . runInputConst e . runInputConst (e ^. hasqlPool) . runInputConst (e ^. cstate) + . mapError (toResponse . rpcExcepctionToWaiError) -- Error RpcException . mapError toResponse -- ErrorS 'InvalidOperation . mapError toResponse -- ErrorS 'MeetingNotFound . mapError toResponse -- ErrorS 'NotATeamMember diff --git a/services/spar/default.nix b/services/spar/default.nix index 315c3c5d75a..5ad0fbf1fad 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -19,6 +19,7 @@ , cookie , crypton , crypton-x509 +, data-default , exceptions , extended , filepath @@ -208,6 +209,7 @@ mkDerivation { bytestring-conversion containers cookie + data-default filepath hscim hspec diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 42885b16c33..6512673b66b 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -30,9 +30,7 @@ library Spar.Data Spar.Data.Instances Spar.Error - Spar.Intra.Brig - Spar.Intra.BrigApp - Spar.Intra.Galley + Spar.Intra.RpcApp Spar.Options Spar.Orphans Spar.Run @@ -71,14 +69,10 @@ library Spar.Sem.AssIDStore Spar.Sem.AssIDStore.Cassandra Spar.Sem.AssIDStore.Mem - Spar.Sem.BrigAccess - Spar.Sem.BrigAccess.Http Spar.Sem.DefaultSsoCode Spar.Sem.DefaultSsoCode.Cassandra Spar.Sem.DefaultSsoCode.Mem Spar.Sem.DefaultSsoCode.Spec - Spar.Sem.GalleyAccess - Spar.Sem.GalleyAccess.Http Spar.Sem.IdPRawMetadataStore Spar.Sem.IdPRawMetadataStore.Cassandra Spar.Sem.IdPRawMetadataStore.Mem @@ -282,7 +276,6 @@ executable spar-integration Test.Spar.APISpec Test.Spar.AppSpec Test.Spar.DataSpec - Test.Spar.Intra.BrigSpec Test.Spar.Scim.AuthSpec Test.Spar.Scim.UserSpec Util @@ -630,6 +623,7 @@ test-suite spec , bytestring-conversion , containers , cookie + , data-default , filepath , hscim , hspec diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index bd8e285b66a..d1e255da57c 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -75,6 +75,7 @@ import qualified Data.X509 as X509 import Data.X509.Extended import Imports import Network.Wai (Request, requestHeaders) +import qualified Network.Wai.Utilities.Error as Wai import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server (defaultRequestIdHeaderName) import Polysemy @@ -87,18 +88,14 @@ import Servant.Server.Experimental.Auth import Spar.App import Spar.CanonicalInterpreter import Spar.Error -import qualified Spar.Intra.BrigApp as Brig +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Orphans () import Spar.Scim hiding (handle) import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AssIDStore (AssIDStore) -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) import qualified Spar.Sem.IdPRawMetadataStore as IdPRawMetadataStore import Spar.Sem.Reporter (Reporter) @@ -128,6 +125,9 @@ import Wire.API.User import Wire.API.User.Auth (CookieLabel) import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.IdPConfigStore (IdPConfigStore, Replaced (..), Replacing (..)) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.IdPSubsystem (IdPSubsystem) @@ -159,8 +159,8 @@ app ctx0 req cont = do cont api :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member AssIDStore r, Member AReqIDStore r, @@ -198,10 +198,10 @@ api opts = :<|> apiINTERNAL apiSSO :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member (Logger String) r, Member (Input Opts) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, Member AReqIDStore r, @@ -233,8 +233,8 @@ apiIDP :: ( Member Random r, Member (Logger String) r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -261,8 +261,8 @@ apiINTERNAL :: Member ScimUserTimesStore r, Member (Logger (Msg -> Msg)) r, Member Random r, - Member GalleyAccess r, - Member BrigAccess r + Member GalleyAPIAccess r, + Member BrigAPIAccess r ) => ServerT InternalAPI (Sem r) apiINTERNAL = @@ -384,8 +384,8 @@ authresp :: ( Member Random r, Member (Logger String) r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, Member AReqIDStore r, @@ -491,7 +491,7 @@ authHandler :: Env -> AuthHandler Request TeamId authHandler ctx = mkAuthHandler $ \req -> (either throwError' pure =<<) $ runSparToHandler ctx $ runError $ do bs <- maybe (throwSparSem SparMissingZUsr) pure $ lookup "Z-User" (requestHeaders req) uid <- maybe (throwSparSem $ SparNoPermission "[internal error] Can't parse Z-User header") pure $ fromByteString bs - BrigAccess.checkAdminGetTeamId uid + BrigAPIAccess.checkAdminGetTeamId uid >>= either (\e -> throwSparSem $ SparNoPermission (Wai.message e)) pure where throwError' se = Spar.Error.sparToServerErrorWithLogging (sparCtxLogger ctx) se >>= throwError @@ -501,8 +501,8 @@ authContext e = authHandler e :. EmptyContext idpGet :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -515,8 +515,8 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do pure idp idpGetRaw :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -534,22 +534,22 @@ idpGetRaw zusr idpid = do idpGetAll :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => Maybe UserId -> Sem r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do - teamid <- Brig.getZUsrCheckPerm zusr ReadIdp + teamid <- Intra.getZUsrCheckPerm zusr ReadIdp idpGetAllByTeamId teamid idpGetAllByTeamId :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -571,8 +571,8 @@ idpDelete :: forall r. ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member SAMLUserStore r, Member IdPConfigStore r, @@ -603,7 +603,7 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid when (SAML.isMultiIngressConfig samlConfig) $ - BrigAccess.sendSAMLIdPChangedEmail $ + BrigAPIAccess.sendSAMLIdPChangedEmail $ IdPDeleted zusr idp logIdPAction "IdP deleted" @@ -615,13 +615,13 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp assertEmptyOrPurge :: TeamId -> Cas.Page (SAML.UserRef, UserId) -> Sem r () assertEmptyOrPurge teamId page = do forM_ (Cas.result page) $ \(uref, uid) -> do - mAccount <- BrigAccess.getAccount NoPendingInvitations uid + mAccount <- BrigAPIAccess.getAccount NoPendingInvitations uid let mUserTeam = userTeam =<< mAccount when (mUserTeam == Just teamId) $ do if purge then do SAMLUserStore.delete uid uref - void $ BrigAccess.deleteUser uid + void $ BrigAPIAccess.deleteUser uid else do throwSparSem SparIdPHasBoundUsers when (Cas.hasMore page) $ @@ -648,7 +648,7 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp idpDoesAuthSelf :: IdP -> UserId -> Sem r Bool idpDoesAuthSelf idp uid = do let idpIssuer = idp ^. SAML.idpMetadata . SAML.edIssuer - mUserIssuer <- (>>= userIssuer) <$> getAccount NoPendingInvitations uid + mUserIssuer <- (>>= userIssuer) <$> BrigAPIAccess.getAccount NoPendingInvitations uid pure $ mUserIssuer == Just idpIssuer -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. @@ -664,8 +664,8 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp idpCreate :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -682,7 +682,7 @@ idpCreate :: Sem r IdP idpCreate samlConfig tid zUser uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do let mbHost = filterMultiIngressZHost (samlConfig._cfgDomainConfigs) uncheckedMbHost - GalleyAccess.assertSSOEnabled tid + Intra.assertSSOEnabled tid guardMultiIngressDuplicateDomain tid mbHost idp <- maybe (IdPConfigStore.newHandle tid) (pure . IdPHandle . fromRange) mHandle @@ -692,7 +692,7 @@ idpCreate samlConfig tid zUser uncheckedMbHost (IdPMetadataValue rawIdpMetadata forM_ mReplaces $ \replaces -> IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) when (SAML.isMultiIngressConfig samlConfig) $ - BrigAccess.sendSAMLIdPChangedEmail $ + BrigAPIAccess.sendSAMLIdPChangedEmail $ IdPCreated zUser idp logIdPAction "IdP created" @@ -737,8 +737,8 @@ filterMultiIngressZHost _ _ = Nothing idpCreateV7 :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -841,8 +841,8 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces idpDomain idHandle = wit idpUpdate :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -861,8 +861,8 @@ idpUpdate samlConfig zusr uncheckedMbHost (IdPMetadataValue raw xml) = idpUpdateXML :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -877,7 +877,7 @@ idpUpdateXML :: Sem r IdP idpUpdateXML samlConfig mbZUsr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML" (Just . show . (^. SAML.idpId)) $ do (zUsr, teamid, idp, previousIdP) <- validateIdPUpdate mbZUsr idpmeta idpid - GalleyAccess.assertSSOEnabled teamid + Intra.assertSSOEnabled teamid guardMultiIngressDuplicateDomain teamid mDomain idpid IdPRawMetadataStore.store (idp ^. SAML.idpId) raw let idp' :: IdP = case mHandle of @@ -895,7 +895,7 @@ idpUpdateXML samlConfig mbZUsr mDomain raw idpmeta idpid mHandle = withDebugLog WireIdPAPIV2 -> Just teamid forM_ (idp'' ^. SAML.idpExtraInfo . oldIssuers) (flip IdPConfigStore.deleteIssuer mbteamid) when (SAML.isMultiIngressConfig samlConfig) $ - BrigAccess.sendSAMLIdPChangedEmail $ + BrigAPIAccess.sendSAMLIdPChangedEmail $ IdPUpdated zUsr previousIdP idp'' logIdPUpdate zUsr idp'' previousIdP pure idp'' @@ -982,8 +982,8 @@ validateIdPUpdate :: (HasCallStack, m ~ Sem r) => ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -1048,8 +1048,8 @@ withDebugLog msg showval action = do authorizeIdP :: ( HasCallStack, - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member (Error SparError) r ) ) => @@ -1063,7 +1063,7 @@ authorizeIdP Nothing _ = ) authorizeIdP (Just zusr) idp = do let teamid = idp ^. SAML.idpExtraInfo . team - GalleyAccess.assertHasPermission teamid CreateUpdateDeleteIdp zusr + Intra.assertHasPermission teamid CreateUpdateDeleteIdp zusr pure (zusr, teamid) enforceHttps :: (Member (Error SparError) r) => URI.URI -> Sem r () diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index f43a93abddd..8ec7c658523 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -71,14 +71,10 @@ import qualified SAML2.WebSSO as SAML import Servant import qualified Servant.Multipart as Multipart import Spar.Error hiding (sparToServerErrorWithLogging) -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.Reporter (Reporter) import qualified Spar.Sem.Reporter as Reporter import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -97,7 +93,11 @@ import Wire.API.User import Wire.API.User.Auth import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess import Wire.Error +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.IdPConfigStore (IdPConfigStore) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.ScimSubsystem.Interpreter @@ -139,17 +139,17 @@ data Env = Env -- -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefUnsafe :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => SAML.UserRef -> Sem r (Maybe User) getUserByUrefUnsafe uref = do - maybe (pure Nothing) (getAccount Intra.WithPendingInvitations) =<< SAMLUserStore.get uref + maybe (pure Nothing) (BrigAPIAccess.getAccount Intra.WithPendingInvitations) =<< SAMLUserStore.get uref -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR getUserIdByScimExternalId :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r ) => TeamId -> @@ -182,7 +182,7 @@ getUserIdByScimExternalId tid eid = do -- undeletable in the team admin page, and ask admins to go talk to their IdP system. createSamlUserWithId :: ( Member (Error SparError) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member SAMLUserStore r ) => TeamId -> @@ -194,7 +194,7 @@ createSamlUserWithId teamid buid suid role = do uname <- either (throwSparSem . SparBadUserName . LText.pack) pure $ Intra.mkUserName Nothing (That suid) - buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing Nothing role + buid' <- BrigAPIAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing Nothing role assert (buid == buid') $ pure () SAMLUserStore.insert suid buid @@ -203,8 +203,8 @@ createSamlUserWithId teamid buid suid role = do -- https://wearezeta.atlassian.net/browse/SQSERVICES-1655) autoprovisionSamlUser :: forall r. - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -237,8 +237,8 @@ autoprovisionSamlUser idp buid suid = do -- make brig initiate the email validate procedure. validateSamlEmailIfExists :: forall r. - ( Member GalleyAccess r, - Member BrigAccess r + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r ) => UserId -> SAML.UserRef -> @@ -251,17 +251,17 @@ validateSamlEmailIfExists uid = \case validateEmail :: forall r. - ( Member GalleyAccess r, - Member BrigAccess r + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r ) => Maybe TeamId -> UserId -> EmailAddress -> Sem r () validateEmail (Just tid) uid email = do - enabled <- GalleyAccess.isEmailValidationEnabledTeam tid + enabled <- GalleyAPIAccess.isEmailValidationEnabledTeam tid let activation = if enabled then SendActivationEmail else AutoActivate - BrigAccess.updateEmail uid email activation + BrigAPIAccess.updateEmail uid email activation validateEmail _ _ _ = pure () -- | The from of the response on the finalize-login request depends on the verdict (denied or @@ -277,8 +277,8 @@ verdictHandler :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member AReqIDStore r, Member VerdictFormatStore r, Member ScimTokenStore r, @@ -324,8 +324,8 @@ verdictHandlerResult :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -368,7 +368,7 @@ catchVerdictErrors = (`catch` hndlr) -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefViaOldIssuerUnsafe :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => IdP -> @@ -386,7 +386,7 @@ getUserByUrefViaOldIssuerUnsafe idp (SAML.UserRef _ subject) = do -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. moveUserToNewIssuer :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => SAML.UserRef -> @@ -395,15 +395,15 @@ moveUserToNewIssuer :: Sem r () moveUserToNewIssuer oldUserRef newUserRef uid = do SAMLUserStore.insert newUserRef uid - BrigAccess.setSSOId uid (UserSSOId newUserRef) + BrigAPIAccess.setSSOId uid (UserSSOId newUserRef) SAMLUserStore.delete uid oldUserRef verdictHandlerResultCore :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -439,7 +439,7 @@ verdictHandlerResultCore idp verdict mlabel = case verdict of pure buid Logger.log Logger.Debug ("granting sso login for " <> show uid) - cky <- BrigAccess.ssoLogin uid mlabel + cky <- BrigAPIAccess.ssoLogin uid mlabel pure $ VerifyHandlerGranted cky uid -- | If the client is web, it will be served with an HTML page that it can process to decide whether diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 884a534b4d1..235a7f78392 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -41,12 +41,8 @@ import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra) import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) -import Spar.Sem.BrigAccess (BrigAccess) -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) -import Spar.Sem.GalleyAccess (GalleyAccess) -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) import Spar.Sem.IdPRawMetadataStore.Cassandra (idpRawMetadataStoreToCassandra) import Spar.Sem.Reporter (Reporter) @@ -63,23 +59,24 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) -import Spar.Sem.Utils (idpDbErrorToSparError, interpretClientToIO, ttlErrorToSparError) +import Spar.Sem.Utils import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog import Wire.API.Routes.Version (expandVersionExp) import Wire.API.User.Saml (TTLError) -import Wire.BrigAPIAccess (BrigAPIAccess) -import Wire.BrigAPIAccess.Rpc (interpretBrigAccess) +import Wire.BrigAPIAccess +import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError, clientErrorToHttpError) -import Wire.GalleyAPIAccess (GalleyAPIAccess) -import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) +import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess.Rpc import Wire.IdPConfigStore (IdPConfigStore) import Wire.IdPConfigStore.Cassandra (idPToCassandra) import Wire.IdPSubsystem (IdPSubsystem) import Wire.IdPSubsystem.Interpreter (IdPSubsystemError, interpretIdPSubsystem) import Wire.ParseException (ParseException, parseExceptionToHttpError) import Wire.Rpc (Rpc, runRpcWithHttp) +import Wire.RpcException import Wire.ScimSubsystem import Wire.ScimSubsystem.Interpreter import Wire.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) @@ -114,10 +111,9 @@ type LowerLevelCanonicalEffs = IdPRawMetadataStore, SAMLUserStore, Embed Cas.Client, - BrigAccess, - GalleyAccess, Error IdpDbError, Error TTLError, + Error RpcException, Error SparError, Reporter, Logger String, @@ -142,10 +138,9 @@ runSparToIO ctx = . stringLoggerToTinyLog . reporterToTinyLogWai . runError @SparError + . rpcExceptionToSparError . ttlErrorToSparError . idpDbErrorToSparError - . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) - . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) . interpretClientToIO (sparCtxCas ctx) . samlUserStoreToCassandra . idpRawMetadataStoreToCassandra diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 328c4725b3f..2dbc8675461 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -31,8 +31,6 @@ module Spar.Error IdpDbError (..), throwSpar, sparToServerErrorWithLogging, - rethrow, - parseResponse, -- FUTUREWORK: we really shouldn't export this, but that requires that we can use our -- custom servant monad in the 'MakeCustomError' instances. sparToServerError, @@ -44,15 +42,11 @@ module Spar.Error ) where -import Bilge (ResponseLBS, responseBody, responseJsonMaybe) -import qualified Bilge import Control.Monad.Except import Data.Aeson import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText -import Data.Typeable (typeRep) -import GHC.Stack (callStack, prettyCallStack) import Imports import Network.HTTP.Types.Status import qualified Network.Wai as Wai @@ -67,6 +61,7 @@ import Wire.API.User.Saml (TTLError) import Wire.Error import Wire.IdPConfigStore import Wire.IdPSubsystem.Interpreter +import Wire.RpcException import Wire.ScimSubsystem.Interpreter type SparError = SAML.Error SparCustomError @@ -99,11 +94,13 @@ data SparCustomError | SparCannotCreateUsersOnReplacedIdP LText | SparCouldNotParseRfcResponse LText LText | SparReAuthRequired + | SparReAuthRateLimitExceeded | SparReAuthCodeAuthFailed | SparReAuthCodeAuthRequired | SparCouldNotRetrieveCookie | SparCassandraError LText | SparCassandraTTLError TTLError + | SparRpcException RpcException | SparNewIdPBadMetadata LText | SparNewIdPPubkeyMismatch | SparNewIdPAlreadyInUse LText @@ -163,6 +160,7 @@ renderSparError (SAML.CustomError (SparCannotCreateUsersOnReplacedIdP replacingI -- RFC-specific errors renderSparError (SAML.CustomError (SparCouldNotParseRfcResponse service msg)) = StdError $ Wai.mkError status502 "bad-upstream" ("Could not parse " <> service <> " response body: " <> msg) renderSparError (SAML.CustomError SparReAuthRequired) = StdError $ Wai.mkError status403 "access-denied" "This operation requires reauthentication." +renderSparError (SAML.CustomError SparReAuthRateLimitExceeded) = StdError $ Wai.mkError status429 "rate-limit-exceeded" "Please use exponential backoff throttling to mitigate this." renderSparError (SAML.CustomError SparReAuthCodeAuthFailed) = StdError $ Wai.mkError status403 "code-authentication-failed" "Reauthentication failed with invalid verification code." renderSparError (SAML.CustomError SparReAuthCodeAuthRequired) = StdError $ Wai.mkError status403 "code-authentication-required" "Reauthentication failed. Verification code required." renderSparError (SAML.CustomError SparCouldNotRetrieveCookie) = StdError $ Wai.mkError status502 "bad-upstream" "Unable to get a cookie from an upstream server." @@ -173,6 +171,7 @@ renderSparError (SAML.CustomError (SparCassandraTTLError ttlerr)) = status400 "ttl-error" (LText.pack $ show ttlerr) +renderSparError (SAML.CustomError (SparRpcException err)) = StdError $ rpcExcepctionToWaiError err renderSparError (SAML.UnknownIdP msg) = StdError $ Wai.mkError status404 "not-found" ("IdP not found: " <> msg) renderSparError (SAML.Forbidden msg) = StdError $ Wai.mkError status403 "forbidden" ("Forbidden: " <> msg) renderSparError (SAML.BadSamlResponseBase64Error msg) = @@ -239,47 +238,6 @@ renderSparError (SAML.CustomError (SparSomeHttpError err)) = err -- Other renderSparError (SAML.CustomServant err) = serverErrorToHttpError err --- | If a call to another backend service fails, just respond with whatever it said. --- --- FUTUREWORK: with servant, there will be a way for the type checker to confirm that we --- handle all exceptions that brig can legally throw! -rethrow :: LText -> ResponseLBS -> (HasCallStack, Log.MonadLogger m, MonadError SparError m) => m a -rethrow serviceName resp = do - Log.info - ( Log.msg ("rfc error" :: Text) - . Log.field "status" (Bilge.statusCode resp) - . Log.field "error" (show err) - . Log.field "callstack" (prettyCallStack callStack) - ) - throwError err - where - err :: SparError - err = - responseJsonMaybe resp - & maybe - ( SAML.CustomError - . SparCouldNotParseRfcResponse serviceName - . ("internal error: " <>) - . LText.pack - . show - . (Bilge.statusCode resp,) - . fromMaybe "" - . responseBody - $ resp - ) - (SAML.CustomServant . waiToServant) - -parseResponse :: forall a m. (FromJSON a, MonadError SparError m, Typeable a) => LText -> ResponseLBS -> m a -parseResponse serviceName resp = do - let typeinfo :: LText - typeinfo = LText.pack $ show (typeRep ([] @a)) <> ": " - - err :: forall a'. LText -> m a' - err = throwSpar . SparCouldNotParseRfcResponse serviceName . (typeinfo <>) - - bdy <- maybe (err "no body") pure $ responseBody resp - either (err . LText.pack) pure $ eitherDecode' bdy - mapScimSubsystemErrors :: (Member (Error SparError) r) => InterpreterFor (Error ScimSubsystemError) r mapScimSubsystemErrors = Polysemy.Error.mapError (SAML.CustomError . SparScimError . scimSubsystemErrorToScimError) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs deleted file mode 100644 index fef947f5c28..00000000000 --- a/services/spar/src/Spar/Intra/Brig.hs +++ /dev/null @@ -1,463 +0,0 @@ --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- 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 . - --- | Client functions for interacting with the Brig API. -module Spar.Intra.Brig - ( MonadSparToBrig (..), - getBrigUserAccount, - getBrigUserByHandle, - getBrigUserByEmail, - getBrigUserRichInfo, - setBrigUserName, - setBrigUserHandle, - setBrigUserManagedBy, - setBrigUserSSOId, - setBrigUserRichInfo, - setBrigUserLocale, - checkHandleAvailable, - deleteBrigUserInternal, - createBrigUserSAML, - createBrigUserNoSAML, - updateEmail, - ensureReAuthorised, - ssoLogin, - getStatus, - getStatusMaybe, - setStatus, - getDefaultUserLocale, - checkAdminGetTeamId, - sendSAMLIdPChangedEmail, - ) -where - -import Bilge -import Control.Monad.Except -import Data.ByteString.Conversion -import Data.Code as Code -import Data.Handle (Handle (fromHandle)) -import Data.Id (Id (Id), TeamId, UserId) -import Data.Misc (PlainTextPassword6) -import qualified Data.Text.Lazy as Lazy -import Imports -import Network.HTTP.Types.Method -import qualified Network.Wai.Utilities.Error as Wai -import qualified SAML2.WebSSO as SAML -import Spar.Error -import qualified System.Logger.Class as Log -import Web.Cookie -import Wire.API.Locale -import Wire.API.Routes.Internal.Brig (IdpChangedNotification) -import Wire.API.Team.Role (Role) -import Wire.API.User -import Wire.API.User.Auth -import Wire.API.User.Auth.ReAuth -import Wire.API.User.Auth.Sso -import Wire.API.User.RichInfo as RichInfo -import Wire.UserSubsystem (HavePendingInvitations (..)) - ----------------------------------------------------------------------- - --- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the --- cookie in the response, and the redirect will make the client negotiate a fresh auth token. --- (This is the easiest way, since the login-request that we are in the middle of responding to here --- is not from the wire client, but from a browser that is still processing a redirect from the --- IdP.) -respToCookie :: (HasCallStack, MonadError SparError m) => ResponseLBS -> m SetCookie -respToCookie resp = do - let crash = throwSpar SparCouldNotRetrieveCookie - unless (statusCode resp == 200) crash - maybe crash (pure . parseSetCookie) $ getHeader "Set-Cookie" resp - ----------------------------------------------------------------------- - -class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where - call :: (Request -> Request) -> m ResponseLBS - -createBrigUserSAML :: - (HasCallStack, MonadSparToBrig m) => - SAML.UserRef -> - UserId -> - TeamId -> - -- | User name - Name -> - -- | Who should have control over the user - ManagedBy -> - Maybe Handle -> - Maybe RichInfo -> - Maybe Locale -> - Role -> - m UserId -createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do - let newUser = - NewUserSpar - { newUserSparUUID = buid, - newUserSparDisplayName = name, - newUserSparSSOId = UserSSOId uref, - newUserSparTeamId = teamid, - newUserSparManagedBy = managedBy, - newUserSparHandle = handle, - newUserSparRichInfo = richInfo, - newUserSparLocale = mLocale, - newUserSparRole = role - } - resp :: ResponseLBS <- - call $ - method POST - . path "/i/users/spar" - . json newUser - if statusCode resp `elem` [200, 201] - then userId . selfUser <$> parseResponse @SelfProfile "brig" resp - else rethrow "brig" resp - -createBrigUserNoSAML :: - (HasCallStack, MonadSparToBrig m) => - Text -> - EmailAddress -> - UserId -> - TeamId -> - -- | User name - Name -> - Maybe Locale -> - Role -> - m UserId -createBrigUserNoSAML extId email uid teamid uname locale role = do - let newUser = NewUserScimInvitation teamid uid extId locale uname email role - resp :: ResponseLBS <- - call $ - method POST - . paths ["/i/teams", toByteString' teamid, "invitations"] - . json newUser - - if statusCode resp `elem` [200, 201] - then userId <$> parseResponse @User "brig" resp - else rethrow "brig" resp - -updateEmail :: (HasCallStack, MonadSparToBrig m) => UserId -> EmailAddress -> EmailActivation -> m () -updateEmail buid email activation = do - resp <- - call $ - method PUT - . path "/i/self/email" - . header "Z-User" (toByteString' buid) - . query - [ ("activation", Just (toByteString' activation)), - -- FUTUREWORK: the following two are for backwards compatibility during deployment - -- of the release containing https://github.com/wireapp/wire-server/pull/4617, can - -- be removed later (fisx, 2025-06-19) - ("validate", Just (fromBool validate)), - ("activate", Just (fromBool activate)) - ] - . json (EmailUpdate email) - case statusCode resp of - 204 -> pure () - 202 -> pure () - _ -> rethrow "brig" resp - where - (validate, activate) = case activation of - AutoActivate -> (False, True) - SendActivationEmail -> (True, False) - - fromBool :: Bool -> ByteString - fromBool True = "true" - fromBool False = "false" - --- | Get a user; returns 'Nothing' if the user was not found or has been deleted. -getBrigUserAccount :: (HasCallStack, MonadSparToBrig m) => HavePendingInvitations -> UserId -> m (Maybe User) -getBrigUserAccount havePending buid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["/i/users"] - . query - [ ("ids", Just $ toByteString' buid), - ( "includePendingInvitations", - Just . toByteString' $ - case havePending of - WithPendingInvitations -> True - NoPendingInvitations -> False - ) - ] - - case statusCode resp of - 200 -> - parseResponse @[User] "brig" resp >>= \case - [account] -> - pure $ - if userDeleted account - then Nothing - else Just account - _ -> pure Nothing - 404 -> pure Nothing - _ -> rethrow "brig" resp - --- | Get a user; returns 'Nothing' if the user was not found. --- --- TODO: currently this is not used, but it might be useful later when/if --- @hscim@ stops doing checks during user creation. -getBrigUserByHandle :: (HasCallStack, MonadSparToBrig m) => Handle -> m (Maybe User) -getBrigUserByHandle handle = do - resp :: ResponseLBS <- - call $ - method GET - . path "/i/users" - . queryItem "handles" (toByteString' handle) - . queryItem "includePendingInvitations" "true" - case statusCode resp of - 200 -> listToMaybe <$> parseResponse @[User] "brig" resp - 404 -> pure Nothing - _ -> rethrow "brig" resp - -getBrigUserByEmail :: (HasCallStack, MonadSparToBrig m) => EmailAddress -> m (Maybe User) -getBrigUserByEmail email = do - resp :: ResponseLBS <- - call $ - method GET - . path "/i/users" - . queryItem "email" (toByteString' email) - . queryItem "includePendingInvitations" "true" - case statusCode resp of - 200 -> do - macc <- listToMaybe <$> parseResponse @[User] "brig" resp - case userEmail =<< macc of - Just email' | email' == email -> pure macc - _ -> pure Nothing - 404 -> pure Nothing - _ -> rethrow "brig" resp - --- | Set user' name. Fails with status <500 if brig fails with <500, and with 500 if brig --- fails with >= 500. -setBrigUserName :: (HasCallStack, MonadSparToBrig m) => UserId -> Name -> m () -setBrigUserName buid (Name name) = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "name"] - . json (NameUpdate name) - let sCode = statusCode resp - if sCode < 300 - then pure () - else rethrow "brig" resp - --- | Set user's handle. Fails with status <500 if brig fails with <500, and with 500 if brig fails --- with >= 500. --- --- NB: that this doesn't take a 'HandleUpdate', since we already construct a valid handle in --- 'validateScimUser' to increase the odds that user creation doesn't fail half-way through --- the many database write operations. -setBrigUserHandle :: (HasCallStack, MonadSparToBrig m) => UserId -> Handle {- not 'HandleUpdate'! -} -> m () -setBrigUserHandle buid handle = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "handle"] - . json (HandleUpdate (fromHandle handle)) - case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of - (200, Nothing) -> - pure () - _ -> - rethrow "brig" resp - --- | Set user's managedBy. Fails with status <500 if brig fails with <500, and with 500 if --- brig fails with >= 500. -setBrigUserManagedBy :: (HasCallStack, MonadSparToBrig m) => UserId -> ManagedBy -> m () -setBrigUserManagedBy buid managedBy = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "managed-by"] - . json (ManagedByUpdate managedBy) - unless (statusCode resp == 200) $ - rethrow "brig" resp - --- | Set user's UserSSOId. -setBrigUserSSOId :: (HasCallStack, MonadSparToBrig m) => UserId -> UserSSOId -> m () -setBrigUserSSOId buid ssoId = do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "sso-id"] - . json ssoId - case statusCode resp of - 200 -> pure () - _ -> rethrow "brig" resp - --- | Set user's richInfo. Fails with status <500 if brig fails with <500, and with 500 if --- brig fails with >= 500. -setBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> RichInfo -> m () -setBrigUserRichInfo buid richInfo = do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "rich-info"] - . json (RichInfoUpdate $ unRichInfo richInfo) - unless (statusCode resp == 200) $ - rethrow "brig" resp - -setBrigUserLocale :: (HasCallStack, MonadSparToBrig m) => UserId -> Maybe Locale -> m () -setBrigUserLocale buid = \case - Just locale -> do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "locale"] - . json (LocaleUpdate locale) - unless (statusCode resp == 200) $ - rethrow "brig" resp - Nothing -> do - resp <- - call $ - method DELETE - . paths ["i", "users", toByteString' buid, "locale"] - unless (statusCode resp == 200) $ - rethrow "brig" resp - -getBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> m RichInfo -getBrigUserRichInfo buid = do - resp <- - call $ - method GET - . paths ["/i/users", toByteString' buid, "rich-info"] - case statusCode resp of - 200 -> parseResponse "brig" resp - _ -> rethrow "brig" resp - -checkHandleAvailable :: (HasCallStack, MonadSparToBrig m) => Handle -> m Bool -checkHandleAvailable hnd = do - resp <- - call $ - method HEAD - . paths ["/i/users/handles", toByteString' hnd] - let sCode = statusCode resp - if - | sCode == 200 -> -- handle exists - pure False - | sCode == 404 -> -- handle not found - pure True - | otherwise -> - rethrow "brig" resp - --- | Call brig to delete a user. --- If the user wasn't deleted completely before, another deletion attempt will be made. -deleteBrigUserInternal :: (HasCallStack, MonadSparToBrig m) => UserId -> m DeleteUserResult -deleteBrigUserInternal buid = do - resp <- - call $ - method DELETE - . paths ["/i/users", toByteString' buid] - case statusCode resp of - 200 -> pure AccountAlreadyDeleted - 202 -> pure AccountDeleted - 404 -> pure NoUser - _ -> rethrow "brig" resp - --- | Verify user's password (needed for certain powerful operations). -ensureReAuthorised :: - (HasCallStack, MonadSparToBrig m) => - Maybe UserId -> - Maybe PlainTextPassword6 -> - Maybe Code.Value -> - Maybe VerificationAction -> - m () -ensureReAuthorised Nothing _ _ _ = throwSpar SparMissingZUsr -ensureReAuthorised (Just uid) secret mbCode mbAction = do - resp <- - call $ - method GET - . paths ["/i/users", toByteString' uid, "reauthenticate"] - . json (ReAuthUser secret mbCode mbAction) - case (statusCode resp, errorLabel resp) of - (200, _) -> pure () - (403, Just "code-authentication-required") -> throwSpar SparReAuthCodeAuthRequired - (403, Just "code-authentication-failed") -> throwSpar SparReAuthCodeAuthFailed - (403, _) -> throwSpar SparReAuthRequired - (_, _) -> rethrow "brig" resp - where - errorLabel :: ResponseLBS -> Maybe Lazy.Text - errorLabel = fmap Wai.label . responseJsonMaybe - --- | Get persistent cookie from brig and redirect user past login process. --- --- If brig responds with status >=400;<500, return Nothing. Otherwise, crash (500). -ssoLogin :: - (HasCallStack, MonadSparToBrig m) => - UserId -> - Maybe CookieLabel -> - m SetCookie -ssoLogin buid mlabel = do - resp :: ResponseLBS <- - call $ - method POST - . path "/i/sso-login" - . json (SsoLogin buid mlabel) - . queryItem "persist" "true" - if statusCode resp == 200 - then respToCookie resp - else rethrow "brig" resp - -getStatus' :: (HasCallStack, MonadSparToBrig m) => UserId -> m ResponseLBS -getStatus' uid = call $ method GET . paths ["/i/users", toByteString' uid, "status"] - --- | FUTUREWORK: this is probably unnecessary, and we can get the status info from 'UserAccount'. -getStatus :: (HasCallStack, MonadSparToBrig m) => UserId -> m AccountStatus -getStatus uid = do - resp <- getStatus' uid - case statusCode resp of - 200 -> fromAccountStatusResp <$> parseResponse @AccountStatusResp "brig" resp - _ -> rethrow "brig" resp - --- | FUTUREWORK: this is probably unnecessary, and we can get the status info from 'UserAccount'. -getStatusMaybe :: (HasCallStack, MonadSparToBrig m) => UserId -> m (Maybe AccountStatus) -getStatusMaybe uid = do - resp <- getStatus' uid - case statusCode resp of - 200 -> Just . fromAccountStatusResp <$> parseResponse @AccountStatusResp "brig" resp - 404 -> pure Nothing - _ -> rethrow "brig" resp - -setStatus :: (HasCallStack, MonadSparToBrig m) => UserId -> AccountStatus -> m () -setStatus uid status = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' uid, "status"] - . json (AccountStatusUpdate status) - case statusCode resp of - 200 -> pure () - _ -> rethrow "brig" resp - -getDefaultUserLocale :: (HasCallStack, MonadSparToBrig m) => m Locale -getDefaultUserLocale = do - resp <- call $ method GET . paths ["/i/users/locale"] - case statusCode resp of - 200 -> luLocale <$> parseResponse @LocaleUpdate "brig" resp - _ -> rethrow "brig" resp - -checkAdminGetTeamId :: (HasCallStack, MonadSparToBrig m) => UserId -> m TeamId -checkAdminGetTeamId uid = do - resp <- call $ method GET . paths ["/i/users", toByteString' uid, "check-admin-get-team-id"] - case statusCode resp of - 200 -> parseResponse @TeamId "brig" resp - _ -> rethrow "brig" resp - -sendSAMLIdPChangedEmail :: (HasCallStack, MonadSparToBrig m) => IdpChangedNotification -> m () -sendSAMLIdPChangedEmail notif = do - resp <- call $ method POST . path "/i/idp/send-idp-changed-email" . json notif - unless (statusCode resp == 200) $ - rethrow "brig" resp diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs deleted file mode 100644 index 31e3e89ba88..00000000000 --- a/services/spar/src/Spar/Intra/Galley.hs +++ /dev/null @@ -1,131 +0,0 @@ --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- 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 . - --- | Client functions for interacting with the Galley API. -module Spar.Intra.Galley where - -import Bilge -import Control.Lens -import Control.Monad.Except -import Data.ByteString.Conversion -import Data.Id (TeamId, UserId) -import qualified Data.Text.Lazy as LText -import Imports -import Network.HTTP.Types.Method -import Spar.Error -import qualified System.Logger.Class as Log -import Wire.API.Team.Feature -import Wire.API.Team.Member -import Wire.API.Team.Role - ----------------------------------------------------------------------- - -class (Monad m, Log.MonadLogger m) => MonadSparToGalley m where - call :: (Request -> Request) -> m ResponseLBS - --- | Get all members of a team. -getTeamMembers :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - m [TeamMember] -getTeamMembers tid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members"] - if statusCode resp == 200 - then (^. teamMembers) <$> parseResponse @TeamMemberList "galley" resp - else rethrow "galley" resp - --- | Get a single member of a team. -getTeamMember :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - UserId -> - m (Maybe TeamMember) -getTeamMember tid uid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] - if statusCode resp == 200 - then Just <$> parseResponse @TeamMember "galley" resp - else - if statusCode resp == 404 - then pure Nothing - else rethrow "galley" resp - --- | user is member of a given team and has a given permission there. -assertHasPermission :: - (HasCallStack, MonadSparToGalley m, MonadError SparError m, IsPerm TeamMember perm, Show perm) => - TeamId -> - perm -> - UserId -> - m () -assertHasPermission tid perm uid = do - resp <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] - case (statusCode resp, parseResponse @TeamMember "galley" resp) of - (200, Right member) | hasPermission member perm -> pure () - _ -> throwSpar (SparNoPermission (LText.pack $ show perm)) - -assertSSOEnabled :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - m () -assertSSOEnabled tid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "features", "sso"] - unless (statusCode resp == 200) $ - rethrow "galley" resp - ws :: LockableFeature SSOConfig <- parseResponse "galley" resp - unless (ws.status == FeatureStatusEnabled) $ - throwSpar SparSSODisabled - -isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> m Bool -isEmailValidationEnabledTeam tid = do - resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] - pure - ( statusCode resp == 200 - && ( ((.status) <$> responseJsonMaybe @(LockableFeature RequireExternalEmailVerificationConfig) resp) - == Just FeatureStatusEnabled - ) - ) - --- | Update a team member. -updateTeamMember :: - (MonadIO m, HasCallStack, MonadSparToGalley m) => - UserId -> - TeamId -> - Role -> - m () -updateTeamMember u tid role = do - let reqBody = mkNewTeamMember u (rolePermissions role) Nothing - rs <- - call $ - method PUT - . paths ["i", "teams", toByteString' tid, "members"] - . contentJson - . json reqBody - print rs diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/RpcApp.hs similarity index 71% rename from services/spar/src/Spar/Intra/BrigApp.hs rename to services/spar/src/Spar/Intra/RpcApp.hs index c1729747b3a..7b959a9a094 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/RpcApp.hs @@ -19,8 +19,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . --- | Client functions for interacting with the Brig API. -module Spar.Intra.BrigApp +-- | Client functions for interacting with the APIs of Brig, Galley, and possibly others. +module Spar.Intra.RpcApp ( veidToUserSSOId, urefToExternalId, oldVeidFromBrigUser, @@ -31,8 +31,10 @@ module Spar.Intra.BrigApp getBrigUserTeam, getZUsrCheckPerm, authorizeScimTokenManagement, - parseResponse, giveDefaultHandle, + ensureReAuthorised, + assertHasPermission, + assertSSOEnabled, -- * re-exports, mostly for historical reasons and lazyness emailFromSAML, @@ -44,25 +46,31 @@ import Control.Monad.Except import Data.ByteString.Conversion import Data.CaseInsensitive (original) import qualified Data.CaseInsensitive as CI +import Data.Code as Code import Data.Handle (Handle, parseHandle) import Data.HavePendingInvitations import Data.Id (TeamId, UserId) +import Data.Misc (PlainTextPassword6) import Data.Text.Encoding import Data.Text.Encoding.Error +import qualified Data.Text.Lazy as LText import Data.These import Data.These.Combinators import Imports import Polysemy import Polysemy.Error import qualified SAML2.WebSSO as SAML -import Spar.Error -import Spar.Sem.BrigAccess (BrigAccess) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess -import Wire.API.Team.Member (HiddenPerm (CreateReadDeleteScimToken), IsPerm, TeamMember) +import Spar.Error (SparCustomError (..), SparError) +import Wire.API.Error.Galley (AuthenticationError (..)) +import Wire.API.Team.Feature +import Wire.API.Team.Member (HiddenPerm (CreateReadDeleteScimToken), IsPerm, TeamMember, hasPermission) import Wire.API.User +import Wire.API.User.Auth.ReAuth (ReAuthUser (..)) import Wire.API.User.Scim (ValidScimId (..)) +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAPIAccess ---------------------------------------------------------------------- @@ -138,16 +146,16 @@ mkUserName Nothing = -- | Check that an id maps to an user on brig that is 'Active' (or optionally -- 'PendingInvitation') and has a team id. -getBrigUserTeam :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) -getBrigUserTeam ifpend = fmap (userTeam =<<) . BrigAccess.getAccount ifpend +getBrigUserTeam :: (HasCallStack, Member BrigAPIAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) +getBrigUserTeam ifpend = fmap (userTeam =<<) . BrigAPIAccess.getAccount ifpend -- | Pull team id for z-user from brig. Check permission in galley. Return team id. Fail if -- permission check fails or the user is not in status 'Active'. getZUsrCheckPerm :: forall r perm. ( HasCallStack, - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Error SparError) r ), IsPerm TeamMember perm, @@ -161,13 +169,13 @@ getZUsrCheckPerm (Just uid) perm = do getBrigUserTeam NoPendingInvitations uid >>= maybe (throw $ SAML.CustomError SparNotInTeam) - (\teamid -> teamid <$ GalleyAccess.assertHasPermission teamid perm uid) + (\teamid -> teamid <$ assertHasPermission teamid perm uid) authorizeScimTokenManagement :: forall r. ( HasCallStack, - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Error SparError) r ) ) => @@ -178,7 +186,7 @@ authorizeScimTokenManagement (Just uid) = do getBrigUserTeam NoPendingInvitations uid >>= maybe (throw $ SAML.CustomError SparNotInTeam) - (\teamid -> teamid <$ GalleyAccess.assertHasPermission teamid CreateReadDeleteScimToken uid) + (\teamid -> teamid <$ assertHasPermission teamid CreateReadDeleteScimToken uid) -- | If the user has no 'Handle', set it to its 'UserId' and update the user in brig. -- Return the handle the user now has (the old one if it existed, the newly created one @@ -194,11 +202,61 @@ authorizeScimTokenManagement (Just uid) = do -- We cannot simply respond with 404 in this case, because the user exists. 404 would suggest -- do the scim peer that it should post the user to create it, but that would create a new -- user instead of finding the old that should be put under scim control. -giveDefaultHandle :: (HasCallStack, Member BrigAccess r) => User -> Sem r Handle +giveDefaultHandle :: (HasCallStack, Member BrigAPIAccess r) => User -> Sem r Handle giveDefaultHandle usr = case userHandle usr of Just handle -> pure handle Nothing -> do let handle = fromJust . parseHandle . decodeUtf8With lenientDecode . toByteString' $ uid uid = userId usr - BrigAccess.setHandle uid handle + BrigAPIAccess.setHandle uid handle pure handle + +-- | Verify user's password (needed for certain powerful operations). +ensureReAuthorised :: + ( Member BrigAPIAccess r, + Member (Error SparError) r + ) => + Maybe UserId -> + Maybe PlainTextPassword6 -> + Maybe Code.Value -> + Maybe VerificationAction -> + Sem r () +ensureReAuthorised Nothing _ _ _ = throw $ SAML.CustomError SparMissingZUsr +ensureReAuthorised (Just uid) mpwd mcode maction = do + result <- BrigAPIAccess.reauthUser uid (ReAuthUser mpwd mcode maction) + case result of + Right () -> pure () + Left ReAuthFailed -> throw $ SAML.CustomError SparReAuthRequired + Left VerificationCodeRequired -> throw $ SAML.CustomError SparReAuthCodeAuthRequired + Left VerificationCodeAuthFailed -> throw $ SAML.CustomError SparReAuthCodeAuthFailed + Left RateLimitExceeded -> throw $ SAML.CustomError SparReAuthRateLimitExceeded + +-- | User is member of a given team and has a given permission there. +assertHasPermission :: + ( Member GalleyAPIAccess r, + Member (Error SparError) r, + IsPerm TeamMember perm, + Show perm + ) => + TeamId -> + perm -> + UserId -> + Sem r () +assertHasPermission tid perm uid = do + mbMember <- GalleyAPIAccess.getTeamMember uid tid + case mbMember of + Just member | hasPermission member perm -> pure () + _ -> throw $ SAML.CustomError (SparNoPermission (LText.pack $ show perm)) + +-- | Check that SSO is enabled for the given team. +assertSSOEnabled :: + ( Member GalleyAPIAccess r, + Member (Error SparError) r + ) => + TeamId -> + Sem r () +assertSSOEnabled tid = do + feat <- GalleyAPIAccess.getFeatureConfigForTeam @_ @SSOConfig tid + unless (feat.status == FeatureStatusEnabled) $ + throw $ + SAML.CustomError SparSSODisabled diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index f2095772ede..caf48e2e7bd 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -83,8 +83,6 @@ import Spar.Options import Spar.Scim.Auth import Spar.Scim.Group () import Spar.Scim.User -import Spar.Sem.BrigAccess (BrigAccess) -import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.Reporter (Reporter) import Spar.Sem.SAMLUserStore (SAMLUserStore) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -100,6 +98,8 @@ import qualified Web.Scim.Schema.Schema as Scim.Schema import qualified Web.Scim.Server as Scim import Wire.API.Routes.Public.Spar import Wire.API.User.Scim +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.IdPConfigStore (IdPConfigStore) import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) @@ -121,8 +121,8 @@ apiScim :: Member (Logger String) r, Member Now r, Member (Error SparError) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimSubsystem r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index c05a53defcb..a915a38bbd5 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -50,11 +50,8 @@ import qualified SAML2.WebSSO as SAML import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>))) import Spar.App (throwSparSem) import qualified Spar.Error as E -import qualified Spar.Intra.BrigApp as Intra.Brig +import qualified Spar.Intra.RpcApp as Intra import Spar.Options -import Spar.Sem.BrigAccess (BrigAccess) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import qualified Web.Scim.Class.Auth as Scim.Class.Auth @@ -64,6 +61,8 @@ import Wire.API.Routes.Named import Wire.API.Routes.Public.Spar (APIScimToken) import Wire.API.User as User import Wire.API.User.Scim as Api +import Wire.BrigAPIAccess +import Wire.GalleyAPIAccess import Wire.IdPConfigStore (IdPConfigStore) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.Sem.Now (Now) @@ -91,8 +90,8 @@ instance (Member ScimTokenStore r) => Scim.Class.Auth.AuthDB SparTag (Sem r) whe apiScimToken :: ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member Now r, Member IdPConfigStore r, @@ -108,17 +107,17 @@ apiScimToken = :<|> Named @"auth-tokens-list" listScimTokens updateScimTokenName :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r, - Member GalleyAccess r + Member GalleyAPIAccess r ) => UserId -> ScimTokenId -> ScimTokenName -> Sem r () updateScimTokenName lusr tokenId name = do - teamid <- Intra.Brig.authorizeScimTokenManagement (Just lusr) + teamid <- Intra.authorizeScimTokenManagement (Just lusr) ScimTokenStore.updateName teamid tokenId name.fromScimTokenName -- | > docs/reference/provisioning/scim-token.md {#RefScimTokenCreate} @@ -128,8 +127,8 @@ createScimTokenV7 :: forall r. ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member Now r, @@ -167,8 +166,8 @@ createScimToken :: forall r. ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member Now r, @@ -187,8 +186,8 @@ createScimToken zusr Api.CreateScimToken {..} = do guardScimTokenCreation :: forall r. ( Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -198,8 +197,8 @@ guardScimTokenCreation :: Maybe Code.Value -> Sem r TeamId guardScimTokenCreation zusr password verificationCode = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr - BrigAccess.ensureReAuthorised zusr password verificationCode (Just User.CreateScimToken) + teamid <- Intra.authorizeScimTokenManagement zusr + Intra.ensureReAuthorised zusr password verificationCode (Just User.CreateScimToken) tokenNumber <- length <$> ScimTokenStore.lookupByTeam teamid maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ @@ -240,8 +239,8 @@ createScimTokenUnchecked teamid mName desc mIdPId = do -- -- Delete a token belonging to user's team. deleteScimToken :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -250,13 +249,13 @@ deleteScimToken :: ScimTokenId -> Sem r NoContent deleteScimToken zusr tokenid = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr + teamid <- Intra.authorizeScimTokenManagement zusr ScimTokenStore.delete teamid tokenid pure NoContent listScimTokensV7 :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -276,8 +275,8 @@ listScimTokensV7 zusr = toV7 <$> listScimTokens zusr -- List all tokens belonging to user's team. Tokens themselves are not available, only -- metadata about them. listScimTokens :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -285,5 +284,5 @@ listScimTokens :: Maybe UserId -> Sem r ScimTokenList listScimTokens zusr = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr + teamid <- Intra.authorizeScimTokenManagement zusr ScimTokenList <$> ScimTokenStore.lookupByTeam teamid diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 1b8f7902628..118e00d2ed2 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -74,15 +74,11 @@ import Polysemy.Input import qualified SAML2.WebSSO as SAML import Spar.App (getUserByUrefUnsafe, getUserByUrefViaOldIssuerUnsafe, getUserIdByScimExternalId) import qualified Spar.App -import Spar.Intra.BrigApp as Intra -import qualified Spar.Intra.BrigApp as Brig +import Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Scim.Auth () import Spar.Scim.Types import qualified Spar.Scim.Types as ST -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -112,6 +108,10 @@ import Wire.API.User.IdentityProvider (IdP) import qualified Wire.API.User.RichInfo as RI import Wire.API.User.Scim (ScimTokenInfo (..), ValidScimId (..)) import qualified Wire.API.User.Scim as ST +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.IdPConfigStore (IdPConfigStore) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.Sem.Logger (Logger) @@ -130,8 +130,8 @@ instance Member Random r, Member (Input Opts) r, Member Now r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member IdPConfigStore r, @@ -208,7 +208,7 @@ validateScimUser :: forall r. ( Member (Logger (Msg -> Msg)) r, Member SAMLUserStore r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member IdPConfigStore r ) => @@ -230,7 +230,7 @@ validateScimUser errloc tokinfo user = validateScimUserNoLogging :: forall r. ( Member SAMLUserStore r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member IdPConfigStore r ) => @@ -289,7 +289,7 @@ validateHandle txt = case parseHandle txt of validateScimUser' :: forall r. ( Member (Error Scim.ScimError) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member SAMLUserStore r ) => -- | Error location (call site, for debugging) @@ -315,7 +315,7 @@ validateScimUser' errloc midp richInfoLimit user = do <> " (" <> errloc <> ")" - either err pure $ Brig.mkUserName (Scim.displayName user) (ST.validScimIdAuthInfo veid) + either err pure $ Intra.mkUserName (Scim.displayName user) (ST.validScimIdAuthInfo veid) richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user lang <- maybe (throw $ badRequest "Could not parse language. Expected format is ISO 639-1.") pure $ mapM parseLanguage $ Scim.preferredLanguage user @@ -377,7 +377,7 @@ validateScimUser' errloc midp richInfoLimit user = do -- recover the 'SAML.UserRef' of the scim user before the update from the database. mkValidScimId :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r, Member (Error Scim.ScimError) r ) => @@ -508,8 +508,8 @@ createValidScimUser :: Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member SAMLUserStore r, @@ -533,7 +533,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- If this is the case we can safely create the user again, AFTER THE -- HALF-CREATED ACCOUNT HAS BEEN GARBAGE-COLLECTED. -- Otherwise we return a conflict error. - lift (BrigAccess.getStatusMaybe buid) >>= \case + lift (BrigAPIAccess.getStatusMaybe buid) >>= \case Just Active -> throwError (externalIdTakenError ("user with status Active exists: " <> Text.pack (show (externalId, buid)))) Just Suspended -> throwError (externalIdTakenError ("user with status Suspended exists" <> Text.pack (show (externalId, buid)))) Just Ephemeral -> throwError (externalIdTakenError ("user with status Ephemeral exists" <> Text.pack (show (externalId, buid)))) @@ -560,14 +560,14 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- FUTUREWORK: outsource this and some other fragments from -- `createValidScimUser` into a function `createValidScimUserBrig` similar -- to `createValidScimUserSpar`? - void $ BrigAccess.createSAML uref buid stiTeam name ManagedByScim (Just handle) (Just richInfo) locale (fromMaybe defaultRole role) + void $ BrigAPIAccess.createSAML uref buid stiTeam name ManagedByScim (Just handle) (Just richInfo) locale (fromMaybe defaultRole role) doEmail email = do - void $ BrigAccess.createNoSAML externalId.validScimIdExternal email buid stiTeam name locale (fromMaybe defaultRole role) - BrigAccess.setHandle buid handle -- FUTUREWORK: possibly do the same one req as we do for saml? + void $ BrigAPIAccess.createNoSAML externalId.validScimIdExternal email buid stiTeam name locale (fromMaybe defaultRole role) + BrigAPIAccess.setHandle buid handle -- FUTUREWORK: possibly do the same one req as we do for saml? these doEmail doUref (\_ uref -> doUref uref) (validScimIdAuthInfo externalId) Logger.debug ("createValidScimUser: brig says " <> show buid) - BrigAccess.setRichInfo buid richInfo + BrigAPIAccess.setRichInfo buid richInfo -- {If we crash now, a POST retry will fail with 409 user already exists. -- Azure at some point will retry with GET /Users?filter=userName eq handle @@ -579,7 +579,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- to reload the Account from brig. storedUser <- do acc <- - lift (BrigAccess.getAccount Brig.WithPendingInvitations buid) + lift (BrigAPIAccess.getAccount Intra.WithPendingInvitations buid) >>= maybe (throwError $ Scim.serverError "Server error: user vanished") pure synthesizeStoredUser acc externalId lift $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) @@ -594,10 +594,10 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- TODO: suspension via scim is brittle, and may leave active users behind: if we don't -- reach the following line due to a crash, the user will be active. lift $ do - old <- BrigAccess.getStatus buid + old <- BrigAPIAccess.getStatus buid let new = ST.scimActiveFlagToAccountStatus old (Scim.unScimBool <$> active') active' = Scim.active . Scim.value . Scim.thing $ storedUser - when (new /= old) $ BrigAccess.setStatus buid new + when (new /= old) $ BrigAPIAccess.setStatus buid new lift $ ScimExternalIdStore.insertStatus stiTeam externalId buid ScimUserCreated pure storedUser @@ -642,8 +642,8 @@ updateValidScimUser :: Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member Now r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member IdPConfigStore r, @@ -670,7 +670,7 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = -- if the locale of the new valid SCIM user is not set, -- we set it to default value from brig - defLocale <- lift BrigAccess.getDefaultUserLocale + defLocale <- lift BrigAPIAccess.getDefaultUserLocale let newValidScimUser = nvsu {ST.locale = ST.locale nvsu <|> Just defLocale} -- assertions about new valid scim user that cannot be checked in 'validateScimUser' because @@ -689,33 +689,33 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = updateVsuUref stiTeam uid (oldValidScimUser.externalId) (newValidScimUser.externalId) when (newValidScimUser.name /= oldValidScimUser.name) $ - BrigAccess.setName uid (newValidScimUser.name) + BrigAPIAccess.setName uid (newValidScimUser.name) when (oldValidScimUser.handle /= newValidScimUser.handle) $ - BrigAccess.setHandle uid (newValidScimUser.handle) + BrigAPIAccess.setHandle uid (newValidScimUser.handle) when (oldValidScimUser.richInfo /= newValidScimUser.richInfo) $ - BrigAccess.setRichInfo uid (newValidScimUser.richInfo) + BrigAPIAccess.setRichInfo uid (newValidScimUser.richInfo) when (oldValidScimUser.locale /= newValidScimUser.locale) $ do - BrigAccess.setLocale uid (newValidScimUser.locale) + BrigAPIAccess.setLocale uid (newValidScimUser.locale) forM_ (newValidScimUser.role) $ \newRole -> do when (oldValidScimUser.role /= Just newRole) $ do - GalleyAccess.updateTeamMember uid stiTeam newRole + GalleyAPIAccess.updateTeamMember uid stiTeam newRole - BrigAccess.getStatusMaybe uid >>= \case + BrigAPIAccess.getStatusMaybe uid >>= \case Nothing -> pure () Just old -> do let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser.active) - when (new /= old) $ BrigAccess.setStatus uid new + when (new /= old) $ BrigAPIAccess.setStatus uid new ScimUserTimesStore.write newScimStoredUser Scim.getUser tokinfo uid updateVsuUref :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -735,7 +735,7 @@ updateVsuUref team uid old new = do ScimExternalIdStore.insert team new.validScimIdExternal uid for_ (justThere new.validScimIdAuthInfo) (`SAMLUserStore.insert` uid) - BrigAccess.setSSOId uid $ veidToUserSSOId new + BrigAPIAccess.setSSOId uid $ veidToUserSSOId new toScimStoredUser :: (HasCallStack) => @@ -793,7 +793,7 @@ updScimStoredUser' now usr (Scim.WithMeta meta (Scim.WithId scimuid _)) = deleteScimUser :: ( Member (Logger (Msg -> Msg)) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member SAMLUserStore r, @@ -814,7 +814,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- ("tombstones") would not have the needed values (`userIdentity = -- Nothing`) to delete a user in spar. I.e. `SAML.UserRef` and `Email` -- cannot be figured out when a `User` has status `Deleted`. - mbAccount <- lift $ BrigAccess.getAccount WithPendingInvitations uid + mbAccount <- lift $ BrigAPIAccess.getAccount WithPendingInvitations uid case mbAccount of Nothing -> -- Ensure there's no left-over of this user in brig. This is safe @@ -823,7 +823,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- be hard as the check relies on the data of `mbBrigUser`): The worst -- thing that could happen is that foreign users cleanup partially -- deleted users. - void . lift $ BrigAccess.deleteUser uid + void . lift $ BrigAPIAccess.deleteUser uid Just brigUser -> do if userTeam brigUser == Just stiTeam then do @@ -834,7 +834,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- (via the TM app) is blocked, though, so there is no legal way to enter -- that situation. deleteUserInSpar brigUser - void . lift $ BrigAccess.deleteUser uid + void . lift $ BrigAPIAccess.deleteUser uid else do -- if we find the user in another team, we pretend it wasn't even there, to -- avoid leaking data to attackers (very unlikely, but hey). @@ -852,14 +852,14 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = mIdpConfig <- mapM (lift . IdPConfigStore.getConfig) stiIdP -- delete user with idp associated *before* this update. - case Brig.oldVeidFromBrigUser account of + case Intra.oldVeidFromBrigUser account of Nothing -> pure () Just veid -> lift $ do for_ (justThere veid.validScimIdAuthInfo) (SAMLUserStore.delete uid) ScimExternalIdStore.delete stiTeam veid.validScimIdExternal -- delete user with idp associated to current scim token. - case Brig.newVeidFromBrigUser account ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of + case Intra.newVeidFromBrigUser account ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Left _ -> pure () Right veid -> lift $ do for_ (justThere veid.validScimIdAuthInfo) (SAMLUserStore.delete uid) @@ -894,7 +894,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdUnused :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -911,7 +911,7 @@ assertExternalIdUnused = -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdNotUsedElsewhere :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -927,7 +927,7 @@ assertExternalIdNotUsedElsewhere tid veid wireUserId = veid assertExternalIdInAllowedValues :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -945,18 +945,18 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: (Member BrigAccess r) => Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused :: (Member BrigAPIAccess r) => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: (Member BrigAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused' :: (Member BrigAPIAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused' msg hndl = - lift (BrigAccess.checkHandleAvailable hndl) >>= \case + lift (BrigAPIAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: (Member BrigAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleNotUsedElsewhere :: (Member BrigAPIAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () assertHandleNotUsedElsewhere uid hndl = do - musr <- lift $ getAccount Brig.WithPendingInvitations uid + musr <- lift $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ assertHandleUnused' "userName already in use by another wire user" hndl @@ -968,8 +968,8 @@ synthesizeStoredUser :: ( Member (Input Opts) r, Member Now r, Member (Logger (Msg -> Msg)) r, - Member BrigAccess r, - Member GalleyAccess r, + Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member ScimUserTimesStore r ) => User -> @@ -991,7 +991,7 @@ synthesizeStoredUser acc veid = let readState :: Sem r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI, Role) readState = (,,,) - <$> BrigAccess.getRichInfo uid + <$> BrigAPIAccess.getRichInfo uid <*> ScimUserTimesStore.read uid <*> inputs scimBaseUri <*> getRole @@ -1001,16 +1001,16 @@ synthesizeStoredUser acc veid = when (isNothing oldAccessTimes) $ ScimUserTimesStore.write storedUser when (oldManagedBy /= ManagedByScim) $ - BrigAccess.setManagedBy uid ManagedByScim + BrigAPIAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser when (oldRichInfo /= newRichInfo) $ - BrigAccess.setRichInfo uid newRichInfo + BrigAPIAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri, role) <- lift readState now <- toUTCTimeMillis <$> lift Now.get let (createdAt, lastUpdatedAt) = fromMaybe (now, now) accessTimes - handle <- lift $ Brig.giveDefaultHandle acc + handle <- lift $ Intra.giveDefaultHandle acc let emails = maybeToList $ @@ -1036,7 +1036,7 @@ synthesizeStoredUser acc veid = getRole :: Sem r Role getRole = do let tmRoleOrDefault m = fromMaybe defaultRole $ m >>= \member -> member ^. Member.permissions . to Member.permissionsRole - maybe (pure defaultRole) (\tid -> tmRoleOrDefault <$> GalleyAccess.getTeamMember tid (userId acc)) (userTeam acc) + maybe (pure defaultRole) (fmap tmRoleOrDefault . GalleyAPIAccess.getTeamMember (userId acc)) (userTeam acc) synthesizeStoredUser' :: (MonadError Scim.ScimError m) => @@ -1094,8 +1094,8 @@ synthesizeScimUser info = -- TODO: now write a test, either in /integration or in spar, whichever is easier. (spar) getUserById :: forall r. - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1108,9 +1108,9 @@ getUserById :: UserId -> MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) getUserById midp stiTeam uid = do - brigUser <- MaybeT . lift $ BrigAccess.getAccount Brig.WithPendingInvitations uid - let mbOldVeid = Brig.oldVeidFromBrigUser brigUser - mbNewVeid = Brig.newVeidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> midp) + brigUser <- MaybeT . lift $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid + let mbOldVeid = Intra.oldVeidFromBrigUser brigUser + mbNewVeid = Intra.newVeidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> midp) case mbNewVeid of Right veid | userTeam brigUser == Just stiTeam -> lift $ do storedUser :: Scim.StoredUser ST.SparTag <- synthesizeStoredUser brigUser veid @@ -1126,10 +1126,10 @@ getUserById midp stiTeam uid = do handleVeidChange brigUser mbOldVeid newVeid = do -- set sso_id when (mbOldVeid /= Just newVeid) do - lift $ BrigAccess.setSSOId uid (veidToUserSSOId newVeid) + lift $ BrigAPIAccess.setSSOId uid (veidToUserSSOId newVeid) -- set managed_by when (userManagedBy brigUser /= ManagedByScim) do - lift $ BrigAccess.setManagedBy uid ManagedByScim + lift $ BrigAPIAccess.setManagedBy uid ManagedByScim -- remove dangling entry from spar.user_v2 table (cassandra) case mbOldVeid of Just oldVeid | ST.veidUref newVeid /= ST.veidUref oldVeid -> do @@ -1138,8 +1138,8 @@ getUserById midp stiTeam uid = do scimFindUserByHandle :: forall r. - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1153,7 +1153,7 @@ scimFindUserByHandle :: MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl - brigUser <- MaybeT . lift . BrigAccess.getByHandle $ handle + brigUser <- MaybeT . lift . BrigAPIAccess.getAccountByHandle $ handle getUserById mIdpConfig stiTeam . userId $ brigUser -- | Construct a 'ValidScimId'. If it is an 'Email', find the non-SAML SCIM user in spar; if @@ -1164,8 +1164,8 @@ scimFindUserByHandle mIdpConfig stiTeam hndl = do -- successful authentication with their SAML credentials. scimFindUserByExternalId :: forall r. - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1186,11 +1186,11 @@ scimFindUserByExternalId mIdpConfig stiTeam eid = do -- there are a few ways to find a user. this should all be redundant, especially the where -- we lookup a user from brig by email, throw it away and only keep the uid, and then use -- the uid to lookup the account again. but cassandra, and also reasons. - mViaEmail :: Maybe UserId <- join <$> (for (justHere veid.validScimIdAuthInfo) ((userId <$$>) . BrigAccess.getByEmail)) + mViaEmail :: Maybe UserId <- join <$> (for (justHere veid.validScimIdAuthInfo) ((userId <$$>) . BrigAPIAccess.getByEmail)) mViaUref :: Maybe UserId <- join <$> (for (justThere veid.validScimIdAuthInfo) SAMLUserStore.get) pure $ mViaEmail <|> mViaUref Just uid -> pure uid - acc <- MaybeT . lift . BrigAccess.getAccount Brig.WithPendingInvitations $ uid + acc <- MaybeT . lift . BrigAPIAccess.getAccount Intra.WithPendingInvitations $ uid getUserById mIdpConfig stiTeam (userId acc) logFilter :: Filter -> (Msg -> Msg) diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs deleted file mode 100644 index b8765965f32..00000000000 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- 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 Spar.Sem.BrigAccess - ( BrigAccess (..), - createSAML, - createNoSAML, - updateEmail, - getAccount, - getByHandle, - getByEmail, - setName, - setHandle, - setManagedBy, - setSSOId, - setRichInfo, - setLocale, - getRichInfo, - checkHandleAvailable, - deleteUser, - ensureReAuthorised, - ssoLogin, - getStatus, - getStatusMaybe, - setStatus, - getDefaultUserLocale, - checkAdminGetTeamId, - sendSAMLIdPChangedEmail, - ) -where - -import Data.Code as Code -import Data.Handle (Handle) -import Data.HavePendingInvitations -import Data.Id (TeamId, UserId) -import Data.Misc (PlainTextPassword6) -import Imports -import Polysemy -import qualified SAML2.WebSSO as SAML -import Web.Cookie -import Wire.API.Locale -import Wire.API.Routes.Internal.Brig (IdpChangedNotification) -import Wire.API.Team.Role -import Wire.API.User -import Wire.API.User.Auth -import Wire.API.User.RichInfo as RichInfo - -data BrigAccess m a where - CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> Maybe Locale -> Role -> BrigAccess m UserId - CreateNoSAML :: Text -> EmailAddress -> UserId -> TeamId -> Name -> Maybe Locale -> Role -> BrigAccess m UserId - UpdateEmail :: UserId -> EmailAddress -> EmailActivation -> BrigAccess m () - GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe User) - GetByHandle :: Handle -> BrigAccess m (Maybe User) - GetByEmail :: EmailAddress -> BrigAccess m (Maybe User) - SetName :: UserId -> Name -> BrigAccess m () - SetHandle :: UserId -> Handle {- not 'HandleUpdate'! -} -> BrigAccess m () - SetManagedBy :: UserId -> ManagedBy -> BrigAccess m () - SetSSOId :: UserId -> UserSSOId -> BrigAccess m () - SetRichInfo :: UserId -> RichInfo -> BrigAccess m () - SetLocale :: UserId -> Maybe Locale -> BrigAccess m () - GetRichInfo :: UserId -> BrigAccess m RichInfo - CheckHandleAvailable :: Handle -> BrigAccess m Bool - DeleteUser :: UserId -> BrigAccess m DeleteUserResult - EnsureReAuthorised :: Maybe UserId -> Maybe PlainTextPassword6 -> Maybe Code.Value -> Maybe VerificationAction -> BrigAccess m () - SsoLogin :: UserId -> Maybe CookieLabel -> BrigAccess m SetCookie - GetStatus :: UserId -> BrigAccess m AccountStatus - GetStatusMaybe :: UserId -> BrigAccess m (Maybe AccountStatus) - SetStatus :: UserId -> AccountStatus -> BrigAccess m () - GetDefaultUserLocale :: BrigAccess m Locale - CheckAdminGetTeamId :: UserId -> BrigAccess m TeamId - SendSAMLIdPChangedEmail :: IdpChangedNotification -> BrigAccess m () - -makeSem ''BrigAccess diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs deleted file mode 100644 index 08880ae3014..00000000000 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ /dev/null @@ -1,68 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Spar.Sem.BrigAccess.Http - ( brigAccessToHttp, - ) -where - -import Bilge -import Imports -import Polysemy -import Polysemy.Error (Error) -import Spar.Error (SparError) -import qualified Spar.Intra.Brig as Intra -import Spar.Sem.BrigAccess -import Spar.Sem.Utils (RunHttpEnv (..), viaRunHttp) -import qualified System.Logger as TinyLog -import Wire.Sem.Logger (Logger) - -brigAccessToHttp :: - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Error SparError) r, - Member (Embed IO) r - ) => - Bilge.Manager -> - Bilge.Request -> - Sem (BrigAccess ': r) a -> - Sem r a -brigAccessToHttp mgr req = - interpret $ - viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m h ri ml r -> Intra.createBrigUserSAML u itlu itlt n m h ri ml r - CreateNoSAML eid e uid itlt n ml r -> Intra.createBrigUserNoSAML eid e uid itlt n ml r - UpdateEmail itlu e a -> Intra.updateEmail itlu e a - GetAccount h itlu -> Intra.getBrigUserAccount h itlu - GetByHandle h -> Intra.getBrigUserByHandle h - GetByEmail e -> Intra.getBrigUserByEmail e - SetName itlu n -> Intra.setBrigUserName itlu n - SetHandle itlu h -> Intra.setBrigUserHandle itlu h - SetManagedBy itlu m -> Intra.setBrigUserManagedBy itlu m - SetSSOId itlu v -> Intra.setBrigUserSSOId itlu v - SetRichInfo itlu r -> Intra.setBrigUserRichInfo itlu r - SetLocale itlu l -> Intra.setBrigUserLocale itlu l - GetRichInfo itlu -> Intra.getBrigUserRichInfo itlu - CheckHandleAvailable h -> Intra.checkHandleAvailable h - DeleteUser itlu -> Intra.deleteBrigUserInternal itlu - EnsureReAuthorised mitlu mp mc ma -> Intra.ensureReAuthorised mitlu mp mc ma - SsoLogin itlu mlabel -> Intra.ssoLogin itlu mlabel - GetStatus itlu -> Intra.getStatus itlu - GetStatusMaybe itlu -> Intra.getStatusMaybe itlu - SetStatus itlu a -> Intra.setStatus itlu a - GetDefaultUserLocale -> Intra.getDefaultUserLocale - CheckAdminGetTeamId itlu -> Intra.checkAdminGetTeamId itlu - SendSAMLIdPChangedEmail notif -> Intra.sendSAMLIdPChangedEmail notif diff --git a/services/spar/src/Spar/Sem/GalleyAccess.hs b/services/spar/src/Spar/Sem/GalleyAccess.hs deleted file mode 100644 index 545395af4cd..00000000000 --- a/services/spar/src/Spar/Sem/GalleyAccess.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- 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 Spar.Sem.GalleyAccess - ( GalleyAccess (..), - getTeamMembers, - getTeamMember, - assertHasPermission, - assertSSOEnabled, - isEmailValidationEnabledTeam, - updateTeamMember, - ) -where - -import Data.Id (TeamId, UserId) -import Imports -import Polysemy -import Wire.API.Team.Member -import Wire.API.Team.Role - -data GalleyAccess m a where - GetTeamMembers :: TeamId -> GalleyAccess m [TeamMember] - GetTeamMember :: TeamId -> UserId -> GalleyAccess m (Maybe TeamMember) - AssertHasPermission :: (Show perm, IsPerm TeamMember perm) => TeamId -> perm -> UserId -> GalleyAccess m () - AssertSSOEnabled :: TeamId -> GalleyAccess m () - IsEmailValidationEnabledTeam :: TeamId -> GalleyAccess m Bool - UpdateTeamMember :: UserId -> TeamId -> Role -> GalleyAccess m () - -makeSem ''GalleyAccess diff --git a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs deleted file mode 100644 index 793bac9c276..00000000000 --- a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs +++ /dev/null @@ -1,53 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Spar.Sem.GalleyAccess.Http - ( RunHttpEnv (..), - viaRunHttp, - galleyAccessToHttp, - ) -where - -import Bilge -import Imports hiding (log) -import Polysemy -import Polysemy.Error -import Spar.Error (SparError) -import qualified Spar.Intra.Galley as Intra -import Spar.Sem.GalleyAccess -import Spar.Sem.Utils -import qualified System.Logger as TinyLog -import Wire.Sem.Logger (Logger) - -galleyAccessToHttp :: - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Error SparError) r, - Member (Embed IO) r - ) => - Bilge.Manager -> - Bilge.Request -> - Sem (GalleyAccess ': r) a -> - Sem r a -galleyAccessToHttp mgr req = - interpret $ - viaRunHttp (RunHttpEnv mgr req) . \case - GetTeamMembers itlt -> Intra.getTeamMembers itlt - GetTeamMember tid uid -> Intra.getTeamMember tid uid - AssertHasPermission itlt perm itlu -> Intra.assertHasPermission itlt perm itlu - AssertSSOEnabled itlt -> Intra.assertSSOEnabled itlt - IsEmailValidationEnabledTeam itlt -> Intra.isEmailValidationEnabledTeam itlt - UpdateTeamMember uid tid role -> Intra.updateTeamMember uid tid role diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs index 0cac0ec9db4..11789114fa2 100644 --- a/services/spar/src/Spar/Sem/Utils.hs +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -18,33 +16,24 @@ -- with this program. If not, see . module Spar.Sem.Utils - ( viaRunHttp, - RunHttpEnv (..), - interpretClientToIO, + ( interpretClientToIO, ttlErrorToSparError, + rpcExceptionToSparError, idpDbErrorToSparError, ) where -import Bilge import Cassandra as Cas import qualified Control.Monad.Catch as Catch -import Control.Monad.Except (ExceptT (..), MonadError, runExceptT) import qualified Data.Text.Lazy as LText -import Imports hiding (log) +import Imports import Polysemy import Polysemy.Error import Polysemy.Final import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Intra.Brig (MonadSparToBrig (..)) -import Spar.Intra.Galley (MonadSparToGalley) -import qualified Spar.Intra.Galley as Intra -import qualified System.Logger as TinyLog -import qualified System.Logger.Class as TinyLog import Wire.API.User.Saml -import Wire.Sem.Logger (Logger) -import qualified Wire.Sem.Logger as Logger +import Wire.RpcException -- | Run an embedded Cassandra 'Client' in @Final IO@. interpretClientToIO :: @@ -70,62 +59,8 @@ interpretClientToIO ctx = interpret $ \case ttlErrorToSparError :: (Member (Error SparError) r) => Sem (Error TTLError ': r) a -> Sem r a ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError) +rpcExceptionToSparError :: (Member (Error SparError) r) => Sem (Error RpcException ': r) a -> Sem r a +rpcExceptionToSparError = mapError (SAML.CustomError . SparRpcException) + idpDbErrorToSparError :: (Member (Error SparError) r) => Sem (Error IdpDbError ': r) a -> Sem r a idpDbErrorToSparError = mapError (SAML.CustomError . IdpDbError) - -data RunHttpEnv r = RunHttpEnv - { rheManager :: Bilge.Manager, - rheRequest :: Bilge.Request - } - -newtype RunHttp r a = RunHttp - { unRunHttp :: ReaderT (RunHttpEnv r) (ExceptT SparError (HttpT (Sem r))) a - } - deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r)) - -instance (Member (Embed IO) r) => MonadIO (RunHttp r) where - liftIO = semToRunHttp . embed - -instance (Member (Embed IO) r) => MonadHttp (RunHttp r) where - handleRequestWithCont r fribia = - RunHttp $ - lift $ - lift $ - handleRequestWithCont r fribia - -semToRunHttp :: Sem r a -> RunHttp r a -semToRunHttp = RunHttp . lift . lift . lift - -viaRunHttp :: - (Member (Error SparError) r) => - RunHttpEnv r -> - RunHttp r a -> - Sem r a -viaRunHttp env m = do - ma <- runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m - case ma of - Left err -> throw err - Right a -> pure a - -instance (Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r) => TinyLog.MonadLogger (RunHttp r) where - log lvl msg = semToRunHttp $ Logger.log lvl msg - -instance - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - MonadSparToGalley (RunHttp r) - where - call modreq = do - req <- asks rheRequest - httpLbs req modreq - -instance - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - MonadSparToBrig (RunHttp r) - where - call modreq = do - req <- asks rheRequest - httpLbs req modreq diff --git a/services/spar/test-integration/Main.hs b/services/spar/test-integration/Main.hs index f1a42c99847..b2c219c6147 100644 --- a/services/spar/test-integration/Main.hs +++ b/services/spar/test-integration/Main.hs @@ -47,7 +47,6 @@ import qualified Test.MetricsSpec import qualified Test.Spar.APISpec import qualified Test.Spar.AppSpec import qualified Test.Spar.DataSpec -import qualified Test.Spar.Intra.BrigSpec import qualified Test.Spar.Scim.AuthSpec import qualified Test.Spar.Scim.UserSpec import Util @@ -107,7 +106,6 @@ mkspecSaml = do describe "Spar.API" Test.Spar.APISpec.spec describe "Spar.App" Test.Spar.AppSpec.spec describe "Spar.Data" Test.Spar.DataSpec.spec - describe "Spar.Intra.Brig" Test.Spar.Intra.BrigSpec.spec mkspecScim :: SpecWith TestEnv mkspecScim = do diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index ec2fff5242f..315d798378c 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -25,6 +25,7 @@ import Bilge.Assert import Cassandra as Cas hiding (Client, Value) import Control.Lens hiding ((.=)) import Control.Monad.Catch (MonadThrow) +import Control.Monad.Error.Class import Control.Monad.Random.Class (getRandomR) import Data.Aeson as Aeson import Data.Aeson.Lens @@ -37,8 +38,9 @@ import Data.Misc import Data.Proxy import Data.String.Conversions import qualified Data.Text as ST -import qualified Data.Text as T import Data.Text.Ascii (decodeBase64, validateBase64) +import qualified Data.Text.Lazy as LT +import Data.Typeable (typeRep) import qualified Data.UUID as UUID hiding (fromByteString, null) import qualified Data.UUID.V4 as UUID (nextRandom) import qualified Data.Vector as Vec @@ -70,10 +72,10 @@ import SAML2.WebSSO.API.Example (SimpleSP) import SAML2.WebSSO.Test.Lenses import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util -import qualified Spar.Intra.BrigApp as Intra +import Spar.Error +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore -import qualified Spar.Sem.BrigAccess as BrigAccess import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI import URI.ByteString.QQ (uri) @@ -95,6 +97,7 @@ import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.User.IdentityProvider import Wire.API.User.Scim hiding (handle) +import qualified Wire.BrigAPIAccess as BrigAPIAccess import qualified Wire.IdPConfigStore as IdPEffect spec :: SpecWith TestEnv @@ -419,7 +422,7 @@ specFinalizeLogin = do subj <- createEmailSubject randEmail mbId1 <- loginWithSubject subj - subjUpper <- createEmailSubject (T.toUpper randEmail) + subjUpper <- createEmailSubject (ST.toUpper randEmail) mbId2 <- loginWithSubject subjUpper liftIO $ do @@ -1267,7 +1270,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do brig <- view teBrig resp <- call . delete $ brig . paths ["i", "users", toByteString' uid] liftIO $ responseStatus resp `shouldBe` status202 - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Deleted) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Deleted) specScimAndSAML :: SpecWith TestEnv specScimAndSAML = do @@ -1431,8 +1434,20 @@ specAux = do . header "Z-User" (toByteString' $ if tryowner then owner else newmember) . expect2xx ) - parsedResp <- either (error . show) (pure . selfUser) (Intra.parseResponse @SelfProfile "brig" rawResp) + parsedResp <- either (error . show) (pure . selfUser) (parseResponse @SelfProfile "brig" rawResp) liftIO $ userTeam parsedResp `shouldSatisfy` isJust + + parseResponse :: forall a m. (FromJSON a, MonadError SparError m, Typeable a) => LText -> ResponseLBS -> m a + parseResponse serviceName resp = do + let typeinfo :: LText + typeinfo = LT.pack $ show (typeRep ([] @a)) <> ": " + + err :: forall a'. LText -> m a' + err = throwSpar . SparCouldNotParseRfcResponse serviceName . (typeinfo <>) + + bdy <- maybe (err "no body") pure $ responseBody resp + either (err . LT.pack) pure $ eitherDecode' bdy + permses :: [Permissions] permses = [ fullPermissions, diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 7d809b979f8..4251a61c859 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -29,7 +29,7 @@ import Imports import SAML2.WebSSO as SAML import Spar.App as App import Spar.Error (IdpDbError (IdpNotFound), SparCustomError (IdpDbError)) -import Spar.Intra.BrigApp (veidFromUserSSOId) +import Spar.Intra.RpcApp (veidFromUserSSOId) import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.AssIDStore as AssIDStore diff --git a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs deleted file mode 100644 index c97ad084a90..00000000000 --- a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs +++ /dev/null @@ -1,65 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Spar.Intra.BrigSpec - ( spec, - ) -where - -import Control.Lens ((^.)) -import Data.Id (Id (Id), UserId) -import qualified Data.UUID as UUID -import Imports hiding (head) -import qualified Spar.Intra.BrigApp as Intra -import Spar.Sem.BrigAccess (getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Test.QuickCheck -import Util -import qualified Web.Scim.Schema.User as Scim.User -import Wire.API.User (DeleteUserResult (..), fromEmail) - -spec :: SpecWith TestEnv -spec = do - describe "user deletion between brig and spar" $ do - it "if a user gets deleted on brig, it will be deleted on spar as well." $ do - pending - it "if a user gets deleted on spar, it will be deleted on brig as well." $ do - pendingWith "or deactivated? we should decide what we want here." - - describe "deleteBrigUserInternal" $ do - it "does not throw for non-existing users" $ do - uid :: UserId <- liftIO $ generate arbitrary - r <- runSpar $ BrigAccess.deleteUser uid - liftIO $ r `shouldBe` NoUser - - describe "getAccount" $ do - it "return Nothing if n/a" $ do - musr <- runSpar $ getAccount Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") - liftIO $ musr `shouldSatisfy` isNothing - - it "return Just if /a" $ do - let setup = do - env <- ask - email <- randomEmail - scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} - (_, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) - tok <- registerScimToken tid Nothing - scimUserId <$> createUser tok scimUser - - uid <- setup - musr <- runSpar $ getAccount Intra.WithPendingInvitations uid - liftIO $ musr `shouldSatisfy` isJust diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index fa651962ee1..97b7c036430 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -63,12 +63,11 @@ import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import SAML2.WebSSO.Test.Util.TestSP (makeSampleIdPMetadata) import qualified SAML2.WebSSO.Test.Util.Types as SAML -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Scim import Spar.Scim.Types (normalizeLikeStored) import qualified Spar.Scim.User as SU -import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore @@ -96,6 +95,7 @@ import qualified Wire.API.User.IdentityProvider as User import Wire.API.User.RichInfo import qualified Wire.API.User.Scim as Spar.Types import qualified Wire.API.User.Search as Search +import qualified Wire.BrigAPIAccess as BrigAPIAccess -- | Tests for @\/scim\/v2\/Users@. spec :: SpecWith TestEnv @@ -150,7 +150,7 @@ specImportToScimFromSAML = pure (uref, uid) let handle = fromRight undefined . parseHandleEither $ Scim.User.userName usr - runSpar (BrigAccess.setHandle uid handle) + runSpar (BrigAPIAccess.setHandle uid handle) assertSparCassandraUref (uref, Just uid) assertSparCassandraScim ((teamid, email), Nothing) @@ -219,7 +219,7 @@ specImportToScimFromSAML = -- the "get" has already changed the ssoid in brig: no more idp assertSparCassandraUref (uref, Nothing) - runSpar (BrigAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do + runSpar (BrigAPIAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do userIdentity acc `shouldBe` let emailText :: Text = decodeUtf8 $ toStrict $ toByteString email in Just (SSOIdentity (UserScimExternalId emailText) (Just email)) @@ -446,7 +446,7 @@ assertBrigCassandra :: ManagedBy -> TestSpar () assertBrigCassandra uid uref usr (valemail, emailValidated) managedBy = do - runSpar (BrigAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do + runSpar (BrigAPIAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do let handle = fromRight errmsg . parseHandleEither $ Scim.User.userName usr where errmsg = error . show . Scim.User.userName $ usr @@ -481,9 +481,9 @@ specSuspend = do -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) handle <- nextHandle - runSpar $ BrigAccess.setHandle member handle + runSpar $ BrigAPIAccess.setHandle member handle unless isActive $ do - runSpar $ BrigAccess.setStatus member Suspended + runSpar $ BrigAPIAccess.setStatus member Suspended [user] <- listUsers tok (Just (filterBy "userName" (fromHandle handle))) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do @@ -502,19 +502,19 @@ specSuspend = do -- Once we get rid of the `scim` table and make scim serve brig records directly, this is -- not an issue anymore. lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUserBlah) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user False lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Suspended) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do void . activeInactiveAndBack $ \tok uid user active -> @@ -553,10 +553,10 @@ specSuspend = do (tok, _) <- registerIdPAndScimToken scimStoredUserBlah <- createUser tok user let uid = Scim.id . Scim.thing $ scimStoredUserBlah - runSpar $ BrigAccess.setStatus uid Suspended - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) + runSpar $ BrigAPIAccess.setStatus uid Suspended + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Suspended) void $ patchUser tok uid $ PatchOp.PatchOp [deleteAttrib "active"] - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) ---------------------------------------------------------------------------- -- User creation @@ -743,10 +743,10 @@ testCreateUserNoIdP = do -- get account from brig, status should be PendingInvitation do - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (pure ()) (error "pending user in brig is visible, even though it should not be") brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser liftIO $ brigUser.userStatus `shouldBe` PendingInvitation @@ -790,7 +790,7 @@ testCreateUserNoIdP = do -- user should now be active do brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure liftIO $ brigUser.userStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -873,7 +873,7 @@ testCreateUserWithSamlIdP = do . expect2xx ) brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser - accStatus <- aFewTimes (runSpar $ BrigAccess.getStatus (userId brigUser)) (== Active) + accStatus <- aFewTimes (runSpar $ BrigAPIAccess.getStatus (userId brigUser)) (== Active) liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -1321,9 +1321,9 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do -- auto-provision user via saml memberWithSSO <- do uid <- loginSsoUserFirstTime idp privCreds - Just usr <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + Just usr <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid handle <- nextHandle - runSpar $ BrigAccess.setHandle uid handle + runSpar $ BrigAPIAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO idpIssuer = idp ^. SAML.idpMetadata . SAML.edIssuer @@ -1335,7 +1335,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ userManagedBy memberWithSSO `shouldBe` ManagedByWire users <- listUsers tok (Just (filterBy "externalId" externalId)) liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] - Just brigUser' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdWithSSO + Just brigUser' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where veidToText :: (MonadError String m) => ValidScimId -> m Text @@ -1357,7 +1357,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do users' <- listUsers tok (Just (filterBy "externalId" emailInvited)) liftIO $ (scimUserId <$> users') `shouldContain` [memberIdInvited] - Just brigUserInvited' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId :: TestSpar () @@ -1370,7 +1370,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -1390,8 +1390,8 @@ testFindNonProvisionedUserNoIdP findBy = do email <- randomEmail uid <- userId <$> call (inviteAndRegisterUser (env ^. teBrig) owner teamid email) handle <- nextHandle - runSpar $ BrigAccess.setHandle uid handle - Just brigUser <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + runSpar $ BrigAPIAccess.setHandle uid handle + Just brigUser <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid do -- inspect brig user @@ -1405,7 +1405,7 @@ testFindNonProvisionedUserNoIdP findBy = do do liftIO $ users `shouldBe` [uid] - Just brigUser' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + Just brigUser' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim liftIO $ brigUser' `shouldBe` scimifyBrigUserHack brigUser email @@ -1420,7 +1420,7 @@ testListNoDeletedUsers = do -- Delete the user _ <- deleteUser tok userid -- Make sure it is deleted in brig before pulling via SCIM (which would recreate it!) - Nothing <- aFewTimes (runSpar (BrigAccess.getAccount Intra.WithPendingInvitations userid)) isNothing + Nothing <- aFewTimes (runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations userid)) isNothing -- Get all users users <- listUsers tok (Just (filterForStoredUser storedUser)) -- Check that the user is absent @@ -1492,7 +1492,7 @@ testGetUser = do shouldBeManagedBy :: (HasCallStack) => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do - managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid) + managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag -- | This is (roughly) the behavior on develop as well as on the branch where this test was @@ -1551,12 +1551,12 @@ testGetUserWithNoHandle = do uid <- loginSsoUserFirstTime idp privcreds tok <- registerScimToken tid (Just (idp ^. SAML.idpId)) - mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid) + mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) liftIO $ mhandle `shouldSatisfy` isNothing storedUser <- getUser tok uid liftIO $ (Scim.User.displayName . Scim.value . Scim.thing) storedUser `shouldSatisfy` isJust - mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid)) isJust + mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid)) isJust liftIO $ mhandle' `shouldSatisfy` isJust liftIO $ (fromHandle <$> mhandle') `shouldBe` (Just . Scim.User.userName . Scim.value . Scim.thing $ storedUser) @@ -1945,7 +1945,7 @@ testBrigSideIsUpdated = do validScimUser <- runSpar . runScimErrorUnsafe $ validateScimUser' "testBrigSideIsUpdated" (Just idp) 999999 user' - brigUser <- maybe (error "no brig user") pure =<< runSpar (BrigAccess.getAccount Intra.WithPendingInvitations userid) + brigUser <- maybe (error "no brig user") pure =<< runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations userid) let scimUserWithDefLocale = validScimUser {Spar.Types.locale = Spar.Types.locale validScimUser <|> Just (Locale (Language EN) Nothing)} brigUser `userShouldMatch` scimUserWithDefLocale @@ -2236,7 +2236,7 @@ specDeleteUser = do storedUser <- createUser tok user let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do - mUsr <- runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations uid + mUsr <- runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid let cond usr = Intra.newVeidFromBrigUser usr (Just (idp ^. SAML.idpMetadata . SAML.edIssuer)) good bad = runValidScimIdEither pure (const $ err bad) err bad = error $ "brig user without UserRef: " <> show (bad, user) @@ -2247,7 +2247,7 @@ specDeleteUser = do deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode brigUser :: Maybe User <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations uid) isNothing + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) isNothing samlUser :: Maybe UserId <- aFewTimes (getUserIdViaRef' uref) isNothing scimUser <- diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index ce8f9cfb0f5..b172bac74b1 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -182,10 +182,9 @@ import qualified Spar.App as IdpConfigStire import qualified Spar.App as Spar import Spar.CanonicalInterpreter import Spar.Error (SparError) -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Run -import Spar.Sem.BrigAccess (getAccount) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified System.Logger.Extended as Log @@ -217,6 +216,7 @@ import qualified Wire.API.User as User import Wire.API.User.Auth hiding (Cookie) import Wire.API.User.IdentityProvider import Wire.API.User.Scim +import Wire.BrigAPIAccess (getAccount) import qualified Wire.IdPConfigStore as IdPConfigStore -- | Call 'mkEnv' with options from config files. diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 02fb3bae4e0..9f8d1b1c023 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -42,7 +42,7 @@ import qualified Network.Wai.Utilities as Error import Polysemy.Error (runError) import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Types (IdPId, idpId) -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Test.QuickCheck (arbitrary, generate) diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs index 002a915528b..771ecf8968f 100644 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test/Test/Spar/Intra/BrigSpec.hs @@ -25,7 +25,7 @@ import Data.These import Data.These.Combinators import Imports import SAML2.WebSSO as SAML -import Spar.Intra.BrigApp +import Spar.Intra.RpcApp import Test.Hspec import Test.QuickCheck import URI.ByteString (URI, laxURIParserOptions, parseURI) diff --git a/services/spar/test/Test/Spar/Saml/IdPSpec.hs b/services/spar/test/Test/Spar/Saml/IdPSpec.hs index 31de2e30574..db2a588498f 100644 --- a/services/spar/test/Test/Spar/Saml/IdPSpec.hs +++ b/services/spar/test/Test/Spar/Saml/IdPSpec.hs @@ -1,6 +1,7 @@ module Test.Spar.Saml.IdPSpec where import Arbitrary () +import Data.Default (Default (..)) import Data.Domain import Data.Id (idToText, parseIdFromText) import qualified Data.List.NonEmpty as NonEmptyL @@ -18,8 +19,6 @@ import SAML2.WebSSO import qualified SAML2.WebSSO as SAML import Spar.API (idpCreate, idpCreateV7, idpDelete, idpUpdate) import Spar.Error -import Spar.Sem.BrigAccess -import Spar.Sem.GalleyAccess import Spar.Sem.IdPRawMetadataStore import Spar.Sem.IdPRawMetadataStore.Mem import Spar.Sem.SAMLUserStore @@ -35,8 +34,15 @@ import qualified Text.XML.DSig as DSig import URI.ByteString (parseURI, strictURIParserOptions) import URI.ByteString.QQ (uri) import Wire.API.Routes.Internal.Brig (IdpChangedNotification (..)) +import Wire.API.Team.Feature (FeatureStatus (FeatureStatusEnabled), LockableFeature (..)) +import Wire.API.Team.Member (mkNewTeamMember, ntmNewTeamMember, rolePermissions) +import Wire.API.Team.Role (Role (RoleOwner)) import Wire.API.User (User (..)) import Wire.API.User.IdentityProvider (IdPMetadataInfo (..), WireIdPAPIVersion (..)) +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess import Wire.IdPConfigStore import Wire.IdPConfigStore.Mem import Wire.Sem.Logger.TinyLog (LogRecorder (..), newLogRecorder, recordLogs) @@ -519,41 +525,18 @@ interpretWithLoggingMock mbAccount action = do let (notifs, res) = either (error . show) id a pure (logs, notifs, res) -galleyAccessMock :: Sem (GalleyAccess ': r) a -> Sem r a +galleyAccessMock :: Sem (GalleyAPIAccess ': r) a -> Sem r a galleyAccessMock = interpret $ \case - GetTeamMembers _teamId -> undefined - GetTeamMember _teamId _userId -> undefined - AssertHasPermission _teamId _perm _userId -> pure () - AssertSSOEnabled _teamId -> pure () - IsEmailValidationEnabledTeam _teamId -> undefined - UpdateTeamMember _userId _teamId _role -> undefined - -brigAccessMock :: Maybe User -> Sem (BrigAccess ': r) a -> Sem r ([IdpChangedNotification], a) + Wire.GalleyAPIAccess.GetTeamMember uid _teamId -> pure (Just $ ntmNewTeamMember $ mkNewTeamMember uid (rolePermissions RoleOwner) Nothing) + Wire.GalleyAPIAccess.GetFeatureConfigForTeam _teamId -> pure (def {status = FeatureStatusEnabled}) + _ -> undefined + +brigAccessMock :: Maybe User -> Sem (BrigAPIAccess ': r) a -> Sem r ([IdpChangedNotification], a) brigAccessMock mbAccount = (runState @([IdpChangedNotification]) mempty .) $ reinterpret $ \case - CreateSAML _userRef _userId _teamId _name _managedBy _mHandle _mRichInfo _mLocale _role -> undefined - CreateNoSAML _txt _email _userId _teamId _name _mLocale _role -> undefined - UpdateEmail _userId _email _activation -> undefined - GetAccount _havePendingInvitations _userId -> pure mbAccount - GetByHandle _handle -> undefined - GetByEmail _email -> undefined - SetName _userId _name -> undefined - SetHandle _userId _handle -> undefined - SetManagedBy _userId _managedBy -> undefined - SetSSOId _userId _ssoId -> undefined - SetRichInfo _userId _richInfo -> undefined - SetLocale _userId _mLocale -> undefined - GetRichInfo _userId -> undefined - CheckHandleAvailable _handle -> undefined - DeleteUser _userId -> undefined - EnsureReAuthorised _mUserId _mPassword _mCode _mAction -> undefined - SsoLogin _userId _label -> undefined - GetStatus _userId -> undefined - GetStatusMaybe _userId -> undefined - SetStatus _userId _status -> undefined - GetDefaultUserLocale -> undefined - CheckAdminGetTeamId _userId -> undefined - SendSAMLIdPChangedEmail notif -> modify (notif :) + Wire.BrigAPIAccess.GetAccount _havePendingInvitations _userId -> pure mbAccount + Wire.BrigAPIAccess.SendSAMLIdPChangedEmail notif -> modify (notif :) + _ -> undefined ignoringState :: (Functor f) => (a -> f (c, b)) -> a -> f b ignoringState f = fmap snd . f @@ -561,8 +544,8 @@ ignoringState f = fmap snd . f type Effs = '[ Random, SAMLUserStore, - GalleyAccess, - BrigAccess, + GalleyAPIAccess, + BrigAPIAccess, ScimTokenStore, IdPConfigStore, IdPRawMetadataStore, diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index f28ed144925..5088a8fde7d 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -26,7 +26,6 @@ import Imports import Polysemy import Polysemy.TinyLog import Spar.Scim.User (deleteScimUser) -import Spar.Sem.BrigAccess import Spar.Sem.SAMLUserStore import Spar.Sem.SAMLUserStore.Mem (samlUserStoreToMem) import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore @@ -39,6 +38,7 @@ import Test.QuickCheck import Web.Scim.Schema.Error import Wire.API.User import Wire.API.User.Scim +import Wire.BrigAPIAccess import Wire.IdPConfigStore import Wire.IdPConfigStore.Mem (idPToMem) import Wire.IdPConfigStore.Orphans () @@ -50,32 +50,32 @@ spec = describe "deleteScimUser" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- - interpretWithBrigAccessMock - (mockBrig (withActiveUser acc) AccountDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (withActiveUser acc)) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () it "is idempotent" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- - interpretWithBrigAccessMock - (mockBrig (withActiveUser acc) AccountAlreadyDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (withActiveUser acc)) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () it "works if there never was an account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- - interpretWithBrigAccessMock - (mockBrig (const Nothing) NoUser) + interpretWithBrigAPIAccessMock + (mockBrig (const Nothing)) (runExceptT $ deleteScimUser tokenInfo uid) r `shouldBe` Right () it "returns no error when there was a partially deleted account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- - interpretWithBrigAccessMock - (mockBrig (const Nothing) AccountDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (const Nothing)) (runExceptT $ deleteScimUser tokenInfo uid) r `shouldBe` Right () @@ -83,7 +83,7 @@ deleteUserAndAssertDeletionInSpar :: forall (r :: EffectRow). ( Members '[ Logger (Msg -> Msg), - BrigAccess, + BrigAPIAccess, ScimExternalIdStore.ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore, @@ -105,7 +105,7 @@ deleteUserAndAssertDeletionInSpar acc tokenInfo = do liftIO $ lr `shouldBe` Nothing pure r -type EffsWithoutBrigAccess = +type EffsWithoutBrigAPIAccess = '[ IdPConfigStore, SAMLUserStore, ScimUserTimesStore, @@ -115,13 +115,13 @@ type EffsWithoutBrigAccess = Final IO ] -interpretWithBrigAccessMock :: - ( Sem (BrigAccess ': EffsWithoutBrigAccess) a -> - Sem EffsWithoutBrigAccess a +interpretWithBrigAPIAccessMock :: + ( Sem (BrigAPIAccess ': EffsWithoutBrigAPIAccess) a -> + Sem EffsWithoutBrigAPIAccess a ) -> - Sem (BrigAccess ': EffsWithoutBrigAccess) a -> + Sem (BrigAPIAccess ': EffsWithoutBrigAPIAccess) a -> IO a -interpretWithBrigAccessMock mock = +interpretWithBrigAPIAccessMock mock = runFinal . embedToFinal @IO . discardTinyLogs @@ -138,12 +138,11 @@ mockBrig :: forall (r :: EffectRow) a. (Member (Embed IO) r) => (UserId -> Maybe User) -> - DeleteUserResult -> - Sem (BrigAccess ': r) a -> + Sem (BrigAPIAccess ': r) a -> Sem r a -mockBrig lookup_user delete_response = interpret $ \case +mockBrig lookup_user = interpret $ \case (GetAccount WithPendingInvitations uid) -> pure $ lookup_user uid - (Spar.Sem.BrigAccess.DeleteUser _) -> pure delete_response + (Wire.BrigAPIAccess.DeleteUser _) -> pure () _ -> do liftIO $ expectationFailure $ "Unexpected effect (call to brig)" error "Throw error here to avoid implementation of all cases." From 9e9d469f9d009d98baa4b0bbd23bcbd511363851 Mon Sep 17 00:00:00 2001 From: Valentin Date: Fri, 8 May 2026 12:35:07 +0100 Subject: [PATCH 17/18] feat/nginz: add zone-based topology constraint (#5208) --- changelog.d/5-internal/nginz-zone-topology | 2 ++ charts/nginz/templates/deployment.yaml | 9 +++------ charts/nginz/values.yaml | 13 +++++++++++++ 3 files changed, 18 insertions(+), 6 deletions(-) create mode 100644 changelog.d/5-internal/nginz-zone-topology diff --git a/changelog.d/5-internal/nginz-zone-topology b/changelog.d/5-internal/nginz-zone-topology new file mode 100644 index 00000000000..fb919b535b1 --- /dev/null +++ b/changelog.d/5-internal/nginz-zone-topology @@ -0,0 +1,2 @@ +Add zone-level topologySpreadConstraints to nginz deployment so pods are spread evenly across availability zones, ensuring traffic reaches all AZs when zone-aware routing is in use. +topologySpreadConstraints are now configurable via values.yaml (defaulting to zone + hostname spreading), allowing chart users to customise pod scheduling without patching the chart. diff --git a/charts/nginz/templates/deployment.yaml b/charts/nginz/templates/deployment.yaml index 11c9f739dbd..7a54dbf969d 100644 --- a/charts/nginz/templates/deployment.yaml +++ b/charts/nginz/templates/deployment.yaml @@ -29,13 +29,10 @@ spec: fluentbit.io/parser-nginz: nginz spec: terminationGracePeriodSeconds: {{ .Values.terminationGracePeriodSeconds }} + {{- with .Values.topologySpreadConstraints }} topologySpreadConstraints: - - maxSkew: 1 - topologyKey: "kubernetes.io/hostname" - whenUnsatisfiable: ScheduleAnyway - labelSelector: - matchLabels: - app: nginz + {{- toYaml . | nindent 8 }} + {{- end }} containers: - name: nginz image: "{{ .Values.images.nginz.repository }}:{{ .Values.images.nginz.tag }}" diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 20412031f42..2e4e3272bd8 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -20,6 +20,19 @@ config: wsPort: 8081 useProxyProtocol: true terminationGracePeriodSeconds: 90 +topologySpreadConstraints: + - maxSkew: 1 + topologyKey: "topology.kubernetes.io/zone" + whenUnsatisfiable: ScheduleAnyway + labelSelector: + matchLabels: + app: nginz + - maxSkew: 1 + topologyKey: "kubernetes.io/hostname" + whenUnsatisfiable: ScheduleAnyway + labelSelector: + matchLabels: + app: nginz nginx_conf: dns_resolver: kube-dns cluster_domain: cluster.local From e8c6f9fd9fc3c8f91084c270675921e39bff29e2 Mon Sep 17 00:00:00 2001 From: Zebot Date: Fri, 8 May 2026 12:56:55 +0000 Subject: [PATCH 18/18] Add changelog for Release 2026-05-08 --- CHANGELOG.md | 46 +++++++++++++++++++ ...PB-25136-do-not-count-apps-as-paying-users | 1 - changelog.d/2-features/WPB-21964-delete | 1 - changelog.d/3-bug-fixes/WPB-21359 | 1 - ...PB-25136-do-not-count-apps-as-paying-users | 1 - .../3-bug-fixes/brig-index-invalid-users | 1 - changelog.d/3-bug-fixes/parent-conv-index | 1 - ...ess-effects-from-spar-into-wire-subsystems | 3 -- changelog.d/5-internal/WPB-00000 | 1 - changelog.d/5-internal/WPB-24072 | 1 - changelog.d/5-internal/WPB-25109 | 1 - changelog.d/5-internal/mlsstats | 2 - changelog.d/5-internal/nginz-zone-topology | 2 - 13 files changed, 46 insertions(+), 16 deletions(-) delete mode 100644 changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users delete mode 100644 changelog.d/2-features/WPB-21964-delete delete mode 100644 changelog.d/3-bug-fixes/WPB-21359 delete mode 100644 changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users delete mode 100644 changelog.d/3-bug-fixes/brig-index-invalid-users delete mode 100644 changelog.d/3-bug-fixes/parent-conv-index delete mode 100644 changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems delete mode 100644 changelog.d/5-internal/WPB-00000 delete mode 100644 changelog.d/5-internal/WPB-24072 delete mode 100644 changelog.d/5-internal/WPB-25109 delete mode 100644 changelog.d/5-internal/mlsstats delete mode 100644 changelog.d/5-internal/nginz-zone-topology diff --git a/CHANGELOG.md b/CHANGELOG.md index e681a5bcddf..758a603d3f2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,49 @@ +# [2026-05-08] (Chart Release 5.31.0) + +## API changes + + +* `GET /teams/:tid/size` response body lists `teamSizeRegulars`, `teamSizeApps`. (#5213) + + +## Features + + +* `DELETE /meetings/:domain/:meetingId` for deleting meetings. (#5066) + + +## Bug fixes and other updates + + +* Fix: Inconsistent removal messages across local and federated conversation members (#5210) + +* Do not count apps as paying users. (#5213) + +* brig-index: Continue indexing even when an invalid user is found in the DB (#4839) + +* Postgres: Index the parent_conv column in the conversation table (#5205, #5209, #5205) + + +## Internal changes + + +* Consolidate brig/galley api access effects from spar into wire-subsystems. + + NB: calls to internal galley end-points were *sometimes* propagating unexpected errors (eg. 400) to the client, sometimes they were turned into a fixed 5xx error. we now consistently do the latter, which is more accurate (we don't want this to ever happen). (#5189) + +* Using a random-generated index name to stabilize `testSearchNoExtraResults` (`brig-integration`). (#5198) + +* Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. (#5126) + +* Move meetings feature check from galley service layer into the MeetingsSubsystem interpreter, ensuring the check is enforced consistently within the subsystem. (#5214) + +* Add tools/mlsstats to the Docker images to be built in CI runs. + mlsstats Helm chart now supports pod identity: ServiceAccount with configurable annotations is created and referenced by the CronJob pod, enabling OIDC-based AWS credential injection instead of static keys. AWS_EC2_METADATA_DISABLED is set so the AWS SDK uses web identity tokens on non-EC2 nodes. Secret creation is skipped when no static credentials are provided. (#5200) + +* Add zone-level topologySpreadConstraints to nginz deployment so pods are spread evenly across availability zones, ensuring traffic reaches all AZs when zone-aware routing is in use. + topologySpreadConstraints are now configurable via values.yaml (defaulting to zone + hostname spreading), allowing chart users to customise pod scheduling without patching the chart. (#5208) + + # [2026-04-20] (Chart Release 5.30.0) ## Release notes diff --git a/changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users b/changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users deleted file mode 100644 index 940164d7ee0..00000000000 --- a/changelog.d/1-api-changes/WPB-25136-do-not-count-apps-as-paying-users +++ /dev/null @@ -1 +0,0 @@ -`GET /teams/:tid/size` response body lists `teamSizeRegulars`, `teamSizeApps`. diff --git a/changelog.d/2-features/WPB-21964-delete b/changelog.d/2-features/WPB-21964-delete deleted file mode 100644 index 1504edcc3eb..00000000000 --- a/changelog.d/2-features/WPB-21964-delete +++ /dev/null @@ -1 +0,0 @@ -`DELETE /meetings/:domain/:meetingId` for deleting meetings. diff --git a/changelog.d/3-bug-fixes/WPB-21359 b/changelog.d/3-bug-fixes/WPB-21359 deleted file mode 100644 index 4c0a7892df3..00000000000 --- a/changelog.d/3-bug-fixes/WPB-21359 +++ /dev/null @@ -1 +0,0 @@ -Fix: Inconsistent removal messages across local and federated conversation members diff --git a/changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users b/changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users deleted file mode 100644 index 0783281d1b5..00000000000 --- a/changelog.d/3-bug-fixes/WPB-25136-do-not-count-apps-as-paying-users +++ /dev/null @@ -1 +0,0 @@ -Do not count apps as paying users. diff --git a/changelog.d/3-bug-fixes/brig-index-invalid-users b/changelog.d/3-bug-fixes/brig-index-invalid-users deleted file mode 100644 index 7d165e74582..00000000000 --- a/changelog.d/3-bug-fixes/brig-index-invalid-users +++ /dev/null @@ -1 +0,0 @@ -brig-index: Continue indexing even when an invalid user is found in the DB \ No newline at end of file diff --git a/changelog.d/3-bug-fixes/parent-conv-index b/changelog.d/3-bug-fixes/parent-conv-index deleted file mode 100644 index 6f5eaa0ccf4..00000000000 --- a/changelog.d/3-bug-fixes/parent-conv-index +++ /dev/null @@ -1 +0,0 @@ -Postgres: Index the parent_conv column in the conversation table (#5205, #5209, ##) \ No newline at end of file diff --git a/changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems b/changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems deleted file mode 100644 index 19f25df9a93..00000000000 --- a/changelog.d/5-internal/WPB-0000-consolidate-brig_galley-api-access-effects-from-spar-into-wire-subsystems +++ /dev/null @@ -1,3 +0,0 @@ -Consolidate brig/galley api access effects from spar into wire-subsystems. - -NB: calls to internal galley end-points were *sometimes* propagating unexpected errors (eg. 400) to the client, sometimes they were turned into a fixed 5xx error. we now consistently do the latter, which is more accurate (we don't want this to ever happen). diff --git a/changelog.d/5-internal/WPB-00000 b/changelog.d/5-internal/WPB-00000 deleted file mode 100644 index 86dad9d6fc8..00000000000 --- a/changelog.d/5-internal/WPB-00000 +++ /dev/null @@ -1 +0,0 @@ -Using a random-generated index name to stabilize `testSearchNoExtraResults` (`brig-integration`). diff --git a/changelog.d/5-internal/WPB-24072 b/changelog.d/5-internal/WPB-24072 deleted file mode 100644 index 61a31439bf8..00000000000 --- a/changelog.d/5-internal/WPB-24072 +++ /dev/null @@ -1 +0,0 @@ -Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. diff --git a/changelog.d/5-internal/WPB-25109 b/changelog.d/5-internal/WPB-25109 deleted file mode 100644 index 760cc4d6672..00000000000 --- a/changelog.d/5-internal/WPB-25109 +++ /dev/null @@ -1 +0,0 @@ -Move meetings feature check from galley service layer into the MeetingsSubsystem interpreter, ensuring the check is enforced consistently within the subsystem. \ No newline at end of file diff --git a/changelog.d/5-internal/mlsstats b/changelog.d/5-internal/mlsstats deleted file mode 100644 index 7a806e0ea45..00000000000 --- a/changelog.d/5-internal/mlsstats +++ /dev/null @@ -1,2 +0,0 @@ -Add tools/mlsstats to the Docker images to be built in CI runs. -mlsstats Helm chart now supports pod identity: ServiceAccount with configurable annotations is created and referenced by the CronJob pod, enabling OIDC-based AWS credential injection instead of static keys. AWS_EC2_METADATA_DISABLED is set so the AWS SDK uses web identity tokens on non-EC2 nodes. Secret creation is skipped when no static credentials are provided. diff --git a/changelog.d/5-internal/nginz-zone-topology b/changelog.d/5-internal/nginz-zone-topology deleted file mode 100644 index fb919b535b1..00000000000 --- a/changelog.d/5-internal/nginz-zone-topology +++ /dev/null @@ -1,2 +0,0 @@ -Add zone-level topologySpreadConstraints to nginz deployment so pods are spread evenly across availability zones, ensuring traffic reaches all AZs when zone-aware routing is in use. -topologySpreadConstraints are now configurable via values.yaml (defaulting to zone + hostname spreading), allowing chart users to customise pod scheduling without patching the chart.