diff --git a/changelog.d/3-bug-fixes/WPB-5803-users-under-legal-hold-can-not-exchange-messages b/changelog.d/3-bug-fixes/WPB-5803-users-under-legal-hold-can-not-exchange-messages new file mode 100644 index 0000000000..4b992f9215 --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-5803-users-under-legal-hold-can-not-exchange-messages @@ -0,0 +1,5 @@ +Various improvements around LH policy conflict detection: +* Fix LH policy conflict detection logic when posting messages +* Better policy conflict error messages (distinguish between old clients and missing consent) +* Add first LH scaffolding and tests to `/integration` +* Annotate some API functions in `/integration` with links to openapi3 docs diff --git a/integration/integration.cabal b/integration/integration.cabal index 6f9148fd06..47710c7c29 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -122,6 +122,7 @@ library Test.FeatureFlags Test.Federation Test.Federator + Test.LegalHold Test.MessageTimer Test.MLS Test.MLS.KeyPackage @@ -142,6 +143,7 @@ library Testlib.HTTP Testlib.JSON Testlib.Mock + Testlib.MockIntegrationService Testlib.ModService Testlib.One2One Testlib.Options diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index a6c8f01874..514f5c8ec5 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -160,7 +160,8 @@ data AddClient = AddClient model :: String, prekeys :: Maybe [Value], lastPrekey :: Maybe Value, - password :: String + password :: String, + acapabilities :: Maybe [String] } instance Default AddClient where @@ -172,9 +173,11 @@ instance Default AddClient where model = "Test Model", prekeys = Nothing, lastPrekey = Nothing, - password = defPassword + password = defPassword, + acapabilities = Just ["legalhold-implicit-consent"] } +-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_clients__uid_ addClient :: (HasCallStack, MakesValue user) => user -> @@ -193,14 +196,15 @@ addClient user args = do "type" .= args.ctype, "label" .= args.clabel, "model" .= args.model, - "password" .= args.password + "password" .= args.password, + "capabilities" .= args.acapabilities ] data UpdateClient = UpdateClient { prekeys :: [Value], lastPrekey :: Maybe Value, label :: Maybe String, - capabilities :: Maybe [Value], + capabilities :: Maybe [String], mlsPublicKeys :: Maybe Value } @@ -245,6 +249,7 @@ deleteClient user client = do [ "password" .= defPassword ] +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_users__uid_domain___uid__clients getClientsQualified :: ( HasCallStack, MakesValue user, @@ -267,6 +272,7 @@ getClientsQualified user domain otherUser = do <> "/clients" submit "GET" req +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_users_list_clients listUsersClients :: (HasCallStack, MakesValue user, MakesValue qualifiedUserIds) => user -> [qualifiedUserIds] -> App Response listUsersClients usr qualifiedUserIds = do qUsers <- mapM objQidObject qualifiedUserIds @@ -588,3 +594,25 @@ updateService dom providerId serviceId mAcceptHeader newName = do . addHdrs . addJSONObject ["name" .= n | n <- maybeToList newName] $ req + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_users__uid_domain___uid__prekeys__client_ +getUsersPrekeysClient :: (HasCallStack, MakesValue caller, MakesValue targetUser) => caller -> targetUser -> String -> App Response +getUsersPrekeysClient caller targetUser targetClient = do + dom <- asString $ targetUser %. "domain" + uid <- asString $ targetUser %. "id" + req <- baseRequest caller Brig Versioned $ joinHttpPath ["users", dom, uid, "prekeys", targetClient] + submit "GET" req + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_users__uid_domain___uid__prekeys +getUsersPrekeyBundle :: (HasCallStack, MakesValue caller, MakesValue targetUser) => caller -> targetUser -> App Response +getUsersPrekeyBundle caller targetUser = do + dom <- asString $ targetUser %. "domain" + uid <- asString $ targetUser %. "id" + req <- baseRequest caller Brig Versioned $ joinHttpPath ["users", dom, uid, "prekeys"] + submit "GET" req + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_users_list_prekeys +getMultiUserPrekeyBundle :: (HasCallStack, MakesValue caller, ToJSON userClients) => caller -> userClients -> App Response +getMultiUserPrekeyBundle caller userClients = do + req <- baseRequest caller Brig Versioned $ joinHttpPath ["users", "list-prekeys"] + submit "POST" (addJSON userClients req) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 2c9ab94c6f..d64db7af1c 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -6,6 +6,7 @@ module API.Galley where import API.Common import Control.Lens hiding ((.=)) import Control.Monad.Reader +import Control.Retry import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Base64 as B64 @@ -513,3 +514,55 @@ getTeamMembers user tid = do tidStr <- asString tid req <- baseRequest user Galley Versioned (joinHttpPath ["teams", tidStr, "members"]) submit "GET" req + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings +enableLegalHold :: (HasCallStack, MakesValue tid, MakesValue ownerid) => tid -> ownerid -> App Response +enableLegalHold tid ownerid = do + tidStr <- asString tid + req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) + submit "PUT" (addJSONObject ["status" .= "enabled", "ttl" .= "unlimited"] req) + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings +postLegalHoldSettings :: (HasCallStack, MakesValue owner, MakesValue tid, MakesValue newService) => owner -> tid -> newService -> App Response +postLegalHoldSettings owner tid newSettings = retrying policy only412 $ \_ -> do + tidStr <- asString tid + req <- baseRequest owner Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "settings"]) + newSettingsObj <- make newSettings + submit "POST" (addJSON newSettingsObj req) + where + policy :: RetryPolicy + policy = limitRetriesByCumulativeDelay 5_000_000 $ exponentialBackoff 50 + + only412 :: RetryStatus -> Response -> App Bool + only412 _ resp = pure $ resp.status == 412 + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold__uid_ +requestLegalHoldDevice :: (HasCallStack, MakesValue tid, MakesValue ownerid, MakesValue uid) => tid -> ownerid -> uid -> App Response +requestLegalHoldDevice tid ownerid uid = do + tidStr <- asString tid + uidStr <- objId uid + req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) + submit "POST" req + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__legalhold__uid__approve +approveLegalHoldDevice :: (HasCallStack, MakesValue tid, MakesValue uid) => tid -> uid -> String -> App Response +approveLegalHoldDevice tid uid pwd = do + tidStr <- asString tid + uidStr <- asString $ uid %. "id" + req <- baseRequest uid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr, "approve"]) + submit "PUT" (addJSONObject ["password" .= pwd] req) + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_consent +consentToLegalHold :: (HasCallStack, MakesValue tid, MakesValue zusr) => tid -> zusr -> String -> App Response +consentToLegalHold tid zusr pwd = do + tidStr <- asString tid + req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "consent"]) + submit "POST" (addJSONObject ["password" .= pwd] req) + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_teams__tid__legalhold__uid_ +getLegalHoldStatus :: (HasCallStack, MakesValue tid, MakesValue zusr) => tid -> zusr -> App Response +getLegalHoldStatus tid zusr = do + tidStr <- asString tid + uidStr <- asString $ zusr %. "id" + req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) + submit "GET" req diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index d1a84aa104..89f3eac571 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -58,3 +58,15 @@ getFederationStatus user domains = submit "GET" $ req & addJSONObject ["domains" .= domainList] + +legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response +legalholdWhitelistTeam uid tid = do + tidStr <- asString tid + req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] + submit "PUT" req + +legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response +legalholdIsTeamInWhitelist uid tid = do + tidStr <- asString tid + req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] + submit "GET" req diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs new file mode 100644 index 0000000000..09f0f8b4ca --- /dev/null +++ b/integration/test/Test/LegalHold.hs @@ -0,0 +1,351 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2023 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.LegalHold where + +import API.Brig +import API.Common +import API.Galley +import API.GalleyInternal +import Control.Lens ((.~), (^?!)) +import qualified Data.Map as Map +import qualified Data.ProtoLens as Proto +import Data.ProtoLens.Labels () +import qualified Data.Set as Set +import GHC.Stack +import Numeric.Lens (hex) +import qualified Proto.Otr as Proto +import qualified Proto.Otr_Fields as Proto +import SetupHelpers +import Testlib.MockIntegrationService +import Testlib.Prekeys +import Testlib.Prelude + +abstractTestLHMessageExchange :: HasCallStack => String -> Int -> Bool -> Bool -> Bool -> Bool -> App () +abstractTestLHMessageExchange dom lhPort clients1New clients2New consentFrom1 consentFrom2 = do + (owner, tid, [mem1, mem2]) <- createTeam dom 3 + + let clientSettings :: Bool -> AddClient + clientSettings allnew = + if allnew + then def -- (`{acapabilities = Just ["legalhold-implicit-consent"]}` is the default) + else def {acapabilities = Nothing} + client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 + _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 + + void $ legalholdWhitelistTeam owner tid >>= assertSuccess + void $ legalholdIsTeamInWhitelist owner tid >>= assertSuccess + void $ postLegalHoldSettings owner tid (mkLegalHoldSettings lhPort) >>= getJSON 201 + + conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 + + requestLegalHoldDevice tid owner mem1 >>= assertSuccess + requestLegalHoldDevice tid owner mem2 >>= assertSuccess + when consentFrom1 $ do + approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess + when consentFrom2 $ do + approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess + + let getCls :: Value -> App [String] + getCls mem = do + res <- getClientsQualified mem dom mem + val <- getJSON 200 res + cls <- asList val + objId `mapM` cls + cs1 :: [String] <- getCls mem1 -- it's ok to include the sender, backend will filter it out. + cs2 :: [String] <- getCls mem2 + + length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 + length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 + + void $ do + successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" + let successfulMsg = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (client1 ^?! hex) + & #recipients .~ [successfulMsgForOtherUsers] + & #reportAll .~ Proto.defMessage + bindResponse (postProteusMessage mem1 (conv %. "qualified_id") successfulMsg) $ \resp -> do + let check :: HasCallStack => Int -> Maybe String -> App () + check status Nothing = do + resp.status `shouldMatchInt` status + check status (Just label) = do + resp.status `shouldMatchInt` status + resp.json %. "label" `shouldMatch` label + + let -- there are two equally valid ways to write this down (feel free to remove one if it gets in your way): + _oneWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of + (_, _, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, _, _) -> + if consentFrom1 /= consentFrom2 + then -- no old clients, but users disagree on LH + check 403 (Just "missing-legalhold-consent") + else -- everybody likes LH + check 201 Nothing + _ -> + -- everything else + check 403 (Just "missing-legalhold-consent-old-clients") + + theOtherWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of + -- NB: "consent" always implies "has an active LH device" + (False, False, False, False) -> + -- no LH in the picture + check 201 Nothing + (False, False, False, True) -> + -- sender has old clients and not given consent, recipient has LH device + check 403 (Just "missing-legalhold-consent-old-clients") + (False, False, True, False) -> + -- recipient has old clients and not given consent, sender has LH device + check 403 (Just "missing-legalhold-consent-old-clients") + (False, False, True, True) -> + -- both sender, recipient have has old clients and LH devices, but given consent + check 403 (Just "missing-legalhold-consent-old-clients") + (False, True, False, False) -> + -- no LH in the picture + check 201 Nothing + (False, True, False, True) -> + -- sender has old clients and not given consent, recipient has LH device (and only new clients) + check 403 (Just "missing-legalhold-consent-old-clients") + (False, True, True, False) -> + -- sender has old clients but given consent and LH device; recipient has not given consent + check 403 (Just "missing-legalhold-consent-old-clients") + (False, True, True, True) -> + -- sender has old clients but given consent and LH device; recipient has LH device (and only new clients) + check 403 (Just "missing-legalhold-consent-old-clients") + (True, False, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, False, False, True) -> + -- recipient has given consent and LH device, but old clients (and sender has not given consent) + check 403 (Just "missing-legalhold-consent-old-clients") + (True, False, True, False) -> + -- recipient has old clients and not given consent, sender has LH device + check 403 (Just "missing-legalhold-consent-old-clients") + (True, False, True, True) -> + -- old clients with recipient, LH devices by all + check 403 (Just "missing-legalhold-consent-old-clients") + (True, True, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, False, True) -> + -- all clients new, no consent from sender, recipient has LH device + check 403 (Just "missing-legalhold-consent") + (True, True, True, False) -> + -- all clients new, no consent from recipient, sender has LH device + check 403 (Just "missing-legalhold-consent") + (True, True, True, True) -> + -- everybody happy with LH + check 201 Nothing + + -- _oneWay -- run this if you want to make sure both ways are equivalent, but please don't commit! + theOtherWay + +data TestClaimKeys + = TCKConsentMissing -- (team not whitelisted, that is) + | TCKOldClient + | TCKConsentAndNewClients + deriving (Bounded, Enum) + +-- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients. +abstractTestLHClaimKeys :: String -> Int -> TestClaimKeys -> App () +abstractTestLHClaimKeys dom lhPort testmode = do + (lowner, ltid, [lmem]) <- createTeam dom 2 + (powner, ptid, [pmem]) <- createTeam dom 2 + + legalholdWhitelistTeam lowner ltid >>= assertSuccess + legalholdIsTeamInWhitelist lowner ltid >>= assertSuccess + void $ postLegalHoldSettings lowner ltid (mkLegalHoldSettings lhPort) >>= getJSON 201 + + requestLegalHoldDevice ltid lowner lmem >>= assertSuccess + approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess + + let addc caps = addClient pmem (settings caps) >>= assertSuccess + settings caps = + def + { prekeys = Just $ take 10 somePrekeysRendered, + lastPrekey = Just $ head someLastPrekeysRendered, + acapabilities = caps + } + in case testmode of + TCKConsentMissing -> + addc $ Just ["legalhold-implicit-consent"] + TCKOldClient -> do + addc Nothing + void $ legalholdWhitelistTeam powner ptid >>= assertSuccess + void $ legalholdIsTeamInWhitelist powner ptid >>= assertSuccess + TCKConsentAndNewClients -> do + addc $ Just ["legalhold-implicit-consent"] + void $ legalholdWhitelistTeam powner ptid >>= assertSuccess + void $ legalholdIsTeamInWhitelist powner ptid >>= assertSuccess + + llhdev :: String <- do + let getCls :: Value -> App [String] + getCls mem = do + res <- getClientsQualified mem dom mem + val <- getJSON 200 res + cls <- asList val + objId `mapM` cls + getCls lmem <&> \case + [d] -> d + bad -> error $ show bad + + let assertResp :: HasCallStack => Response -> App () + assertResp resp = case testmode of + TCKConsentMissing -> do + resp.status `shouldMatchInt` 403 + resp.json %. "label" `shouldMatch` "missing-legalhold-consent" + TCKOldClient -> do + resp.status `shouldMatchInt` 403 + resp.json %. "label" `shouldMatch` "missing-legalhold-consent-old-clients" + TCKConsentAndNewClients -> do + resp.status `shouldMatchInt` 200 + + bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) $ assertResp + bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) $ assertResp + + slmemdom <- asString $ lmem %. "qualified_id.domain" + slmemid <- asString $ lmem %. "qualified_id.id" + let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList [llhdev])])] + bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp + +-- | FUTUREWORK: if you run this test, you will get "Out of prekeys" errors, so we split it up +-- in 19 individual tests that each seem to reset the pool. +_testLegalhold :: App () +_testLegalhold = do + -- we spawn services ourselves here so galley can reach the LH service (which is also + -- spawned) under localhost. if you want to limit yourself to running only some of these + -- locally, write an ad-hoc test case that you don't commit. + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + sequence_ $ abstractTestLHMessageExchange dom lhPort <$> [minBound ..] <*> [minBound ..] <*> [minBound ..] <*> [minBound ..] + abstractTestLHClaimKeys dom lhPort `mapM_` [minBound ..] + +testLHMessageExchange01 :: App () +testLHMessageExchange01 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False False False False + +testLHMessageExchange02 :: App () +testLHMessageExchange02 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False False False True + +testLHMessageExchange03 :: App () +testLHMessageExchange03 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False False True False + +testLHMessageExchange04 :: App () +testLHMessageExchange04 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False False True True + +testLHMessageExchange05 :: App () +testLHMessageExchange05 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False True False False + +testLHMessageExchange06 :: App () +testLHMessageExchange06 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False True False True + +testLHMessageExchange07 :: App () +testLHMessageExchange07 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False True True False + +testLHMessageExchange08 :: App () +testLHMessageExchange08 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort False True True True + +testLHMessageExchange09 :: App () +testLHMessageExchange09 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True False False False + +testLHMessageExchange10 :: App () +testLHMessageExchange10 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True False False True + +testLHMessageExchange11 :: App () +testLHMessageExchange11 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True False True False + +testLHMessageExchange12 :: App () +testLHMessageExchange12 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True False True True + +testLHMessageExchange13 :: App () +testLHMessageExchange13 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True True False False + +testLHMessageExchange14 :: App () +testLHMessageExchange14 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True True False True + +testLHMessageExchange15 :: App () +testLHMessageExchange15 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True True True False + +testLHMessageExchange16 :: App () +testLHMessageExchange16 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHMessageExchange dom lhPort True True True True + +testLHClaimKeys01 :: App () +testLHClaimKeys01 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHClaimKeys dom lhPort TCKConsentMissing + +testLHClaimKeys02 :: App () +testLHClaimKeys02 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHClaimKeys dom lhPort TCKOldClient + +testLHClaimKeys03 :: App () +testLHClaimKeys03 = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + abstractTestLHClaimKeys dom lhPort TCKConsentAndNewClients diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index 6ffceccee9..e0978f4e38 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -31,7 +31,7 @@ getLastPrekey = App $ do lpk <- liftIO $ atomicModifyIORef pks getPK pure $ object ["id" .= lastPrekeyId, "key" .= lpk] where - getPK [] = error "Out of prekeys" + getPK [] = error "No last prekey left" getPK (k : ks) = (ks, k) lastPrekeyId :: Int diff --git a/integration/test/Testlib/MockIntegrationService.hs b/integration/test/Testlib/MockIntegrationService.hs new file mode 100644 index 0000000000..4d7c64a515 --- /dev/null +++ b/integration/test/Testlib/MockIntegrationService.hs @@ -0,0 +1,154 @@ +module Testlib.MockIntegrationService (withMockServer, lhMockApp, mkLegalHoldSettings) where + +import Control.Monad.Catch +import Control.Monad.Reader +import qualified Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Streaming.Network +import Data.String.Conversions (cs) +import Network.HTTP.Types +import Network.Socket +import qualified Network.Socket as Socket +import Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.Warp.Internal as Warp +import qualified Network.Wai.Handler.WarpTLS as Warp +import Testlib.Prekeys +import Testlib.Prelude +import UnliftIO.Async +import UnliftIO.Chan +import UnliftIO.MVar +import UnliftIO.Timeout (timeout) + +mockServerPubKey :: String +mockServerPubKey = + "-----BEGIN PUBLIC KEY-----\n\ + \MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0\n\ + \G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH\n\ + \WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV\n\ + \VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS\n\ + \bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8\n\ + \7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la\n\ + \nQIDAQAB\n\ + \-----END PUBLIC KEY-----" + +mockServerPrivKey :: String +mockServerPrivKey = + "-----BEGIN RSA PRIVATE KEY-----\n\ + \MIIEpAIBAAKCAQEAu+Kg/PHHU3atXrUbKnw0G06FliXcNt3lMwl2os5twEDcPPFw\n\ + \/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPHWvUBdiLfGrZqJO223DB6D8K2Su/o\n\ + \dmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKVVPOaOzgtAB21XKRiQ4ermqgi3/nj\n\ + \r03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiSbUKr/BeArYRcjzr/h5m1In6fG/if\n\ + \9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg87X883H+LA/d6X5CTiPv1VMxXdBUi\n\ + \GPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7lanQIDAQABAoIBAQC0doVy7zgpLsBv\n\ + \Sz0AnbPe1pjxEwRlntRbJSfSULySALqJvs5s4adSVGUBHX3z/LousAP1SRpCppuU\n\ + \8wrLBFgjQVlaAzyQB84EEl+lNtrG8Jrvd2es9R/4sJDkqy50+yuPN5wnzWPFIjhg\n\ + \3jP5CHDu29y0LMzsY5yjkzDe9B0bueXEZVU+guRjhpwHHKOFeAr9J9bugFUwgeAr\n\ + \jF0TztzFAb0fsUNPiQAho1J5PyjSVgItaPfAPv/p30ROG+rz+Rd5NSSvBC5F+yOo\n\ + \azb84zzwCg/knAfIz7SOMRrmBh2qhGZFZ8gXdq65UaYv+cpT/qo28mpAT2vOkyeD\n\ + \aPZp0ysBAoGBAOQROoDipe/5BTHBcXYuUE1qa4RIj3wgql5I8igXr4K6ppYBmaOg\n\ + \DL2rrnqD86chv0P4l/XOomKFwYhVGXtqRkeYnk6mQXwNVkgqcGbY5PSNyMg5+ekq\n\ + \jSOOPHGzzTWKzYuUDUpB/Lf6jbTv8fq2GYW3ZYiqQ/xiugOvglZrTE7NAoGBANLl\n\ + \irjByfxAWGhzCrDx0x5MBpsetadI9wUA8u1BDdymsRg73FDn3z7NipVUAMDXMGVj\n\ + \lqbCRlHESO2yP4GaPEA4FM+MbTZSuhAYV+SY07mEPLHF64/nJas83Zp91r5rhaqJ\n\ + \L9rWCl3KJ5OUnr3YizCnHIW72FxjwtpjxHJLupsRAoGAGIbhy8qUHeKh9F/hW9xP\n\ + \NoQjW+6Rv7+jktA1eqpRbbW1BJzXcQldVWiJMxPNuEOg1iZ98SlvvTi1P3wnaWZc\n\ + \eIapP7wRfs3QYaJuxCC/Pq2g0ieqALFazGAXkALOJtvujvw1Ea9XBlIjuzmyxEuh\n\ + \Iwg+Gxx0g0f6yTquwax4YGECgYEAnpAK3qKFNO1ECzQDo8oNy0ep59MNDPtlDhQK\n\ + \katJus5xdCD9oq7TQKrVOTTxZAvmzTQ1PqfuqueDVYOhD9Zg2n/P1cRlEGTek99Z\n\ + \pfvppB/yak6+r3FA9yBKFS/r1zuMQg3nNweav62QV/tz5pT7AdeDMGFtaPlwtTYx\n\ + \qyWY5aECgYBPySbPccNj+xxQzxcti2y/UXjC04RgOA/Hm1D0exa0vBqS9uxlOdG8\n\ + \F47rKenpBrslvdfTVsCDB1xyP2ebWVzp6EqMycw6OLPxgo3fBfZ4pi6P+rByh0Cc\n\ + \Lhfh+ET0CPnKCxtop3lUrn4ZvqchS0j3J+M0pDuqoWF5hfKxFhkEIw==\n\ + \-----END RSA PRIVATE KEY-----" + +mockServerCert :: String +mockServerCert = + "-----BEGIN CERTIFICATE-----\n\ + \MIIDdjCCAl4CCQCm0AiwERR/qjANBgkqhkiG9w0BAQsFADB9MQswCQYDVQQGEwJE\n\ + \RTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJsaW4xGDAWBgNVBAoMD1dp\n\ + \cmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20xHzAdBgkqhkiG9w0BCQEW\n\ + \EGJhY2tlbmRAd2lyZS5jb20wHhcNMTYwODA0MTMxNDQyWhcNMzYwNzMwMTMxNDQy\n\ + \WjB9MQswCQYDVQQGEwJERTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJs\n\ + \aW4xGDAWBgNVBAoMD1dpcmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20x\n\ + \HzAdBgkqhkiG9w0BCQEWEGJhY2tlbmRAd2lyZS5jb20wggEiMA0GCSqGSIb3DQEB\n\ + \AQUAA4IBDwAwggEKAoIBAQC74qD88cdTdq1etRsqfDQbToWWJdw23eUzCXaizm3A\n\ + \QNw88XD994aIArKbGn7smpkOux5LkP1Mcatb45BEg8da9QF2It8atmok7bbcMHoP\n\ + \wrZK7+h2aeNknbPbeuFegQCtOmW74OD0r5zYtV5dMpVU85o7OC0AHbVcpGJDh6ua\n\ + \qCLf+eOvTetfKr+o2S413q01yD4cB8bF8a+8JJgF+JJtQqv8F4CthFyPOv+HmbUi\n\ + \fp8b+J/0YQjqbx3EdP0ltjnfCKSyjDLpqMK6qyQgWDztfzzcf4sD93pfkJOI+/VU\n\ + \zFd0FSIY+4L0hP/oI1DX8sW3Q/ftrHnz4sZiVoWjuVqdAgMBAAEwDQYJKoZIhvcN\n\ + \AQELBQADggEBAEuwlHElIGR56KVC1dJiw238mDGjMfQzSP76Wi4zWS6/zZwJUuog\n\ + \BkC+vacfju8UAMvL+vdqkjOVUHor84/2wuq0qn91AjOITD7tRAZB+XLXxsikKv/v\n\ + \OXE3A/lCiNi882NegPyXAfFPp/71CIiTQZps1eQkAvhD5t5WiFYPESxDlvEJrHFY\n\ + \XP4+pp8fL8YPS7iZNIq+z+P8yVIw+B/Hs0ht7wFIYN0xACbU8m9+Rs08JMoT16c+\n\ + \hZMuK3BWD3fzkQVfW0yMwz6fWRXB483ZmekGkgndOTDoJQMdJXZxHpI3t2FcxQYj\n\ + \T45GXxRd18neXtuYa/OoAw9UQFDN5XfXN0g=\n\ + \-----END CERTIFICATE-----" + +botHost :: String +botHost = "localhost" + +withFreePortAnyAddr :: (MonadMask m, MonadIO m) => ((Warp.Port, Socket) -> m a) -> m a +withFreePortAnyAddr = bracket openFreePortAnyAddr (liftIO . Socket.close . snd) + +openFreePortAnyAddr :: MonadIO m => m (Warp.Port, Socket) +openFreePortAnyAddr = liftIO $ bindRandomPortTCP (fromString "*") + +withMockServer :: + HasCallStack => + -- | the mock server + (Chan e -> Application) -> + -- | the test + (Warp.Port -> Chan e -> App a) -> + App a +withMockServer mkApp go = withFreePortAnyAddr $ \(sPort, sock) -> do + serverStarted <- newEmptyMVar + let tlss = Warp.tlsSettingsMemory (cs mockServerCert) (cs mockServerPrivKey) + let defs = Warp.defaultSettings {Warp.settingsPort = sPort, Warp.settingsBeforeMainLoop = putMVar serverStarted ()} + buf <- newChan + srv <- async . liftIO . Warp.runTLSSocket tlss defs sock $ mkApp buf + srvMVar <- UnliftIO.Timeout.timeout 5_000_000 (takeMVar serverStarted) + case srvMVar of + Just () -> go sPort buf `finally` cancel srv + Nothing -> error . show =<< poll srv + +-- | LegalHold service. Just fake the API, do not maintain any internal state. +lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> Wai.Application +lhMockApp ch req cont = do + reqBody <- Wai.strictRequestBody req + writeChan ch (req, reqBody) + case (cs <$> pathInfo req, cs $ requestMethod req, cs @_ @String <$> getRequestHeader "Authorization" req) of + (["legalhold", "status"], "GET", _) -> cont respondOk + (_, _, Nothing) -> cont missingAuth + (["legalhold", "initiate"], "POST", Just _) -> cont initiateResp + (["legalhold", "confirm"], "POST", Just _) -> cont respondOk + (["legalhold", "remove"], "POST", Just _) -> cont respondOk + _ -> cont respondBad + where + initiateResp :: Wai.Response + initiateResp = + responseLBS status200 [(hContentType, cs "application/json")] . encode . Data.Aeson.object $ + [ "prekeys" .= drop 3 somePrekeysRendered, + "last_prekey" .= (someLastPrekeysRendered !! 2) + ] + + respondOk :: Wai.Response + respondOk = responseLBS status200 mempty mempty + + respondBad :: Wai.Response + respondBad = responseLBS status404 mempty mempty + + missingAuth :: Wai.Response + missingAuth = responseLBS status400 mempty (cs "no authorization header") + + getRequestHeader :: String -> Wai.Request -> Maybe ByteString + getRequestHeader name = lookup (fromString name) . requestHeaders + +mkLegalHoldSettings :: Warp.Port -> Value +mkLegalHoldSettings lhPort = + object + [ "base_url" .= ("https://" <> botHost <> ":" <> show lhPort <> "/legalhold"), + "public_key" .= mockServerPubKey, + "auth_token" .= "tok" + ] diff --git a/integration/test/Testlib/Prekeys.hs b/integration/test/Testlib/Prekeys.hs index 56cff0bbb8..00ede28161 100644 --- a/integration/test/Testlib/Prekeys.hs +++ b/integration/test/Testlib/Prekeys.hs @@ -1,7 +1,20 @@ -module Testlib.Prekeys where +module Testlib.Prekeys + ( somePrekeys, + someLastPrekeys, + somePrekeysRendered, + someLastPrekeysRendered, + ) +where +import Data.Aeson +import Data.String +import Data.Word import Prelude +-- | FUTUREWORK: client ids are calculated from prekeys in brig, so we should have a more +-- robust mechanism to pick them, to avoid id clashes as well as running out of list. just +-- call cryptobox? (or fake it, find out where the id is encoded in the key payload, count +-- that inside an MVar, and return the same key with different id every time?) somePrekeys :: [String] somePrekeys = [ "pQABAQECoQBYIOjl7hw0D8YRNqkkBQETCxyr7/ywE/2R5RWcUPM+GJACA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", @@ -25,11 +38,7 @@ somePrekeys = "pQABARMCoQBYIEoEFiIpCHgn74CAD+GhIfIgbQtdCqQqkOXHWxRlG6Y6A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", "pQABARQCoQBYINVEwTRxNSe0rxZxon4Rifz2l4rtQZn7mHtKYCiFAK9IA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", "pQABARUCoQBYIN3aeX2Ayi2rPFbiaYb+O2rdHUpFhzRs2j28pCmbGpflA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", - "pQABARYCoQBYIJe5OJ17YKQrNmIH3sE++r++4Z5ld36axqAMjjQ3jtQWA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", - "pQABARcCoQBYIASE94LjK6Raipk/lN/YewouqO+kcQGpxIqP+iW2hyHiA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", - "pQABARgYAqEAWCBZ222LpS6/99Btlw+83PihrA655skwsNevt//8oz5axQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2", - "pQABARgZAqEAWCDGEwo61w4O8T8lyw0HdoOjGWBKQUNqo6+jSfrPR9alrAOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2", - "pQABARgaAqEAWCBMSQoQ6B35plB80i1O3AWlJSftCEbCbju97Iykg5+NWQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2" + "pQABARYCoQBYIJe5OJ17YKQrNmIH3sE++r++4Z5ld36axqAMjjQ3jtQWA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=" ] someLastPrekeys :: [String] @@ -61,3 +70,12 @@ someLastPrekeys = "pQABARn//wKhAFggQtT7lLZzH171F4jCbHNwxEAt28FwdQ8Kt2tbxFzPgC0DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", "pQABARn//wKhAFggQeUPM119c+6zRsEupA8zshTfrZiLpXx1Ji0UMMumq9IDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==" ] + +render :: [Word16] -> [String] -> [Value] +render is = zipWith (\i k -> object [fromString "id" .= i, fromString "key" .= k]) is + +somePrekeysRendered :: [Value] +somePrekeysRendered = render [1 ..] somePrekeys + +someLastPrekeysRendered :: [Value] +someLastPrekeysRendered = render (repeat maxBound) someLastPrekeys diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index 034e57f942..b436775494 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -37,7 +37,8 @@ spec = (MessageSendResponse.testObject_MessageSendResponse2, "testObject_MessageSendResponse2.json"), (MessageSendResponse.testObject_MessageSendResponse3, "testObject_MessageSendResponse3.json"), (MessageSendResponse.testObject_MessageSendResponse4, "testObject_MessageSendResponse4.json"), - (MessageSendResponse.testObject_MessageSendResponse5, "testObject_MessageSendResponse5.json") + (MessageSendResponse.testObject_MessageSendResponse5, "testObject_MessageSendResponse5.json"), + (MessageSendResponse.testObject_MessageSendResponse6, "testObject_MessageSendResponse6.json") ] testObjects [ (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus1, "testObject_MLSMessageSendingStatus1.json"), diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs index 1127f400b7..dc4c094613 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs @@ -151,3 +151,6 @@ testObject_MessageSendResponse4 = MessageSendResponse . Left $ MessageNotSentCon testObject_MessageSendResponse5 :: MessageSendResponse testObject_MessageSendResponse5 = MessageSendResponse . Left $ MessageNotSentUnknownClient + +testObject_MessageSendResponse6 :: MessageSendResponse +testObject_MessageSendResponse6 = MessageSendResponse . Left $ MessageNotSentLegalholdOldClients diff --git a/libs/wire-api-federation/test/golden/testObject_MessageSendResponse6.json b/libs/wire-api-federation/test/golden/testObject_MessageSendResponse6.json new file mode 100644 index 0000000000..23b32e4e13 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MessageSendResponse6.json @@ -0,0 +1,5 @@ +{ + "Left": { + "tag": "MessageNotSentLegalholdOldClients" + } +} \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index 71eb5628a7..ba1a227794 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -33,6 +33,7 @@ data BrigError | CodeAuthenticationFailed | CodeAuthenticationRequired | MissingLegalholdConsent + | MissingLegalholdConsentOldClients | ConnectionLimitReached | UnknownClient | ClientNotFound @@ -143,6 +144,13 @@ type instance MapError 'CodeAuthenticationFailed = 'StaticError 403 "code-authen type instance MapError 'CodeAuthenticationRequired = 'StaticError 403 "code-authentication-required" "Code authentication is required" +type instance + MapError 'MissingLegalholdConsentOldClients = + 'StaticError + 403 + "missing-legalhold-consent-old-clients" + "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has old clients that do not support legalhold's UI requirements" + type instance MapError 'MissingLegalholdConsent = 'StaticError diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index b85428cde0..57f76ef1d6 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -124,6 +124,7 @@ data GalleyError | -- Legal hold Error -- FUTUREWORK: make LegalHoldError more static and documented MissingLegalholdConsent + | MissingLegalholdConsentOldClients | NoUserLegalHoldConsent | LegalHoldNotEnabled | LegalHoldDisableUnimplemented @@ -298,6 +299,8 @@ type instance MapError 'LegalHoldServiceInvalidKey = 'StaticError 400 "legalhold type instance MapError 'MissingLegalholdConsent = 'StaticError 403 "missing-legalhold-consent" "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has not granted consent" +type instance MapError 'MissingLegalholdConsentOldClients = 'StaticError 403 "missing-legalhold-consent-old-clients" "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has old clients that do not support legalhold's UI requirements" + type instance MapError 'LegalHoldServiceNotRegistered = 'StaticError 400 "legalhold-not-registered" "legal hold service has not been registered for this team" type instance MapError 'LegalHoldServiceBadResponse = 'StaticError 400 "legalhold-status-bad" "legal hold service: invalid response" 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 f03b19870b..d2f435e4a9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -243,6 +243,7 @@ type InternalAPIBase = "guard-legalhold-policy-conflicts" ( "guard-legalhold-policy-conflicts" :> CanThrow 'MissingLegalholdConsent + :> CanThrow 'MissingLegalholdConsentOldClients :> ReqBody '[Servant.JSON] GuardLegalholdPolicyConflicts :> MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 200 "Guard Legalhold Policy") ) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 6c8ac4cd92..ada615249c 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -947,6 +947,7 @@ type ConnectionAPI = ( Summary "Create a connection to another user" :> Until 'V2 :> MakesFederatedCall 'Brig "send-connection-action" + :> CanThrow 'MissingLegalholdConsentOldClients :> CanThrow 'MissingLegalholdConsent :> CanThrow 'InvalidUser :> CanThrow 'ConnectionLimitReached @@ -971,6 +972,7 @@ type ConnectionAPI = ( Summary "Create a connection to another user" :> MakesFederatedCall 'Brig "get-users-by-ids" :> MakesFederatedCall 'Brig "send-connection-action" + :> CanThrow 'MissingLegalholdConsentOldClients :> CanThrow 'MissingLegalholdConsent :> CanThrow 'InvalidUser :> CanThrow 'ConnectionLimitReached @@ -1050,6 +1052,7 @@ type ConnectionAPI = ( Summary "Update a connection to another user" :> Until 'V2 :> MakesFederatedCall 'Brig "send-connection-action" + :> CanThrow 'MissingLegalholdConsentOldClients :> CanThrow 'MissingLegalholdConsent :> CanThrow 'InvalidUser :> CanThrow 'ConnectionLimitReached @@ -1079,6 +1082,7 @@ type ConnectionAPI = ( Summary "Update a connection to another user" :> MakesFederatedCall 'Brig "get-users-by-ids" :> MakesFederatedCall 'Brig "send-connection-action" + :> CanThrow 'MissingLegalholdConsentOldClients :> CanThrow 'MissingLegalholdConsent :> CanThrow 'InvalidUser :> CanThrow 'ConnectionLimitReached diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs index 70b75bf40d..4d544b64a5 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs @@ -131,6 +131,7 @@ type BotAPI = ( Summary "Claim users prekeys" :> CanThrow 'AccessDenied :> CanThrow 'TooManyClients + :> CanThrow 'MissingLegalholdConsentOldClients :> CanThrow 'MissingLegalholdConsent :> ZBot :> "bot" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs index 02625476f3..e079e33110 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE DeriveAnyClass #-} module Wire.API.Routes.Public.Galley.Messaging where @@ -121,20 +122,21 @@ type MessagingAPI = data MessageNotSent a = MessageNotSentConversationNotFound | MessageNotSentUnknownClient + | MessageNotSentLegalholdOldClients | MessageNotSentLegalhold | MessageNotSentClientMissing a deriving stock (Eq, Show, Generic, Functor) deriving (AsUnion (MessageNotSentResponses a)) via (GenericAsUnion (MessageNotSentResponses a) (MessageNotSent a)) - -instance GSOP.Generic (MessageNotSent a) + deriving anyclass (GSOP.Generic) instance S.ToSchema a => S.ToSchema (MessageNotSent a) type MessageNotSentResponses a = '[ ErrorResponse 'ConvNotFound, ErrorResponse 'BrigError.UnknownClient, + ErrorResponse 'BrigError.MissingLegalholdConsentOldClients, ErrorResponse 'BrigError.MissingLegalholdConsent, Respond 412 "Missing clients" a ] diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index c043616262..d1758a3dd0 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -71,6 +71,7 @@ connError (ConnectBlacklistedUserKey k) = StdError $ foldKey (const blacklistedE connError (ConnectInvalidEmail _ _) = StdError (errorToWai @'E.InvalidEmail) connError ConnectInvalidPhone {} = StdError (errorToWai @'E.InvalidPhone) connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers +connError ConnectMissingLegalholdConsentOldClients = StdError (errorToWai @'E.MissingLegalholdConsentOldClients) connError ConnectMissingLegalholdConsent = StdError (errorToWai @'E.MissingLegalholdConsent) connError (ConnectFederationError e) = fedError e connError ConnectTeamFederationError = StdError (errorToWai @'E.TeamsNotFederating) @@ -167,6 +168,7 @@ clientError ClientLegalHoldCannotBeRemoved = StdError can'tDeleteLegalHoldClient clientError ClientLegalHoldCannotBeAdded = StdError can'tAddLegalHoldClient clientError (ClientFederationError e) = fedError e clientError ClientCapabilitiesCannotBeRemoved = StdError clientCapabilitiesCannotBeRemoved +clientError ClientMissingLegalholdConsentOldClients = StdError (errorToWai @'E.MissingLegalholdConsentOldClients) clientError ClientMissingLegalholdConsent = StdError (errorToWai @'E.MissingLegalholdConsent) clientError ClientCodeAuthenticationFailed = StdError verificationCodeAuthFailed clientError ClientCodeAuthenticationRequired = StdError verificationCodeRequired diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 2feb733c77..4958a8c39a 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -356,9 +356,7 @@ servantSitemap = userClientAPI :: ServerT UserClientAPI (Handler r) userClientAPI = Named @"add-client" (callsFed (exposeAnnotations addClient)) - :<|> Named - @"update-client" - updateClient + :<|> Named @"update-client" updateClient :<|> Named @"delete-client" deleteClient :<|> Named @"list-clients" listClients :<|> Named @"get-client" getClient diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index ea7a6ec38e..bdc0a3548e 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -127,6 +127,8 @@ data ConnectionError ConnectSameBindingTeamUsers | -- | Something doesn't work because somebody has a LH device and somebody else has not granted consent. ConnectMissingLegalholdConsent + | -- | Same as above, but because old clients that don't support LH are still in the game. + ConnectMissingLegalholdConsentOldClients | -- | Remote connection creation or update failed because of a federation error ConnectFederationError FederationError | -- | The teams of the users that want to connect do not federate @@ -183,6 +185,7 @@ data ClientError | ClientLegalHoldCannotBeAdded | ClientFederationError FederationError | ClientCapabilitiesCannotBeRemoved + | ClientMissingLegalholdConsentOldClients | ClientMissingLegalholdConsent | ClientCodeAuthenticationFailed | ClientCodeAuthenticationRequired diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 65befb08cc..1735cd65d5 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -66,12 +66,13 @@ import Cassandra (MonadClient) import Conduit (runConduit, (.|)) import Control.Error (ExceptT) import Control.Error.Util -import Control.Lens (view, (.~), (?~), (^.)) +import Control.Lens (view, (.~), (?~), (^.), (^?)) import Control.Monad.Catch import Control.Monad.Trans.Except (runExceptT, throwE) import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Lens import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as BL import Data.Conduit.List qualified as C @@ -979,7 +980,14 @@ guardLegalhold protectee userClients = do res <- lift . wrapHttp $ galleyRequest PUT req case Bilge.statusCode res of 200 -> pure () - 403 -> throwE ClientMissingLegalholdConsent + 403 -> case Bilge.responseJsonMaybe @Value res >>= (^? key "label") of + Just "missing-legalhold-consent" -> throwE ClientMissingLegalholdConsent + Just "missing-legalhold-consent-old-clients" -> throwE ClientMissingLegalholdConsentOldClients + _ -> + -- only happens if galley misbehaves (fisx: this could also be a parse error if we + -- used a more constraining type to send back & forth between brig and galley, but + -- merging brig and galley would make this train of thought go away more naturally). + throwE ClientMissingLegalholdConsent 404 -> pure () -- allow for galley not to be ready, so the set of valid deployment orders is non-empty. _ -> throwM internalServerError where diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 9d065a5131..18b2df3cad 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -478,13 +478,15 @@ guardLegalholdPolicyConflictsH :: Member (Input Opts) r, Member TeamStore r, Member P.TinyLog r, - Member (ErrorS 'MissingLegalholdConsent) r + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'MissingLegalholdConsentOldClients) r ) => GuardLegalholdPolicyConflicts -> Sem r () guardLegalholdPolicyConflictsH glh = do mapError @LegalholdConflicts (const $ Tagged @'MissingLegalholdConsent ()) $ - guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) + mapError @LegalholdConflictsOldClients (const $ Tagged @'MissingLegalholdConsentOldClients ()) $ + guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) -- | Get an MLS conversation client list iGetMLSClientListForConv :: diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index a6d098b459..2c7ec7aa8b 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -16,12 +16,18 @@ -- with this program. If not, see . {-# OPTIONS_GHC -Wno-overlapping-patterns #-} -module Galley.API.LegalHold.Conflicts where - -import Control.Lens (view) +module Galley.API.LegalHold.Conflicts + ( guardQualifiedLegalholdPolicyConflicts, + guardLegalholdPolicyConflicts, + LegalholdConflicts (LegalholdConflicts), + LegalholdConflictsOldClients (LegalholdConflictsOldClients), + ) +where + +import Control.Lens (view, (^.)) import Data.ByteString.Conversion (toByteString') import Data.Id -import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) +import Data.LegalHold (UserLegalHoldStatus (..)) import Data.Map qualified as Map import Data.Misc import Data.Qualified @@ -45,9 +51,12 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts +data LegalholdConflictsOldClients = LegalholdConflictsOldClients + guardQualifiedLegalholdPolicyConflicts :: ( Member BrigAccess r, Member (Error LegalholdConflicts) r, + Member (Error LegalholdConflictsOldClients) r, Member (Input (Local ())) r, Member (Input Opts) r, Member TeamStore r, @@ -73,6 +82,7 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do guardLegalholdPolicyConflicts :: ( Member BrigAccess r, Member (Error LegalholdConflicts) r, + Member (Error LegalholdConflictsOldClients) r, Member (Input Opts) r, Member TeamStore r, Member P.TinyLog r @@ -86,7 +96,10 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do opts <- input case view (settings . featureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> case FutureWork @'LegalholdPlusFederationNotImplemented () of - FutureWork () -> pure () -- FUTUREWORK: if federation is enabled, we still need to run the guard! + FutureWork () -> + -- FUTUREWORK: if federation is enabled, we still need to run the guard! + -- see also: LegalholdPlusFederationNotImplemented + pure () FeatureLegalHoldDisabledByDefault -> guardLegalholdPolicyConflictsUid self otherClients FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> guardLegalholdPolicyConflictsUid self otherClients @@ -94,82 +107,72 @@ guardLegalholdPolicyConflictsUid :: forall r. ( Member BrigAccess r, Member (Error LegalholdConflicts) r, + Member (Error LegalholdConflictsOldClients) r, Member TeamStore r, Member P.TinyLog r ) => UserId -> UserClients -> Sem r () -guardLegalholdPolicyConflictsUid self otherClients = do - let otherCids :: [ClientId] - otherCids = Set.toList . Set.unions . Map.elems . userClients $ otherClients - - otherUids :: [UserId] - otherUids = nub $ Map.keys . userClients $ otherClients - - when (nub otherUids /= [self {- if all other clients belong to us, there can be no conflict -}]) $ do - allClients :: UserClientsFull <- lookupClientsFull (nub $ self : otherUids) - - let selfClients :: [Client.Client] = - allClients - & Client.userClientsFull - & Map.lookup self - & fromMaybe Set.empty - & Set.toList - - otherClientHasLH :: Bool - otherClientHasLH = - let clients = - allClients - & Client.userClientsFull - & Map.delete self - & Map.elems - & Set.unions - & Set.toList - & filter ((`elem` otherCids) . Client.clientId) - in Client.LegalHoldClientType `elem` (Client.clientType <$> clients) - - checkSelfHasLHClients :: Bool - checkSelfHasLHClients = - any ((== Client.LegalHoldClientType) . Client.clientType) selfClients - - checkSelfHasOldClients :: Bool - checkSelfHasOldClients = - any isOld selfClients - where - isOld :: Client.Client -> Bool - isOld = - (Client.ClientSupportsLegalholdImplicitConsent `Set.notMember`) - . Client.fromClientCapabilityList - . Client.clientCapabilities - - checkConsentMissing :: Sem r Bool - checkConsentMissing = do - -- (we could also get the profile from brig. would make the code slightly more - -- concise, but not really help with the rpc back-and-forth, so, like, why?) - mbUser <- accountUser <$$> getUser self - mbTeamMember <- join <$> for (mbUser >>= userTeam) (`getTeamMember` self) - let lhStatus = maybe defUserLegalHoldStatus (view legalHoldStatus) mbTeamMember - pure (lhStatus == UserLegalHoldNoConsent) - - P.debug $ - Log.field "self" (toByteString' self) - Log.~~ Log.field "otherClients" (toByteString' $ show otherClients) - Log.~~ Log.field "otherClientHasLH" (toByteString' otherClientHasLH) - Log.~~ Log.field "checkSelfHasOldClients" (toByteString' checkSelfHasOldClients) - Log.~~ Log.field "checkSelfHasLHClients" (toByteString' checkSelfHasLHClients) - Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) - - -- (I've tried to order the following checks for minimum IO; did it work? ~~fisx) - when otherClientHasLH $ do - when checkSelfHasOldClients $ do - P.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: old clients" :: Text) - throw LegalholdConflicts - - unless checkSelfHasLHClients {- carrying a LH device implies having granted LH consent -} $ do - whenM checkConsentMissing $ do - -- We assume this is impossible, since conversations are automatically - -- blocked if LH consent is missing of any participant. - -- We add this check here as an extra failsafe. - P.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text) +guardLegalholdPolicyConflictsUid self (Map.keys . userClients -> otherUids) = do + allClients :: UserClientsFull <- lookupClientsFull (nub $ self : otherUids) + + let allClientsMetadata :: [Client.Client] + allClientsMetadata = + allClients + & Client.userClientsFull + & Map.elems + & Set.unions + & Set.toList + + anyClientHasLH :: Bool + anyClientHasLH = Client.LegalHoldClientType `elem` (Client.clientType <$> allClientsMetadata) + + anyClientIsOld :: Bool + anyClientIsOld = any isOld allClientsMetadata + where + isOld :: Client.Client -> Bool + isOld = + (Client.ClientSupportsLegalholdImplicitConsent `Set.notMember`) + . Client.fromClientCapabilityList + . Client.clientCapabilities + + checkAnyConsentMissing :: Sem r Bool + checkAnyConsentMissing = do + users :: [User] <- accountUser <$$> getUsers (self : otherUids) + -- NB: `users` can't be empty! + let checkUserConsentMissing :: User -> Sem r Bool + checkUserConsentMissing user = + case userTeam user of + Just tid -> do + mbMem <- getTeamMember tid (Wire.API.User.userId user) + case mbMem of + Nothing -> pure True -- it's weird that there is a member id but no member, we better bail + Just mem -> pure $ mem ^. legalHoldStatus `notElem` [UserLegalHoldDisabled, UserLegalHoldEnabled] + Nothing -> do + pure True -- personal users can not give consent + or <$> checkUserConsentMissing `mapM` users + + P.debug $ + Log.field "self" (toByteString' self) + Log.~~ Log.field "allClients" (toByteString' $ show allClients) + Log.~~ Log.field "allClientsMetadata" (toByteString' $ show allClientsMetadata) + Log.~~ Log.field "anyClientIsOld" (toByteString' anyClientIsOld) + Log.~~ Log.field "anyClientHasLH" (toByteString' anyClientHasLH) + Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) + + -- when no other client is under LH, then we're good and can leave this function. but... + when anyClientHasLH $ do + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[5]: anyClientHasLH" :: Text) + if anyClientIsOld + then do + -- you can't effectively give consent as long as you have old clients: when using the + -- old clients, you still would not be exposed to the popups and red dot where + -- required. + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: anyClientIsOld" :: Text) + throw LegalholdConflictsOldClients + else do + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: checkConsentMissing?" :: Text) + whenM checkAnyConsentMissing $ do + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[4]: checkConsentMissing!" :: Text) throw LegalholdConflicts diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 66657736a6..47822ff352 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -36,7 +36,6 @@ module Galley.API.Message where import Control.Lens -import Control.Monad.Extra (eitherM) import Data.Aeson (encode) import Data.Bifunctor import Data.ByteString.Conversion (toByteString') @@ -232,10 +231,9 @@ getRemoteClients remoteMembers = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> fedClient @'Brig @"get-user-clients" (GetUserClients uids) --- FUTUREWORK: sender should be Local UserId postRemoteOtrMessage :: (Member FederatorAccess r) => - Qualified UserId -> + Local UserId -> Remote ConvId -> ByteString -> Sem r (PostOtrResponse MessageSendingStatus) @@ -243,7 +241,7 @@ postRemoteOtrMessage sender conv rawMsg = do let msr = ProteusMessageSendRequest { convId = tUnqualified conv, - sender = qUnqualified sender, + sender = qUnqualified (tUntagged sender), rawMessage = Base64ByteString rawMsg } rpc = fedClient @'Galley @"send-message" msr @@ -317,14 +315,10 @@ postBroadcast lusr con msg = runError $ do (flattenMap $ qualifiedNewOtrRecipients msg) (qualifiedNewOtrClientMismatchStrategy msg) otrResult = mkMessageSendingStatus (toUTCTimeMillis now) mismatch - unless sendMessage $ do - let lhProtectee = qualifiedUserToProtectee (tDomain lusr) User (tUntagged lusr) - missingClients = qmMissing mismatch - mapError @LegalholdConflicts @(MessageNotSent MessageSendingStatus) - (const MessageNotSentLegalhold) - $ runLocalInput lusr - $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients + guardQualifiedLegalholdPolicyConflictsWrapper User (tUntagged lusr) localClients [] lusr + + unless sendMessage $ do throw $ MessageNotSentClientMissing otrResult failedToSend <- @@ -353,6 +347,7 @@ postBroadcast lusr con msg = runError $ do unless (length localUserIdsToLookup <= limit) $ throwS @'BroadcastLimitExceeded selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: ( Member (ErrorS 'BroadcastLimitExceeded) r, Member TeamStore r @@ -458,17 +453,14 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = (flattenMap $ qualifiedNewOtrRecipients msg) (qualifiedNewOtrClientMismatchStrategy msg) otrResult = mkMessageSendingStatus nowMillis mismatch + + -- throw error if there is a legalhold policy conflict + guardQualifiedLegalholdPolicyConflictsWrapper senderType sender localClients qualifiedRemoteClients lcnv + + -- throw error if clients are missing unless sendMessage $ do - let lhProtectee = qualifiedUserToProtectee localDomain senderType sender - missingClients = qmMissing mismatch - legalholdErr = pure MessageNotSentLegalhold - clientMissingErr = pure $ MessageNotSentClientMissing otrResult - e <- - runLocalInput lcnv - . eitherM (const legalholdErr) (const clientMissingErr) - . runError @LegalholdConflicts - $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients - throw e + throw $ MessageNotSentClientMissing otrResult + failedToSend <- sendMessages now @@ -533,6 +525,48 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = qualifiedOtrRecipientsMap $ qualifiedNewOtrRecipients msg +guardQualifiedLegalholdPolicyConflictsWrapper :: + ( Member BrigAccess r, + Member (Error (MessageNotSent MessageSendingStatus)) r, + Member (Input Opts) r, + Member TeamStore r, + Member P.TinyLog r + ) => + UserType -> + Qualified UserId -> + Clients.Clients -> + [Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))] -> + Local any -> + Sem r () +guardQualifiedLegalholdPolicyConflictsWrapper senderType sender localClients qualifiedRemoteClients lany = do + wrapper $ guardQualifiedLegalholdPolicyConflicts lhProtectee allReceivingClients + where + localDomain = tDomain lany + lhProtectee = qualifiedUserToProtectee localDomain senderType sender + + allReceivingClients = mkQualifiedUserClients $ parseLocal localClients <> parseRemote qualifiedRemoteClients + where + parseLocal :: Clients.Clients -> QualifiedRecipientSet + parseLocal = + Set.fromList + . mconcat + . fmap (\(uid, cids) -> (localDomain,uid,) <$> cids) + . Clients.toList + + parseRemote :: [Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))] -> QualifiedRecipientSet + parseRemote = + Set.fromList + . mconcat + . fmap (\((dom, uid), Set.toList -> cids) -> (dom,uid,) <$> cids) + . mconcat + . fmap Map.toList + . rights + + wrapper = + runLocalInput lany + . mapError @LegalholdConflicts @(MessageNotSent MessageSendingStatus) (const MessageNotSentLegalhold) + . mapError @LegalholdConflictsOldClients @(MessageNotSent MessageSendingStatus) (const MessageNotSentLegalholdOldClients) + -- FUTUREWORK: This is just a workaround and would not be needed if we had a proper monoid/semigroup instance for Map where the values have a monoid instance. collectFailedToSend :: Foldable f => diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index cb5c20c7de..bd860ef86b 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -1232,7 +1232,7 @@ postProteusMessage sender zcon conv msg = runLocalInput sender $ do foldQualified sender (\c -> postQualifiedOtrMessage User (tUntagged sender) (Just zcon) c (rpValue msg)) - (\c -> postRemoteOtrMessage (tUntagged sender) c (rpRaw msg)) + (\c -> postRemoteOtrMessage sender c (rpRaw msg)) conv postProteusBroadcast :: diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index f358015010..91315aa036 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -69,7 +69,6 @@ import TestSetup import Wire.API.Connection (UserConnection) import Wire.API.Connection qualified as Conn import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) -import Wire.API.Message qualified as Msg import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Feature qualified as Public @@ -80,7 +79,6 @@ import Wire.API.Team.Member qualified as Team import Wire.API.Team.Permission import Wire.API.Team.Role import Wire.API.User.Client -import Wire.API.User.Client qualified as Client onlyIfLhWhitelisted :: TestM () -> TestM () onlyIfLhWhitelisted action = do @@ -131,7 +129,6 @@ testsPublic s = [ testGroup -- FUTUREWORK: ungroup this level "teams listed" [ test s "happy flow" testInWhitelist, - test s "handshake between LH device and user with old clients is blocked" testOldClientsBlockDeviceHandshake, testGroup "no-consent" $ do connectFirst <- ("connectFirst",) <$> [False, True] teamPeer <- ("teamPeer",) <$> [False, True] @@ -164,10 +161,7 @@ testsPublic s = ] ], testOnlyIfLhWhitelisted s "Cannot create conversation with both LH activated and non-consenting users" testCannotCreateGroupWithUsersInConflict, - test s "bench hack" testBenchHack, - test s "User cannot fetch prekeys of LH users if consent is missing" (testClaimKeys TCKConsentMissing), - test s "User cannot fetch prekeys of LH users: if user has old client" (testClaimKeys TCKOldClient), - test s "User can fetch prekeys of LH users if consent is given and user has only new clients" (testClaimKeys TCKConsentAndNewClients) + test s "bench hack" testBenchHack ] ] ] @@ -698,92 +692,6 @@ testInWhitelist = do assertEqual "last_prekey should be set when LH is pending" (Just (head someLastPrekeys)) lastPrekey' assertEqual "client.id should be set when LH is pending" (Just someClientId) clientId' -testOldClientsBlockDeviceHandshake :: TestM () -testOldClientsBlockDeviceHandshake = do - -- "handshake between LH device and user with old devices is blocked" - -- - -- this specifically checks the place that handles otr messages and responds with status - -- 412 and a list of missing clients. - -- - -- if any of those clients are LH, this test provodes a "missing-legalhold-consent" error - -- instead, without any information about the LH clients. the condition is actually "has - -- old device or has not granted consent", but the latter part is blocked earlier in 1:1 and - -- group conversations, and hard to test at the device level.) - -- - -- tracked here: https://wearezeta.atlassian.net/browse/SQSERVICES-454 - - (legalholder, tid) <- createBindingTeam - legalholder2 <- view Team.userId <$> addUserToTeam legalholder tid - (peer, tid2) <- - -- has to be a team member, granting LH consent for personal users is not supported. - createBindingTeam - - let doEnableLH :: HasCallStack => UserId -> UserId -> TestM ClientId - doEnableLH owner uid = do - requestLegalHoldDevice owner uid tid !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) uid uid tid !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid tid - liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - getInternalClientsFull (UserSet $ Set.singleton uid) - <&> do - userClientsFull - >>> Map.elems - >>> Set.unions - >>> Set.toList - >>> head - >>> clientId - - putLHWhitelistTeam tid !!! const 200 === statusCode - - withDummyTestServiceForTeam legalholder tid $ \_chan -> do - legalholderLHDevice <- doEnableLH legalholder legalholder - _legalholder2LHDevice <- doEnableLH legalholder legalholder2 - - let caps = Set.singleton Client.ClientSupportsLegalholdImplicitConsent - legalholderClient <- do - clnt <- randomClientWithCaps legalholder (someLastPrekeys !! 1) (Just caps) - ensureClientCaps legalholder clnt (Client.ClientCapabilityList caps) - pure clnt - legalholder2Client <- do - clnt <- randomClient legalholder2 (someLastPrekeys !! 3) - -- this another way to do it (instead of providing caps during client creation). - ensureClientCaps legalholder2 clnt (Client.ClientCapabilityList mempty) - upgradeClientToLH legalholder2 clnt - ensureClientCaps legalholder2 clnt (Client.ClientCapabilityList caps) - pure clnt - putLHWhitelistTeam tid2 !!! const 200 === statusCode - connectUsers peer (List1.list1 legalholder [legalholder2]) - - convId <- - decodeConvId - <$> ( postConv peer [legalholder, legalholder2] (Just "gossip") [] Nothing Nothing - UserId -> ClientId -> TestM ResponseLBS - runit sender senderClient = do - postOtrMessage id sender senderClient convId rcps - where - rcps = - [ (legalholder, legalholderClient, "ciphered"), - (legalholder, legalholderLHDevice, "ciphered"), - (legalholder2, legalholder2Client, "ciphered") - -- legalholder2 LH device missing - ] - - -- LH devices are treated as clients that have the ClientSupportsLegalholdImplicitConsent - -- capability (so LH doesn't break for users who have LH devices; it sounds silly, but - -- it's good to test this, since it did require adding a few lines of production code in - -- 'addClient' about client capabilities). - runit legalholder legalholderClient >>= errWith 412 (\(_ :: Msg.ClientMismatch) -> True) - - -- If user has a client without the ClientSupportsLegalholdImplicitConsent - -- capability then message sending is prevented to legalhold devices. - peerClient <- randomClient peer (someLastPrekeys !! 2) - runit peer peerClient >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") - upgradeClientToLH peer peerClient - runit peer peerClient >>= errWith 412 (\(_ :: Msg.ClientMismatch) -> True) - -- If LH is activated for other user in 1:1 conv, 1:1 conv is blocked testNoConsentBlockOne2OneConv :: HasCallStack => Bool -> Bool -> Bool -> Bool -> TestM () testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnection = do @@ -1112,69 +1020,6 @@ testCannotCreateGroupWithUsersInConflict = do createTeamConvAccessRaw userLHNotActivated tid [peer2, legalholder] (Just "corp + us") Nothing Nothing Nothing (Just roleNameWireMember) >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") -data TestClaimKeys - = TCKConsentMissing - | TCKOldClient - | TCKConsentAndNewClients - -testClaimKeys :: TestClaimKeys -> TestM () -testClaimKeys testcase = do - -- "cannot fetch prekeys of LH users if requester did not give consent or has old clients" - (legalholder, tid) <- createBindingTeam - (peer, teamPeer) <- createBindingTeam - - let doEnableLH :: HasCallStack => TeamId -> UserId -> UserId -> TestM ClientId - doEnableLH team owner uid = do - requestLegalHoldDevice owner uid team !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) uid uid team !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid team - liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - getInternalClientsFull (UserSet $ Set.singleton uid) - <&> do - userClientsFull - >>> Map.elems - >>> Set.unions - >>> Set.toList - >>> head - >>> clientId - - let makePeerClient :: TestM () - makePeerClient = case testcase of - TCKConsentMissing -> do - peerClient <- randomClient peer (someLastPrekeys !! 2) - upgradeClientToLH peer peerClient - TCKOldClient -> do - void $ randomClient peer (someLastPrekeys !! 2) - putLHWhitelistTeam teamPeer !!! const 200 === statusCode - TCKConsentAndNewClients -> do - peerClient <- randomClient peer (someLastPrekeys !! 2) - upgradeClientToLH peer peerClient - putLHWhitelistTeam teamPeer !!! const 200 === statusCode - - let assertResponse' :: Assertions () - assertResponse' = case testcase of - TCKConsentMissing -> bad - TCKOldClient -> bad - TCKConsentAndNewClients -> good - where - good = testResponse 200 Nothing - bad = testResponse 403 (Just "missing-legalhold-consent") - - let fetchKeys :: ClientId -> TestM () - fetchKeys legalholderLHDevice = do - getUsersPrekeysClientUnqualified peer legalholder legalholderLHDevice !!! assertResponse' - getUsersPrekeyBundleUnqualified peer legalholder !!! assertResponse' - let userClients = UserClients (Map.fromList [(legalholder, Set.fromList [legalholderLHDevice])]) - getMultiUserPrekeyBundleUnqualified peer userClients !!! assertResponse' - - putLHWhitelistTeam tid !!! const 200 === statusCode - - withDummyTestServiceForTeam legalholder tid $ \_chan -> do - legalholderLHDevice <- doEnableLH tid legalholder legalholder - - makePeerClient - fetchKeys legalholderLHDevice - testBenchHack :: HasCallStack => TestM () testBenchHack = do {- representative sample run on an old laptop: diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index d5884a6e59..8be3b15851 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -629,7 +629,7 @@ testOldClientsBlockDeviceHandshake = do -- this specifically checks the place that handles otr messages and responds with status -- 412 and a list of missing clients. -- - -- if any of those clients are LH, this test provodes a "missing-legalhold-consent" error + -- if any of those clients are LH, this test provides a "missing-legalhold-consent-old-clients" error -- instead, without any information about the LH clients. the condition is actually "has -- old device or has not granted consent", but the latter part is blocked earlier in 1:1 and -- group conversations, and hard to test at the device level.) @@ -705,7 +705,7 @@ testOldClientsBlockDeviceHandshake = do -- If user has a client without the ClientSupportsLegalholdImplicitConsent -- capability then message sending is prevented to legalhold devices. peerClient <- randomClient peer (someLastPrekeys !! 2) - runit peer peerClient >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") + runit peer peerClient >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent-old-clients") upgradeClientToLH peer peerClient runit peer peerClient >>= errWith 412 (\(_ :: Msg.ClientMismatch) -> True)