{-# 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
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 () ->
() -> 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)
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
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
[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)
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