-- 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.Cassandra.Client
  ( interpretClientStoreToCassandra,
    lookupClients,
  )
where

import Cassandra
import Control.Arrow
import Control.Lens
import Data.Id
import Data.List.Split (chunksOf)
import Galley.Cassandra.Queries qualified as Cql
import Galley.Cassandra.Store
import Galley.Cassandra.Util
import Galley.Effects.ClientStore (ClientStore (..))
import Galley.Env
import Galley.Monad
import Galley.Options
import Galley.Types.Clients (Clients)
import Galley.Types.Clients qualified as Clients
import Imports
import Polysemy
import Polysemy.Input
import Polysemy.TinyLog
import UnliftIO qualified

updateClient :: Bool -> UserId -> ClientId -> Client ()
updateClient :: Bool -> UserId -> ClientId -> Client ()
updateClient Bool
add UserId
usr ClientId
cls = do
  let q :: ClientId -> QueryString W (Identity UserId) ()
q = if Bool
add then ClientId -> QueryString W (Identity UserId) ()
Cql.upsertMemberAddClient else ClientId -> QueryString W (Identity UserId) ()
Cql.upsertMemberRmClient
  RetrySettings -> Client () -> Client ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (Client () -> Client ()) -> Client () -> Client ()
forall a b. (a -> b) -> a -> b
$ QueryString W (Identity UserId) ()
-> QueryParams (Identity UserId) -> Client ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write (ClientId -> QueryString W (Identity UserId) ()
q ClientId
cls) (Consistency -> Identity UserId -> QueryParams (Identity UserId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (UserId -> Identity UserId
forall a. a -> Identity a
Identity UserId
usr))

-- Do, at most, 16 parallel lookups of up to 128 users each
lookupClients :: [UserId] -> Client Clients
lookupClients :: [UserId] -> Client Clients
lookupClients [UserId]
users =
  [(UserId, [ClientId])] -> Clients
Clients.fromList ([(UserId, [ClientId])] -> Clients)
-> ([[[(UserId, [ClientId])]]] -> [(UserId, [ClientId])])
-> [[[(UserId, [ClientId])]]]
-> Clients
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(UserId, [ClientId])]] -> [(UserId, [ClientId])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(UserId, [ClientId])]] -> [(UserId, [ClientId])])
-> ([[[(UserId, [ClientId])]]] -> [[(UserId, [ClientId])]])
-> [[[(UserId, [ClientId])]]]
-> [(UserId, [ClientId])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[(UserId, [ClientId])]]] -> [[(UserId, [ClientId])]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    ([[[(UserId, [ClientId])]]] -> Clients)
-> Client [[[(UserId, [ClientId])]]] -> Client Clients
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[UserId]]
-> ([UserId] -> Client [[(UserId, [ClientId])]])
-> Client [[[(UserId, [ClientId])]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int -> [UserId] -> [[UserId]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
2048 [UserId]
users) (([UserId] -> Client [(UserId, [ClientId])])
-> [[UserId]] -> Client [[(UserId, [ClientId])]]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
UnliftIO.mapConcurrently [UserId] -> Client [(UserId, [ClientId])]
forall {f :: * -> *}.
MonadClient f =>
[UserId] -> f [(UserId, [ClientId])]
getClients ([[UserId]] -> Client [[(UserId, [ClientId])]])
-> ([UserId] -> [[UserId]])
-> [UserId]
-> Client [[(UserId, [ClientId])]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [UserId] -> [[UserId]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
128)
  where
    getClients :: [UserId] -> f [(UserId, [ClientId])]
getClients [UserId]
us =
      ((UserId, Set ClientId) -> (UserId, [ClientId]))
-> [(UserId, Set ClientId)] -> [(UserId, [ClientId])]
forall a b. (a -> b) -> [a] -> [b]
map ((Set ClientId -> [ClientId])
-> (UserId, Set ClientId) -> (UserId, [ClientId])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Set ClientId -> [ClientId]
forall a. Set a -> [a]
fromSet)
        ([(UserId, Set ClientId)] -> [(UserId, [ClientId])])
-> f [(UserId, Set ClientId)] -> f [(UserId, [ClientId])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetrySettings
-> f [(UserId, Set ClientId)] -> f [(UserId, Set ClientId)]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R (Identity [UserId]) (UserId, Set ClientId)
-> QueryParams (Identity [UserId]) -> f [(UserId, Set ClientId)]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery R (Identity [UserId]) (UserId, Set ClientId)
Cql.selectClients (Consistency -> Identity [UserId] -> QueryParams (Identity [UserId])
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum ([UserId] -> Identity [UserId]
forall a. a -> Identity a
Identity [UserId]
us)))

eraseClients :: UserId -> Client ()
eraseClients :: UserId -> Client ()
eraseClients UserId
user = RetrySettings -> Client () -> Client ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (PrepQuery W (Identity UserId) ()
-> QueryParams (Identity UserId) -> Client ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Identity UserId) ()
Cql.rmClients (Consistency -> Identity UserId -> QueryParams (Identity UserId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (UserId -> Identity UserId
forall a. a -> Identity a
Identity UserId
user)))

interpretClientStoreToCassandra ::
  ( Member (Embed IO) r,
    Member (Input ClientState) r,
    Member (Input Env) r,
    Member TinyLog r
  ) =>
  Sem (ClientStore ': r) a ->
  Sem r a
interpretClientStoreToCassandra :: forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r,
 Member (Input Env) r, Member TinyLog r) =>
Sem (ClientStore : r) a -> Sem r a
interpretClientStoreToCassandra = (forall (rInitial :: EffectRow) x.
 ClientStore (Sem rInitial) x -> Sem r x)
-> Sem (ClientStore : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  ClientStore (Sem rInitial) x -> Sem r x)
 -> Sem (ClientStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    ClientStore (Sem rInitial) x -> Sem r x)
-> Sem (ClientStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  GetClients [UserId]
uids -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ClientStore.GetClients"
    Client Clients -> Sem r Clients
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client Clients -> Sem r Clients)
-> Client Clients -> Sem r Clients
forall a b. (a -> b) -> a -> b
$ [UserId] -> Client Clients
lookupClients [UserId]
uids
  CreateClient UserId
uid ClientId
cid -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ClientStore.CreateClient"
    Client () -> Sem r ()
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client () -> Sem r ()) -> Client () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bool -> UserId -> ClientId -> Client ()
updateClient Bool
True UserId
uid ClientId
cid
  DeleteClient UserId
uid ClientId
cid -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ClientStore.DeleteClient"
    Client () -> Sem r ()
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client () -> Sem r ()) -> Client () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bool -> UserId -> ClientId -> Client ()
updateClient Bool
False UserId
uid ClientId
cid
  DeleteClients UserId
uid -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ClientStore.DeleteClients"
    Client () -> Sem r ()
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input ClientState) r) =>
Client a -> Sem r a
embedClient (Client () -> Sem r ()) -> Client () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ UserId -> Client ()
eraseClients UserId
uid
  ClientStore (Sem rInitial) x
UseIntraClientListing -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"ClientStore.UseIntraClientListing"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x)
-> (Getting x Env x -> App x) -> Getting x Env x -> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting x Env x -> App x
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting x Env x -> Sem r x) -> Getting x Env x -> Sem r x
forall a b. (a -> b) -> a -> b
$ (Opts -> Const x Opts) -> Env -> Const x Env
Lens' Env Opts
options ((Opts -> Const x Opts) -> Env -> Const x Env)
-> ((x -> Const x x) -> Opts -> Const x Opts) -> Getting x Env x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Settings -> Const x Settings) -> Opts -> Const x Opts
Lens' Opts Settings
settings ((Settings -> Const x Settings) -> Opts -> Const x Opts)
-> ((x -> Const x x) -> Settings -> Const x Settings)
-> (x -> Const x x)
-> Opts
-> Const x Opts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> Const x x) -> Settings -> Const x Settings
(Bool -> Const x Bool) -> Settings -> Const x Settings
Lens' Settings Bool
intraListing