module Galley.API.MLS.Migration where
import Brig.Types.Intra
import Data.Qualified
import Data.Set qualified as Set
import Data.Time
import Galley.API.MLS.Types
import Galley.Effects.BrigAccess
import Galley.Effects.FederatorAccess
import Galley.Types.Conversations.Members
import Imports
import Polysemy
import Wire.API.Federation.API
import Wire.API.Team.Feature
import Wire.API.User
newtype ApAll f = ApAll {forall (f :: * -> *). ApAll f -> f Bool
unApAll :: f Bool}
instance (Monad f) => Semigroup (ApAll f) where
ApAll f Bool
a <> :: ApAll f -> ApAll f -> ApAll f
<> ApAll f Bool
b = f Bool -> ApAll f
forall (f :: * -> *). f Bool -> ApAll f
ApAll (f Bool -> ApAll f) -> f Bool -> ApAll f
forall a b. (a -> b) -> a -> b
$ f Bool
a f Bool -> (Bool -> f Bool) -> f Bool
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> if Bool
x then f Bool
b else Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
instance (Monad f) => Monoid (ApAll f) where
mempty :: ApAll f
mempty = f Bool -> ApAll f
forall (f :: * -> *). f Bool -> ApAll f
ApAll (Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
checkMigrationCriteria ::
( Member BrigAccess r,
Member FederatorAccess r
) =>
UTCTime ->
MLSConversation ->
LockableFeature MlsMigrationConfig ->
Sem r Bool
checkMigrationCriteria :: forall (r :: EffectRow).
(Member BrigAccess r, Member FederatorAccess r) =>
UTCTime
-> MLSConversation
-> LockableFeature MlsMigrationConfig
-> Sem r Bool
checkMigrationCriteria UTCTime
now MLSConversation
conv LockableFeature MlsMigrationConfig
ws
| LockableFeature MlsMigrationConfig
ws.status FeatureStatus -> FeatureStatus -> Bool
forall a. Eq a => a -> a -> Bool
== FeatureStatus
FeatureStatusDisabled = Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
| Bool
afterDeadline = Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
| Bool
otherwise = ApAll (Sem r) -> Sem r Bool
forall (f :: * -> *). ApAll f -> f Bool
unApAll (ApAll (Sem r) -> Sem r Bool) -> ApAll (Sem r) -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ [ApAll (Sem r)] -> ApAll (Sem r)
forall a. Monoid a => [a] -> a
mconcat [ApAll (Sem r)
localUsersMigrated, ApAll (Sem r)
remoteUsersMigrated]
where
afterDeadline :: Bool
afterDeadline = Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UTCTime
now >=) LockableFeature MlsMigrationConfig
ws.config.finaliseRegardlessAfter
containsMLS :: Set BaseProtocolTag -> Bool
containsMLS = BaseProtocolTag -> Set BaseProtocolTag -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member BaseProtocolTag
BaseProtocolMLSTag
localUsersMigrated :: ApAll (Sem r)
localUsersMigrated = Sem r Bool -> ApAll (Sem r)
forall (f :: * -> *). f Bool -> ApAll f
ApAll (Sem r Bool -> ApAll (Sem r)) -> Sem r Bool -> ApAll (Sem r)
forall a b. (a -> b) -> a -> b
$ do
[User]
localProfiles <-
[UserId] -> Sem r [User]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r [User]
getUsers ((LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map LocalMember -> UserId
lmId MLSConversation
conv.mcLocalMembers)
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
$ (User -> Bool) -> [User] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set BaseProtocolTag -> Bool
containsMLS (Set BaseProtocolTag -> Bool)
-> (User -> Set BaseProtocolTag) -> User -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> Set BaseProtocolTag
userSupportedProtocols) [User]
localProfiles
remoteUsersMigrated :: ApAll (Sem r)
remoteUsersMigrated = Sem r Bool -> ApAll (Sem r)
forall (f :: * -> *). f Bool -> ApAll f
ApAll (Sem r Bool -> ApAll (Sem r)) -> Sem r Bool -> ApAll (Sem r)
forall a b. (a -> b) -> a -> b
$ do
[UserProfile]
remoteProfiles <- ([QualifiedWithTag 'QRemote [UserProfile]] -> [UserProfile])
-> Sem r [QualifiedWithTag 'QRemote [UserProfile]]
-> Sem r [UserProfile]
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((QualifiedWithTag 'QRemote [UserProfile] -> [UserProfile])
-> [QualifiedWithTag 'QRemote [UserProfile]] -> [UserProfile]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap QualifiedWithTag 'QRemote [UserProfile] -> [UserProfile]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified)
(Sem r [QualifiedWithTag 'QRemote [UserProfile]]
-> Sem r [UserProfile])
-> ((Remote [UserId] -> FederatorClient 'Brig [UserProfile])
-> Sem r [QualifiedWithTag 'QRemote [UserProfile]])
-> (Remote [UserId] -> FederatorClient 'Brig [UserProfile])
-> Sem r [UserProfile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Remote UserId]
-> (Remote [UserId] -> FederatorClient 'Brig [UserProfile])
-> Sem r [QualifiedWithTag 'QRemote [UserProfile]]
forall (r :: EffectRow) (c :: Component) (f :: * -> *) x a.
(Member FederatorAccess r, KnownComponent c, Foldable f,
Functor f) =>
f (Remote x)
-> (Remote [x] -> FederatorClient c a) -> Sem r [Remote a]
runFederatedConcurrently ((RemoteMember -> Remote UserId)
-> [RemoteMember] -> [Remote UserId]
forall a b. (a -> b) -> [a] -> [b]
map RemoteMember -> Remote UserId
rmId MLSConversation
conv.mcRemoteMembers)
((Remote [UserId] -> FederatorClient 'Brig [UserProfile])
-> Sem r [UserProfile])
-> (Remote [UserId] -> FederatorClient 'Brig [UserProfile])
-> Sem r [UserProfile]
forall a b. (a -> b) -> a -> b
$ \Remote [UserId]
ruids ->
forall {k} (comp :: Component) (name :: k)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Brig @"get-users-by-ids" (Remote [UserId] -> [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [UserId]
ruids)
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
$ (UserProfile -> Bool) -> [UserProfile] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set BaseProtocolTag -> Bool
containsMLS (Set BaseProtocolTag -> Bool)
-> (UserProfile -> Set BaseProtocolTag) -> UserProfile -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserProfile -> Set BaseProtocolTag
profileSupportedProtocols) [UserProfile]
remoteProfiles