-- 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/>.

module Galley.API.Clients
  ( getClients,
    rmClient,
  )
where

import Data.Id
import Data.Proxy
import Data.Qualified
import Data.Range
import Data.Time
import Galley.API.Error
import Galley.API.MLS.Removal
import Galley.API.Query qualified as Query
import Galley.API.Util
import Galley.Effects
import Galley.Effects.BackendNotificationQueueAccess
import Galley.Effects.ClientStore qualified as E
import Galley.Effects.ConversationStore (getConversation)
import Galley.Env
import Galley.Types.Clients (clientIds)
import Imports
import Network.AMQP qualified as Q
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import System.Logger.Message
import Wire.API.Conversation hiding (Member)
import Wire.API.Federation.API
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Error
import Wire.API.Routes.MultiTablePaging
import Wire.NotificationSubsystem
import Wire.Sem.Paging.Cassandra (CassandraPaging)

getClients ::
  ( Member BrigAccess r,
    Member ClientStore r
  ) =>
  UserId ->
  Sem r [ClientId]
getClients :: forall (r :: EffectRow).
(Member BrigAccess r, Member ClientStore r) =>
UserId -> Sem r [ClientId]
getClients UserId
usr = UserId -> Clients -> [ClientId]
clientIds UserId
usr (Clients -> [ClientId]) -> Sem r Clients -> Sem r [ClientId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId] -> Sem r Clients
forall (r :: EffectRow).
(Member BrigAccess r, Member ClientStore r) =>
[UserId] -> Sem r Clients
getBrigClients [UserId
usr]

-- | Remove a client from conversations it is part of according to the
-- conversation protocol (Proteus or MLS). In addition, remove the client from
-- the "clients" table in Galley.
rmClient ::
  forall p1 r.
  ( p1 ~ CassandraPaging,
    Member ClientStore r,
    Member ConversationStore r,
    Member (Error FederationError) r,
    Member ExternalAccess r,
    Member BackendNotificationQueueAccess r,
    Member NotificationSubsystem r,
    Member (Input Env) r,
    Member (Input (Local ())) r,
    Member (Input UTCTime) r,
    Member (ListItems p1 ConvId) r,
    Member (ListItems p1 (Remote ConvId)) r,
    Member MemberStore r,
    Member (Error InternalError) r,
    Member ProposalStore r,
    Member Random r,
    Member SubConversationStore r,
    Member P.TinyLog r
  ) =>
  UserId ->
  ClientId ->
  Sem r ()
rmClient :: forall p1 (r :: EffectRow).
(p1 ~ CassandraPaging, Member ClientStore r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member ExternalAccess r, Member BackendNotificationQueueAccess r,
 Member NotificationSubsystem r, Member (Input Env) r,
 Member (Input (Local ())) r, Member (Input UTCTime) r,
 Member (ListItems p1 ConvId) r,
 Member (ListItems p1 (Remote ConvId)) r, Member MemberStore r,
 Member (Error InternalError) r, Member ProposalStore r,
 Member Random r, Member SubConversationStore r,
 Member TinyLog r) =>
UserId -> ClientId -> Sem r ()
rmClient UserId
usr ClientId
cid = do
  Clients
clients <- [UserId] -> Sem r Clients
forall (r :: EffectRow).
Member ClientStore r =>
[UserId] -> Sem r Clients
E.getClients [UserId
usr]
  if (ClientId
cid ClientId -> [ClientId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` UserId -> Clients -> [ClientId]
clientIds UserId
usr Clients
clients)
    then do
      Local UserId
lusr <- UserId -> Sem r (Local UserId)
forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal UserId
usr
      let nRange1000 :: Range 1 1000 Int32
nRange1000 = Proxy 1000 -> Range 1 1000 Int32
forall (n :: Nat) (x :: Nat) (m :: Nat) a.
(n <= x, x <= m, KnownNat x, Num a) =>
Proxy x -> Range n m a
toRange (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @1000) :: Range 1 1000 Int32
      ConvIdsPage
firstConvIds <- Local UserId -> GetPaginatedConversationIds -> Sem r ConvIdsPage
forall p (r :: EffectRow).
(p ~ CassandraPaging,
 (Member ConversationStore r, Member (Error InternalError) r,
  Member (Input Env) r, Member (ListItems p ConvId) r,
  Member (ListItems p (Remote ConvId)) r, Member TinyLog r)) =>
Local UserId -> GetPaginatedConversationIds -> Sem r ConvIdsPage
Query.conversationIdsPageFrom Local UserId
lusr (Maybe
  (MultiTablePagingState ConversationPagingName LocalOrRemoteTable)
-> Range 1 1000 Int32 -> GetPaginatedConversationIds
forall (name :: Symbol) tables (max :: Nat) (def :: Nat).
Maybe (MultiTablePagingState name tables)
-> Range 1 max Int32
-> GetMultiTablePageRequest name tables max def
GetPaginatedConversationIds Maybe
  (MultiTablePagingState ConversationPagingName LocalOrRemoteTable)
forall a. Maybe a
Nothing Range 1 1000 Int32
nRange1000)
      Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r ()
goConvs Range 1 1000 Int32
nRange1000 ConvIdsPage
firstConvIds Local UserId
lusr
      UserId -> ClientId -> Sem r ()
forall (r :: EffectRow).
Member ClientStore r =>
UserId -> ClientId -> Sem r ()
E.deleteClient UserId
usr ClientId
cid
    else
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.debug
        ( ByteString -> Text -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"user" (UserId -> Text
forall {k} (a :: k). Id a -> Text
idToText UserId
usr)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"client" (ClientId -> Text
clientToText ClientId
cid)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"rmClientH: client already gone")
        )
  where
    goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r ()
    goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r ()
goConvs Range 1 1000 Int32
range ConvIdsPage
page Local UserId
lusr = do
      let ([ConvId]
localConvs, [Remote ConvId]
remoteConvs) = Local UserId -> [Qualified ConvId] -> ([ConvId], [Remote ConvId])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local UserId
lusr (ConvIdsPage -> [Qualified ConvId]
forall (name :: Symbol) (resultsKey :: Symbol) tables a.
MultiTablePage name resultsKey tables a -> [a]
mtpResults ConvIdsPage
page)
      [ConvId] -> (ConvId -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ConvId]
localConvs ((ConvId -> Sem r ()) -> Sem r ())
-> (ConvId -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \ConvId
convId -> do
        Maybe Conversation
mConv <- ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
getConversation ConvId
convId
        Maybe Conversation -> (Conversation -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Conversation
mConv ((Conversation -> Sem r ()) -> Sem r ())
-> (Conversation -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Conversation
conv -> do
          Local Conversation
lconv <- Conversation -> Sem r (Local Conversation)
forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal Conversation
conv
          Local Conversation -> Qualified UserId -> ClientId -> Sem r ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member (Error FederationError) r, Member ExternalAccess r,
 Member NotificationSubsystem r, Member (Input Env) r,
 Member (Input UTCTime) r, Member MemberStore r,
 Member ProposalStore r, Member Random r,
 Member SubConversationStore r, Member TinyLog r) =>
Local Conversation -> Qualified UserId -> ClientId -> Sem r ()
removeClient Local Conversation
lconv (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) ClientId
cid
      (Range 1 1000 [Remote ConvId] -> Sem r ())
-> [Range 1 1000 [Remote ConvId]] -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Range 1 1000 [Remote ConvId] -> Sem r ()
removeRemoteMLSClients ([Remote ConvId] -> [Range 1 1000 [Remote ConvId]]
forall a (n :: Nat).
(Within [a] 1 n, KnownNat n) =>
[a] -> [Range 1 n [a]]
rangedChunks [Remote ConvId]
remoteConvs)
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConvIdsPage -> Bool
forall (name :: Symbol) (resultsKey :: Symbol) tables a.
MultiTablePage name resultsKey tables a -> Bool
mtpHasMore ConvIdsPage
page) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
        let nextState :: MultiTablePagingState ConversationPagingName LocalOrRemoteTable
nextState = ConvIdsPage
-> MultiTablePagingState ConversationPagingName LocalOrRemoteTable
forall (name :: Symbol) (resultsKey :: Symbol) tables a.
MultiTablePage name resultsKey tables a
-> MultiTablePagingState name tables
mtpPagingState ConvIdsPage
page
            nextQuery :: GetPaginatedConversationIds
nextQuery = Maybe
  (MultiTablePagingState ConversationPagingName LocalOrRemoteTable)
-> Range 1 1000 Int32 -> GetPaginatedConversationIds
forall (name :: Symbol) tables (max :: Nat) (def :: Nat).
Maybe (MultiTablePagingState name tables)
-> Range 1 max Int32
-> GetMultiTablePageRequest name tables max def
GetPaginatedConversationIds (MultiTablePagingState ConversationPagingName LocalOrRemoteTable
-> Maybe
     (MultiTablePagingState ConversationPagingName LocalOrRemoteTable)
forall a. a -> Maybe a
Just MultiTablePagingState ConversationPagingName LocalOrRemoteTable
nextState) Range 1 1000 Int32
range
        ConvIdsPage
newCids <- Local UserId -> GetPaginatedConversationIds -> Sem r ConvIdsPage
forall p (r :: EffectRow).
(p ~ CassandraPaging,
 (Member ConversationStore r, Member (Error InternalError) r,
  Member (Input Env) r, Member (ListItems p ConvId) r,
  Member (ListItems p (Remote ConvId)) r, Member TinyLog r)) =>
Local UserId -> GetPaginatedConversationIds -> Sem r ConvIdsPage
Query.conversationIdsPageFrom Local UserId
lusr GetPaginatedConversationIds
nextQuery
        Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r ()
goConvs Range 1 1000 Int32
range ConvIdsPage
newCids Local UserId
lusr

    removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r ()
    removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r ()
removeRemoteMLSClients Range 1 1000 [Remote ConvId]
convIds = do
      [Remote [ConvId]] -> (Remote [ConvId] -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Remote ConvId] -> [Remote [ConvId]]
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Remote a) -> [Remote [a]]
bucketRemote (Range 1 1000 [Remote ConvId] -> [Remote ConvId]
forall (n :: Nat) (m :: Nat) a. Range n m a -> a
fromRange Range 1 1000 [Remote ConvId]
convIds)) ((Remote [ConvId] -> Sem r ()) -> Sem r ())
-> (Remote [ConvId] -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Remote [ConvId]
remoteConvs ->
        let rpc :: FedQueueClient 'Galley ()
rpc =
              forall {k} (tag :: k) (c :: Component).
(HasNotificationEndpoint tag, HasVersionRange tag, HasFedPath tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag),
 c ~ NotificationComponent k) =>
Payload tag -> FedQueueClient c ()
forall (tag :: GalleyNotificationTag) (c :: Component).
(HasNotificationEndpoint tag, HasVersionRange tag, HasFedPath tag,
 KnownComponent (NotificationComponent GalleyNotificationTag),
 ToJSON (Payload tag),
 c ~ NotificationComponent GalleyNotificationTag) =>
Payload tag -> FedQueueClient c ()
fedQueueClient
                @'OnClientRemovedTag
                (UserId -> ClientId -> [ConvId] -> ClientRemovedRequest
ClientRemovedRequest UserId
usr ClientId
cid (Remote [ConvId] -> [ConvId]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [ConvId]
remoteConvs))
         in DeliveryMode
-> Remote [ConvId] -> FedQueueClient 'Galley () -> Sem r ()
forall (c :: Component) (r :: EffectRow) x a.
(KnownComponent c, Member (Error FederationError) r,
 Member BackendNotificationQueueAccess r) =>
DeliveryMode -> Remote x -> FedQueueClient c a -> Sem r a
enqueueNotification DeliveryMode
Q.Persistent Remote [ConvId]
remoteConvs FedQueueClient 'Galley ()
rpc