From 7cdaf5e11b26b888b08efe53af77623ed9564f47 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 16 Sep 2024 11:17:49 +0200 Subject: [PATCH 1/8] [feat] add two tests for scenarios with MLS + legalhold --- integration/test/Test/LegalHold.hs | 48 ++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index c948bccb649..b2e909704af 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2023 Wire Swiss GmbH @@ -35,6 +37,7 @@ import Data.ProtoLens.Labels () import qualified Data.Set as Set import qualified Data.Text as T import GHC.Stack +import MLS.Util import Network.Wai (Request (pathInfo, requestMethod)) import Notifications import Numeric.Lens (hex) @@ -904,3 +907,48 @@ testLHDisableBeforeApproval = do disableLegalHold tid alice bob defPassword >>= assertStatus 200 getBob'sStatus `shouldMatch` "disabled" + +testMLSThenLegalhold :: (HasCallStack) => App () +testMLSThenLegalhold = do + -- scenario 1: + -- charlie creates an MLS group and then tries to put himself under legalhold + -- as soon as he puts himself under legalhold, he is removed from the MLS conversation + (charlie, tid, []) <- createTeam OwnDomain 1 + [charlie1] <- traverse (createMLSClient def) [charlie] + void $ createNewGroup charlie1 + void $ createAddCommit charlie1 [charlie] >>= sendAndConsumeCommitBundle + + legalholdWhitelistTeam tid charlie >>= assertStatus 200 + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid charlie (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + withWebSocket charlie \ws -> do + requestLegalHoldDevice tid charlie charlie >>= assertSuccess + approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword >>= assertSuccess + -- if charlie approves of the legalhold device, he is thrown out of all MLS conversations + notif <- awaitMatch isConvLeaveNotif ws + printJSON notif + profile <- getUser charlie charlie >>= getJSON 200 + pStatus <- profile %. "legalhold_status" & asString + pStatus `shouldMatch` "enabled" + +testLegalholdThenMLS :: (HasCallStack) => App () +testLegalholdThenMLS = do + -- scenario 2: + -- charlie first is put under legalhold and after that wants to join an MLS conversation + -- charlie should not be allows to do so + (alice, tid, [charlie]) <- createTeam OwnDomain 2 + [alice1, _charlie1] <- traverse (createMLSClient def) [alice, charlie] + void $ createNewGroup alice1 + void $ createAddCommit alice1 [alice] >>= sendAndConsumeCommitBundle + legalholdWhitelistTeam tid alice >>= assertStatus 200 + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + requestLegalHoldDevice tid alice charlie >>= assertSuccess + approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword >>= assertSuccess + profile <- getUser alice charlie >>= getJSON 200 + pStatus <- profile %. "legalhold_status" & asString + pStatus `shouldMatch` "enabled" + + createAddCommit alice1 [charlie] >>= \mp -> + postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \resp -> + resp.status `shouldMatchRange` (400, 499) From 60018c8530843167059f6f8c4a038835352ea0d2 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 16 Sep 2024 11:50:00 +0200 Subject: [PATCH 2/8] [chore] add TODO --- services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index 6b466db99ff..4fe3f43d279 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -162,6 +162,8 @@ processInternalCommit senderIdentity con lConvOrSub ciphersuite ciphersuiteUpdat Right clientInfo -> do let allClients = Set.map ciId clientInfo let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) + -- TODO(mangoiv): check if any legalhold clients exist and abort if any + -- We check the following condition: -- allMLSClients ⊆ clients ⊆ allClients -- i.e. From 11b2e19e90a264b3f47fbbedd194d9f867789719 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 16 Sep 2024 17:28:11 +0200 Subject: [PATCH 3/8] [feat] don't allow claiming keypackages of users under legalhold - new client error which returns 409 if someone (client or federating backend) tries to claim a keypackage of a user under legalhold (including pending) - add Fail effect to Brig and interpret to IO Error (server error 500) --- integration/test/Test/LegalHold.hs | 21 ++++-------- .../src/Wire/GalleyAPIAccess.hs | 3 ++ .../src/Wire/GalleyAPIAccess/Rpc.hs | 20 +++++++++++ services/brig/src/Brig/API/Error.hs | 1 + services/brig/src/Brig/API/Federation.hs | 4 ++- services/brig/src/Brig/API/MLS/KeyPackages.hs | 33 +++++++++++++++++++ services/brig/src/Brig/API/Public.hs | 2 ++ services/brig/src/Brig/API/Types.hs | 3 ++ services/brig/src/Brig/App.hs | 4 +++ .../brig/src/Brig/CanonicalInterpreter.hs | 3 ++ services/galley/galley.cabal | 1 + 11 files changed, 80 insertions(+), 15 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index b2e909704af..2d25e5ac832 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wwarn #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2023 Wire Swiss GmbH @@ -908,11 +906,11 @@ testLHDisableBeforeApproval = do >>= assertStatus 200 getBob'sStatus `shouldMatch` "disabled" +-- WPB-10783 testMLSThenLegalhold :: (HasCallStack) => App () testMLSThenLegalhold = do -- scenario 1: - -- charlie creates an MLS group and then tries to put himself under legalhold - -- as soon as he puts himself under legalhold, he is removed from the MLS conversation + -- if charlie is in any MLS conversation, he cannot approve to be put under legalhold (charlie, tid, []) <- createTeam OwnDomain 1 [charlie1] <- traverse (createMLSClient def) [charlie] void $ createNewGroup charlie1 @@ -921,21 +919,16 @@ testMLSThenLegalhold = do legalholdWhitelistTeam tid charlie >>= assertStatus 200 withMockServer def lhMockApp \lhDomAndPort _chan -> do postLegalHoldSettings tid charlie (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 - withWebSocket charlie \ws -> do - requestLegalHoldDevice tid charlie charlie >>= assertSuccess - approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword >>= assertSuccess - -- if charlie approves of the legalhold device, he is thrown out of all MLS conversations - notif <- awaitMatch isConvLeaveNotif ws - printJSON notif - profile <- getUser charlie charlie >>= getJSON 200 - pStatus <- profile %. "legalhold_status" & asString - pStatus `shouldMatch` "enabled" + requestLegalHoldDevice tid charlie charlie >>= assertSuccess + approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword + `bindResponse` assertLabel 409 "mls-legalhold-not-allowed" +-- WPB-10772 testLegalholdThenMLS :: (HasCallStack) => App () testLegalholdThenMLS = do -- scenario 2: -- charlie first is put under legalhold and after that wants to join an MLS conversation - -- charlie should not be allows to do so + -- charlie should not be allowed to do so (alice, tid, [charlie]) <- createTeam OwnDomain 2 [alice1, _charlie1] <- traverse (createMLSClient def) [alice, charlie] void $ createNewGroup alice1 diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index e129fb5bc2c..cbb4f769837 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -31,6 +31,7 @@ import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team import Wire.API.Team.Conversation qualified as Conv import Wire.API.Team.Feature +import Wire.API.Team.LegalHold import Wire.API.Team.Member qualified as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility @@ -94,6 +95,8 @@ data GalleyAPIAccess m a where GetTeamLegalHoldStatus :: TeamId -> GalleyAPIAccess m (LockableFeature LegalholdConfig) + GetUserLegalholdStatus :: + Local UserId -> TeamId -> GalleyAPIAccess m UserLegalHoldStatusResponse GetTeamSearchVisibility :: TeamId -> GalleyAPIAccess m TeamSearchVisibility diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index aa9dcb4dc9e..dcafabedce8 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -46,6 +46,7 @@ import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Conversation qualified as Conv import Wire.API.Team.Feature +import Wire.API.Team.LegalHold import Wire.API.Team.Member as Member import Wire.API.Team.Role import Wire.API.Team.SearchVisibility @@ -80,6 +81,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamName id' -> getTeamName id' GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' GetTeamSearchVisibility id' -> getTeamSearchVisibility id' + GetUserLegalholdStatus id' tid -> getUserLegalholdStatus id' tid ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' GetAllTeamFeaturesForUser m_id' -> getAllTeamFeaturesForUser m_id' @@ -89,6 +91,24 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = UnblockConversation lusr mconn qcnv -> unblockConversation v lusr mconn qcnv GetEJPDConvInfo uid -> getEJPDConvInfo uid +getUserLegalholdStatus :: + ( Member TinyLog r, + Member (Error ParseException) r, + Member Rpc r + ) => + Local UserId -> + TeamId -> + Sem (Input Endpoint : r) UserLegalHoldStatusResponse +getUserLegalholdStatus luid tid = do + debug $ + remote "galley" + . msg (val "get legalhold user status") + decodeBodyOrThrow "galley" =<< galleyRequest do + method GET + . paths ["teams", toByteString' tid, "legalhold", toByteString' (tUnqualified luid)] + . zUser (tUnqualified luid) + . expect2xx + galleyRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) galleyRequest req = do ep <- input diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index 98618e5dbd0..d824e7384e8 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -133,6 +133,7 @@ clientError (ClientDataError e) = clientDataError e clientError (ClientUserNotFound _) = StdError (errorToWai @'E.InvalidUser) clientError ClientLegalHoldCannotBeRemoved = StdError can'tDeleteLegalHoldClient clientError ClientLegalHoldCannotBeAdded = StdError can'tAddLegalHoldClient +clientError ClientLegalHoldIncompatible = StdError $ Wai.mkError status409 "mls-legalhold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations" clientError (ClientFederationError e) = fedError e clientError ClientCapabilitiesCannotBeRemoved = StdError clientCapabilitiesCannotBeRemoved clientError ClientMissingLegalholdConsentOldClients = StdError (errorToWai @'E.MissingLegalholdConsentOldClients) diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 58af99451bf..370761fb73f 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -52,6 +52,7 @@ import Gundeck.Types.Push qualified as Push import Imports hiding ((\\)) import Network.Wai.Utilities.Error ((!>>)) import Polysemy +import Polysemy.Fail (Fail) import Servant (ServerT) import Servant.API import Wire.API.Connection @@ -87,6 +88,7 @@ federationSitemap :: Member NotificationSubsystem r, Member UserSubsystem r, Member UserStore r, + Member Fail r, Member DeleteQueue r ) => ServerT FederationAPI (Handler r) @@ -193,7 +195,7 @@ claimMultiPrekeyBundle :: Handler r UserClientPrekeyMap claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc !>> clientError -fedClaimKeyPackages :: Domain -> ClaimKeyPackageRequest -> Handler r (Maybe KeyPackageBundle) +fedClaimKeyPackages :: (Member Fail r, Member GalleyAPIAccess r, Member UserStore r) => Domain -> ClaimKeyPackageRequest -> Handler r (Maybe KeyPackageBundle) fedClaimKeyPackages domain ckpr = isMLSEnabled >>= \case True -> do diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index d27fc78db78..33dcbcc90a1 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -40,9 +40,12 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.CommaSeparatedList import Data.Id +import Data.LegalHold import Data.Qualified import Data.Set qualified as Set import Imports +import Polysemy (Member) +import Polysemy.Fail (Fail) import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.MLS.CipherSuite @@ -51,6 +54,9 @@ import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation import Wire.API.Team.LegalHold import Wire.API.User.Client +import Wire.GalleyAPIAccess (GalleyAPIAccess, getUserLegalholdStatus) +import Wire.StoredUser +import Wire.UserStore (UserStore, getUsers) uploadKeyPackages :: Local UserId -> ClientId -> KeyPackageUpload -> Handler r () uploadKeyPackages lusr cid kps = do @@ -60,6 +66,7 @@ uploadKeyPackages lusr cid kps = do lift . wrapClient $ Data.insertKeyPackages (tUnqualified lusr) cid kps' claimKeyPackages :: + (Member GalleyAPIAccess r, Member UserStore r, Member Fail r) => Local UserId -> Maybe ClientId -> Qualified UserId -> @@ -67,6 +74,7 @@ claimKeyPackages :: Handler r KeyPackageBundle claimKeyPackages lusr mClient target mSuite = do assertMLSEnabled + suite <- getCipherSuite mSuite foldQualified lusr @@ -75,12 +83,22 @@ claimKeyPackages lusr mClient target mSuite = do target claimLocalKeyPackages :: + forall r. + (Member GalleyAPIAccess r, Member UserStore r, Member Fail r) => Qualified UserId -> Maybe ClientId -> CipherSuiteTag -> Local UserId -> ExceptT ClientError (AppT r) KeyPackageBundle claimLocalKeyPackages qusr skipOwn suite target = do + -- while we do not support federation + MLS together with legalhold, to make sure that + -- the remote backend is complicit with our legalhold policies, we disallow anyone + -- fetching key packages for users under legalhold + -- + -- This way we prevent both locally and on the remote to add a legalholded user to an MLS + -- conversation + assertUserNotLegalholded + -- skip own client when the target is the requesting user itself let own = guard (qusr == tUntagged target) *> skipOwn clients <- map clientId <$> wrapClientE (Data.lookupClients (tUnqualified target)) @@ -103,6 +121,21 @@ claimLocalKeyPackages qusr skipOwn suite target = do uncurry (KeyPackageBundleEntry (tUntagged target) c) <$> wrapClientM (Data.claimKeyPackage target c suite) + assertUserNotLegalholded :: ExceptT ClientError (AppT r) () + assertUserNotLegalholded = do + -- this is okay because there can only be one StoredUser per UserId + [su] <- lift $ liftSem $ getUsers [tUnqualified target] + for_ su.teamId \tid -> do + resp <- lift $ liftSem $ getUserLegalholdStatus target tid + -- if an admin tries to put a user under legalhold + -- the user has to first reject to be put under legalhold + -- before they can join conversations again + case resp.ulhsrStatus of + UserLegalHoldPending -> throwE ClientLegalHoldIncompatible + UserLegalHoldEnabled -> throwE ClientLegalHoldIncompatible + UserLegalHoldDisabled -> pure () + UserLegalHoldNoConsent -> pure () + claimRemoteKeyPackages :: Local UserId -> CipherSuite -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 554eceb5b85..3a17461f4ba 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -92,6 +92,7 @@ import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.Fail (Fail) import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) @@ -267,6 +268,7 @@ servantSitemap :: Member (ConnectionStore InternalPaging) r, Member (Embed HttpClientIO) r, Member (Embed IO) r, + Member Fail r, Member FederationConfigStore r, Member (Input (Local ())) r, Member AuthenticationSubsystem r, diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 076b844e1fc..8eac26e9861 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -176,6 +176,9 @@ data ClientError | ClientUserNotFound !UserId | ClientLegalHoldCannotBeRemoved | ClientLegalHoldCannotBeAdded + | -- | this error is thrown if legalhold if incompatible with different features + -- for now, this is the case for MLS and federation + ClientLegalHoldIncompatible | ClientFederationError FederationError | ClientCapabilitiesCannotBeRemoved | ClientMissingLegalholdConsentOldClients diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 882204e28d7..33cd95d4c06 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -137,6 +137,7 @@ import OpenSSL.EVP.Digest (Digest, getDigestByName) import OpenSSL.Session (SSLOption (..)) import OpenSSL.Session qualified as SSL import Polysemy +import Polysemy.Fail import Polysemy.Final import Polysemy.Input (Input, input) import Prometheus @@ -482,6 +483,9 @@ instance MonadMonitor (AppT r) where instance MonadThrow (AppT r) where throwM = liftIO . throwM +instance (Member Fail r) => MonadFail (AppT r) where + fail = AppT . fail + instance (Member (Final IO) r) => MonadThrow (Sem r) where throwM = embedFinal . throwM @IO diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 88cbc80b02a..22d982a3f6e 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -27,6 +27,7 @@ import Polysemy.Async import Polysemy.Conc import Polysemy.Embed (runEmbedded) import Polysemy.Error (Error, errorToIOFinal, mapError, runError) +import Polysemy.Fail import Polysemy.Input (Input, runInputConst, runInputSem) import Polysemy.TinyLog (TinyLog) import Wire.API.Allowlists (AllowlistEmailDomains) @@ -141,6 +142,7 @@ type BrigCanonicalEffects = Error SomeException, TinyLog, Embed HttpClientIO, + Fail, Embed IO, Race, Async, @@ -174,6 +176,7 @@ runBrigToIO e (AppT ma) = do . asyncToIOFinal . interpretRace . embedToFinal + . failToEmbed @IO -- if a fallible pattern fails, we throw a hard IO error . runEmbedded (runHttpClientIO e) . loggerToTinyLogReqId (e ^. App.requestId) (e ^. applog) . runError @SomeException diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 790607e9bf6..f8b8d8c11df 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -25,6 +25,7 @@ common common-all default-extensions: AllowAmbiguousTypes BangPatterns + BlockArguments ConstraintKinds DataKinds DefaultSignatures From f841f73cf95f9f062783a4e45f41ab39ae71bf70 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 17 Sep 2024 10:38:24 +0200 Subject: [PATCH 4/8] [fix] fix test scenario and error message --- integration/test/Test/LegalHold.hs | 7 +++---- services/brig/src/Brig/API/Error.hs | 2 +- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 2d25e5ac832..0cbcde92e4c 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -932,7 +932,6 @@ testLegalholdThenMLS = do (alice, tid, [charlie]) <- createTeam OwnDomain 2 [alice1, _charlie1] <- traverse (createMLSClient def) [alice, charlie] void $ createNewGroup alice1 - void $ createAddCommit alice1 [alice] >>= sendAndConsumeCommitBundle legalholdWhitelistTeam tid alice >>= assertStatus 200 withMockServer def lhMockApp \lhDomAndPort _chan -> do postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 @@ -942,6 +941,6 @@ testLegalholdThenMLS = do pStatus <- profile %. "legalhold_status" & asString pStatus `shouldMatch` "enabled" - createAddCommit alice1 [charlie] >>= \mp -> - postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \resp -> - resp.status `shouldMatchRange` (400, 499) + mls <- getMLSState + claimKeyPackages mls.ciphersuite alice1 charlie + >>= assertLabel 409 "mls-legal-hold-not-allowed" diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index d824e7384e8..9210cd77564 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -133,7 +133,7 @@ clientError (ClientDataError e) = clientDataError e clientError (ClientUserNotFound _) = StdError (errorToWai @'E.InvalidUser) clientError ClientLegalHoldCannotBeRemoved = StdError can'tDeleteLegalHoldClient clientError ClientLegalHoldCannotBeAdded = StdError can'tAddLegalHoldClient -clientError ClientLegalHoldIncompatible = StdError $ Wai.mkError status409 "mls-legalhold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations" +clientError ClientLegalHoldIncompatible = StdError $ Wai.mkError status409 "mls-legal-hold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations" clientError (ClientFederationError e) = fedError e clientError ClientCapabilitiesCannotBeRemoved = StdError clientCapabilitiesCannotBeRemoved clientError ClientMissingLegalholdConsentOldClients = StdError (errorToWai @'E.MissingLegalholdConsentOldClients) From ef1b0da9a89a411e0cceadee1ad17abf9e2427ed Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 17 Sep 2024 14:15:10 +0200 Subject: [PATCH 5/8] [feat] cater for the scenario when a user doesn't claim keypackages - if a user doens't claim keypackages (because they create the group by themselves) the local backend checks whether that user is legalholded and rejects the commit in that case - also adds some utilities (e.g. pattern synonyms fo Local and Remote) and propagates the Fail constraint --- integration/test/Test/LegalHold.hs | 65 ++++++++++++++-- libs/types-common/src/Data/Qualified.hs | 12 +++ .../src/Wire/API/Federation/API.hs | 3 +- libs/wire-api/src/Wire/API/Error.hs | 5 ++ libs/wire-api/src/Wire/API/Error/Galley.hs | 5 ++ .../src/Wire/API/Routes/Public/Galley/MLS.hs | 57 +++++++------- services/galley/galley.cabal | 1 + services/galley/src/Galley/API/Federation.hs | 23 +++--- services/galley/src/Galley/API/LegalHold.hs | 41 +--------- .../galley/src/Galley/API/LegalHold/Get.hs | 78 +++++++++++++++++++ services/galley/src/Galley/API/MLS/Message.hs | 35 ++++++++- services/galley/src/Galley/App.hs | 3 + .../galley/src/Galley/Effects/TeamStore.hs | 2 + 13 files changed, 243 insertions(+), 87 deletions(-) create mode 100644 services/galley/src/Galley/API/LegalHold/Get.hs diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 0cbcde92e4c..8500eda3ac3 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -906,7 +906,9 @@ testLHDisableBeforeApproval = do >>= assertStatus 200 getBob'sStatus `shouldMatch` "disabled" +-- --------- -- WPB-10783 +-- --------- testMLSThenLegalhold :: (HasCallStack) => App () testMLSThenLegalhold = do -- scenario 1: @@ -923,15 +925,19 @@ testMLSThenLegalhold = do approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword `bindResponse` assertLabel 409 "mls-legalhold-not-allowed" +-- --------- -- WPB-10772 -testLegalholdThenMLS :: (HasCallStack) => App () -testLegalholdThenMLS = do - -- scenario 2: - -- charlie first is put under legalhold and after that wants to join an MLS conversation - -- charlie should not be allowed to do so +-- --------- + +-- | scenario 2.1: +-- charlie first is put under legalhold and after that wants to join an MLS conversation +-- claiming a keypackage of charlie to add them to a conversation should not be possible +testLegalholdThenMLSThirdParty :: (HasCallStack) => App () +testLegalholdThenMLSThirdParty = do (alice, tid, [charlie]) <- createTeam OwnDomain 2 - [alice1, _charlie1] <- traverse (createMLSClient def) [alice, charlie] - void $ createNewGroup alice1 + [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie] + _ <- uploadNewKeyPackage charlie1 + _ <- createNewGroup alice1 legalholdWhitelistTeam tid alice >>= assertStatus 200 withMockServer def lhMockApp \lhDomAndPort _chan -> do postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 @@ -943,4 +949,47 @@ testLegalholdThenMLS = do mls <- getMLSState claimKeyPackages mls.ciphersuite alice1 charlie - >>= assertLabel 409 "mls-legal-hold-not-allowed" + `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed" + +-- | scenario 2.2: +-- charlie is put under legalhold but creates an MLS Group himself +-- since he doesn't need to claim his own keypackage to do so, this would succeed +-- we need to check upon group creation if the user is under legalhold and reject +-- the operation if they are +testLegalholdThenMLSSelf :: (HasCallStack) => App () +testLegalholdThenMLSSelf = do + (alice, tid, [charlie]) <- createTeam OwnDomain 2 + [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie] + _ <- uploadNewKeyPackage alice1 + legalholdWhitelistTeam tid alice >>= assertStatus 200 + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + requestLegalHoldDevice tid alice charlie >>= assertSuccess + approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword >>= assertSuccess + profile <- getUser alice charlie >>= getJSON 200 + pStatus <- profile %. "legalhold_status" & asString + pStatus `shouldMatch` "enabled" + + -- charlie tries to create a group and should fail when POSTing the add commit + _ <- createNewGroup charlie1 + + void + -- we try to add alice since adding charlie himself would trigger 2.1 + -- since he'd try to claim his own keypackages + $ createAddCommit charlie1 [alice] + >>= \mp -> + postMLSCommitBundle mp.sender (mkBundle mp) + `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed" + + -- (unsurprisingly) this same thing should also work in the one2one case + + respJson <- getMLSOne2OneConversation alice charlie >>= getJSON 200 + resetGroup alice1 (respJson %. "conversation") + + void + -- we try to add alice since adding charlie himself would trigger 2.1 + -- since he'd try to claim his own keypackages + $ createAddCommit charlie1 [alice] + >>= \mp -> + postMLSCommitBundle mp.sender (mkBundle mp) + `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed" diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 8b06c4ea58f..a126464aca2 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -31,6 +31,8 @@ module Data.Qualified tSplit, qTagUnsafe, Remote, + pattern Remote, + pattern Local, toRemoteUnsafe, Local, toLocalUnsafe, @@ -127,6 +129,16 @@ foldQualified loc f g q | otherwise = g (qTagUnsafe q) +pattern Local :: forall a x. forall. Local a -> (Local x, Qualified a) +pattern Local loc <- ((\(loc, q) -> (tDomain loc == qDomain q, qUnqualified q <$ loc)) -> (True, loc)) + +pattern Remote :: forall a x. forall. Remote a -> (Local x, Qualified a) +pattern Remote loc <- ((\(loc, q) -> (tDomain loc == qDomain q, qTagUnsafe q)) -> (False, loc)) + +{-# COMPLETE Local, Remote #-} + +-- pattern Remote :: Remote a -> (Local x, Qualified a) + -- Partition a collection of qualified values into locals and remotes. -- -- Note that the local values are returned as unqualified values, as a (probably diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 1c45da47edf..ba46921b04c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -29,7 +29,7 @@ module Wire.API.Federation.API fedQueueClient, sendBundle, fedClientIn, - module Wire.API.MakesFederatedCall, + module X, -- * Re-exports Component (..), @@ -59,6 +59,7 @@ import Wire.API.Federation.Endpoint import Wire.API.Federation.HasNotificationEndpoint import Wire.API.Federation.Version import Wire.API.MakesFederatedCall +import Wire.API.MakesFederatedCall as X hiding (Location (..)) import Wire.API.Routes.Named -- Note: this type family being injective means that in most cases there is no need diff --git a/libs/wire-api/src/Wire/API/Error.hs b/libs/wire-api/src/Wire/API/Error.hs index f37711ac06f..a1899f9f6ca 100644 --- a/libs/wire-api/src/Wire/API/Error.hs +++ b/libs/wire-api/src/Wire/API/Error.hs @@ -41,11 +41,13 @@ module Wire.API.Error throwS, noteS, mapErrorS, + runErrorS, mapToRuntimeError, mapToDynamicError, ) where +import Control.Error (hush) import Control.Lens (at, (%~), (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson qualified as A @@ -272,6 +274,9 @@ throwS = throw (Tagged @e ()) noteS :: forall e r a. (Member (ErrorS e) r) => Maybe a -> Sem r a noteS = note (Tagged @e ()) +runErrorS :: forall e r a. Sem (ErrorS e : r) a -> Sem r (Maybe a) +runErrorS = fmap hush . runError @(Tagged e ()) + mapErrorS :: forall e e' r a. (Member (ErrorS e') r) => diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index 22ad24e1c2d..a7bd372b9f1 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -105,6 +105,9 @@ data GalleyError | MLSSubConvClientNotInParent | MLSMigrationCriteriaNotSatisfied | MLSFederatedOne2OneNotSupported + | -- | MLS and federation are incompatible with legalhold - this error is thrown if a user + -- tries to create an MLS group while being under legalhold + MLSLegalholdIncompatible | -- NoBindingTeamMembers | NoBindingTeam @@ -256,6 +259,8 @@ type instance MapError 'MLSMigrationCriteriaNotSatisfied = 'StaticError 400 "mls type instance MapError 'MLSFederatedOne2OneNotSupported = 'StaticError 400 "mls-federated-one2one-not-supported" "Federated One2One MLS conversations are only supported in API version >= 6" +type instance MapError MLSLegalholdIncompatible = 'StaticError 409 "mls-legal-hold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations" + type instance MapError 'NoBindingTeamMembers = 'StaticError 403 "non-binding-team-members" "Both users must be members of the same binding team" type instance MapError 'NoBindingTeam = 'StaticError 403 "no-binding-team" "Operation allowed only on binding teams" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index ccace964c21..347bc01158d 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -72,33 +72,34 @@ type MLSMessagingAPI = :<|> Named "mls-commit-bundle" ( Summary "Post a MLS CommitBundle" - :> From 'V5 - :> MakesFederatedCall 'Galley "on-mls-message-sent" - :> MakesFederatedCall 'Galley "mls-welcome" - :> MakesFederatedCall 'Galley "send-mls-commit-bundle" - :> MakesFederatedCall 'Galley "on-conversation-updated" - :> MakesFederatedCall 'Brig "get-mls-clients" - :> MakesFederatedCall 'Brig "get-users-by-ids" - :> MakesFederatedCall 'Brig "api-version" - :> CanThrow 'ConvAccessDenied - :> CanThrow 'ConvMemberNotFound - :> CanThrow 'ConvNotFound - :> CanThrow 'LegalHoldNotEnabled - :> CanThrow 'MissingLegalholdConsent - :> CanThrow 'MLSClientMismatch - :> CanThrow 'MLSClientSenderUserMismatch - :> CanThrow 'MLSCommitMissingReferences - :> CanThrow 'MLSGroupConversationMismatch - :> CanThrow 'MLSInvalidLeafNodeIndex - :> CanThrow 'MLSNotEnabled - :> CanThrow 'MLSProposalNotFound - :> CanThrow 'MLSProtocolErrorTag - :> CanThrow 'MLSSelfRemovalNotAllowed - :> CanThrow 'MLSStaleMessage - :> CanThrow 'MLSSubConvClientNotInParent - :> CanThrow 'MLSUnsupportedMessage - :> CanThrow 'MLSUnsupportedProposal - :> CanThrow 'MLSWelcomeMismatch + :> From V5 + :> MakesFederatedCall Galley "on-mls-message-sent" + :> MakesFederatedCall Galley "mls-welcome" + :> MakesFederatedCall Galley "send-mls-commit-bundle" + :> MakesFederatedCall Galley "on-conversation-updated" + :> MakesFederatedCall Brig "get-mls-clients" + :> MakesFederatedCall Brig "get-users-by-ids" + :> MakesFederatedCall Brig "api-version" + :> CanThrow ConvAccessDenied + :> CanThrow ConvMemberNotFound + :> CanThrow ConvNotFound + :> CanThrow LegalHoldNotEnabled + :> CanThrow MissingLegalholdConsent + :> CanThrow MLSClientMismatch + :> CanThrow MLSClientSenderUserMismatch + :> CanThrow MLSCommitMissingReferences + :> CanThrow MLSGroupConversationMismatch + :> CanThrow MLSInvalidLeafNodeIndex + :> CanThrow MLSNotEnabled + :> CanThrow MLSProposalNotFound + :> CanThrow MLSProtocolErrorTag + :> CanThrow MLSSelfRemovalNotAllowed + :> CanThrow MLSStaleMessage + :> CanThrow MLSSubConvClientNotInParent + :> CanThrow MLSUnsupportedMessage + :> CanThrow MLSUnsupportedProposal + :> CanThrow MLSWelcomeMismatch + :> CanThrow MLSLegalholdIncompatible :> CanThrow MLSProposalFailure :> CanThrow NonFederatingBackends :> CanThrow UnreachableBackends @@ -107,7 +108,7 @@ type MLSMessagingAPI = :> ZClient :> ZConn :> ReqBody '[MLS] (RawMLS CommitBundle) - :> MultiVerb1 'POST '[JSON] (Respond 201 "Commit accepted and forwarded" MLSMessageSendingStatus) + :> MultiVerb1 POST '[JSON] (Respond 201 "Commit accepted and forwarded" MLSMessageSendingStatus) ) :<|> Named "mls-public-keys" diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f8b8d8c11df..8f65f561258 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -82,6 +82,7 @@ library Galley.API.Internal Galley.API.LegalHold Galley.API.LegalHold.Conflicts + Galley.API.LegalHold.Get Galley.API.LegalHold.Team Galley.API.Mapping Galley.API.Message diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 8ca7057686a..5d23e68b499 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -67,6 +67,7 @@ import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports import Polysemy import Polysemy.Error +import Polysemy.Fail (Fail) import Polysemy.Input import Polysemy.Internal.Kind (Append) import Polysemy.Resource @@ -605,6 +606,7 @@ sendMLSCommitBundle :: Member (Input UTCTime) r, Member LegalHoldStore r, Member MemberStore r, + Member Fail r, Member Resource r, Member TeamStore r, Member P.TinyLog r, @@ -626,15 +628,18 @@ sendMLSCommitBundle remoteDomain msr = handleMLSMessageErrors $ do ibundle <- noteS @'MLSUnsupportedMessage $ mkIncomingBundle bundle (ctype, qConvOrSub) <- getConvFromGroupId ibundle.groupId when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch - MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSCommitBundle - loc - (tUntagged sender) - msr.senderClient - ctype - qConvOrSub - Nothing - ibundle + -- this cannot throw the error since we always pass the sender which is qualified to be remote + Just resp <- + runErrorS @MLSLegalholdIncompatible $ + postMLSCommitBundle + loc + (tUntagged @QRemote sender) + msr.senderClient + ctype + qConvOrSub + Nothing + ibundle + pure $ MLSMessageResponseUpdates $ map lcuUpdate resp sendMLSMessage :: ( Member BackendNotificationQueueAccess r, diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 75eceeec319..cd2227ff4e3 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -34,7 +34,7 @@ import Brig.Types.Connection (UpdateConnectionsInternal (..)) import Brig.Types.Team.LegalHold (legalHoldService, viewLegalHoldService) import Control.Exception (assert) import Control.Lens (view, (^.)) -import Data.ByteString.Conversion (toByteString, toByteString') +import Data.ByteString.Conversion (toByteString) import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) @@ -44,6 +44,7 @@ import Data.Qualified import Data.Range (toRange) import Data.Time.Clock import Galley.API.Error +import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) @@ -290,44 +291,6 @@ removeSettings' tid = LHService.removeLegalHold tid (tUnqualified luid) changeLegalholdStatusAndHandlePolicyConflicts tid luid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) --- | 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 LegalHoldStore r, - Member TeamStore r, - Member P.TinyLog r - ) => - Local UserId -> - TeamId -> - UserId -> - Sem r Public.UserLegalHoldStatusResponse -getUserStatus _lzusr tid uid = do - teamMember <- noteS @'TeamMemberNotFound =<< getTeamMember tid uid - 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) - -- | Change 'UserLegalHoldStatus' from no consent to disabled. FUTUREWORK: -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). diff --git a/services/galley/src/Galley/API/LegalHold/Get.hs b/services/galley/src/Galley/API/LegalHold/Get.hs new file mode 100644 index 00000000000..3607c040060 --- /dev/null +++ b/services/galley/src/Galley/API/LegalHold/Get.hs @@ -0,0 +1,78 @@ +-- 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.API.Error +import Galley.Effects +import Galley.Effects.LegalHoldStore qualified as LegalHoldData +import Galley.Effects.TeamStore +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 + +-- | 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 LegalHoldStore r, + Member TeamStore r, + Member P.TinyLog r + ) => + Local UserId -> + TeamId -> + UserId -> + Sem r Public.UserLegalHoldStatusResponse +getUserStatus _lzusr tid uid = do + teamMember <- noteS @'TeamMemberNotFound =<< getTeamMember tid uid + 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/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index b5eef0766c4..8076a288bc0 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -29,16 +29,18 @@ module Galley.API.MLS.Message ) where -import Control.Comonad import Data.Domain import Data.Id import Data.Json.Util +import Data.LegalHold import Data.Qualified import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Text.Lazy qualified as LT import Data.Tuple.Extra import Galley.API.Action import Galley.API.Error +import Galley.API.LegalHold.Get (getUserStatus) import Galley.API.MLS.Commit.Core (getCommitData) import Galley.API.MLS.Commit.ExternalCommit import Galley.API.MLS.Commit.InternalCommit @@ -58,9 +60,11 @@ import Galley.Effects.ConversationStore import Galley.Effects.FederatorAccess import Galley.Effects.MemberStore import Galley.Effects.SubConversationStore +import Galley.Effects.TeamStore (getUserTeams) import Imports import Polysemy import Polysemy.Error +import Polysemy.Fail import Polysemy.Input import Polysemy.Internal import Polysemy.Output @@ -81,6 +85,7 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation +import Wire.API.Team.LegalHold import Wire.NotificationSubsystem -- FUTUREWORK @@ -148,6 +153,8 @@ postMLSMessageFromLocalUser lusr c conn smsg = do postMLSCommitBundle :: ( HasProposalEffects r, Members MLSBundleStaticErrors r, + Member Fail r, + Member (ErrorS MLSLegalholdIncompatible) r, Member Random r, Member Resource r, Member SubConversationStore r @@ -171,6 +178,8 @@ postMLSCommitBundleFromLocalUser :: ( HasProposalEffects r, Members MLSBundleStaticErrors r, Member Random r, + Member Fail r, + Member (ErrorS MLSLegalholdIncompatible) r, Member Resource r, Member SubConversationStore r ) => @@ -193,8 +202,10 @@ postMLSCommitBundleToLocalConv :: ( HasProposalEffects r, Members MLSBundleStaticErrors r, Member Resource r, + Member (ErrorS MLSLegalholdIncompatible) r, Member SubConversationStore r, - Member Random r + Member Random r, + Member Fail r ) => Qualified UserId -> ClientId -> @@ -211,6 +222,26 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do note (mlsProtocolError "Unsupported ciphersuite") $ cipherSuiteTag bundle.groupInfo.value.groupContext.cipherSuite + -- when a user tries to join any mls conversation while being legalholded + -- they receive a 409 stating that mls and legalhold are incompatible + case (lConvOrSubId, qusr) of + Local luid -> + when (isNothing convOrSub.mlsMeta.cnvmlsActiveData) do + usrTeams <- getUserTeams (tUnqualified luid) + for_ usrTeams \tid -> do + -- this would only return 'Left' if the team member did vanish directly in the process of this + -- request or if the legalhold state was somehow inconsistent. We can safely assume that this + -- should be a server error + Right resp <- runError @(Tagged TeamMemberNotFound ()) $ getUserStatus luid tid (tUnqualified luid) + case resp.ulhsrStatus of + UserLegalHoldPending -> throwS @MLSLegalholdIncompatible + UserLegalHoldEnabled -> throwS @MLSLegalholdIncompatible + UserLegalHoldDisabled -> pure () + UserLegalHoldNoConsent -> pure () + + -- we can skip the remote case because we currently to not support creating conversations on the remote backend + Remote _ -> pure () + ciphersuiteUpdate <- case convOrSub.mlsMeta.cnvmlsActiveData of -- if this is the first commit of the conversation, update ciphersuite Nothing -> pure True diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index a7488032814..baa3284e861 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -92,6 +92,7 @@ import OpenSSL.Session as Ssl import Polysemy import Polysemy.Async import Polysemy.Error +import Polysemy.Fail import Polysemy.Input import Polysemy.Internal (Append) import Polysemy.Resource @@ -124,6 +125,7 @@ type GalleyEffects0 = Error FederationError, Async, Delay, + Fail, Embed IO, Error JSONResponse, Resource, @@ -243,6 +245,7 @@ evalGalley e = . resourceToIOFinal . runError . embedToFinal @IO + . failToEmbed @IO . runDelay . asyncToIOFinal . mapError toResponse diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index 6c6eca8de17..6ce47062720 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -125,6 +125,8 @@ data TeamStore m a where Maybe (PagingState CassandraPaging TeamMember) -> PagingBounds CassandraPaging TeamMember -> TeamStore m (Page CassandraPaging TeamMember) + -- FUTUREWORK(mangoiv): this should be a single 'TeamId' (@'Maybe' 'TeamId'@), there's no way + -- a user could be part of multiple teams GetUserTeams :: UserId -> TeamStore m [TeamId] GetUsersTeams :: [UserId] -> TeamStore m (Map UserId TeamId) GetOneUserTeam :: UserId -> TeamStore m (Maybe TeamId) From dc1005cbca0f717c4fdcb0462f2dabd26dc65e3b Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 17 Sep 2024 14:30:47 +0200 Subject: [PATCH 6/8] [chore] add changelog entry --- changelog.d/2-features/WPB-10772 | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 changelog.d/2-features/WPB-10772 diff --git a/changelog.d/2-features/WPB-10772 b/changelog.d/2-features/WPB-10772 new file mode 100644 index 00000000000..e5fe1d13db9 --- /dev/null +++ b/changelog.d/2-features/WPB-10772 @@ -0,0 +1,5 @@ +makes it impossible for a user to join an MLS conversation while already under legalhold (at least pending) + +This implies two things: +- if a user is under legalhold they cannot ever join an MLS conversation, not even an MLS self conversation +- a user has to reject an to be put under legalhold when it wants to join MLS conversation (not explicitly acknowledging is not enough) From cc909f8e565add4b8a5ed9557f52227f8c77cc01 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 17 Sep 2024 14:32:26 +0200 Subject: [PATCH 7/8] [chore] remove failing testcase for next ticket --- integration/test/Test/LegalHold.hs | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 8500eda3ac3..f359d54d2c3 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -906,25 +906,6 @@ testLHDisableBeforeApproval = do >>= assertStatus 200 getBob'sStatus `shouldMatch` "disabled" --- --------- --- WPB-10783 --- --------- -testMLSThenLegalhold :: (HasCallStack) => App () -testMLSThenLegalhold = do - -- scenario 1: - -- if charlie is in any MLS conversation, he cannot approve to be put under legalhold - (charlie, tid, []) <- createTeam OwnDomain 1 - [charlie1] <- traverse (createMLSClient def) [charlie] - void $ createNewGroup charlie1 - void $ createAddCommit charlie1 [charlie] >>= sendAndConsumeCommitBundle - - legalholdWhitelistTeam tid charlie >>= assertStatus 200 - withMockServer def lhMockApp \lhDomAndPort _chan -> do - postLegalHoldSettings tid charlie (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 - requestLegalHoldDevice tid charlie charlie >>= assertSuccess - approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword - `bindResponse` assertLabel 409 "mls-legalhold-not-allowed" - -- --------- -- WPB-10772 -- --------- From 1ce66123488b6cb77fde371fa09740d87b653029 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 17 Sep 2024 15:38:12 +0200 Subject: [PATCH 8/8] [chore] apply changes as requested by @pcapriotty - introduce new type RelativeTo - remove leftovers - adjust changelog --- changelog.d/2-features/WPB-10772 | 6 ++-- libs/types-common/src/Data/Qualified.hs | 28 ++++++++++--------- .../Galley/API/MLS/Commit/InternalCommit.hs | 2 -- services/galley/src/Galley/API/MLS/Message.hs | 2 +- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/changelog.d/2-features/WPB-10772 b/changelog.d/2-features/WPB-10772 index e5fe1d13db9..97dd0b3286b 100644 --- a/changelog.d/2-features/WPB-10772 +++ b/changelog.d/2-features/WPB-10772 @@ -1,5 +1,5 @@ -makes it impossible for a user to join an MLS conversation while already under legalhold (at least pending) +Makes it impossible for a user to join an MLS conversation while already under legalhold (at least pending) This implies two things: -- if a user is under legalhold they cannot ever join an MLS conversation, not even an MLS self conversation -- a user has to reject an to be put under legalhold when it wants to join MLS conversation (not explicitly acknowledging is not enough) +1. If a user is under legalhold they cannot ever join an MLS conversation, not even an MLS self conversation. +2. A user has to reject to be put under legalhold when they want to join an MLS conversation (ignoring the request to be put under legalhold is not enough). diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index a126464aca2..0dbc73f99ec 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -31,8 +31,7 @@ module Data.Qualified tSplit, qTagUnsafe, Remote, - pattern Remote, - pattern Local, + RelativeTo (Remote, Local, RelativeTo), toRemoteUnsafe, Local, toLocalUnsafe, @@ -123,21 +122,24 @@ qualifyAs :: QualifiedWithTag t x -> a -> QualifiedWithTag t a qualifyAs = ($>) foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b -foldQualified loc f g q - | tDomain loc == qDomain q = - f (qTagUnsafe q) - | otherwise = - g (qTagUnsafe q) +foldQualified loc kLocal kRemote q = case q `RelativeTo` loc of + Local l -> kLocal l + Remote r -> kRemote r -pattern Local :: forall a x. forall. Local a -> (Local x, Qualified a) -pattern Local loc <- ((\(loc, q) -> (tDomain loc == qDomain q, qUnqualified q <$ loc)) -> (True, loc)) +data a `RelativeTo` x = Qualified a `RelativeTo` Local x -pattern Remote :: forall a x. forall. Remote a -> (Local x, Qualified a) -pattern Remote loc <- ((\(loc, q) -> (tDomain loc == qDomain q, qTagUnsafe q)) -> (False, loc)) +checkRelative :: a `RelativeTo` x -> Either (Local a) (Remote a) +checkRelative (q `RelativeTo` loc) + | tDomain loc == qDomain q = Left (qTagUnsafe q) + | otherwise = Right (qTagUnsafe q) -{-# COMPLETE Local, Remote #-} +pattern Local :: forall a x. Local a -> a `RelativeTo` x +pattern Local loc <- (checkRelative -> Left loc) + +pattern Remote :: forall a x. Remote a -> a `RelativeTo` x +pattern Remote rem <- (checkRelative -> Right rem) --- pattern Remote :: Remote a -> (Local x, Qualified a) +{-# COMPLETE Local, Remote #-} -- Partition a collection of qualified values into locals and remotes. -- diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index 4fe3f43d279..6b466db99ff 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -162,8 +162,6 @@ processInternalCommit senderIdentity con lConvOrSub ciphersuite ciphersuiteUpdat Right clientInfo -> do let allClients = Set.map ciId clientInfo let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) - -- TODO(mangoiv): check if any legalhold clients exist and abort if any - -- We check the following condition: -- allMLSClients ⊆ clients ⊆ allClients -- i.e. diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 8076a288bc0..f3c43774b29 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -224,7 +224,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do -- when a user tries to join any mls conversation while being legalholded -- they receive a 409 stating that mls and legalhold are incompatible - case (lConvOrSubId, qusr) of + case qusr `RelativeTo` lConvOrSubId of Local luid -> when (isNothing convOrSub.mlsMeta.cnvmlsActiveData) do usrTeams <- getUserTeams (tUnqualified luid)