...

libs/wire-api/src/Wire/API/User/Client.hs

@@ -26,9 +26,12 @@ module Wire.API.User.Client
     -- * UserClients
     UserClientMap (..),
     QualifiedUserClientMap (..),
+    UserClientsFull (..),
+    userClientsFullToUserClients,
     UserClients (..),
     QualifiedUserClients (..),
     filterClients,
+    filterClientsFull,
 
     -- * Client
     Client (..),
@@ -271,6 +274,16 @@ instance (Typeable a, ToSchema (UserClientMap a)) => ToSchema (QualifiedUserClie
 --------------------------------------------------------------------------------
 -- UserClients
 
+newtype UserClientsFull = UserClientsFull
+  { userClientsFull :: Map UserId (Set Client)
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving newtype (Semigroup, Monoid)
+  deriving (Arbitrary) via (GenericUniform UserClientsFull)
+
+userClientsFullToUserClients :: UserClientsFull -> UserClients
+userClientsFullToUserClients (UserClientsFull mp) = UserClients $ Set.map clientId <$> mp
+
 -- TODO: check if example generated by swagger look okay (probably not)
 newtype UserClients = UserClients
   { userClients :: Map UserId (Set ClientId)
@@ -320,6 +333,9 @@ instance Arbitrary UserClients where
 filterClients :: (Set ClientId -> Bool) -> UserClients -> UserClients
 filterClients p (UserClients c) = UserClients $ Map.filter p c
 
+filterClientsFull :: (Set Client -> Bool) -> UserClientsFull -> UserClientsFull
+filterClientsFull p (UserClientsFull c) = UserClientsFull $ Map.filter p c
+
 newtype QualifiedUserClients = QualifiedUserClients
   { qualifiedUserClients :: Map Domain UserClients
   }
@@ -352,7 +368,18 @@ data Client = Client
     clientLabel :: Maybe Text,
     clientCookie :: Maybe CookieLabel,
     clientLocation :: Maybe Location,
-    clientModel :: Maybe Text
+    clientModel :: Maybe Text,
+    clientCapabilities :: Maybe _
+    {-
+
+      instead of adding it here, we can also call brig when we need this info in galley:
+
+    get "/clients/:client/capabilities" (continue getClientCapabilitiesH) $
+      zauthUserId
+        .&. capture "client"
+        .&. accept "application" "json"
+
+      -}
   }
   deriving stock (Eq, Show, Generic, Ord)
   deriving (Arbitrary) via (GenericUniform Client)

services/galley/src/Galley/API/Error.hs

@@ -215,6 +215,9 @@ userLegalHoldNotPending = Error status412 "legalhold-not-pending" "legal hold ca
 noLegalHoldDeviceAllocated :: Error
 noLegalHoldDeviceAllocated = Error status404 "legalhold-no-device-allocated" "no legal hold device is registered for this user. POST /teams/:tid/legalhold/:uid/ to start the flow."
 
+userLegalHoldNotSupported :: Error
+userLegalHoldNotSupported = Error status412 "legalhold-not-supported" "you have not granted consent, or you are using old clients that do not support legalhold"
+
 disableSsoNotImplemented :: Error
 disableSsoNotImplemented =
   Error

services/galley/src/Galley/API/Update.hs

@@ -107,6 +107,7 @@ import qualified Wire.API.Event.Conversation as Public
 import qualified Wire.API.Message as Public
 import qualified Wire.API.Message.Proto as Proto
 import Wire.API.Routes.Public.Galley (UpdateResponses)
+import qualified Wire.API.User.Client as Client
 
 acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response
 acceptConvH (usr ::: conn ::: cnv) = do
@@ -973,7 +974,9 @@ handleOtrResponse ::
   Galley OtrResult
 handleOtrResponse usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of
   ValidOtrRecipients m r -> go r >> pure (OtrSent m)
-  MissingOtrRecipients m -> pure (OtrMissingRecipients m)
+  MissingOtrRecipients m -> do
+    guardLegalholdPolicyConflicts usr m
+    pure (OtrMissingRecipients m)
   InvalidOtrSenderUser -> throwM convNotFound
   InvalidOtrSenderClient -> throwM unknownClient
 
@@ -1058,3 +1061,49 @@ checkOtrRecipients usr sid prs vms vcs val now
       OtrIgnoreAllMissing -> Clients.nil
       OtrReportMissing us -> Clients.filter (`Set.member` us) miss
       OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss
+
+-- | If user has legalhold status `no_consent` or has client devices that have no legalhold
+-- capability, and some of the clients she is about to get connected are LH devices, respond
+-- with 412 and do not process notification.
+--
+-- This is a fallback safeguard that shouldn't get triggered if backend and clients work as
+-- intended.
+guardLegalholdPolicyConflicts :: UserId -> ClientMismatch -> Galley ()
+guardLegalholdPolicyConflicts uid mismatch = do
+  let missingCids :: [ClientId]
+      missingCids = Set.toList . Set.unions . Map.elems . userClients . missingClients $ mismatch
+
+      missinUids :: [UserId]
+      missingUids = nub $ Map.keys . userClients . missingClients $ mismatch
+
+  allcs :: UserClientsFull <- Intra.lookupClientsFull (uid : missingUids)
+
+  let checkLHPresent :: Bool
+      checkLHPresent = do
+        let clients =
+              allcs
+                & Client.userClientsFull
+                & Map.delete uid
+                & Map.elems
+                & Set.unions
+                & Set.toList
+                & filter ((`elem` cids) . Client.clientId)
+
+        pure $ Client.LegalHoldClientType `elem` (Client.clientType <$> clients)
+
+      checkUserHasOldClients :: Bool
+      checkUserHasOldClients = undefined
+
+      checkUserHasLHClients :: Bool
+      checkUserHasLHClients = undefined
+
+      checkConsentMissing :: Galley Bool
+      checkConsentMissing = undefined uid
+
+  -- (I've tried to order the following checks for minimum IO; did it work?  ~~fisx)
+  when checkLHPresent $ do
+    when checkUserHasOldClients $ do
+      throwM userLegalHoldNotSupported
+    when (not checkUserHasLHClients {- carrying a LH device implies having granted LH consent -}) $ do
+      whenM checkConsentMissing $ do
+        throwM userLegalHoldNotSupported

services/galley/src/Galley/Intra/Client.hs

@@ -17,6 +17,7 @@
 
 module Galley.Intra.Client
   ( lookupClients,
+    lookupClientsFull,
     notifyClientsAboutLegalHoldRequest,
     addLegalHoldClientToUser,
     removeLegalHoldClientFromUser,
@@ -40,12 +41,12 @@ import Galley.API.Error
 import Galley.App
 import Galley.External.LegalHoldService
 import Galley.Intra.Util
-import Galley.Types (UserClients, filterClients)
 import Imports
 import Network.HTTP.Types.Method
 import Network.HTTP.Types.Status
 import Network.Wai.Utilities.Error
 import qualified System.Logger.Class as Logger
+import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull)
 
 -- | Calls 'Brig.API.internalListClientsH'.
 lookupClients :: [UserId] -> Galley UserClients
@@ -60,6 +61,19 @@ lookupClients uids = do
   clients <- parseResponse (Error status502 "server-error") r
   return $ filterClients (not . Set.null) clients
 
+-- | Calls 'Brig.API.internalListClientsFullH'.
+lookupClientsFull :: [UserId] -> Galley UserClientsFull
+lookupClientsFull uids = do
+  (brigHost, brigPort) <- brigReq
+  r <-
+    call "brig" $
+      method POST . host brigHost . port brigPort
+        . path "/i/clients/full"
+        . json (UserSet $ Set.fromList uids)
+        . expect2xx
+  clients <- error "parseResponse (Error status502 \"server-error\")" r
+  return $ filterClientsFull (not . Set.null) clients
+
 -- | Calls 'Brig.API.legalHoldClientRequestedH'.
 notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> Galley ()
 notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do

services/galley/test/integration/API/Teams/LegalHold.hs

@@ -783,6 +783,18 @@ testNoConsentBlockDeviceHandshake :: TestM ()
 testNoConsentBlockDeviceHandshake = do
   -- "handshake between LH device and user without consent is blocked"
   -- tracked here: https://wearezeta.atlassian.net/browse/SQSERVICES-454
+
+  {-
+    - set up team and personal user
+    - everybody grants consent
+    - create conv, send some messages
+    - personal user adds old client
+    - send another message
+    - boom!
+    - (then we can also remove the messaging tests in https://wearezeta.atlassian.net/browse/SQSERVICES-429.)
+    - (maybe can we even avoid implementing https://wearezeta.atlassian.net/browse/SQSERVICES-405 altogether?)
+  -}
+
   pure ()
 
 testNoConsentBlockOne2OneConv :: TestM ()