[WPB-10772] Make it impossible for a user under legalhold to join an MLS conversation

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: 
+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).

integration/test/Test/LegalHold.hs

@@ -35,6 +35,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 +905,72 @@ testLHDisableBeforeApproval = do
     disableLegalHold tid alice bob defPassword
       >>= assertStatus 200
     getBob'sStatus `shouldMatch` "disabled"
+
+-- ---------
+-- WPB-10772
+-- ---------
+
+--  | 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]
+  _ <- uploadNewKeyPackage charlie1
+  _ <- createNewGroup 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"
+
+    mls <- getMLSState
+    claimKeyPackages mls.ciphersuite alice1 charlie
+      `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"

libs/types-common/src/Data/Qualified.hs

@@ -31,6 +31,7 @@ module Data.Qualified
     tSplit,
     qTagUnsafe,
     Remote,
+    RelativeTo (Remote, Local, RelativeTo),
     toRemoteUnsafe,
     Local,
     toLocalUnsafe,
@@ -121,11 +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
+
+data a `RelativeTo` x = Qualified a `RelativeTo` Local x
+
+checkRelative :: a `RelativeTo` x -> Either (Local a) (Remote a)
+checkRelative (q `RelativeTo` loc)
+  | tDomain loc == qDomain q = Left (qTagUnsafe q)
+  | otherwise = Right (qTagUnsafe q)
+
+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)
+
+{-# COMPLETE Local, Remote #-}
 
 -- Partition a collection of qualified values into locals and remotes.
 --

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

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) =>

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"

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"

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

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

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-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)

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