-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2023 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/>.

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

-- | Similar to @Ap f All@, but short-circuiting.
--
-- For example:
-- @
-- ApAll (pure False) <> ApAll (putStrLn "hi" $> True)
-- @
-- does not print anything.
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 <-
        (UserAccount -> User) -> [UserAccount] -> [User]
forall a b. (a -> b) -> [a] -> [b]
map UserAccount -> User
accountUser
          ([UserAccount] -> [User]) -> Sem r [UserAccount] -> Sem r [User]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId] -> Sem r [UserAccount]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r [UserAccount]
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 x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 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 x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 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