-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- 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 <https://www.gnu.org/licenses/>.
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}

module Galley.API.LegalHold.Conflicts
  ( guardQualifiedLegalholdPolicyConflicts,
    guardLegalholdPolicyConflicts,
    LegalholdConflicts (LegalholdConflicts),
    LegalholdConflictsOldClients (LegalholdConflictsOldClients),
  )
where

import Control.Lens (to, view, (^.))
import Data.ByteString.Conversion (toByteString')
import Data.Id
import Data.LegalHold (UserLegalHoldStatus (..))
import Data.Map qualified as Map
import Data.Misc
import Data.Qualified
import Data.Set qualified as Set
import Galley.API.Util
import Galley.Effects
import Galley.Effects.BrigAccess
import Galley.Effects.TeamStore
import Galley.Options
import Galley.Types.Teams
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import System.Logger.Class qualified as Log
import Wire.API.Team.Feature
import Wire.API.Team.LegalHold
import Wire.API.Team.Member
import Wire.API.User
import Wire.API.User.Client as Client

data LegalholdConflicts = LegalholdConflicts

data LegalholdConflictsOldClients = LegalholdConflictsOldClients

guardQualifiedLegalholdPolicyConflicts ::
  ( Member BrigAccess r,
    Member (Error LegalholdConflicts) r,
    Member (Input (Local ())) r,
    Member (Input Opts) r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  LegalholdProtectee ->
  QualifiedUserClients ->
  Sem r ()
guardQualifiedLegalholdPolicyConflicts :: forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
 Member (Input (Local ())) r, Member (Input Opts) r,
 Member TeamStore r, Member TinyLog r) =>
LegalholdProtectee -> QualifiedUserClients -> Sem r ()
guardQualifiedLegalholdPolicyConflicts LegalholdProtectee
protectee QualifiedUserClients
qclients = do
  Domain
localDomain <- Local () -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain (Local () -> Domain) -> Sem r (Local ()) -> Sem r Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> Sem r (Local ())
forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal ()
  LegalholdProtectee -> UserClients -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
 Member (Input Opts) r, Member TeamStore r, Member TinyLog r) =>
LegalholdProtectee -> UserClients -> Sem r ()
guardLegalholdPolicyConflicts LegalholdProtectee
protectee
    (UserClients -> Sem r ())
-> (QualifiedUserClients -> UserClients)
-> QualifiedUserClients
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map UserId (Set ClientId) -> UserClients
UserClients
    (Map UserId (Set ClientId) -> UserClients)
-> (QualifiedUserClients -> Map UserId (Set ClientId))
-> QualifiedUserClients
-> UserClients
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map UserId (Set ClientId)
-> Domain
-> Map Domain (Map UserId (Set ClientId))
-> Map UserId (Set ClientId)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map UserId (Set ClientId)
forall a. Monoid a => a
mempty Domain
localDomain
    (Map Domain (Map UserId (Set ClientId))
 -> Map UserId (Set ClientId))
-> (QualifiedUserClients -> Map Domain (Map UserId (Set ClientId)))
-> QualifiedUserClients
-> Map UserId (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedUserClients -> Map Domain (Map UserId (Set ClientId))
qualifiedUserClients
    (QualifiedUserClients -> Sem r ())
-> QualifiedUserClients -> Sem r ()
forall a b. (a -> b) -> a -> b
$ QualifiedUserClients
qclients

-- | 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 ::
  ( Member BrigAccess r,
    Member (Error LegalholdConflicts) r,
    Member (Input Opts) r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  LegalholdProtectee ->
  UserClients ->
  Sem r ()
guardLegalholdPolicyConflicts :: forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
 Member (Input Opts) r, Member TeamStore r, Member TinyLog r) =>
LegalholdProtectee -> UserClients -> Sem r ()
guardLegalholdPolicyConflicts LegalholdProtectee
LegalholdPlusFederationNotImplemented UserClients
_otherClients = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
guardLegalholdPolicyConflicts LegalholdProtectee
UnprotectedBot UserClients
_otherClients = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
guardLegalholdPolicyConflicts (ProtectedUser UserId
self) UserClients
otherClients = do
  Opts
opts <- Sem r Opts
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  case Getting
  (FeatureDefaults LegalholdConfig)
  Opts
  (FeatureDefaults LegalholdConfig)
-> Opts -> FeatureDefaults LegalholdConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> Opts -> Const (FeatureDefaults LegalholdConfig) Opts
Lens' Opts Settings
settings ((Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
 -> Opts -> Const (FeatureDefaults LegalholdConfig) Opts)
-> ((FeatureDefaults LegalholdConfig
     -> Const
          (FeatureDefaults LegalholdConfig)
          (FeatureDefaults LegalholdConfig))
    -> Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> Getting
     (FeatureDefaults LegalholdConfig)
     Opts
     (FeatureDefaults LegalholdConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FeatureFlags
 -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
-> Settings -> Const (FeatureDefaults LegalholdConfig) Settings
Lens' Settings FeatureFlags
featureFlags ((FeatureFlags
  -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
 -> Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> ((FeatureDefaults LegalholdConfig
     -> Const
          (FeatureDefaults LegalholdConfig)
          (FeatureDefaults LegalholdConfig))
    -> FeatureFlags
    -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
-> (FeatureDefaults LegalholdConfig
    -> Const
         (FeatureDefaults LegalholdConfig)
         (FeatureDefaults LegalholdConfig))
-> Settings
-> Const (FeatureDefaults LegalholdConfig) Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FeatureFlags -> FeatureDefaults LegalholdConfig)
-> (FeatureDefaults LegalholdConfig
    -> Const
         (FeatureDefaults LegalholdConfig)
         (FeatureDefaults LegalholdConfig))
-> FeatureFlags
-> Const (FeatureDefaults LegalholdConfig) FeatureFlags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to FeatureFlags -> FeatureDefaults LegalholdConfig
forall {k} (x :: k) (f :: k -> *) (xs :: [k]).
NpProject x xs =>
NP f xs -> f x
npProject) Opts
opts of
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldDisabledPermanently -> case forall {k} (label :: k) payload.
payload -> FutureWork label payload
forall (label :: LegalholdProtectee) payload.
payload -> FutureWork label payload
FutureWork @'LegalholdPlusFederationNotImplemented () of
      FutureWork () ->
        -- FUTUREWORK: if federation is enabled, we still need to run the guard!
        -- see also: LegalholdPlusFederationNotImplemented
        () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldDisabledByDefault -> UserId -> UserClients -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
 Member TeamStore r, Member TinyLog r) =>
UserId -> UserClients -> Sem r ()
guardLegalholdPolicyConflictsUid UserId
self UserClients
otherClients
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> UserId -> UserClients -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
 Member TeamStore r, Member TinyLog r) =>
UserId -> UserClients -> Sem r ()
guardLegalholdPolicyConflictsUid UserId
self UserClients
otherClients

guardLegalholdPolicyConflictsUid ::
  forall r.
  ( Member BrigAccess r,
    Member (Error LegalholdConflicts) r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  UserId ->
  UserClients ->
  Sem r ()
guardLegalholdPolicyConflictsUid :: forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
 Member TeamStore r, Member TinyLog r) =>
UserId -> UserClients -> Sem r ()
guardLegalholdPolicyConflictsUid UserId
self (Map UserId (Set ClientId) -> [UserId]
forall k a. Map k a -> [k]
Map.keys (Map UserId (Set ClientId) -> [UserId])
-> (UserClients -> Map UserId (Set ClientId))
-> UserClients
-> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserClients -> Map UserId (Set ClientId)
userClients -> [UserId]
otherUids) = do
  UserClientsFull
allClients :: UserClientsFull <- [UserId] -> Sem r UserClientsFull
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r UserClientsFull
lookupClientsFull ([UserId] -> [UserId]
forall a. Eq a => [a] -> [a]
nub ([UserId] -> [UserId]) -> [UserId] -> [UserId]
forall a b. (a -> b) -> a -> b
$ UserId
self UserId -> [UserId] -> [UserId]
forall a. a -> [a] -> [a]
: [UserId]
otherUids)

  let allClientsMetadata :: [Client.Client]
      allClientsMetadata :: [Client]
allClientsMetadata =
        UserClientsFull
allClients
          UserClientsFull
-> (UserClientsFull -> Map UserId (Set Client))
-> Map UserId (Set Client)
forall a b. a -> (a -> b) -> b
& UserClientsFull -> Map UserId (Set Client)
Client.userClientsFull
          Map UserId (Set Client)
-> (Map UserId (Set Client) -> [Set Client]) -> [Set Client]
forall a b. a -> (a -> b) -> b
& Map UserId (Set Client) -> [Set Client]
forall k a. Map k a -> [a]
Map.elems
          [Set Client] -> ([Set Client] -> Set Client) -> Set Client
forall a b. a -> (a -> b) -> b
& [Set Client] -> Set Client
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
          Set Client -> (Set Client -> [Client]) -> [Client]
forall a b. a -> (a -> b) -> b
& Set Client -> [Client]
forall a. Set a -> [a]
Set.toList

      anyClientHasLH :: Bool
      anyClientHasLH :: Bool
anyClientHasLH = ClientType
Client.LegalHoldClientType ClientType -> [ClientType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Client -> ClientType
Client.clientType (Client -> ClientType) -> [Client] -> [ClientType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Client]
allClientsMetadata)

      checkAnyConsentMissing :: Sem r Bool
      checkAnyConsentMissing :: Sem r Bool
checkAnyConsentMissing = do
        [User]
users <- [UserId] -> Sem r [User]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r [User]
getUsers (UserId
self UserId -> [UserId] -> [UserId]
forall a. a -> [a] -> [a]
: [UserId]
otherUids)
        -- NB: `users` can't be empty!
        let checkUserConsentMissing :: User -> Sem r Bool
            checkUserConsentMissing :: User -> Sem r Bool
checkUserConsentMissing User
user =
              case User -> Maybe TeamId
userTeam User
user of
                Just TeamId
tid -> do
                  Maybe TeamMember
mbMem <- TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
getTeamMember TeamId
tid (User -> UserId
Wire.API.User.userId User
user)
                  case Maybe TeamMember
mbMem of
                    Maybe TeamMember
Nothing -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- it's weird that there is a member id but no member, we better bail
                    Just TeamMember
mem -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Sem r Bool) -> Bool -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ case TeamMember
mem TeamMember
-> Getting UserLegalHoldStatus TeamMember UserLegalHoldStatus
-> UserLegalHoldStatus
forall s a. s -> Getting a s a -> a
^. Getting UserLegalHoldStatus TeamMember UserLegalHoldStatus
forall (tag :: PermissionTag) (f :: * -> *).
Functor f =>
(UserLegalHoldStatus -> f UserLegalHoldStatus)
-> TeamMember' tag -> f (TeamMember' tag)
legalHoldStatus of
                      UserLegalHoldStatus
UserLegalHoldDisabled -> Bool
False
                      UserLegalHoldStatus
UserLegalHoldPending -> Bool
False
                      UserLegalHoldStatus
UserLegalHoldEnabled -> Bool
False
                      UserLegalHoldStatus
UserLegalHoldNoConsent -> Bool
True
                Maybe TeamId
Nothing -> do
                  Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- personal users can not give consent
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Sem r [Bool] -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User -> Sem r Bool
checkUserConsentMissing (User -> Sem r Bool) -> [User] -> Sem r [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [User]
users

  (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.debug ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"self" (UserId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' UserId
self)
      (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"allClients" (String -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ UserClientsFull -> String
forall a. Show a => a -> String
show UserClientsFull
allClients)
      (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"allClientsMetadata" (String -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [Client] -> String
forall a. Show a => a -> String
show [Client]
allClientsMetadata)
      (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"anyClientHasLH" (Bool -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' Bool
anyClientHasLH)
      (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (Text
"guardLegalholdPolicyConflicts[1]" :: Text)

  -- when no other client is under LH, then we're good and can leave this function.  but...
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
anyClientHasLH (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.debug ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (Text
"guardLegalholdPolicyConflicts[5]: anyClientHasLH" :: Text)
    Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM Sem r Bool
checkAnyConsentMissing (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.debug ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (Text
"guardLegalholdPolicyConflicts[4]: checkConsentMissing!" :: Text)
      LegalholdConflicts -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw LegalholdConflicts
LegalholdConflicts