From 31c815374967e553dcbe8301463c48e96fdbc98d Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 3 Mar 2026 08:09:24 +0000 Subject: [PATCH 1/3] wip --- libs/cassandra-util/src/Cassandra.hs | 3 - libs/cassandra-util/src/Cassandra/Exec.hs | 260 +++++++++++++++++- libs/cassandra-util/src/Cassandra/Settings.hs | 2 +- libs/cassandra-util/src/Cassandra/Util.hs | 10 +- 4 files changed, 265 insertions(+), 10 deletions(-) diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 24406334813..88df0dd24fa 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -67,11 +67,9 @@ import Cassandra.Exec as C addPrepQuery, batch, emptyPage, - hasMore, init, liftClient, localState, - nextPage, paginate, paginateC, paginateWithState, @@ -83,7 +81,6 @@ import Cassandra.Exec as C pwsHasMore, query, query1, - result, retry, runClient, setConsistency, diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index 9d5c7a03d52..408b06ce23c 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -24,6 +24,20 @@ module Cassandra.Exec paramsP, x5, x1, + BatchM, + Client, + ClientState, + MonadClient, + Page (..), + PrepQuery, + Row, + addPrepQuery, + batch, + emptyPage, + init, + liftClient, + localState, + paginate, paginateC, GeneralPaginationState (..), paginationStateCassandra, @@ -33,20 +47,109 @@ module Cassandra.Exec paginateWithStateC, paramsPagingState, pwsHasMore, - module C, + prepared, + query, + query1, + registerClientKeyspace, + retry, + runClient, + setConsistency, + setType, + shutdown, + trans, + write, ) where -import Cassandra.CQL (Consistency, R) +import Cassandra.CQL (Consistency, Keyspace, QueryString (QueryString), R, W, unKeyspace) import Control.Monad.Catch import Data.Conduit +import Data.Text qualified as Text +import Data.Text.Lazy qualified as LT +import Database.CQL.IO qualified as C -- We only use these locally. import Database.CQL.IO (ProtocolError (UnexpectedResponse), RetrySettings, RunQ, defRetrySettings, eagerRetrySettings, getResult, hrHost, hrResponse, runQ) -- Things we just import and re-export. -import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, addPrepQuery, addQuery, adjustConsistency, adjustResponseTimeout, adjustSendTimeout, batch, emptyPage, init, liftClient, localState, paginate, prepared, query, query1, queryString, retry, runClient, schema, setConsistency, setSerialConsistency, setType, shutdown, trans, write) +import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, emptyPage, liftClient, localState, queryString, retry, setConsistency, setType, shutdown, trans) import Database.CQL.Protocol (Error, QueryParams (QueryParams), Tuple, pagingState) import Database.CQL.Protocol qualified as Protocol +import GHC.Conc.Sync (myThreadId) import Imports hiding (init) +import System.IO.Unsafe (unsafePerformIO) +import System.Mem.StableName (StableName, eqStableName, makeStableName) + +{-# NOINLINE clientKeyspaces #-} +clientKeyspaces :: IORef [(StableName ClientState, Maybe Keyspace)] +clientKeyspaces = unsafePerformIO $ newIORef [] + +{-# NOINLINE threadKeyspaces #-} +threadKeyspaces :: IORef [(ThreadId, [Maybe Keyspace])] +threadKeyspaces = unsafePerformIO $ newIORef [] + +class KeyspaceQualifiable q where + qualifyWithKeyspace :: Maybe Keyspace -> q k a b -> q k a b + +instance KeyspaceQualifiable QueryString where + qualifyWithKeyspace Nothing q = q + qualifyWithKeyspace (Just keyspace) (QueryString queryText) = + QueryString (qualifyCql keyspace queryText) + +instance KeyspaceQualifiable PrepQuery where + qualifyWithKeyspace keyspace = + C.prepared . qualifyWithKeyspace keyspace . C.queryString + +init :: C.Settings -> IO ClientState +init = C.init + +runClient :: MonadIO m => ClientState -> Client a -> m a +runClient clientState action = do + liftIO $ do + keyspace <- lookupClientKeyspace clientState + withThreadKeyspace keyspace (C.runClient clientState action) + +query :: + (MonadClient m, Tuple a, Tuple b, RunQ q, KeyspaceQualifiable q) => + q R a b -> + QueryParams a -> + m [b] +query q params_ = do + keyspace <- currentThreadKeyspace + C.query (qualifyWithKeyspace keyspace q) params_ + +query1 :: + (MonadClient m, Tuple a, Tuple b, RunQ q, KeyspaceQualifiable q) => + q R a b -> + QueryParams a -> + m (Maybe b) +query1 q params_ = do + keyspace <- currentThreadKeyspace + C.query1 (qualifyWithKeyspace keyspace q) params_ + +write :: + (MonadClient m, Tuple a, RunQ q, KeyspaceQualifiable q) => + q W a () -> + QueryParams a -> + m () +write q params_ = do + keyspace <- currentThreadKeyspace + C.write (qualifyWithKeyspace keyspace q) params_ + +paginate :: + (MonadClient m, Tuple a, Tuple b, RunQ q) => + q R a b -> + QueryParams a -> + m (Page b) +paginate = C.paginate + +addPrepQuery :: (Show a, Tuple a, Tuple b) => PrepQuery W a b -> a -> BatchM () +addPrepQuery q params_ = + C.addPrepQuery (qualifyWithKeyspace currentThreadKeyspaceUnsafe q) params_ + +batch :: MonadClient m => BatchM () -> m () +batch = C.batch + +prepared :: QueryString k a b -> PrepQuery k a b +prepared = C.prepared params :: Consistency -> a -> QueryParams a params c p = QueryParams c False p Nothing Nothing Nothing Nothing @@ -162,3 +265,154 @@ paramsPagingState c p n state = QueryParams c False p (Just n) state Nothing Not pwsHasMore :: PageWithState a b -> Bool pwsHasMore = isJust . pwsState + +data QualificationMode + = Normal + | ExpectTable + | ExpectTableKeyword + +registerClientKeyspace :: ClientState -> Maybe Keyspace -> IO () +registerClientKeyspace clientState keyspace = do + stable <- makeStableName clientState + atomicModifyIORef' clientKeyspaces $ \pairs -> + ((stable, keyspace) : pairs, ()) + +lookupClientKeyspace :: ClientState -> IO (Maybe Keyspace) +lookupClientKeyspace clientState = do + stable <- makeStableName clientState + pairs <- readIORef clientKeyspaces + pure $ go stable pairs + where + go _ [] = Nothing + go needle ((candidate, keyspace) : rest) = + if eqStableName needle candidate + then keyspace + else go needle rest + +withThreadKeyspace :: Maybe Keyspace -> IO a -> IO a +withThreadKeyspace keyspace = + bracket_ (pushThreadKeyspace keyspace) popThreadKeyspace + +pushThreadKeyspace :: Maybe Keyspace -> IO () +pushThreadKeyspace keyspace = do + tid <- myThreadId + atomicModifyIORef' threadKeyspaces $ \pairs -> + (upsert pairs tid [keyspace], ()) + where + upsert [] key value = [(key, value)] + upsert ((key, values) : rest) tid' value + | key == tid' = (key, value <> values) : rest + | otherwise = (key, values) : upsert rest tid' value + +popThreadKeyspace :: IO () +popThreadKeyspace = do + tid <- myThreadId + atomicModifyIORef' threadKeyspaces $ \pairs -> + (pop pairs tid, ()) + where + pop [] _ = [] + pop ((key, values) : rest) tid' + | key /= tid' = (key, values) : pop rest tid' + | otherwise = case values of + _ : xs | null xs -> rest + _ : xs -> (key, xs) : rest + [] -> rest + +currentThreadKeyspace :: MonadClient m => m (Maybe Keyspace) +currentThreadKeyspace = liftClient currentThreadKeyspaceClient + +currentThreadKeyspaceClient :: Client (Maybe Keyspace) +currentThreadKeyspaceClient = liftIO currentThreadKeyspaceIO + +currentThreadKeyspaceIO :: IO (Maybe Keyspace) +currentThreadKeyspaceIO = do + tid <- myThreadId + keyspaces <- readIORef threadKeyspaces + pure $ lookup tid keyspaces >>= listToMaybe . catMaybes + +currentThreadKeyspaceUnsafe :: Maybe Keyspace +currentThreadKeyspaceUnsafe = unsafePerformIO currentThreadKeyspaceIO +{-# NOINLINE currentThreadKeyspaceUnsafe #-} + +qualifyCql :: Keyspace -> LT.Text -> LT.Text +qualifyCql keyspace = LT.pack . go Nothing Normal . LT.unpack + where + keyspacePrefix = Text.unpack (unKeyspace keyspace) <> "." + + go :: Maybe String -> QualificationMode -> String -> String + go _ _ [] = [] + go prevWord mode s@(c : cs) + | c == '\'' = + let (strChunk, rest) = takeSingleQuoted s + in strChunk <> go prevWord mode rest + | c == '"' = + let (strChunk, rest) = takeDoubleQuoted s + in strChunk <> go prevWord mode rest + | isAsciiLower c || isAsciiUpper c || c == '_' = + let (token, rest) = span isIdentChar s + tokenLower = map toLower token + (mode', token') = transformToken prevWord mode tokenLower token rest + prevWord' = Just tokenLower + in token' <> go prevWord' mode' rest + | otherwise = c : go prevWord mode cs + + transformToken :: Maybe String -> QualificationMode -> String -> String -> String -> (QualificationMode, String) + transformToken prevWord mode tokenLower token rest = case mode of + ExpectTableKeyword -> + if tokenLower == "table" || tokenLower == "columnfamily" + then (ExpectTable, token) + else (Normal, token) + ExpectTable -> + if tokenLower `elem` ["if", "not", "exists", "only"] + then (ExpectTable, token) + else + let token' = + if isQualifiedIdentifier rest + then token + else keyspacePrefix <> token + in (Normal, token') + Normal -> + if tokenLower `elem` ["from", "into", "update", "join"] + then (ExpectTable, token) + else + if tokenLower `elem` ["alter", "create", "drop", "truncate"] + then (ExpectTableKeyword, token) + else + if tokenLower == "on" && prevWord == Just "index" + then (ExpectTable, token) + else (Normal, token) + + isQualifiedIdentifier :: String -> Bool + isQualifiedIdentifier = \case + [] -> False + x : xs + | isSpace x -> isQualifiedIdentifier xs + | otherwise -> x == '.' + + isIdentChar :: Char -> Bool + isIdentChar ch = isAsciiLower ch || isAsciiUpper ch || isDigit ch || ch == '_' + + takeSingleQuoted :: String -> (String, String) + takeSingleQuoted = goQuoted '\'' + + takeDoubleQuoted :: String -> (String, String) + takeDoubleQuoted = goQuoted '"' + + goQuoted :: Char -> String -> (String, String) + goQuoted quoteChar = \case + [] -> ([], []) + x : xs -> + let (body, rest) = consume xs + in (x : body, rest) + where + consume [] = ([], []) + consume (x : xs) + | x == quoteChar = + case xs of + y : ys | y == quoteChar -> + let (body, rest) = consume ys + in (x : y : body, rest) + _ -> ([x], xs) + | otherwise = + let (body, rest) = consume xs + in (x : body, rest) diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index 4e38328ef0b..e2a3649a193 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -34,7 +34,7 @@ import Data.Aeson.Lens import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Text (pack, stripSuffix, unpack) -import Database.CQL.IO as C hiding (values) +import Database.CQL.IO as C hiding (addPrepQuery, addQuery, batch, init, paginate, query, query1, runClient, values, write) import Database.CQL.IO.Tinylog as C (mkLogger) import Imports import Network.Wreq diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index d6968ead939..b7472e53af6 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -25,6 +25,7 @@ module Cassandra.Util where import Cassandra.CQL +import Cassandra.Exec qualified as CassandraExec import Cassandra.Options import Cassandra.Schema import Cassandra.Settings (dcFilterPolicyIfConfigured, initialContactsDisco, initialContactsPlain, mkLogger) @@ -50,7 +51,9 @@ defInitCassandra opts logger = do . setKeyspace (Keyspace opts.keyspace) . setProtocolVersion V4 $ defSettings - initCassandra basicCasSettings opts.tlsCa logger + client <- initCassandra basicCasSettings opts.tlsCa logger + CassandraExec.registerClientKeyspace client (Just (Keyspace opts.keyspace)) + pure client -- | Create Cassandra `ClientState` ("connection") for a service initCassandraForService :: @@ -79,6 +82,7 @@ initCassandraForService opts serviceName discoUrl mbSchemaVersion logger = do . setPolicy (dcFilterPolicyIfConfigured logger opts.filterNodesByDatacentre) $ defSettings p <- initCassandra basicCasSettings opts.tlsCa logger + CassandraExec.registerClientKeyspace p (Just (Keyspace opts.keyspace)) maybe (pure ()) (\v -> runClient p $ (versionCheck v)) mbSchemaVersion pure p @@ -86,7 +90,7 @@ initCassandra :: Settings -> Maybe FilePath -> Log.Logger -> IO ClientState initCassandra settings (Just tlsCaPath) logger = do sslContext <- createSSLContext tlsCaPath let settings' = setSSLContext sslContext settings - init settings' + CassandraExec.init settings' where createSSLContext :: FilePath -> IO OpenSSL.SSLContext createSSLContext certFile = do @@ -103,7 +107,7 @@ initCassandra settings (Just tlsCaPath) logger = do pure sslContext initCassandra settings Nothing logger = do void . liftIO $ Log.debug logger (Log.msg ("No TLS cert file path configured." :: Text)) - init settings + CassandraExec.init settings -- | Read cassandra's writetimes https://docs.datastax.com/en/dse/5.1/cql/cql/cql_using/useWritetime.html -- as UTCTime values without any loss of precision From 2c61075335da5b3b6f5d9a60029a6f6838949529 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 3 Mar 2026 13:04:26 +0000 Subject: [PATCH 2/3] Revert "wip" This reverts commit 31c815374967e553dcbe8301463c48e96fdbc98d. --- libs/cassandra-util/src/Cassandra.hs | 3 + libs/cassandra-util/src/Cassandra/Exec.hs | 260 +----------------- libs/cassandra-util/src/Cassandra/Settings.hs | 2 +- libs/cassandra-util/src/Cassandra/Util.hs | 10 +- 4 files changed, 10 insertions(+), 265 deletions(-) diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 88df0dd24fa..24406334813 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -67,9 +67,11 @@ import Cassandra.Exec as C addPrepQuery, batch, emptyPage, + hasMore, init, liftClient, localState, + nextPage, paginate, paginateC, paginateWithState, @@ -81,6 +83,7 @@ import Cassandra.Exec as C pwsHasMore, query, query1, + result, retry, runClient, setConsistency, diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index 408b06ce23c..9d5c7a03d52 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -24,20 +24,6 @@ module Cassandra.Exec paramsP, x5, x1, - BatchM, - Client, - ClientState, - MonadClient, - Page (..), - PrepQuery, - Row, - addPrepQuery, - batch, - emptyPage, - init, - liftClient, - localState, - paginate, paginateC, GeneralPaginationState (..), paginationStateCassandra, @@ -47,109 +33,20 @@ module Cassandra.Exec paginateWithStateC, paramsPagingState, pwsHasMore, - prepared, - query, - query1, - registerClientKeyspace, - retry, - runClient, - setConsistency, - setType, - shutdown, - trans, - write, + module C, ) where -import Cassandra.CQL (Consistency, Keyspace, QueryString (QueryString), R, W, unKeyspace) +import Cassandra.CQL (Consistency, R) import Control.Monad.Catch import Data.Conduit -import Data.Text qualified as Text -import Data.Text.Lazy qualified as LT -import Database.CQL.IO qualified as C -- We only use these locally. import Database.CQL.IO (ProtocolError (UnexpectedResponse), RetrySettings, RunQ, defRetrySettings, eagerRetrySettings, getResult, hrHost, hrResponse, runQ) -- Things we just import and re-export. -import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, emptyPage, liftClient, localState, queryString, retry, setConsistency, setType, shutdown, trans) +import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, addPrepQuery, addQuery, adjustConsistency, adjustResponseTimeout, adjustSendTimeout, batch, emptyPage, init, liftClient, localState, paginate, prepared, query, query1, queryString, retry, runClient, schema, setConsistency, setSerialConsistency, setType, shutdown, trans, write) import Database.CQL.Protocol (Error, QueryParams (QueryParams), Tuple, pagingState) import Database.CQL.Protocol qualified as Protocol -import GHC.Conc.Sync (myThreadId) import Imports hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import System.Mem.StableName (StableName, eqStableName, makeStableName) - -{-# NOINLINE clientKeyspaces #-} -clientKeyspaces :: IORef [(StableName ClientState, Maybe Keyspace)] -clientKeyspaces = unsafePerformIO $ newIORef [] - -{-# NOINLINE threadKeyspaces #-} -threadKeyspaces :: IORef [(ThreadId, [Maybe Keyspace])] -threadKeyspaces = unsafePerformIO $ newIORef [] - -class KeyspaceQualifiable q where - qualifyWithKeyspace :: Maybe Keyspace -> q k a b -> q k a b - -instance KeyspaceQualifiable QueryString where - qualifyWithKeyspace Nothing q = q - qualifyWithKeyspace (Just keyspace) (QueryString queryText) = - QueryString (qualifyCql keyspace queryText) - -instance KeyspaceQualifiable PrepQuery where - qualifyWithKeyspace keyspace = - C.prepared . qualifyWithKeyspace keyspace . C.queryString - -init :: C.Settings -> IO ClientState -init = C.init - -runClient :: MonadIO m => ClientState -> Client a -> m a -runClient clientState action = do - liftIO $ do - keyspace <- lookupClientKeyspace clientState - withThreadKeyspace keyspace (C.runClient clientState action) - -query :: - (MonadClient m, Tuple a, Tuple b, RunQ q, KeyspaceQualifiable q) => - q R a b -> - QueryParams a -> - m [b] -query q params_ = do - keyspace <- currentThreadKeyspace - C.query (qualifyWithKeyspace keyspace q) params_ - -query1 :: - (MonadClient m, Tuple a, Tuple b, RunQ q, KeyspaceQualifiable q) => - q R a b -> - QueryParams a -> - m (Maybe b) -query1 q params_ = do - keyspace <- currentThreadKeyspace - C.query1 (qualifyWithKeyspace keyspace q) params_ - -write :: - (MonadClient m, Tuple a, RunQ q, KeyspaceQualifiable q) => - q W a () -> - QueryParams a -> - m () -write q params_ = do - keyspace <- currentThreadKeyspace - C.write (qualifyWithKeyspace keyspace q) params_ - -paginate :: - (MonadClient m, Tuple a, Tuple b, RunQ q) => - q R a b -> - QueryParams a -> - m (Page b) -paginate = C.paginate - -addPrepQuery :: (Show a, Tuple a, Tuple b) => PrepQuery W a b -> a -> BatchM () -addPrepQuery q params_ = - C.addPrepQuery (qualifyWithKeyspace currentThreadKeyspaceUnsafe q) params_ - -batch :: MonadClient m => BatchM () -> m () -batch = C.batch - -prepared :: QueryString k a b -> PrepQuery k a b -prepared = C.prepared params :: Consistency -> a -> QueryParams a params c p = QueryParams c False p Nothing Nothing Nothing Nothing @@ -265,154 +162,3 @@ paramsPagingState c p n state = QueryParams c False p (Just n) state Nothing Not pwsHasMore :: PageWithState a b -> Bool pwsHasMore = isJust . pwsState - -data QualificationMode - = Normal - | ExpectTable - | ExpectTableKeyword - -registerClientKeyspace :: ClientState -> Maybe Keyspace -> IO () -registerClientKeyspace clientState keyspace = do - stable <- makeStableName clientState - atomicModifyIORef' clientKeyspaces $ \pairs -> - ((stable, keyspace) : pairs, ()) - -lookupClientKeyspace :: ClientState -> IO (Maybe Keyspace) -lookupClientKeyspace clientState = do - stable <- makeStableName clientState - pairs <- readIORef clientKeyspaces - pure $ go stable pairs - where - go _ [] = Nothing - go needle ((candidate, keyspace) : rest) = - if eqStableName needle candidate - then keyspace - else go needle rest - -withThreadKeyspace :: Maybe Keyspace -> IO a -> IO a -withThreadKeyspace keyspace = - bracket_ (pushThreadKeyspace keyspace) popThreadKeyspace - -pushThreadKeyspace :: Maybe Keyspace -> IO () -pushThreadKeyspace keyspace = do - tid <- myThreadId - atomicModifyIORef' threadKeyspaces $ \pairs -> - (upsert pairs tid [keyspace], ()) - where - upsert [] key value = [(key, value)] - upsert ((key, values) : rest) tid' value - | key == tid' = (key, value <> values) : rest - | otherwise = (key, values) : upsert rest tid' value - -popThreadKeyspace :: IO () -popThreadKeyspace = do - tid <- myThreadId - atomicModifyIORef' threadKeyspaces $ \pairs -> - (pop pairs tid, ()) - where - pop [] _ = [] - pop ((key, values) : rest) tid' - | key /= tid' = (key, values) : pop rest tid' - | otherwise = case values of - _ : xs | null xs -> rest - _ : xs -> (key, xs) : rest - [] -> rest - -currentThreadKeyspace :: MonadClient m => m (Maybe Keyspace) -currentThreadKeyspace = liftClient currentThreadKeyspaceClient - -currentThreadKeyspaceClient :: Client (Maybe Keyspace) -currentThreadKeyspaceClient = liftIO currentThreadKeyspaceIO - -currentThreadKeyspaceIO :: IO (Maybe Keyspace) -currentThreadKeyspaceIO = do - tid <- myThreadId - keyspaces <- readIORef threadKeyspaces - pure $ lookup tid keyspaces >>= listToMaybe . catMaybes - -currentThreadKeyspaceUnsafe :: Maybe Keyspace -currentThreadKeyspaceUnsafe = unsafePerformIO currentThreadKeyspaceIO -{-# NOINLINE currentThreadKeyspaceUnsafe #-} - -qualifyCql :: Keyspace -> LT.Text -> LT.Text -qualifyCql keyspace = LT.pack . go Nothing Normal . LT.unpack - where - keyspacePrefix = Text.unpack (unKeyspace keyspace) <> "." - - go :: Maybe String -> QualificationMode -> String -> String - go _ _ [] = [] - go prevWord mode s@(c : cs) - | c == '\'' = - let (strChunk, rest) = takeSingleQuoted s - in strChunk <> go prevWord mode rest - | c == '"' = - let (strChunk, rest) = takeDoubleQuoted s - in strChunk <> go prevWord mode rest - | isAsciiLower c || isAsciiUpper c || c == '_' = - let (token, rest) = span isIdentChar s - tokenLower = map toLower token - (mode', token') = transformToken prevWord mode tokenLower token rest - prevWord' = Just tokenLower - in token' <> go prevWord' mode' rest - | otherwise = c : go prevWord mode cs - - transformToken :: Maybe String -> QualificationMode -> String -> String -> String -> (QualificationMode, String) - transformToken prevWord mode tokenLower token rest = case mode of - ExpectTableKeyword -> - if tokenLower == "table" || tokenLower == "columnfamily" - then (ExpectTable, token) - else (Normal, token) - ExpectTable -> - if tokenLower `elem` ["if", "not", "exists", "only"] - then (ExpectTable, token) - else - let token' = - if isQualifiedIdentifier rest - then token - else keyspacePrefix <> token - in (Normal, token') - Normal -> - if tokenLower `elem` ["from", "into", "update", "join"] - then (ExpectTable, token) - else - if tokenLower `elem` ["alter", "create", "drop", "truncate"] - then (ExpectTableKeyword, token) - else - if tokenLower == "on" && prevWord == Just "index" - then (ExpectTable, token) - else (Normal, token) - - isQualifiedIdentifier :: String -> Bool - isQualifiedIdentifier = \case - [] -> False - x : xs - | isSpace x -> isQualifiedIdentifier xs - | otherwise -> x == '.' - - isIdentChar :: Char -> Bool - isIdentChar ch = isAsciiLower ch || isAsciiUpper ch || isDigit ch || ch == '_' - - takeSingleQuoted :: String -> (String, String) - takeSingleQuoted = goQuoted '\'' - - takeDoubleQuoted :: String -> (String, String) - takeDoubleQuoted = goQuoted '"' - - goQuoted :: Char -> String -> (String, String) - goQuoted quoteChar = \case - [] -> ([], []) - x : xs -> - let (body, rest) = consume xs - in (x : body, rest) - where - consume [] = ([], []) - consume (x : xs) - | x == quoteChar = - case xs of - y : ys | y == quoteChar -> - let (body, rest) = consume ys - in (x : y : body, rest) - _ -> ([x], xs) - | otherwise = - let (body, rest) = consume xs - in (x : body, rest) diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index e2a3649a193..4e38328ef0b 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -34,7 +34,7 @@ import Data.Aeson.Lens import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Text (pack, stripSuffix, unpack) -import Database.CQL.IO as C hiding (addPrepQuery, addQuery, batch, init, paginate, query, query1, runClient, values, write) +import Database.CQL.IO as C hiding (values) import Database.CQL.IO.Tinylog as C (mkLogger) import Imports import Network.Wreq diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index b7472e53af6..d6968ead939 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -25,7 +25,6 @@ module Cassandra.Util where import Cassandra.CQL -import Cassandra.Exec qualified as CassandraExec import Cassandra.Options import Cassandra.Schema import Cassandra.Settings (dcFilterPolicyIfConfigured, initialContactsDisco, initialContactsPlain, mkLogger) @@ -51,9 +50,7 @@ defInitCassandra opts logger = do . setKeyspace (Keyspace opts.keyspace) . setProtocolVersion V4 $ defSettings - client <- initCassandra basicCasSettings opts.tlsCa logger - CassandraExec.registerClientKeyspace client (Just (Keyspace opts.keyspace)) - pure client + initCassandra basicCasSettings opts.tlsCa logger -- | Create Cassandra `ClientState` ("connection") for a service initCassandraForService :: @@ -82,7 +79,6 @@ initCassandraForService opts serviceName discoUrl mbSchemaVersion logger = do . setPolicy (dcFilterPolicyIfConfigured logger opts.filterNodesByDatacentre) $ defSettings p <- initCassandra basicCasSettings opts.tlsCa logger - CassandraExec.registerClientKeyspace p (Just (Keyspace opts.keyspace)) maybe (pure ()) (\v -> runClient p $ (versionCheck v)) mbSchemaVersion pure p @@ -90,7 +86,7 @@ initCassandra :: Settings -> Maybe FilePath -> Log.Logger -> IO ClientState initCassandra settings (Just tlsCaPath) logger = do sslContext <- createSSLContext tlsCaPath let settings' = setSSLContext sslContext settings - CassandraExec.init settings' + init settings' where createSSLContext :: FilePath -> IO OpenSSL.SSLContext createSSLContext certFile = do @@ -107,7 +103,7 @@ initCassandra settings (Just tlsCaPath) logger = do pure sslContext initCassandra settings Nothing logger = do void . liftIO $ Log.debug logger (Log.msg ("No TLS cert file path configured." :: Text)) - CassandraExec.init settings + init settings -- | Read cassandra's writetimes https://docs.datastax.com/en/dse/5.1/cql/cql/cql_using/useWritetime.html -- as UTCTime values without any loss of precision From 844a1af973dc618a791117d96944dc72919756ba Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 3 Mar 2026 16:13:00 +0000 Subject: [PATCH 3/3] wip: refactor to explicitly qualify tables --- libs/cassandra-util/src/Cassandra/Util.hs | 40 +- .../src/Wire/ActivationCodeStore/Cassandra.hs | 41 +- .../src/Wire/BlockListStore/Cassandra.hs | 45 +- .../src/Wire/ClientStore/Cassandra.hs | 241 +++--- .../src/Wire/CodeStore/Cassandra.hs | 24 +- .../src/Wire/CodeStore/Cassandra/Queries.hs | 31 +- .../src/Wire/CodeStore/Migration.hs | 5 +- .../src/Wire/ConversationStore/Cassandra.hs | 722 +++++++++--------- .../ConversationStore/Cassandra/Queries.hs | 321 ++++---- .../Wire/DomainRegistrationStore/Cassandra.hs | 81 +- .../Cassandra.hs | 46 +- .../src/Wire/LegalHoldStore/Cassandra.hs | 72 +- .../Wire/LegalHoldStore/Cassandra/Queries.hs | 93 +-- .../Wire/PasswordResetCodeStore/Cassandra.hs | 49 +- .../src/Wire/PasswordStore/Cassandra.hs | 51 +- .../src/Wire/PropertyStore/Cassandra.hs | 98 ++- .../src/Wire/ProposalStore/Cassandra.hs | 61 +- .../src/Wire/ServiceStore/Cassandra.hs | 40 +- .../src/Wire/TeamFeatureStore/Cassandra.hs | 18 +- .../TeamFeatureStore/Cassandra/Queries.hs | 28 +- .../src/Wire/TeamFeatureStore/Migrating.hs | 4 +- .../src/Wire/TeamFeatureStore/Migration.hs | 5 +- .../src/Wire/TeamStore/Cassandra.hs | 174 ++--- .../src/Wire/TeamStore/Cassandra/Queries.hs | 146 ++-- .../src/Wire/UserKeyStore/Cassandra.hs | 81 +- .../src/Wire/UserStore/Cassandra.hs | 518 +++++++------ libs/wire-subsystems/src/Wire/Util.hs | 15 + services/brig/src/Brig/Budget.hs | 22 +- .../brig/src/Brig/CanonicalInterpreter.hs | 4 +- services/brig/src/Brig/Data/Activation.hs | 46 +- services/brig/src/Brig/Data/Connection.hs | 288 +++---- .../Brig/Effects/ConnectionStore/Cassandra.hs | 9 +- .../test/integration/API/User/Connection.hs | 7 +- .../src/Galley/Cassandra/CustomBackend.hs | 24 +- .../galley/src/Galley/Cassandra/Queries.hs | 145 ++-- .../src/Galley/Cassandra/SearchVisibility.hs | 24 +- services/galley/src/Galley/Cassandra/Store.hs | 13 + services/galley/src/Galley/Cassandra/Team.hs | 60 +- .../spar/src/Spar/CanonicalInterpreter.hs | 7 +- .../src/Spar/Sem/ScimTokenStore/Cassandra.hs | 197 +++-- 40 files changed, 2094 insertions(+), 1802 deletions(-) diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index d6968ead939..3c949640229 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -19,6 +19,9 @@ module Cassandra.Util ( defInitCassandra, initCassandraForService, initCassandra, + registerClientKeyspace, + lookupClientKeyspace, + requireClientKeyspace, Writetime (..), writetimeToInt64, ) @@ -39,7 +42,39 @@ import Database.CQL.IO import Database.CQL.IO.Tinylog qualified as CT import Imports hiding (init) import OpenSSL.Session qualified as OpenSSL +import System.IO.Unsafe (unsafePerformIO) import System.Logger qualified as Log +import System.Mem.StableName (StableName, eqStableName, makeStableName) + +{-# NOINLINE clientKeyspaces #-} +clientKeyspaces :: IORef [(StableName ClientState, Keyspace)] +clientKeyspaces = unsafePerformIO $ newIORef [] + +registerClientKeyspace :: ClientState -> Keyspace -> IO () +registerClientKeyspace clientState keyspace = do + stable <- makeStableName clientState + atomicModifyIORef' clientKeyspaces $ \entries -> + ((stable, keyspace) : entries, ()) + +lookupClientKeyspace :: ClientState -> IO (Maybe Keyspace) +lookupClientKeyspace clientState = do + stable <- makeStableName clientState + entries <- readIORef clientKeyspaces + pure $ go stable entries + where + go _ [] = Nothing + go needle ((candidate, keyspace) : rest) = + if eqStableName needle candidate + then Just keyspace + else go needle rest + +requireClientKeyspace :: (HasCallStack) => ClientState -> IO Keyspace +requireClientKeyspace clientState = + lookupClientKeyspace clientState >>= \case + Just keyspace -> pure keyspace + Nothing -> + error + "Missing keyspace for Cassandra ClientState. Initialize via Cassandra.Util.defInitCassandra/initCassandraForService or call registerClientKeyspace." defInitCassandra :: CassandraOpts -> Log.Logger -> IO ClientState defInitCassandra opts logger = do @@ -50,7 +85,9 @@ defInitCassandra opts logger = do . setKeyspace (Keyspace opts.keyspace) . setProtocolVersion V4 $ defSettings - initCassandra basicCasSettings opts.tlsCa logger + clientState <- initCassandra basicCasSettings opts.tlsCa logger + registerClientKeyspace clientState (Keyspace opts.keyspace) + pure clientState -- | Create Cassandra `ClientState` ("connection") for a service initCassandraForService :: @@ -79,6 +116,7 @@ initCassandraForService opts serviceName discoUrl mbSchemaVersion logger = do . setPolicy (dcFilterPolicyIfConfigured logger opts.filterNodesByDatacentre) $ defSettings p <- initCassandra basicCasSettings opts.tlsCa logger + registerClientKeyspace p (Keyspace opts.keyspace) maybe (pure ()) (\v -> runClient p $ (versionCheck v)) mbSchemaVersion pure p diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs index 56ff6f247a5..b38ffa0dc60 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -18,6 +18,7 @@ module Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Id import Data.Text (pack) import Data.Text.Ascii qualified as Ascii @@ -33,32 +34,36 @@ import Wire.API.User.Activation import Wire.API.User.EmailAddress import Wire.ActivationCodeStore import Wire.UserKeyStore +import Wire.Util (qualifiedTableName) interpretActivationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor ActivationCodeStore r interpretActivationCodeStoreToCassandra casClient = interpret $ - runEmbedded (runClient casClient) . embed . \case + \case LookupActivationCode ek -> do - liftIO (mkActivationKey ek) - >>= retry x1 . query1 cql . params LocalQuorum . Identity - NewActivationCode ek timeout uid -> newActivationCodeImpl ek timeout uid + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) . embed $ do + liftIO (mkActivationKey ek) + >>= retry x1 . query1 (lookupActivationCodeQuery keyspace) . params LocalQuorum . Identity + NewActivationCode ek timeout uid -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) . embed $ newActivationCodeImpl keyspace ek timeout uid where - cql :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) - cql = - [sql| - SELECT user, code FROM activation_keys WHERE key = ? - |] + lookupActivationCodeQuery :: Keyspace -> PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) + lookupActivationCodeQuery keyspace = + fromString $ "SELECT user, code FROM " <> table keyspace "activation_keys" <> " WHERE key = ?" -- | Create a new pending activation for a given 'EmailKey'. newActivationCodeImpl :: (MonadClient m) => + Keyspace -> EmailKey -> -- | The timeout for the activation code. Timeout -> -- | The user with whom to associate the activation code. Maybe UserId -> m Activation -newActivationCodeImpl uk timeout u = do +newActivationCodeImpl keyspace uk timeout u = do let typ = "email" key = fromEmail (emailKeyOrig uk) code <- liftIO $ genCode @@ -66,7 +71,7 @@ newActivationCodeImpl uk timeout u = do where insert t k c = do key <- liftIO $ mkActivationKey uk - retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout) + retry x5 . write (keyInsert keyspace) $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout) pure $ Activation key c genCode = ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" @@ -85,12 +90,16 @@ mkActivationKey k = do . T.encodeUtf8 $ emailKeyUniq k -keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () -keyInsert = - "INSERT INTO activation_keys \ - \(key, key_type, key_text, code, user, retries) VALUES \ - \(? , ? , ? , ? , ? , ? ) USING TTL ?" +keyInsert :: Keyspace -> PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () +keyInsert keyspace = + fromString $ + "INSERT INTO " + <> table keyspace "activation_keys" + <> " (key, key_type, key_text, code, user, retries) VALUES (? , ? , ? , ? , ? , ? ) USING TTL ?" -- | Max. number of activation attempts per 'ActivationKey'. maxAttempts :: Int32 maxAttempts = 3 + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs index 0bf4f46d3ac..ac8788c0914 100644 --- a/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs @@ -21,10 +21,12 @@ module Wire.BlockListStore.Cassandra where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Imports import Polysemy import Wire.BlockListStore (BlockListStore (..)) import Wire.UserKeyStore +import Wire.Util (qualifiedTableName) interpretBlockListStoreToCassandra :: forall r. @@ -33,30 +35,39 @@ interpretBlockListStoreToCassandra :: InterpreterFor BlockListStore r interpretBlockListStoreToCassandra casClient = interpret $ - embed @IO . runClient casClient . \case - Insert uk -> insert uk - Exists uk -> exists uk - Delete uk -> delete uk + \case + Insert uk -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (insert keyspace uk) + Exists uk -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (exists keyspace uk) + Delete uk -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (delete keyspace uk) -------------------------------------------------------------------------------- -- UserKey block listing -insert :: (MonadClient m) => EmailKey -> m () -insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ emailKeyUniq uk)) +insert :: (MonadClient m) => Keyspace -> EmailKey -> m () +insert keyspace uk = retry x5 $ write (keyInsert keyspace) (params LocalQuorum (Identity $ emailKeyUniq uk)) -exists :: (MonadClient m) => EmailKey -> m Bool -exists uk = +exists :: (MonadClient m) => Keyspace -> EmailKey -> m Bool +exists keyspace uk = (pure . isJust) . fmap runIdentity - =<< retry x1 (query1 keySelect (params LocalQuorum (Identity $ emailKeyUniq uk))) + =<< retry x1 (query1 (keySelect keyspace) (params LocalQuorum (Identity $ emailKeyUniq uk))) -delete :: (MonadClient m) => EmailKey -> m () -delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq uk)) +delete :: (MonadClient m) => Keyspace -> EmailKey -> m () +delete keyspace uk = retry x5 $ write (keyDelete keyspace) (params LocalQuorum (Identity $ emailKeyUniq uk)) -keyInsert :: PrepQuery W (Identity Text) () -keyInsert = "INSERT INTO blacklist (key) VALUES (?)" +keyInsert :: Keyspace -> PrepQuery W (Identity Text) () +keyInsert keyspace = fromString $ "INSERT INTO " <> table keyspace "blacklist" <> " (key) VALUES (?)" -keySelect :: PrepQuery R (Identity Text) (Identity Text) -keySelect = "SELECT key FROM blacklist WHERE key = ?" +keySelect :: Keyspace -> PrepQuery R (Identity Text) (Identity Text) +keySelect keyspace = fromString $ "SELECT key FROM " <> table keyspace "blacklist" <> " WHERE key = ?" -keyDelete :: PrepQuery W (Identity Text) () -keyDelete = "DELETE FROM blacklist WHERE key = ?" +keyDelete :: Keyspace -> PrepQuery W (Identity Text) () +keyDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "blacklist" <> " WHERE key = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs index 8bd18d29f4c..063a16c4f9c 100644 --- a/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs @@ -7,6 +7,7 @@ where import Cassandra as C hiding (Client) import Cassandra qualified as C import Cassandra.Settings as C hiding (Client) +import Cassandra.Util (requireClientKeyspace) import Control.Error (atMay) import Control.Monad.Random (randomRIO) import Data.ByteString.Conversion (toByteString) @@ -33,6 +34,7 @@ import Wire.ClientStore (ClientStore (..), DuplicateMLSPublicKey (..)) import Wire.ClientStore.DynamoDB import Wire.Sem.Logger qualified as Log import Wire.Sem.Metrics (Metrics) +import Wire.Util (qualifiedTableName) data ClientStoreCassandraEnv = ClientStoreCassandraEnv { casClient :: ClientState, @@ -51,55 +53,62 @@ interpretClientStoreCassandra env = -- Lifecycle Upsert uid cid timestamp nc -> upsertImpl uid cid timestamp nc Delete uid cid -> deleteImpl uid cid - UpdateLabel uid cid lbl -> runCasClient $ updateLabelImpl uid cid lbl - UpdateCapabilities uid cid caps -> runCasClient $ updateCapabilitiesImpl uid cid caps - UpdateLastActive uid cid timestamp -> runCasClient $ updateLastActiveImpl uid cid timestamp + UpdateLabel uid cid lbl -> runCasClientWithKeyspace $ \keyspace -> updateLabelImpl keyspace uid cid lbl + UpdateCapabilities uid cid caps -> runCasClientWithKeyspace $ \keyspace -> updateCapabilitiesImpl keyspace uid cid caps + UpdateLastActive uid cid timestamp -> runCasClientWithKeyspace $ \keyspace -> updateLastActiveImpl keyspace uid cid timestamp -- Lookups - LookupClient uid cid -> runCasClient $ lookupClientImpl uid cid - LookupClients uid -> runCasClient $ lookupClientsImpl uid - LookupClientIds uid -> runCasClient $ lookupClientIdsImpl uid - LookupClientIdsBulk uids -> runCasClient $ lookupClientIdsBulkImpl uids - LookupClientsBulk uids -> runCasClient $ lookupClientsBulkImpl uids - LookupPubClientsBulk uids -> runCasClient $ lookupPubClientsBulkImpl uids - LookupPrekeyIds uid cid -> runCasClient $ lookupPrekeyIdsImpl uid cid - GetActivityTimestamps uid -> runCasClient $ getActivityTimestampsImpl uid + LookupClient uid cid -> runCasClientWithKeyspace $ \keyspace -> lookupClientImpl keyspace uid cid + LookupClients uid -> runCasClientWithKeyspace $ \keyspace -> lookupClientsImpl keyspace uid + LookupClientIds uid -> runCasClientWithKeyspace $ \keyspace -> lookupClientIdsImpl keyspace uid + LookupClientIdsBulk uids -> runCasClientWithKeyspace $ \keyspace -> lookupClientIdsBulkImpl keyspace uids + LookupClientsBulk uids -> runCasClientWithKeyspace $ \keyspace -> lookupClientsBulkImpl keyspace uids + LookupPubClientsBulk uids -> runCasClientWithKeyspace $ \keyspace -> lookupPubClientsBulkImpl keyspace uids + LookupPrekeyIds uid cid -> runCasClientWithKeyspace $ \keyspace -> lookupPrekeyIdsImpl keyspace uid cid + GetActivityTimestamps uid -> runCasClientWithKeyspace $ \keyspace -> getActivityTimestampsImpl keyspace uid -- Proteus - UpdatePrekeys uid cid prekeys -> runCasClient $ updatePrekeysImpl uid cid prekeys + UpdatePrekeys uid cid prekeys -> runCasClientWithKeyspace $ \keyspace -> updatePrekeysImpl keyspace uid cid prekeys ClaimPrekey uid cid -> claimPrekeyImpl uid cid -- MLS AddMLSPublicKeys uid cid keys -> addMLSPublicKeysImpl uid cid keys - LookupMLSPublicKey uid cid scheme -> runCasClient $ lookupMLSPublicKeyImpl uid cid scheme + LookupMLSPublicKey uid cid scheme -> runCasClientWithKeyspace $ \keyspace -> lookupMLSPublicKeyImpl keyspace uid cid scheme runCasClient :: (Member (Input ClientStoreCassandraEnv) r, Member (Final IO) r) => C.Client a -> Sem r a runCasClient action = do c <- inputs (.casClient) embedToFinal . runEmbedded (C.runClient c) . embed $ action +runCasClientWithKeyspace :: (Member (Input ClientStoreCassandraEnv) r, Member (Final IO) r) => (Keyspace -> C.Client a) -> Sem r a +runCasClientWithKeyspace action = do + c <- inputs (.casClient) + embedToFinal . runEmbedded (C.runClient c) . embed $ do + keyspace <- liftIO $ requireClientKeyspace c + action keyspace + upsertImpl :: (Member (Input ClientStoreCassandraEnv) r, Member (Final IO) r) => UserId -> ClientId -> UTCTimeMillis -> NewClient -> Sem r (Maybe DuplicateMLSPublicKey) upsertImpl uid newId now c = do let keys = unpackLastPrekey (newClientLastKey c) : newClientPrekeys c - runCasClient $ do - updatePrekeysImpl uid newId keys + runCasClientWithKeyspace $ \keyspace -> do + updatePrekeysImpl keyspace uid newId keys let prm = (uid, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, newClientModel c, C.Set . Set.toList . fromClientCapabilityList <$> newClientCapabilities c) - retry x5 $ write insertClient (params LocalQuorum prm) + retry x5 $ write (insertClient keyspace) (params LocalQuorum prm) addMLSPublicKeysImpl uid newId (Map.assocs (newClientMLSPublicKeys c)) -lookupClientImpl :: (MonadClient m) => UserId -> ClientId -> m (Maybe Client) -lookupClientImpl u c = do - keys <- retry x1 (query selectMLSPublicKeys (params LocalQuorum (u, c))) +lookupClientImpl :: (MonadClient m) => Keyspace -> UserId -> ClientId -> m (Maybe Client) +lookupClientImpl keyspace u c = do + keys <- retry x1 (query (selectMLSPublicKeys keyspace) (params LocalQuorum (u, c))) fmap (toClient keys) - <$> retry x1 (query1 selectClient (params LocalQuorum (u, c))) + <$> retry x1 (query1 (selectClient keyspace) (params LocalQuorum (u, c))) -lookupClientsBulkImpl :: (MonadClient m) => [UserId] -> m (UserMap (Imports.Set Client)) -lookupClientsBulkImpl uids = liftClient $ do +lookupClientsBulkImpl :: (MonadClient m) => Keyspace -> [UserId] -> m (UserMap (Imports.Set Client)) +lookupClientsBulkImpl keyspace uids = liftClient $ do userClientTuples <- pooledMapConcurrentlyN 50 getClientSetWithUser uids pure . UserMap $ Map.fromList userClientTuples where getClientSetWithUser :: (MonadClient m) => UserId -> m (UserId, Imports.Set Client) - getClientSetWithUser u = fmap ((u,) . Set.fromList) . lookupClientsImpl $ u + getClientSetWithUser u = fmap ((u,) . Set.fromList) . lookupClientsImpl keyspace $ u -lookupPubClientsBulkImpl :: (MonadClient m) => [UserId] -> m (UserMap (Imports.Set PubClient)) -lookupPubClientsBulkImpl uids = liftClient $ do +lookupPubClientsBulkImpl :: (MonadClient m) => Keyspace -> [UserId] -> m (UserMap (Imports.Set PubClient)) +lookupPubClientsBulkImpl keyspace uids = liftClient $ do userClientTuples <- pooledMapConcurrentlyN 50 getClientSetWithUser uids pure . UserMap $ Map.fromList userClientTuples where @@ -107,13 +116,13 @@ lookupPubClientsBulkImpl uids = liftClient $ do getClientSetWithUser u = (u,) . Set.fromList . map toPubClient <$> executeQuery u executeQuery :: (MonadClient m) => UserId -> m [(ClientId, Maybe ClientClass)] - executeQuery u = retry x1 (query selectPubClients (params LocalQuorum (Identity u))) + executeQuery u = retry x1 (query (selectPubClients keyspace) (params LocalQuorum (Identity u))) -lookupClientsImpl :: (MonadClient m) => UserId -> m [Client] -lookupClientsImpl u = do +lookupClientsImpl :: (MonadClient m) => Keyspace -> UserId -> m [Client] +lookupClientsImpl keyspace u = do keys <- (\(cid, ss, Blob b) -> (cid, [(ss, LBS.toStrict b)])) - <$$> retry x1 (query selectMLSPublicKeysByUser (params LocalQuorum (Identity u))) + <$$> retry x1 (query (selectMLSPublicKeysByUser keyspace) (params LocalQuorum (Identity u))) let keyMap = Map.fromListWith (<>) keys updateKeys c = c @@ -121,30 +130,27 @@ lookupClientsImpl u = do Map.fromList $ Map.findWithDefault [] c.clientId keyMap } updateKeys . toClient [] - <$$> retry x1 (query selectClients (params LocalQuorum (Identity u))) + <$$> retry x1 (query (selectClients keyspace) (params LocalQuorum (Identity u))) -lookupClientIdsImpl :: (MonadClient m) => UserId -> m [ClientId] -lookupClientIdsImpl u = +lookupClientIdsImpl :: (MonadClient m) => Keyspace -> UserId -> m [ClientId] +lookupClientIdsImpl keyspace u = map runIdentity - <$> retry x1 (query selectClientIds (params LocalQuorum (Identity u))) + <$> retry x1 (query (selectClientIds keyspace) (params LocalQuorum (Identity u))) -lookupClientIdsBulkImpl :: (MonadClient m) => [UserId] -> m UserClients -lookupClientIdsBulkImpl us = +lookupClientIdsBulkImpl :: (MonadClient m) => Keyspace -> [UserId] -> m UserClients +lookupClientIdsBulkImpl keyspace us = UserClients . Map.fromList <$> liftClient (pooledMapConcurrentlyN 16 getClientIds us) where - getClientIds u = (u,) <$> fmap Set.fromList (lookupClientIdsImpl u) + getClientIds u = (u,) <$> fmap Set.fromList (lookupClientIdsImpl keyspace u) -lookupPrekeyIdsImpl :: (MonadClient m) => UserId -> ClientId -> m [PrekeyId] -lookupPrekeyIdsImpl u c = +lookupPrekeyIdsImpl :: (MonadClient m) => Keyspace -> UserId -> ClientId -> m [PrekeyId] +lookupPrekeyIdsImpl keyspace u c = map runIdentity - <$> retry x1 (query selectPrekeyIds (params LocalQuorum (u, c))) + <$> retry x1 (query (selectPrekeyIds keyspace) (params LocalQuorum (u, c))) -getActivityTimestampsImpl :: (MonadClient m) => UserId -> m [Maybe UTCTime] -getActivityTimestampsImpl uid = do - runIdentity <$$> retry x1 (query q (params LocalQuorum (Identity uid))) - where - q :: PrepQuery R (Identity UserId) (Identity (Maybe UTCTime)) - q = "SELECT last_active from clients where user = ?" +getActivityTimestampsImpl :: (MonadClient m) => Keyspace -> UserId -> m [Maybe UTCTime] +getActivityTimestampsImpl keyspace uid = + runIdentity <$$> retry x1 (query (selectActivityTimestamps keyspace) (params LocalQuorum (Identity uid))) deleteImpl :: (Member (Input ClientStoreCassandraEnv) r, Member (Final IO) r) => @@ -152,33 +158,33 @@ deleteImpl :: ClientId -> Sem r () deleteImpl u c = do - runCasClient $ do - retry x5 $ write removeClient (params LocalQuorum (u, c)) - retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) + runCasClientWithKeyspace $ \keyspace -> do + retry x5 $ write (removeClient keyspace) (params LocalQuorum (u, c)) + retry x5 $ write (removeClientKeys keyspace) (params LocalQuorum (u, c)) inputs (.prekeyLocking) >>= \case Left _ -> pure () Right optLockEnv -> embedToFinal . runInputConst optLockEnv $ deleteOptLock u c -updateLabelImpl :: (MonadClient m) => UserId -> ClientId -> Maybe Text -> m () -updateLabelImpl u c l = retry x5 $ write updateClientLabelQuery (params LocalQuorum (l, u, c)) +updateLabelImpl :: (MonadClient m) => Keyspace -> UserId -> ClientId -> Maybe Text -> m () +updateLabelImpl keyspace u c l = retry x5 $ write (updateClientLabelQuery keyspace) (params LocalQuorum (l, u, c)) -updateCapabilitiesImpl :: (MonadClient m) => UserId -> ClientId -> Maybe ClientCapabilityList -> m () -updateCapabilitiesImpl u c fs = retry x5 $ write updateClientCapabilitiesQuery (params LocalQuorum (C.Set . Set.toList . fromClientCapabilityList <$> fs, u, c)) +updateCapabilitiesImpl :: (MonadClient m) => Keyspace -> UserId -> ClientId -> Maybe ClientCapabilityList -> m () +updateCapabilitiesImpl keyspace u c fs = retry x5 $ write (updateClientCapabilitiesQuery keyspace) (params LocalQuorum (C.Set . Set.toList . fromClientCapabilityList <$> fs, u, c)) -- | If the update fails, which can happen if device does not exist, then ignore the error silently. -updateLastActiveImpl :: (MonadClient m) => UserId -> ClientId -> UTCTime -> m () -updateLastActiveImpl u c t = +updateLastActiveImpl :: (MonadClient m) => Keyspace -> UserId -> ClientId -> UTCTime -> m () +updateLastActiveImpl keyspace u c t = void . retry x5 $ trans - updateClientLastActiveQuery + (updateClientLastActiveQuery keyspace) (params LocalQuorum (t, u, c)) -updatePrekeysImpl :: (MonadClient m) => UserId -> ClientId -> [UncheckedPrekeyBundle] -> m () -updatePrekeysImpl u c pks = do +updatePrekeysImpl :: (MonadClient m) => Keyspace -> UserId -> ClientId -> [UncheckedPrekeyBundle] -> m () +updatePrekeysImpl keyspace u c pks = do for_ pks $ \k -> do let args = (u, c, prekeyId k, prekeyKey k) - retry x5 $ write insertClientKey (params LocalQuorum args) + retry x5 $ write (insertClientKey keyspace) (params LocalQuorum args) claimPrekeyImpl :: forall r. @@ -192,17 +198,18 @@ claimPrekeyImpl :: Sem r (Maybe ClientPrekey) claimPrekeyImpl u c = do cas <- inputs (.casClient) + keyspace <- runCasClientWithKeyspace pure mClaimedKey <- inputs (.prekeyLocking) >>= \case -- Use random prekey selection strategy Left localLock -> embedFinal $ withLocalLock localLock $ do - prekeys <- C.runClient cas $ retry x1 $ query userPrekeys (params LocalQuorum (u, c)) + prekeys <- C.runClient cas $ retry x1 $ query (userPrekeys keyspace) (params LocalQuorum (u, c)) prekey <- pickRandomPrekey prekeys - C.runClient cas $ traverse removeAndReturnPreKey prekey + C.runClient cas $ traverse (removeAndReturnPreKey keyspace) prekey -- Use DynamoDB based optimistic locking strategy Right optLockEnv -> runInputConst optLockEnv . withOptLock u c . embedFinal . C.runClient cas $ do - prekey <- retry x1 $ query1 userPrekey (params LocalQuorum (u, c)) - traverse removeAndReturnPreKey prekey + prekey <- retry x1 $ query1 (userPrekey keyspace) (params LocalQuorum (u, c)) + traverse (removeAndReturnPreKey keyspace) prekey when (fmap (.prekeyData.prekeyId) mClaimedKey == Just lastPrekeyId) $ Log.debug $ field "user" (toByteString u) @@ -210,11 +217,11 @@ claimPrekeyImpl u c = do . msg (val "last resort prekey used") pure mClaimedKey where - removeAndReturnPreKey :: (PrekeyId, Text) -> C.Client ClientPrekey - removeAndReturnPreKey (i, k) = do + removeAndReturnPreKey :: Keyspace -> (PrekeyId, Text) -> C.Client ClientPrekey + removeAndReturnPreKey keyspace' (i, k) = do when (i /= lastPrekeyId) $ retry x1 $ - write removePrekey (params LocalQuorum (u, c, i)) + write (removePrekey keyspace') (params LocalQuorum (u, c, i)) pure $ ClientPrekey c (UncheckedPrekeyBundle i k) pickRandomPrekey :: [(PrekeyId, Text)] -> IO (Maybe (PrekeyId, Text)) @@ -229,12 +236,13 @@ claimPrekeyImpl u c = do lookupMLSPublicKeyImpl :: (MonadClient m) => + Keyspace -> UserId -> ClientId -> SignatureSchemeTag -> m (Maybe LByteString) -lookupMLSPublicKeyImpl u c ss = - (fromBlob . runIdentity) <$$> retry x1 (query1 selectMLSPublicKey (params LocalQuorum (u, c, ss))) +lookupMLSPublicKeyImpl keyspace u c ss = + (fromBlob . runIdentity) <$$> retry x1 (query1 (selectMLSPublicKey keyspace) (params LocalQuorum (u, c, ss))) addMLSPublicKeysImpl :: (Member (Input ClientStoreCassandraEnv) r, Member (Final IO) r) => @@ -242,23 +250,25 @@ addMLSPublicKeysImpl :: ClientId -> [(SignatureSchemeTag, ByteString)] -> Sem r (Maybe DuplicateMLSPublicKey) -addMLSPublicKeysImpl u c keys = - runError (traverse_ (uncurry (addMLSPublicKey u c)) keys) >>= \case +addMLSPublicKeysImpl u c keys = do + keyspace <- runCasClientWithKeyspace pure + runError (traverse_ (uncurry (addMLSPublicKey keyspace u c)) keys) >>= \case Left e -> pure $ Just e Right () -> pure Nothing addMLSPublicKey :: (Member (Input ClientStoreCassandraEnv) r, Member (Final IO) r, Member (Error DuplicateMLSPublicKey) r) => + Keyspace -> UserId -> ClientId -> SignatureSchemeTag -> ByteString -> Sem r () -addMLSPublicKey u c ss pk = do +addMLSPublicKey keyspace u c ss pk = do rows <- runCasClient $ trans - insertMLSPublicKeys + (insertMLSPublicKeys keyspace) ( params LocalQuorum (u, c, ss, Blob (LBS.fromStrict pk)) @@ -274,64 +284,73 @@ addMLSPublicKey u c ss pk = do ------------------------------------------------------------------------------- -- Queries -insertClient :: PrepQuery W (UserId, ClientId, UTCTimeMillis, ClientType, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Text, Maybe (C.Set ClientCapability)) () -insertClient = "INSERT INTO clients (user, client, tstamp, type, label, class, cookie, model, capabilities) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)" +insertClient :: Keyspace -> PrepQuery W (UserId, ClientId, UTCTimeMillis, ClientType, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Text, Maybe (C.Set ClientCapability)) () +insertClient keyspace = fromString $ "INSERT INTO " <> table keyspace "clients" <> " (user, client, tstamp, type, label, class, cookie, model, capabilities) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)" + +updateClientLabelQuery :: Keyspace -> PrepQuery W (Maybe Text, UserId, ClientId) () +updateClientLabelQuery keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "UPDATE " <> table keyspace "clients" <> " SET label = ? WHERE user = ? AND client = ?" + +updateClientCapabilitiesQuery :: Keyspace -> PrepQuery W (Maybe (C.Set ClientCapability), UserId, ClientId) () +updateClientCapabilitiesQuery keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "UPDATE " <> table keyspace "clients" <> " SET capabilities = ? WHERE user = ? AND client = ?" -updateClientLabelQuery :: PrepQuery W (Maybe Text, UserId, ClientId) () -updateClientLabelQuery = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE clients SET label = ? WHERE user = ? AND client = ?" +updateClientLastActiveQuery :: Keyspace -> PrepQuery W (UTCTime, UserId, ClientId) Row +updateClientLastActiveQuery keyspace = fromString $ "UPDATE " <> table keyspace "clients" <> " SET last_active = ? WHERE user = ? AND client = ? IF EXISTS" -updateClientCapabilitiesQuery :: PrepQuery W (Maybe (C.Set ClientCapability), UserId, ClientId) () -updateClientCapabilitiesQuery = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE clients SET capabilities = ? WHERE user = ? AND client = ?" +selectClientIds :: Keyspace -> PrepQuery R (Identity UserId) (Identity ClientId) +selectClientIds keyspace = fromString $ "SELECT client from " <> table keyspace "clients" <> " where user = ?" -updateClientLastActiveQuery :: PrepQuery W (UTCTime, UserId, ClientId) Row -updateClientLastActiveQuery = "UPDATE clients SET last_active = ? WHERE user = ? AND client = ? IF EXISTS" +selectClients :: Keyspace -> PrepQuery R (Identity UserId) (ClientId, ClientType, UTCTimeMillis, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Text, Maybe (C.Set ClientCapability), Maybe UTCTime) +selectClients keyspace = fromString $ "SELECT client, type, tstamp, label, class, cookie, model, capabilities, last_active from " <> table keyspace "clients" <> " where user = ?" -selectClientIds :: PrepQuery R (Identity UserId) (Identity ClientId) -selectClientIds = "SELECT client from clients where user = ?" +selectPubClients :: Keyspace -> PrepQuery R (Identity UserId) (ClientId, Maybe ClientClass) +selectPubClients keyspace = fromString $ "SELECT client, class from " <> table keyspace "clients" <> " where user = ?" -selectClients :: PrepQuery R (Identity UserId) (ClientId, ClientType, UTCTimeMillis, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Text, Maybe (C.Set ClientCapability), Maybe UTCTime) -selectClients = "SELECT client, type, tstamp, label, class, cookie, model, capabilities, last_active from clients where user = ?" +selectClient :: Keyspace -> PrepQuery R (UserId, ClientId) (ClientId, ClientType, UTCTimeMillis, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Text, Maybe (C.Set ClientCapability), Maybe UTCTime) +selectClient keyspace = fromString $ "SELECT client, type, tstamp, label, class, cookie, model, capabilities, last_active from " <> table keyspace "clients" <> " where user = ? and client = ?" -selectPubClients :: PrepQuery R (Identity UserId) (ClientId, Maybe ClientClass) -selectPubClients = "SELECT client, class from clients where user = ?" +insertClientKey :: Keyspace -> PrepQuery W (UserId, ClientId, PrekeyId, Text) () +insertClientKey keyspace = fromString $ "INSERT INTO " <> table keyspace "prekeys" <> " (user, client, key, data) VALUES (?, ?, ?, ?)" -selectClient :: PrepQuery R (UserId, ClientId) (ClientId, ClientType, UTCTimeMillis, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Text, Maybe (C.Set ClientCapability), Maybe UTCTime) -selectClient = "SELECT client, type, tstamp, label, class, cookie, model, capabilities, last_active from clients where user = ? and client = ?" +removeClient :: Keyspace -> PrepQuery W (UserId, ClientId) () +removeClient keyspace = fromString $ "DELETE FROM " <> table keyspace "clients" <> " where user = ? and client = ?" -insertClientKey :: PrepQuery W (UserId, ClientId, PrekeyId, Text) () -insertClientKey = "INSERT INTO prekeys (user, client, key, data) VALUES (?, ?, ?, ?)" +removeClientKeys :: Keyspace -> PrepQuery W (UserId, ClientId) () +removeClientKeys keyspace = fromString $ "DELETE FROM " <> table keyspace "prekeys" <> " where user = ? and client = ?" -removeClient :: PrepQuery W (UserId, ClientId) () -removeClient = "DELETE FROM clients where user = ? and client = ?" +userPrekey :: Keyspace -> PrepQuery R (UserId, ClientId) (PrekeyId, Text) +userPrekey keyspace = fromString $ "SELECT key, data FROM " <> table keyspace "prekeys" <> " where user = ? and client = ? LIMIT 1" -removeClientKeys :: PrepQuery W (UserId, ClientId) () -removeClientKeys = "DELETE FROM prekeys where user = ? and client = ?" +userPrekeys :: Keyspace -> PrepQuery R (UserId, ClientId) (PrekeyId, Text) +userPrekeys keyspace = fromString $ "SELECT key, data FROM " <> table keyspace "prekeys" <> " where user = ? and client = ?" -userPrekey :: PrepQuery R (UserId, ClientId) (PrekeyId, Text) -userPrekey = "SELECT key, data FROM prekeys where user = ? and client = ? LIMIT 1" +selectPrekeyIds :: Keyspace -> PrepQuery R (UserId, ClientId) (Identity PrekeyId) +selectPrekeyIds keyspace = fromString $ "SELECT key FROM " <> table keyspace "prekeys" <> " where user = ? and client = ?" -userPrekeys :: PrepQuery R (UserId, ClientId) (PrekeyId, Text) -userPrekeys = "SELECT key, data FROM prekeys where user = ? and client = ?" +removePrekey :: Keyspace -> PrepQuery W (UserId, ClientId, PrekeyId) () +removePrekey keyspace = fromString $ "DELETE FROM " <> table keyspace "prekeys" <> " where user = ? and client = ? and key = ?" -selectPrekeyIds :: PrepQuery R (UserId, ClientId) (Identity PrekeyId) -selectPrekeyIds = "SELECT key FROM prekeys where user = ? and client = ?" +selectMLSPublicKey :: Keyspace -> PrepQuery R (UserId, ClientId, SignatureSchemeTag) (Identity Blob) +selectMLSPublicKey keyspace = fromString $ "SELECT key from " <> table keyspace "mls_public_keys" <> " where user = ? and client = ? and sig_scheme = ?" -removePrekey :: PrepQuery W (UserId, ClientId, PrekeyId) () -removePrekey = "DELETE FROM prekeys where user = ? and client = ? and key = ?" +selectMLSPublicKeys :: Keyspace -> PrepQuery R (UserId, ClientId) (SignatureSchemeTag, Blob) +selectMLSPublicKeys keyspace = fromString $ "SELECT sig_scheme, key from " <> table keyspace "mls_public_keys" <> " where user = ? and client = ?" -selectMLSPublicKey :: PrepQuery R (UserId, ClientId, SignatureSchemeTag) (Identity Blob) -selectMLSPublicKey = "SELECT key from mls_public_keys where user = ? and client = ? and sig_scheme = ?" +selectMLSPublicKeysByUser :: Keyspace -> PrepQuery R (Identity UserId) (ClientId, SignatureSchemeTag, Blob) +selectMLSPublicKeysByUser keyspace = fromString $ "SELECT client, sig_scheme, key from " <> table keyspace "mls_public_keys" <> " where user = ?" -selectMLSPublicKeys :: PrepQuery R (UserId, ClientId) (SignatureSchemeTag, Blob) -selectMLSPublicKeys = "SELECT sig_scheme, key from mls_public_keys where user = ? and client = ?" +insertMLSPublicKeys :: Keyspace -> PrepQuery W (UserId, ClientId, SignatureSchemeTag, Blob) Row +insertMLSPublicKeys keyspace = + fromString $ + "INSERT INTO " + <> table keyspace "mls_public_keys" + <> " (user, client, sig_scheme, key) \ + \VALUES (?, ?, ?, ?) IF NOT EXISTS" -selectMLSPublicKeysByUser :: PrepQuery R (Identity UserId) (ClientId, SignatureSchemeTag, Blob) -selectMLSPublicKeysByUser = "SELECT client, sig_scheme, key from mls_public_keys where user = ?" +selectActivityTimestamps :: Keyspace -> PrepQuery R (Identity UserId) (Identity (Maybe UTCTime)) +selectActivityTimestamps keyspace = fromString $ "SELECT last_active from " <> table keyspace "clients" <> " where user = ?" -insertMLSPublicKeys :: PrepQuery W (UserId, ClientId, SignatureSchemeTag, Blob) Row -insertMLSPublicKeys = - "INSERT INTO mls_public_keys (user, client, sig_scheme, key) \ - \VALUES (?, ?, ?, ?) IF NOT EXISTS" +table :: Keyspace -> String -> String +table = qualifiedTableName ------------------------------------------------------------------------------- -- Conversions diff --git a/libs/wire-subsystems/src/Wire/CodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/CodeStore/Cassandra.hs index d320f13369b..4b4558eb117 100644 --- a/libs/wire-subsystems/src/Wire/CodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/CodeStore/Cassandra.hs @@ -31,7 +31,7 @@ import Wire.API.Password import Wire.CodeStore (CodeStore (..)) import Wire.CodeStore.Cassandra.Queries qualified as Cql import Wire.CodeStore.Code as Code -import Wire.Util (embedClientInput) +import Wire.Util (embedClientInputWithKeyspace) interpretCodeStoreToCassandra :: ( Member (Embed IO) r, @@ -42,11 +42,11 @@ interpretCodeStoreToCassandra :: Sem r a interpretCodeStoreToCassandra = interpret $ \case GetCode k -> do - embedClientInput $ lookupCode k + embedClientInputWithKeyspace $ \keyspace -> lookupCode keyspace k CreateCode code mPw -> do - embedClientInput $ insertCode code mPw + embedClientInputWithKeyspace $ \keyspace -> insertCode keyspace code mPw DeleteCode k -> do - embedClientInput $ deleteCode k + embedClientInputWithKeyspace $ \keyspace -> deleteCode keyspace k MakeKey cid -> do Code.mkKey cid GenerateCode cid t -> do @@ -61,19 +61,19 @@ interpretCodeStoreToCassandra = interpret $ \case Nothing -> pure Nothing -- | Insert a conversation code -insertCode :: Code -> Maybe Password -> Client () -insertCode c mPw = do +insertCode :: Keyspace -> Code -> Maybe Password -> Client () +insertCode keyspace c mPw = do let k = codeKey c let v = codeValue c let cnv = codeConversation c let t = round (codeTTL c) - retry x5 (write Cql.insertCode (params LocalQuorum (k, v, cnv, mPw, t))) + retry x5 (write (Cql.insertCode keyspace) (params LocalQuorum (k, v, cnv, mPw, t))) -- | Lookup a conversation by code. -lookupCode :: Key -> Client (Maybe (Code, Maybe Password)) -lookupCode k = - fmap (toCode k) <$> retry x1 (query1 Cql.lookupCode (params LocalQuorum (Identity k))) +lookupCode :: Keyspace -> Key -> Client (Maybe (Code, Maybe Password)) +lookupCode keyspace k = + fmap (toCode k) <$> retry x1 (query1 (Cql.lookupCode keyspace) (params LocalQuorum (Identity k))) -- | Delete a code associated with the given conversation key -deleteCode :: Key -> Client () -deleteCode k = retry x5 $ write Cql.deleteCode (params LocalQuorum (Identity k)) +deleteCode :: Keyspace -> Key -> Client () +deleteCode keyspace k = retry x5 $ write (Cql.deleteCode keyspace) (params LocalQuorum (Identity k)) diff --git a/libs/wire-subsystems/src/Wire/CodeStore/Cassandra/Queries.hs b/libs/wire-subsystems/src/Wire/CodeStore/Cassandra/Queries.hs index 23b31b8e9aa..1613c2b1ec8 100644 --- a/libs/wire-subsystems/src/Wire/CodeStore/Cassandra/Queries.hs +++ b/libs/wire-subsystems/src/Wire/CodeStore/Cassandra/Queries.hs @@ -22,15 +22,30 @@ import Data.Id import Imports import Wire.API.Conversation.Code import Wire.API.Password (Password) +import Wire.Util (qualifiedTableName) -insertCode :: PrepQuery W (Key, Value, ConvId, Maybe Password, Int32) () -insertCode = "INSERT INTO conversation_codes (key, value, conversation, scope, password) VALUES (?, ?, ?, 1, ?) USING TTL ?" +insertCode :: Keyspace -> PrepQuery W (Key, Value, ConvId, Maybe Password, Int32) () +insertCode keyspace = + fromString $ + "INSERT INTO " + <> table keyspace "conversation_codes" + <> " (key, value, conversation, scope, password) VALUES (?, ?, ?, 1, ?) USING TTL ?" -lookupCode :: PrepQuery R (Identity Key) (Value, Int32, ConvId, Maybe Password) -lookupCode = "SELECT value, ttl(value), conversation, password FROM conversation_codes WHERE key = ? AND scope = 1" +lookupCode :: Keyspace -> PrepQuery R (Identity Key) (Value, Int32, ConvId, Maybe Password) +lookupCode keyspace = + fromString $ + "SELECT value, ttl(value), conversation, password FROM " + <> table keyspace "conversation_codes" + <> " WHERE key = ? AND scope = 1" -deleteCode :: PrepQuery W (Identity Key) () -deleteCode = "DELETE FROM conversation_codes WHERE key = ? AND scope = 1" +deleteCode :: Keyspace -> PrepQuery W (Identity Key) () +deleteCode keyspace = fromString $ "DELETE FROM " <> table keyspace "conversation_codes" <> " WHERE key = ? AND scope = 1" -selectAllCodes :: PrepQuery R () (Key, Value, Int32, ConvId, Maybe Password) -selectAllCodes = "SELECT key, value, ttl(value), conversation, password FROM conversation_codes" +selectAllCodes :: Keyspace -> PrepQuery R () (Key, Value, Int32, ConvId, Maybe Password) +selectAllCodes keyspace = + fromString $ + "SELECT key, value, ttl(value), conversation, password FROM " + <> table keyspace "conversation_codes" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/CodeStore/Migration.hs b/libs/wire-subsystems/src/Wire/CodeStore/Migration.hs index 8f14bc5423e..078b557851e 100644 --- a/libs/wire-subsystems/src/Wire/CodeStore/Migration.hs +++ b/libs/wire-subsystems/src/Wire/CodeStore/Migration.hs @@ -18,6 +18,7 @@ module Wire.CodeStore.Migration (migrateCodesLoop) where import Cassandra hiding (Value) +import Cassandra.Util (requireClientKeyspace) import Data.ByteString.Conversion import Data.Code (Key, Value) import Data.Conduit @@ -95,7 +96,9 @@ migrateAllCodes :: ConduitM () Void (Sem r) () migrateAllCodes migOpts migCounter = do lift $ info $ Log.msg (Log.val "migrateAllCodes") - withCount (paginateSem Cql.selectAllCodes (paramsP LocalQuorum () migOpts.pageSize) x5) + cassClient <- lift input + keyspace <- lift (embed (requireClientKeyspace cassClient)) + withCount (paginateSem (Cql.selectAllCodes keyspace) (paramsP LocalQuorum () migOpts.pageSize) x5) .| logRetrievedPage migOpts.pageSize id .| C.mapM_ (traverse_ (\row@(key, _, _, _, _) -> handleErrors (toByteString' key) (migrateCodeRow migCounter row))) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index 6fdd631757d..b1462db739a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -89,15 +89,15 @@ import Wire.Util ----------------------------------------------------------------------------------------- -- CONVERSATION STORE -createConversation :: Local ConvId -> NewConversation -> Client StoredConversation -createConversation lcnv nc = do +createConversation :: Keyspace -> Local ConvId -> NewConversation -> Client StoredConversation +createConversation keyspace lcnv nc = do let storedConv = newStoredConversation lcnv nc meta = storedConv.metadata retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum addPrepQuery - Cql.insertConv + (Cql.insertConv keyspace) ( storedConv.id_, meta.cnvmType, meta.cnvmCreator, @@ -115,28 +115,28 @@ createConversation lcnv nc = do meta.cnvmParent, fmap (.depth) (historyConfig meta.cnvmHistory) ) - for_ (cnvmTeam meta) $ \tid -> addPrepQuery Cql.insertTeamConv (tid, storedConv.id_) + for_ (cnvmTeam meta) $ \tid -> addPrepQuery (Cql.insertTeamConv keyspace) (tid, storedConv.id_) let localUsers = map (\m -> (m.id_, m.convRoleName)) storedConv.localMembers remoteUsers = map (\m -> (,m.convRoleName) <$> m.id_) storedConv.remoteMembers - void $ addMembers storedConv.id_ $ UserList localUsers remoteUsers + void $ addMembers keyspace storedConv.id_ $ UserList localUsers remoteUsers pure storedConv -deleteConversation :: ConvId -> Client () -deleteConversation cid = do - retry x5 $ write Cql.markConvDeleted (params LocalQuorum (Identity cid)) +deleteConversation :: Keyspace -> ConvId -> Client () +deleteConversation keyspace cid = do + retry x5 $ write (Cql.markConvDeleted keyspace) (params LocalQuorum (Identity cid)) - localMembers <- members cid - remoteMembers <- lookupRemoteMembers cid + localMembers <- members keyspace cid + remoteMembers <- lookupRemoteMembers keyspace cid - removeMembersFromLocalConv cid $ + removeMembersFromLocalConv keyspace cid $ UserList ((.id_) <$> localMembers) ((.id_) <$> remoteMembers) - retry x5 $ write Cql.deleteConv (params LocalQuorum (Identity cid)) + retry x5 $ write (Cql.deleteConv keyspace) (params LocalQuorum (Identity cid)) -conversationMeta :: ConvId -> Client (Maybe ConversationMetadata) -conversationMeta conv = +conversationMeta :: Keyspace -> ConvId -> Client (Maybe ConversationMetadata) +conversationMeta keyspace conv = fmap (toConvMeta . snd . toStoredConvRow) - <$> retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) + <$> retry x1 (query1 (Cql.selectConv keyspace) (params LocalQuorum (Identity conv))) parseAccessRoles :: Maybe AccessRoleLegacy -> Maybe (Imports.Set AccessRole) -> Maybe (Imports.Set AccessRole) parseAccessRoles mbLegacy mbAccess = mbAccess <|> fromAccessRoleLegacy <$> mbLegacy @@ -165,59 +165,59 @@ toStoredConvRow (cty, muid, acc, role, roleV2, nme, ti, del, timer, rm, ptag, mg ) ) -getGroupInfo :: ConvId -> Client (Maybe GroupInfoData) -getGroupInfo cid = do +getGroupInfo :: Keyspace -> ConvId -> Client (Maybe GroupInfoData) +getGroupInfo keyspace cid = do (runIdentity =<<) <$> retry x1 ( query1 - Cql.selectGroupInfo + (Cql.selectGroupInfo keyspace) (params LocalQuorum (Identity cid)) ) -isConvAlive :: ConvId -> Client Bool -isConvAlive cid = do - result <- retry x1 (query1 Cql.isConvDeleted (params LocalQuorum (Identity cid))) +isConvAlive :: Keyspace -> ConvId -> Client Bool +isConvAlive keyspace cid = do + result <- retry x1 (query1 (Cql.isConvDeleted keyspace) (params LocalQuorum (Identity cid))) case runIdentity <$> result of Nothing -> pure False Just Nothing -> pure True Just (Just True) -> pure False Just (Just False) -> pure True -updateConvType :: ConvId -> ConvType -> Client () -updateConvType cid ty = +updateConvType :: Keyspace -> ConvId -> ConvType -> Client () +updateConvType keyspace cid ty = retry x5 $ - write Cql.updateConvType (params LocalQuorum (ty, cid)) + write (Cql.updateConvType keyspace) (params LocalQuorum (ty, cid)) -updateConvName :: ConvId -> Range 1 256 Text -> Client () -updateConvName cid name = retry x5 $ write Cql.updateConvName (params LocalQuorum (fromRange name, cid)) +updateConvName :: Keyspace -> ConvId -> Range 1 256 Text -> Client () +updateConvName keyspace cid name = retry x5 $ write (Cql.updateConvName keyspace) (params LocalQuorum (fromRange name, cid)) -updateConvAccess :: ConvId -> ConversationAccessData -> Client () -updateConvAccess cid (ConversationAccessData acc role) = +updateConvAccess :: Keyspace -> ConvId -> ConversationAccessData -> Client () +updateConvAccess keyspace cid (ConversationAccessData acc role) = retry x5 $ - write Cql.updateConvAccess (params LocalQuorum (Cql.Set (toList acc), Cql.Set (toList role), cid)) + write (Cql.updateConvAccess keyspace) (params LocalQuorum (Cql.Set (toList acc), Cql.Set (toList role), cid)) -updateConvReceiptMode :: ConvId -> ReceiptMode -> Client () -updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params LocalQuorum (receiptMode, cid)) +updateConvReceiptMode :: Keyspace -> ConvId -> ReceiptMode -> Client () +updateConvReceiptMode keyspace cid receiptMode = retry x5 $ write (Cql.updateConvReceiptMode keyspace) (params LocalQuorum (receiptMode, cid)) -updateConvMessageTimer :: ConvId -> Maybe Milliseconds -> Client () -updateConvMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params LocalQuorum (mtimer, cid)) +updateConvMessageTimer :: Keyspace -> ConvId -> Maybe Milliseconds -> Client () +updateConvMessageTimer keyspace cid mtimer = retry x5 $ write (Cql.updateConvMessageTimer keyspace) (params LocalQuorum (mtimer, cid)) -getConvEpoch :: ConvId -> Client (Maybe Epoch) -getConvEpoch cid = +getConvEpoch :: Keyspace -> ConvId -> Client (Maybe Epoch) +getConvEpoch keyspace cid = (runIdentity =<<) <$> retry x1 - (query1 Cql.getConvEpoch (params LocalQuorum (Identity cid))) + (query1 (Cql.getConvEpoch keyspace) (params LocalQuorum (Identity cid))) -updateConvEpoch :: ConvId -> Epoch -> Client () -updateConvEpoch cid epoch = retry x5 $ write Cql.updateConvEpoch (params LocalQuorum (epoch, cid)) +updateConvEpoch :: Keyspace -> ConvId -> Epoch -> Client () +updateConvEpoch keyspace cid epoch = retry x5 $ write (Cql.updateConvEpoch keyspace) (params LocalQuorum (epoch, cid)) -updateConvHistory :: ConvId -> History -> Client () -updateConvHistory cid history = +updateConvHistory :: Keyspace -> ConvId -> History -> Client () +updateConvHistory keyspace cid history = retry x5 $ write - Cql.updateConvHistory + (Cql.updateConvHistory keyspace) ( params LocalQuorum ( fmap (.depth) (historyConfig history), @@ -225,44 +225,44 @@ updateConvHistory cid history = ) ) -updateConvCipherSuite :: ConvId -> CipherSuiteTag -> Client () -updateConvCipherSuite cid cs = +updateConvCipherSuite :: Keyspace -> ConvId -> CipherSuiteTag -> Client () +updateConvCipherSuite keyspace cid cs = retry x5 $ write - Cql.updateConvCipherSuite + (Cql.updateConvCipherSuite keyspace) (params LocalQuorum (cs, cid)) -updateConvCellsState :: ConvId -> CellsState -> Client () -updateConvCellsState cid ps = +updateConvCellsState :: Keyspace -> ConvId -> CellsState -> Client () +updateConvCellsState keyspace cid ps = retry x5 $ write - Cql.updateConvCellsState + (Cql.updateConvCellsState keyspace) (params LocalQuorum (ps, cid)) -resetConversation :: ConvId -> GroupId -> Client () -resetConversation cid groupId = +resetConversation :: Keyspace -> ConvId -> GroupId -> Client () +resetConversation keyspace cid groupId = retry x5 $ write - Cql.resetConversation + (Cql.resetConversation keyspace) (params LocalQuorum (groupId, cid)) -setGroupInfo :: ConvId -> GroupInfoData -> Client () -setGroupInfo conv gid = - write Cql.updateGroupInfo (params LocalQuorum (gid, conv)) +setGroupInfo :: Keyspace -> ConvId -> GroupInfoData -> Client () +setGroupInfo keyspace conv gid = + write (Cql.updateGroupInfo keyspace) (params LocalQuorum (gid, conv)) -getConversation :: ConvId -> Client (Maybe StoredConversation) -getConversation conv = do - cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) - remoteMems <- UnliftIO.async $ lookupRemoteMembers conv +getConversation :: Keyspace -> ConvId -> Client (Maybe StoredConversation) +getConversation keyspace conv = do + cdata <- UnliftIO.async $ retry x1 (query1 (Cql.selectConv keyspace) (params LocalQuorum (Identity conv))) + remoteMems <- UnliftIO.async $ lookupRemoteMembers keyspace conv mConvRow <- UnliftIO.wait (toStoredConvRow <$$> cdata) case mConvRow of Nothing -> pure Nothing Just (Just True, _) -> do - deleteConversation conv + deleteConversation keyspace conv pure Nothing Just (_, convRow) -> do toConv conv - <$> members conv + <$> members keyspace conv <*> UnliftIO.wait remoteMems <*> pure (Just convRow) @@ -271,9 +271,10 @@ localConversations :: Member TinyLog r ) => ClientState -> + Keyspace -> [ConvId] -> Sem r [StoredConversation] -localConversations client = +localConversations client keyspace = collectAndLog <=< (runEmbedded (runClient client) . embed . UnliftIO.pooledMapConcurrentlyN 8 localConversation') where @@ -282,41 +283,42 @@ localConversations client = localConversation' :: ConvId -> Client (Either ByteString StoredConversation) localConversation' cid = - note ("No conversation for: " <> toByteString' cid) <$> getConversation cid + note ("No conversation for: " <> toByteString' cid) <$> getConversation keyspace cid -- | Takes a list of conversation ids and returns those found for the given -- user. -localConversationIdsOf :: UserId -> [ConvId] -> Client [ConvId] -localConversationIdsOf usr cids = do - runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params LocalQuorum (usr, cids))) +localConversationIdsOf :: Keyspace -> UserId -> [ConvId] -> Client [ConvId] +localConversationIdsOf keyspace usr cids = do + runIdentity <$$> retry x1 (query (Cql.selectUserConvsIn keyspace) (params LocalQuorum (usr, cids))) -getLocalConvIds :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Client (ResultSet ConvId) -getLocalConvIds usr start (fromRange -> maxIds) = do +getLocalConvIds :: Keyspace -> UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Client (ResultSet ConvId) +getLocalConvIds keyspace usr start (fromRange -> maxIds) = do mkResultSetByLength (fromIntegral maxIds) . fmap runIdentity . result <$> case start of - Just c -> paginate Cql.selectUserConvsFrom (paramsP LocalQuorum (usr, c) (maxIds + 1)) - Nothing -> paginate Cql.selectUserConvs (paramsP LocalQuorum (Identity usr) (maxIds + 1)) + Just c -> paginate (Cql.selectUserConvsFrom keyspace) (paramsP LocalQuorum (usr, c) (maxIds + 1)) + Nothing -> paginate (Cql.selectUserConvs keyspace) (paramsP LocalQuorum (Identity usr) (maxIds + 1)) -getRemoteConvIds :: UserId -> Maybe (Remote ConvId) -> Range 1 1000 Int32 -> Client (ResultSet (Remote ConvId)) -getRemoteConvIds usr start (fromRange -> maxIds) = do +getRemoteConvIds :: Keyspace -> UserId -> Maybe (Remote ConvId) -> Range 1 1000 Int32 -> Client (ResultSet (Remote ConvId)) +getRemoteConvIds keyspace usr start (fromRange -> maxIds) = do mkResultSetByLength (fromIntegral maxIds) . fmap (uncurry toRemoteUnsafe) . result <$> case start of - Just (tUntagged -> Qualified c dom) -> paginate Cql.selectUserRemoteConvsFrom (paramsP LocalQuorum (usr, dom, c) (maxIds + 1)) - Nothing -> paginate Cql.selectUserRemoteConvs (paramsP LocalQuorum (Identity usr) (maxIds + 1)) + Just (tUntagged -> Qualified c dom) -> paginate (Cql.selectUserRemoteConvsFrom keyspace) (paramsP LocalQuorum (usr, dom, c) (maxIds + 1)) + Nothing -> paginate (Cql.selectUserRemoteConvs keyspace) (paramsP LocalQuorum (Identity usr) (maxIds + 1)) -- | Takes a list of remote conversation ids and fetches member status flags -- for the given user remoteConversationStatus :: + Keyspace -> UserId -> [Remote ConvId] -> Client (Map (Remote ConvId) MemberStatus) -remoteConversationStatus uid = +remoteConversationStatus keyspace uid = fmap mconcat - . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain keyspace uid) . bucketRemote -remoteConversationStatusOnDomain :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomain uid rconvs = +remoteConversationStatusOnDomain :: Keyspace -> UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomain keyspace uid rconvs = Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params LocalQuorum (uid, tDomain rconvs, tUnqualified rconvs)) + <$> query (Cql.selectRemoteConvMemberStatuses keyspace) (params LocalQuorum (uid, tDomain rconvs, tUnqualified rconvs)) where toPair (conv, omus, omur, oar, oarr, hid, hidr) = ( qualifyAs rconvs conv, @@ -324,37 +326,31 @@ remoteConversationStatusOnDomain uid rconvs = ) updateToMixedProtocol :: - (Member (Embed IO) r) => - ClientState -> + Keyspace -> ConvId -> GroupId -> Epoch -> - Sem r () -updateToMixedProtocol client convId gid epoch = do - runEmbedded (runClient client) . embed . retry x5 . batch $ do + Client () +updateToMixedProtocol keyspace convId gid epoch = + retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.updateToMixedConv (convId, ProtocolMixedTag, gid, epoch) - pure () + addPrepQuery (Cql.updateToMixedConv keyspace) (convId, ProtocolMixedTag, gid, epoch) -updateToMLSProtocol :: - (Member (Embed IO) r) => - ClientState -> - ConvId -> - Sem r () -updateToMLSProtocol client cnv = - runEmbedded (runClient client) . embed . retry x5 $ - write Cql.updateToMLSConv (params LocalQuorum (cnv, ProtocolMLSTag)) +updateToMLSProtocol :: Keyspace -> ConvId -> Client () +updateToMLSProtocol keyspace cnv = + retry x5 $ + write (Cql.updateToMLSConv keyspace) (params LocalQuorum (cnv, ProtocolMLSTag)) -updateChannelAddPermissions :: ConvId -> AddPermission -> Client () -updateChannelAddPermissions cid cap = retry x5 $ write Cql.updateChannelAddPermission (params LocalQuorum (cap, cid)) +updateChannelAddPermissions :: Keyspace -> ConvId -> AddPermission -> Client () +updateChannelAddPermissions keyspace cid cap = retry x5 $ write (Cql.updateChannelAddPermission keyspace) (params LocalQuorum (cap, cid)) -acquireCommitLock :: GroupId -> Epoch -> NominalDiffTime -> Client LockAcquired -acquireCommitLock groupId epoch ttl = do +acquireCommitLock :: Keyspace -> GroupId -> Epoch -> NominalDiffTime -> Client LockAcquired +acquireCommitLock keyspace groupId epoch ttl = do rows <- retry x5 $ trans - Cql.acquireCommitLock + (Cql.acquireCommitLock keyspace) ( params LocalQuorum (groupId, epoch, round ttl) @@ -366,11 +362,11 @@ acquireCommitLock groupId epoch ttl = do then Acquired else NotAcquired -releaseCommitLock :: GroupId -> Epoch -> Client () -releaseCommitLock groupId epoch = +releaseCommitLock :: Keyspace -> GroupId -> Epoch -> Client () +releaseCommitLock keyspace groupId epoch = retry x5 $ write - Cql.releaseCommitLock + (Cql.releaseCommitLock keyspace) ( params LocalQuorum (groupId, epoch) @@ -380,31 +376,31 @@ checkTransSuccess :: [Row] -> Bool checkTransSuccess [] = False checkTransSuccess (row : _) = either (const False) (fromMaybe False) $ fromRow 0 row -removeTeamConv :: TeamId -> ConvId -> Client () -removeTeamConv tid cid = liftClient $ do +removeTeamConv :: Keyspace -> TeamId -> ConvId -> Client () +removeTeamConv keyspace tid cid = liftClient $ do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.markConvDeleted (Identity cid) - addPrepQuery Cql.deleteTeamConv (tid, cid) - deleteConversation cid + addPrepQuery (Cql.markConvDeleted keyspace) (Identity cid) + addPrepQuery (Cql.deleteTeamConv keyspace) (tid, cid) + deleteConversation keyspace cid -teamConversation :: TeamId -> ConvId -> Client (Maybe ConvId) -teamConversation t c = - runIdentity <$$> retry x1 (query1 Cql.selectTeamConv (params LocalQuorum (t, c))) +teamConversation :: Keyspace -> TeamId -> ConvId -> Client (Maybe ConvId) +teamConversation keyspace t c = + runIdentity <$$> retry x1 (query1 (Cql.selectTeamConv keyspace) (params LocalQuorum (t, c))) -getTeamConversations :: TeamId -> Client [ConvId] -getTeamConversations t = - runIdentity <$$> retry x1 (query Cql.selectTeamConvs (params LocalQuorum (Identity t))) +getTeamConversations :: Keyspace -> TeamId -> Client [ConvId] +getTeamConversations keyspace t = + runIdentity <$$> retry x1 (query (Cql.selectTeamConvs keyspace) (params LocalQuorum (Identity t))) -deleteTeamConversations :: TeamId -> Client () -deleteTeamConversations tid = do +deleteTeamConversations :: Keyspace -> TeamId -> Client () +deleteTeamConversations keyspace tid = do convs <- teamConversationsForPagination Nothing 2000 remove convs where remove :: Page ConvId -> Client () remove convs = do - for_ (result convs) $ removeTeamConv tid + for_ (result convs) $ removeTeamConv keyspace tid unless (null $ result convs) $ remove =<< nextPage convs @@ -414,8 +410,8 @@ deleteTeamConversations tid = do Client (Page ConvId) teamConversationsForPagination start n = runIdentity <$$> case start of - Just c -> paginate Cql.selectTeamConvsFrom (paramsP LocalQuorum (tid, c) n) - Nothing -> paginate Cql.selectTeamConvs (paramsP LocalQuorum (Identity tid) n) + Just c -> paginate (Cql.selectTeamConvsFrom keyspace) (paramsP LocalQuorum (tid, c) n) + Nothing -> paginate (Cql.selectTeamConvs keyspace) (paramsP LocalQuorum (Identity tid) n) ----------------------------------------------------------------------------------------- -- MEMBERS STORE @@ -425,10 +421,11 @@ deleteTeamConversations tid = do -- When the role is not specified, it defaults to admin. -- Please make sure the conversation doesn't exceed the maximum size! addMembers :: + Keyspace -> ConvId -> UserList (UserId, RoleName) -> Client ([LocalMember], [RemoteMember]) -addMembers conv (UserList lusers rusers) = do +addMembers keyspace conv (UserList lusers rusers) = do -- batch statement with 500 users are known to be above the batch size limit -- and throw "Batch too large" errors. Therefor we chunk requests and insert -- sequentially. (parallelizing would not aid performance as the partition @@ -444,8 +441,8 @@ addMembers conv (UserList lusers rusers) = do setConsistency LocalQuorum for_ chunk $ \(u, r) -> do -- User is local, too, so we add it to both the member and the user table - addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) - addPrepQuery Cql.insertUserConv (u, conv) + addPrepQuery (Cql.insertMember keyspace) (conv, u, Nothing, Nothing, r) + addPrepQuery (Cql.insertUserConv keyspace) (u, conv) for_ (List.chunksOf 32 rusers) $ \chunk -> do retry x5 . batch $ do @@ -456,44 +453,44 @@ addMembers conv (UserList lusers rusers) = do -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has -- been (or will be) made separately. See Galley.API.Update.addMembers - addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) + addPrepQuery (Cql.insertRemoteMember keyspace) (conv, domain, uid, role) pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) -removeMembersFromLocalConv :: ConvId -> UserList UserId -> Client () -removeMembersFromLocalConv cnv victims = void $ do +removeMembersFromLocalConv :: Keyspace -> ConvId -> UserList UserId -> Client () +removeMembersFromLocalConv keyspace cnv victims = void $ do UnliftIO.concurrently - (removeLocalMembersFromLocalConv cnv (ulLocals victims)) - (removeRemoteMembersFromLocalConv cnv (ulRemotes victims)) + (removeLocalMembersFromLocalConv keyspace cnv (ulLocals victims)) + (removeRemoteMembersFromLocalConv keyspace cnv (ulRemotes victims)) -removeLocalMembersFromLocalConv :: ConvId -> [UserId] -> Client () -removeLocalMembersFromLocalConv _ [] = pure () -removeLocalMembersFromLocalConv cnv victims = do +removeLocalMembersFromLocalConv :: Keyspace -> ConvId -> [UserId] -> Client () +removeLocalMembersFromLocalConv _ _ [] = pure () +removeLocalMembersFromLocalConv keyspace cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum for_ victims $ \victim -> do - addPrepQuery Cql.removeMember (cnv, victim) - addPrepQuery Cql.deleteUserConv (victim, cnv) + addPrepQuery (Cql.removeMember keyspace) (cnv, victim) + addPrepQuery (Cql.deleteUserConv keyspace) (victim, cnv) -removeRemoteMembersFromLocalConv :: ConvId -> [Remote UserId] -> Client () -removeRemoteMembersFromLocalConv _ [] = pure () -removeRemoteMembersFromLocalConv cnv victims = do +removeRemoteMembersFromLocalConv :: Keyspace -> ConvId -> [Remote UserId] -> Client () +removeRemoteMembersFromLocalConv _ _ [] = pure () +removeRemoteMembersFromLocalConv keyspace cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum for_ victims $ \(tUntagged -> Qualified uid domain) -> - addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) + addPrepQuery (Cql.removeRemoteMember keyspace) (cnv, domain, uid) -members :: ConvId -> Client [LocalMember] -members conv = do - parents <- retry x1 $ query Cql.selectConvParent (params LocalQuorum (Identity conv)) +members :: Keyspace -> ConvId -> Client [LocalMember] +members keyspace conv = do + parents <- retry x1 $ query (Cql.selectConvParent keyspace) (params LocalQuorum (Identity conv)) nubBy ((==) `on` (.id_)) . concatMap (mapMaybe toMember) <$> UnliftIO.pooledMapConcurrentlyN 16 fetchMembers (conv : mapMaybe runIdentity parents) where fetchMembers convId = retry x1 $ - query Cql.selectMembers (params LocalQuorum (Identity convId)) + query (Cql.selectMembers keyspace) (params LocalQuorum (Identity convId)) toMemberStatus :: ( -- otr muted @@ -545,9 +542,9 @@ toMember (usr, srv, prv, Just 0, omus, omur, oar, oarr, hid, hidr, crn) = } toMember _ = Nothing -lookupRemoteMember :: ConvId -> Domain -> UserId -> Client (Maybe RemoteMember) -lookupRemoteMember conv domain usr = do - mkMem <$$> retry x1 (query1 Cql.selectRemoteMember (params LocalQuorum (conv, domain, usr))) +lookupRemoteMember :: Keyspace -> ConvId -> Domain -> UserId -> Client (Maybe RemoteMember) +lookupRemoteMember keyspace conv domain usr = do + mkMem <$$> retry x1 (query1 (Cql.selectRemoteMember keyspace) (params LocalQuorum (conv, domain, usr))) where mkMem (Identity role) = RemoteMember @@ -555,9 +552,9 @@ lookupRemoteMember conv domain usr = do convRoleName = role } -lookupRemoteMembers :: ConvId -> Client [RemoteMember] -lookupRemoteMembers conv = do - fmap (map mkMem) . retry x1 $ query Cql.selectRemoteMembers (params LocalQuorum (Identity conv)) +lookupRemoteMembers :: Keyspace -> ConvId -> Client [RemoteMember] +lookupRemoteMembers keyspace conv = do + fmap (map mkMem) . retry x1 $ query (Cql.selectRemoteMembers keyspace) (params LocalQuorum (Identity conv)) where mkMem (domain, usr, role) = RemoteMember @@ -566,23 +563,24 @@ lookupRemoteMembers conv = do } member :: + Keyspace -> ConvId -> UserId -> Client (Maybe LocalMember) -member cnv usr = do - parents <- retry x1 $ query Cql.selectConvParent (params LocalQuorum (Identity cnv)) +member keyspace cnv usr = do + parents <- retry x1 $ query (Cql.selectConvParent keyspace) (params LocalQuorum (Identity cnv)) asum . map (toMember =<<) <$> UnliftIO.pooledMapConcurrentlyN 16 fetchMembers (cnv : mapMaybe runIdentity parents) where fetchMembers convId = - retry x1 (query1 Cql.selectMember (params LocalQuorum (convId, usr))) + retry x1 (query1 (Cql.selectMember keyspace) (params LocalQuorum (convId, usr))) -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations -- on the remote end. -addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Client () -addLocalMembersToRemoteConv _ [] = pure () -addLocalMembersToRemoteConv rconv users = do +addLocalMembersToRemoteConv :: Keyspace -> Remote ConvId -> [UserId] -> Client () +addLocalMembersToRemoteConv _ _ [] = pure () +addLocalMembersToRemoteConv keyspace rconv users = do -- FUTUREWORK: consider using pooledMapConcurrentlyN for_ (List.chunksOf 32 users) $ \chunk -> retry x5 . batch $ do @@ -590,81 +588,85 @@ addLocalMembersToRemoteConv rconv users = do setConsistency LocalQuorum for_ chunk $ \u -> addPrepQuery - Cql.insertUserRemoteConv + (Cql.insertUserRemoteConv keyspace) (u, tDomain rconv, tUnqualified rconv) updateSelfMember :: + Keyspace -> Qualified ConvId -> Local UserId -> MemberUpdate -> Client () -updateSelfMember qcnv lusr = +updateSelfMember keyspace qcnv lusr = foldQualified lusr - updateSelfMemberLocalConv - updateSelfMemberRemoteConv + (updateSelfMemberLocalConv keyspace) + (updateSelfMemberRemoteConv keyspace) qcnv lusr updateSelfMemberLocalConv :: + Keyspace -> Local ConvId -> Local UserId -> MemberUpdate -> Client () -updateSelfMemberLocalConv lcid luid mup = do +updateSelfMemberLocalConv keyspace lcid luid mup = do retry x5 . batch $ do setType BatchUnLogged setConsistency LocalQuorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery - Cql.updateOtrMemberMutedStatus + (Cql.updateOtrMemberMutedStatus keyspace) (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery - Cql.updateOtrMemberArchived + (Cql.updateOtrMemberArchived keyspace) (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery - Cql.updateMemberHidden + (Cql.updateMemberHidden keyspace) (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) updateSelfMemberRemoteConv :: + Keyspace -> Remote ConvId -> Local UserId -> MemberUpdate -> Client () -updateSelfMemberRemoteConv (tUntagged -> Qualified cid domain) luid mup = do +updateSelfMemberRemoteConv keyspace (tUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged setConsistency LocalQuorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery - Cql.updateRemoteOtrMemberMutedStatus + (Cql.updateRemoteOtrMemberMutedStatus keyspace) (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery - Cql.updateRemoteOtrMemberArchived + (Cql.updateRemoteOtrMemberArchived keyspace) (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery - Cql.updateRemoteMemberHidden + (Cql.updateRemoteMemberHidden keyspace) (h, mupHiddenRef mup, domain, cid, tUnqualified luid) updateOtherMemberLocalConv :: + Keyspace -> Local ConvId -> Qualified UserId -> OtherMemberUpdate -> Client () -updateOtherMemberLocalConv lcid quid omu = +updateOtherMemberLocalConv keyspace lcid quid omu = do let add r | tDomain lcid == qDomain quid = addPrepQuery - Cql.updateMemberConvRoleName + (Cql.updateMemberConvRoleName keyspace) (r, tUnqualified lcid, qUnqualified quid) | otherwise = addPrepQuery - Cql.updateRemoteMemberConvRoleName + (Cql.updateRemoteMemberConvRoleName keyspace) (r, tUnqualified lcid, qDomain quid, qUnqualified quid) retry x5 . batch $ do setType BatchUnLogged @@ -675,10 +677,11 @@ updateOtherMemberLocalConv lcid quid omu = -- Return the filtered list and a boolean indicating whether the all the input -- users are members. filterRemoteConvMembers :: + Keyspace -> [UserId] -> Remote ConvId -> Client ([UserId], Bool) -filterRemoteConvMembers users (tUntagged -> Qualified conv dom) = +filterRemoteConvMembers keyspace users (tUntagged -> Qualified conv dom) = fmap Data.Monoid.getAll . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users @@ -687,107 +690,109 @@ filterRemoteConvMembers users (tUntagged -> Qualified conv dom) = filterMember user = fmap (map runIdentity) . retry x1 - $ query Cql.selectRemoteConvMembers (params LocalQuorum (user, dom, conv)) + $ query (Cql.selectRemoteConvMembers keyspace) (params LocalQuorum (user, dom, conv)) lookupLocalMemberRemoteConv :: + Keyspace -> UserId -> Remote ConvId -> Client (Maybe UserId) -lookupLocalMemberRemoteConv uid (tUntagged -> Qualified conv dom) = +lookupLocalMemberRemoteConv keyspace uid (tUntagged -> Qualified conv dom) = runIdentity <$$> retry x5 - (query1 Cql.selectRemoteConvMembers (params LocalQuorum (uid, dom, conv))) + (query1 (Cql.selectRemoteConvMembers keyspace) (params LocalQuorum (uid, dom, conv))) -haveRemoteConvs :: [UserId] -> Client [UserId] -haveRemoteConvs uids = +haveRemoteConvs :: Keyspace -> [UserId] -> Client [UserId] +haveRemoteConvs keyspace uids = catMaybes <$> UnliftIO.pooledMapConcurrentlyN 16 runSelect uids where - selectUserFromRemoteConv :: PrepQuery R (Identity UserId) (Identity UserId) - selectUserFromRemoteConv = "select user from user_remote_conv where user = ? limit 1" + selectUserFromRemoteConv :: Keyspace -> PrepQuery R (Identity UserId) (Identity UserId) + selectUserFromRemoteConv ks = fromString $ "select user from " <> qualifiedTableName ks "user_remote_conv" <> " where user = ? limit 1" runSelect :: UserId -> Client (Maybe UserId) runSelect uid = - runIdentity <$$> retry x5 (query1 selectUserFromRemoteConv (params LocalQuorum (Identity uid))) + runIdentity <$$> retry x5 (query1 (selectUserFromRemoteConv keyspace) (params LocalQuorum (Identity uid))) removeLocalMembersFromRemoteConv :: + Keyspace -> -- | The conversation to remove members from Remote ConvId -> -- | Members to remove local to this backend [UserId] -> Client () -removeLocalMembersFromRemoteConv _ [] = pure () -removeLocalMembersFromRemoteConv (tUntagged -> Qualified conv convDomain) victims = +removeLocalMembersFromRemoteConv _ _ [] = pure () +removeLocalMembersFromRemoteConv keyspace (tUntagged -> Qualified conv convDomain) victims = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) + for_ victims $ \u -> addPrepQuery (Cql.deleteUserRemoteConv keyspace) (u, convDomain, conv) -addMLSClients :: GroupId -> Qualified UserId -> Set.Set (ClientId, LeafIndex) -> Client () -addMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do +addMLSClients :: Keyspace -> GroupId -> Qualified UserId -> Set.Set (ClientId, LeafIndex) -> Client () +addMLSClients keyspace groupId (Qualified usr domain) cs = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum for_ cs $ \(c, idx) -> - addPrepQuery Cql.addMLSClient (groupId, domain, usr, c, fromIntegral idx) + addPrepQuery (Cql.addMLSClient keyspace) (groupId, domain, usr, c, fromIntegral idx) -planMLSClientRemoval :: (Foldable f) => GroupId -> f ClientIdentity -> Client () -planMLSClientRemoval groupId cids = +planMLSClientRemoval :: (Foldable f) => Keyspace -> GroupId -> f ClientIdentity -> Client () +planMLSClientRemoval keyspace groupId cids = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum for_ cids $ \cid -> do addPrepQuery - Cql.planMLSClientRemoval + (Cql.planMLSClientRemoval keyspace) (groupId, ciDomain cid, ciUser cid, ciClient cid) -removeMLSClients :: GroupId -> Qualified UserId -> Set.Set ClientId -> Client () -removeMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do +removeMLSClients :: Keyspace -> GroupId -> Qualified UserId -> Set.Set ClientId -> Client () +removeMLSClients keyspace groupId (Qualified usr domain) cs = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum for_ cs $ \c -> - addPrepQuery Cql.removeMLSClient (groupId, domain, usr, c) + addPrepQuery (Cql.removeMLSClient keyspace) (groupId, domain, usr, c) -removeAllMLSClients :: GroupId -> Client () -removeAllMLSClients groupId = do - retry x5 $ write Cql.removeAllMLSClients (params LocalQuorum (Identity groupId)) +removeAllMLSClients :: Keyspace -> GroupId -> Client () +removeAllMLSClients keyspace groupId = do + retry x5 $ write (Cql.removeAllMLSClients keyspace) (params LocalQuorum (Identity groupId)) -- FUTUREWORK: support adding bots to a remote conversation -addBotMember :: ServiceRef -> BotId -> ConvId -> Client BotMember -addBotMember s bot cnv = do +addBotMember :: Keyspace -> ServiceRef -> BotId -> ConvId -> Client BotMember +addBotMember keyspace s bot cnv = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.insertUserConv (botUserId bot, cnv) - addPrepQuery Cql.insertBot (cnv, bot, sid, pid) + addPrepQuery (Cql.insertUserConv keyspace) (botUserId bot, cnv) + addPrepQuery (Cql.insertBot keyspace) (cnv, bot, sid, pid) pure (BotMember mem) where pid = s ^. serviceRefProvider sid = s ^. serviceRefId mem = (newMember (botUserId bot)) {service = Just s} -lookupMLSClientLeafIndices :: GroupId -> Client (ClientMap LeafIndex, IndexMap) -lookupMLSClientLeafIndices groupId = do - entries <- retry x5 (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) +lookupMLSClientLeafIndices :: Keyspace -> GroupId -> Client (ClientMap LeafIndex, IndexMap) +lookupMLSClientLeafIndices keyspace groupId = do + entries <- retry x5 (query (Cql.lookupMLSClients keyspace) (params LocalQuorum (Identity groupId))) pure $ (mkClientMap &&& mkIndexMap) entries -lookupMLSClients :: GroupId -> Client (ClientMap LeafIndex) -lookupMLSClients = fmap fst . lookupMLSClientLeafIndices +lookupMLSClients :: Keyspace -> GroupId -> Client (ClientMap LeafIndex) +lookupMLSClients keyspace = fmap fst . lookupMLSClientLeafIndices keyspace ----------------------------------------------------------------------------------------- -- SUB CONVERSATION STORE -selectSubConversation :: ConvId -> SubConvId -> Client (Maybe SubConversation) -selectSubConversation convId subConvId = runMaybeT $ do +selectSubConversation :: Keyspace -> ConvId -> SubConvId -> Client (Maybe SubConversation) +selectSubConversation keyspace convId subConvId = runMaybeT $ do (mSuite, mEpoch, mEpochWritetime, mGroupId) <- MaybeT $ - retry x5 (query1 Cql.selectSubConversation (params LocalQuorum (convId, subConvId))) + retry x5 (query1 (Cql.selectSubConversation keyspace) (params LocalQuorum (convId, subConvId))) let activeData = ActiveMLSConversationData <$> mEpoch <*> fmap writetimeToUTC mEpochWritetime <*> mSuite groupId <- hoistMaybe mGroupId - (cm, im) <- lift $ lookupMLSClientLeafIndices groupId + (cm, im) <- lift $ lookupMLSClientLeafIndices keyspace groupId pure $ SubConversation { scParentConvId = convId, @@ -802,15 +807,16 @@ selectSubConversation convId subConvId = runMaybeT $ do } insertSubConversation :: + Keyspace -> ConvId -> SubConvId -> GroupId -> Client SubConversation -insertSubConversation convId subConvId groupId = do +insertSubConversation keyspace convId subConvId groupId = do retry x5 ( write - Cql.insertSubConversation + (Cql.insertSubConversation keyspace) ( params LocalQuorum (convId, subConvId, Epoch 0, groupId, Nothing) @@ -818,33 +824,33 @@ insertSubConversation convId subConvId groupId = do ) pure (newSubConversation convId subConvId groupId) -updateSubConvGroupInfo :: ConvId -> SubConvId -> Maybe GroupInfoData -> Client () -updateSubConvGroupInfo convId subConvId mGroupInfo = - retry x5 (write Cql.updateSubConvGroupInfo (params LocalQuorum (convId, subConvId, mGroupInfo))) +updateSubConvGroupInfo :: Keyspace -> ConvId -> SubConvId -> Maybe GroupInfoData -> Client () +updateSubConvGroupInfo keyspace convId subConvId mGroupInfo = + retry x5 (write (Cql.updateSubConvGroupInfo keyspace) (params LocalQuorum (convId, subConvId, mGroupInfo))) -selectSubConvGroupInfo :: ConvId -> SubConvId -> Client (Maybe GroupInfoData) -selectSubConvGroupInfo convId subConvId = - (runIdentity =<<) <$> retry x5 (query1 Cql.selectSubConvGroupInfo (params LocalQuorum (convId, subConvId))) +selectSubConvGroupInfo :: Keyspace -> ConvId -> SubConvId -> Client (Maybe GroupInfoData) +selectSubConvGroupInfo keyspace convId subConvId = + (runIdentity =<<) <$> retry x5 (query1 (Cql.selectSubConvGroupInfo keyspace) (params LocalQuorum (convId, subConvId))) -selectSubConvEpoch :: ConvId -> SubConvId -> Client (Maybe Epoch) -selectSubConvEpoch convId subConvId = - (runIdentity =<<) <$> retry x5 (query1 Cql.selectSubConvEpoch (params LocalQuorum (convId, subConvId))) +selectSubConvEpoch :: Keyspace -> ConvId -> SubConvId -> Client (Maybe Epoch) +selectSubConvEpoch keyspace convId subConvId = + (runIdentity =<<) <$> retry x5 (query1 (Cql.selectSubConvEpoch keyspace) (params LocalQuorum (convId, subConvId))) -setEpochForSubConversation :: ConvId -> SubConvId -> Epoch -> Client () -setEpochForSubConversation cid sconv epoch = - retry x5 (write Cql.insertEpochForSubConversation (params LocalQuorum (epoch, cid, sconv))) +setEpochForSubConversation :: Keyspace -> ConvId -> SubConvId -> Epoch -> Client () +setEpochForSubConversation keyspace cid sconv epoch = + retry x5 (write (Cql.insertEpochForSubConversation keyspace) (params LocalQuorum (epoch, cid, sconv))) -setCipherSuiteForSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Client () -setCipherSuiteForSubConversation cid sconv cs = - retry x5 (write Cql.insertCipherSuiteForSubConversation (params LocalQuorum (cs, cid, sconv))) +setCipherSuiteForSubConversation :: Keyspace -> ConvId -> SubConvId -> CipherSuiteTag -> Client () +setCipherSuiteForSubConversation keyspace cid sconv cs = + retry x5 (write (Cql.insertCipherSuiteForSubConversation keyspace) (params LocalQuorum (cs, cid, sconv))) -deleteSubConversation :: ConvId -> SubConvId -> Client () -deleteSubConversation cid sconv = - retry x5 $ write Cql.deleteSubConversation (params LocalQuorum (cid, sconv)) +deleteSubConversation :: Keyspace -> ConvId -> SubConvId -> Client () +deleteSubConversation keyspace cid sconv = + retry x5 $ write (Cql.deleteSubConversation keyspace) (params LocalQuorum (cid, sconv)) -listSubConversations :: ConvId -> Client (Map SubConvId ConversationMLSData) -listSubConversations cid = do - subs <- retry x1 (query Cql.listSubConversations (params LocalQuorum (Identity cid))) +listSubConversations :: Keyspace -> ConvId -> Client (Map SubConvId ConversationMLSData) +listSubConversations keyspace cid = do + subs <- retry x1 (query (Cql.listSubConversations keyspace) (params LocalQuorum (Identity cid))) pure . Map.fromList $ do (subId, cs, epoch, ts, gid) <- subs let activeData = case (epoch, ts) of @@ -865,23 +871,23 @@ listSubConversations cid = do } ) -setConversationOutOfSync :: ConvId -> Bool -> Client () -setConversationOutOfSync cid outOfSync = - retry x5 (write Cql.insertConvOutOfSync (params LocalQuorum (cid, outOfSync))) +setConversationOutOfSync :: Keyspace -> ConvId -> Bool -> Client () +setConversationOutOfSync keyspace cid outOfSync = + retry x5 (write (Cql.insertConvOutOfSync keyspace) (params LocalQuorum (cid, outOfSync))) -isConversationOutOfSync :: ConvId -> Client Bool -isConversationOutOfSync cid = +isConversationOutOfSync :: Keyspace -> ConvId -> Client Bool +isConversationOutOfSync keyspace cid = maybe False (fromMaybe False . runIdentity) - <$> retry x1 (query1 Cql.lookupConvOutOfSync (params LocalQuorum (Identity cid))) + <$> retry x1 (query1 (Cql.lookupConvOutOfSync keyspace) (params LocalQuorum (Identity cid))) interpretMLSCommitLockStoreToCassandra :: (Member (Embed IO) r, Member TinyLog r) => ClientState -> InterpreterFor MLSCommitLockStore r interpretMLSCommitLockStoreToCassandra client = interpret $ \case AcquireCommitLock gId epoch ttl -> do logEffect "MLSCommitLockStore.AcquireCommitLock" - embedClient client $ acquireCommitLock gId epoch ttl + embedClientWithKeyspace client (\keyspace -> acquireCommitLock keyspace gId epoch ttl) ReleaseCommitLock gId epoch -> do logEffect "MLSCommitLockStore.ReleaseCommitLock" - embedClient client $ releaseCommitLock gId epoch + embedClientWithKeyspace client (\keyspace -> releaseCommitLock keyspace gId epoch) interpretConversationStoreToCassandra :: forall r a. @@ -894,191 +900,190 @@ interpretConversationStoreToCassandra :: interpretConversationStoreToCassandra client = interpret $ \case UpsertConversation lcnv nc -> do logEffect "ConversationStore.CreateConversation" - embedClient client $ createConversation lcnv nc + embedClientWithKeyspace client (\keyspace -> createConversation keyspace lcnv nc) GetConversation cid -> do logEffect "ConversationStore.GetConversation" - embedClient client $ getConversation cid + embedClientWithKeyspace client (\keyspace -> getConversation keyspace cid) GetConversationEpoch cid -> do logEffect "ConversationStore.GetConversationEpoch" - embedClient client $ getConvEpoch cid + embedClientWithKeyspace client (\keyspace -> getConvEpoch keyspace cid) GetConversations cids -> do logEffect "ConversationStore.GetConversations" - localConversations client cids + keyspace <- embed (requireClientKeyspace client) + localConversations client keyspace cids GetLocalConversationIds uid start maxIds -> do logEffect "ConversationStore.GetLocalConversationIds" - embedClient client $ getLocalConvIds uid start maxIds + embedClientWithKeyspace client (\keyspace -> getLocalConvIds keyspace uid start maxIds) GetRemoteConversationIds uid start maxIds -> do logEffect "ConversationStore.GetRemoteConversationIds" - embedClient client $ getRemoteConvIds uid start maxIds + embedClientWithKeyspace client (\keyspace -> getRemoteConvIds keyspace uid start maxIds) GetConversationMetadata cid -> do logEffect "ConversationStore.GetConversationMetadata" - embedClient client $ conversationMeta cid + embedClientWithKeyspace client (\keyspace -> conversationMeta keyspace cid) GetGroupInfo cid -> do logEffect "ConversationStore.GetGroupInfo" - embedClient client $ getGroupInfo cid + embedClientWithKeyspace client (\keyspace -> getGroupInfo keyspace cid) IsConversationAlive cid -> do logEffect "ConversationStore.IsConversationAlive" - embedClient client $ isConvAlive cid + embedClientWithKeyspace client (\keyspace -> isConvAlive keyspace cid) SelectConversations uid cids -> do logEffect "ConversationStore.SelectConversations" - embedClient client $ localConversationIdsOf uid cids + embedClientWithKeyspace client (\keyspace -> localConversationIdsOf keyspace uid cids) GetRemoteConversationStatus uid cids -> do logEffect "ConversationStore.GetRemoteConversationStatus" - embedClient client $ remoteConversationStatus uid cids + embedClientWithKeyspace client (\keyspace -> remoteConversationStatus keyspace uid cids) SetConversationType cid ty -> do logEffect "ConversationStore.SetConversationType" - embedClient client $ updateConvType cid ty + embedClientWithKeyspace client (\keyspace -> updateConvType keyspace cid ty) SetConversationName cid value -> do logEffect "ConversationStore.SetConversationName" - embedClient client $ updateConvName cid value + embedClientWithKeyspace client (\keyspace -> updateConvName keyspace cid value) SetConversationAccess cid value -> do logEffect "ConversationStore.SetConversationAccess" - embedClient client $ updateConvAccess cid value + embedClientWithKeyspace client (\keyspace -> updateConvAccess keyspace cid value) SetConversationReceiptMode cid value -> do logEffect "ConversationStore.SetConversationReceiptMode" - embedClient client $ updateConvReceiptMode cid value + embedClientWithKeyspace client (\keyspace -> updateConvReceiptMode keyspace cid value) SetConversationMessageTimer cid value -> do logEffect "ConversationStore.SetConversationMessageTimer" - embedClient client $ updateConvMessageTimer cid value + embedClientWithKeyspace client (\keyspace -> updateConvMessageTimer keyspace cid value) SetConversationHistory cid value -> do logEffect "ConversationStore.SetConversationHistory" - embedClient client $ updateConvHistory cid value + embedClientWithKeyspace client (\keyspace -> updateConvHistory keyspace cid value) SetConversationEpoch cid epoch -> do logEffect "ConversationStore.SetConversationEpoch" - embedClient client $ updateConvEpoch cid epoch + embedClientWithKeyspace client (\keyspace -> updateConvEpoch keyspace cid epoch) SetConversationCipherSuite cid cs -> do logEffect "ConversationStore.SetConversationCipherSuite" - embedClient client $ updateConvCipherSuite cid cs + embedClientWithKeyspace client (\keyspace -> updateConvCipherSuite keyspace cid cs) SetConversationCellsState cid ps -> do logEffect "ConversationStore.SetConversationCellsState" - embedClient client $ updateConvCellsState cid ps + embedClientWithKeyspace client (\keyspace -> updateConvCellsState keyspace cid ps) ResetConversation cid groupId -> do logEffect "ConversationStore.ResetConversation" - embedClient client $ resetConversation cid groupId + embedClientWithKeyspace client (\keyspace -> resetConversation keyspace cid groupId) DeleteConversation cid -> do logEffect "ConversationStore.DeleteConversation" - embedClient client $ deleteConversation cid + embedClientWithKeyspace client (\keyspace -> deleteConversation keyspace cid) SetGroupInfo cid gib -> do logEffect "ConversationStore.SetGroupInfo" - embedClient client $ setGroupInfo cid gib + embedClientWithKeyspace client (\keyspace -> setGroupInfo keyspace cid gib) UpdateToMixedProtocol cid groupId epoch -> do logEffect "ConversationStore.UpdateToMixedProtocol" - updateToMixedProtocol client cid groupId epoch + embedClientWithKeyspace client (\keyspace -> updateToMixedProtocol keyspace cid groupId epoch) UpdateToMLSProtocol cid -> do logEffect "ConversationStore.UpdateToMLSProtocol" - updateToMLSProtocol client cid + embedClientWithKeyspace client (\keyspace -> updateToMLSProtocol keyspace cid) UpdateChannelAddPermissions cid cap -> do logEffect "ConversationStore.UpdateChannelAddPermissions" - embedClient client $ updateChannelAddPermissions cid cap + embedClientWithKeyspace client (\keyspace -> updateChannelAddPermissions keyspace cid cap) DeleteTeamConversation tid cid -> do logEffect "ConversationStore.DeleteTeamConversation" - embedClient client $ removeTeamConv tid cid + embedClientWithKeyspace client (\keyspace -> removeTeamConv keyspace tid cid) GetTeamConversation tid cid -> do logEffect "ConversationStore.GetTeamConversation" - embedClient client $ teamConversation tid cid + embedClientWithKeyspace client (\keyspace -> teamConversation keyspace tid cid) GetTeamConversations tid -> do logEffect "ConversationStore.GetTeamConversations" - embedClient client $ getTeamConversations tid + embedClientWithKeyspace client (\keyspace -> getTeamConversations keyspace tid) DeleteTeamConversations tid -> do logEffect "ConversationStore.DeleteTeamConversations" - embedClient client $ deleteTeamConversations tid + embedClientWithKeyspace client (\keyspace -> deleteTeamConversations keyspace tid) UpsertMembers cid ul -> do logEffect "ConversationStore.CreateMembers" - embedClient client $ addMembers cid ul + embedClientWithKeyspace client (\keyspace -> addMembers keyspace cid ul) UpsertMembersInRemoteConversation rcid uids -> do logEffect "ConversationStore.CreateMembersInRemoteConversation" - embedClient client $ addLocalMembersToRemoteConv rcid uids + embedClientWithKeyspace client (\keyspace -> addLocalMembersToRemoteConv keyspace rcid uids) CreateBotMember sr bid cid -> do logEffect "ConversationStore.CreateBotMember" - embedClient client $ addBotMember sr bid cid + embedClientWithKeyspace client (\keyspace -> addBotMember keyspace sr bid cid) GetLocalMember cid uid -> do logEffect "ConversationStore.GetLocalMember" - embedClient client $ member cid uid + embedClientWithKeyspace client (\keyspace -> member keyspace cid uid) GetLocalMembers cid -> do logEffect "ConversationStore.GetLocalMembers" - embedClient client $ members cid + embedClientWithKeyspace client (\keyspace -> members keyspace cid) GetRemoteMember cid uid -> do logEffect "ConversationStore.GetRemoteMember" - embedClient client $ lookupRemoteMember cid (tDomain uid) (tUnqualified uid) + embedClientWithKeyspace client (\keyspace -> lookupRemoteMember keyspace cid (tDomain uid) (tUnqualified uid)) GetRemoteMembers rcid -> do logEffect "ConversationStore.GetRemoteMembers" - embedClient client $ lookupRemoteMembers rcid + embedClientWithKeyspace client (\keyspace -> lookupRemoteMembers keyspace rcid) CheckLocalMemberRemoteConv uid rcnv -> do logEffect "ConversationStore.CheckLocalMemberRemoteConv" - fmap (not . null) $ embedClient client $ lookupLocalMemberRemoteConv uid rcnv + fmap (not . null) $ embedClientWithKeyspace client (\keyspace -> lookupLocalMemberRemoteConv keyspace uid rcnv) SelectRemoteMembers uids rcnv -> do logEffect "ConversationStore.SelectRemoteMembers" - embedClient client $ filterRemoteConvMembers uids rcnv + embedClientWithKeyspace client (\keyspace -> filterRemoteConvMembers keyspace uids rcnv) SetSelfMember qcid luid upd -> do logEffect "ConversationStore.SetSelfMember" - embedClient client $ updateSelfMember qcid luid upd + embedClientWithKeyspace client (\keyspace -> updateSelfMember keyspace qcid luid upd) SetOtherMember lcid quid upd -> do logEffect "ConversationStore.SetOtherMember" - embedClient client $ updateOtherMemberLocalConv lcid quid upd + embedClientWithKeyspace client (\keyspace -> updateOtherMemberLocalConv keyspace lcid quid upd) DeleteMembers cnv ul -> do logEffect "ConversationStore.DeleteMembers" - embedClient client $ removeMembersFromLocalConv cnv ul + embedClientWithKeyspace client (\keyspace -> removeMembersFromLocalConv keyspace cnv ul) DeleteMembersInRemoteConversation rcnv uids -> do logEffect "ConversationStore.DeleteMembersInRemoteConversation" - runEmbedded (runClient client) $ - embed $ - removeLocalMembersFromRemoteConv rcnv uids + embedClientWithKeyspace client (\keyspace -> removeLocalMembersFromRemoteConv keyspace rcnv uids) AddMLSClients lcnv quid cs -> do logEffect "ConversationStore.AddMLSClients" - embedClient client $ addMLSClients lcnv quid cs + embedClientWithKeyspace client (\keyspace -> addMLSClients keyspace lcnv quid cs) PlanClientRemoval lcnv cids -> do logEffect "ConversationStore.PlanClientRemoval" - embedClient client $ planMLSClientRemoval lcnv cids + embedClientWithKeyspace client (\keyspace -> planMLSClientRemoval keyspace lcnv cids) RemoveMLSClients lcnv quid cs -> do logEffect "ConversationStore.RemoveMLSClients" - embedClient client $ removeMLSClients lcnv quid cs + embedClientWithKeyspace client (\keyspace -> removeMLSClients keyspace lcnv quid cs) RemoveAllMLSClients gid -> do logEffect "ConversationStore.RemoveAllMLSClients" - embedClient client $ removeAllMLSClients gid + embedClientWithKeyspace client (\keyspace -> removeAllMLSClients keyspace gid) LookupMLSClients lcnv -> do logEffect "ConversationStore.LookupMLSClients" - embedClient client $ lookupMLSClients lcnv + embedClientWithKeyspace client (\keyspace -> lookupMLSClients keyspace lcnv) LookupMLSClientLeafIndices lcnv -> do logEffect "ConversationStore.LookupMLSClientLeafIndices" - embedClient client $ lookupMLSClientLeafIndices lcnv + embedClientWithKeyspace client (\keyspace -> lookupMLSClientLeafIndices keyspace lcnv) UpsertSubConversation convId subConvId groupId -> do logEffect "ConversationStore.CreateSubConversation" - embedClient client $ insertSubConversation convId subConvId groupId + embedClientWithKeyspace client (\keyspace -> insertSubConversation keyspace convId subConvId groupId) GetSubConversation convId subConvId -> do logEffect "ConversationStore.GetSubConversation" - embedClient client $ selectSubConversation convId subConvId + embedClientWithKeyspace client (\keyspace -> selectSubConversation keyspace convId subConvId) GetSubConversationGroupInfo convId subConvId -> do logEffect "ConversationStore.GetSubConversationGroupInfo" - embedClient client $ selectSubConvGroupInfo convId subConvId + embedClientWithKeyspace client (\keyspace -> selectSubConvGroupInfo keyspace convId subConvId) GetSubConversationEpoch convId subConvId -> do logEffect "ConversationStore.GetSubConversationEpoch" - embedClient client $ selectSubConvEpoch convId subConvId + embedClientWithKeyspace client (\keyspace -> selectSubConvEpoch keyspace convId subConvId) SetSubConversationGroupInfo convId subConvId mPgs -> do logEffect "ConversationStore.SetSubConversationGroupInfo" - embedClient client $ updateSubConvGroupInfo convId subConvId mPgs + embedClientWithKeyspace client (\keyspace -> updateSubConvGroupInfo keyspace convId subConvId mPgs) SetSubConversationEpoch cid sconv epoch -> do logEffect "ConversationStore.SetSubConversationEpoch" - embedClient client $ setEpochForSubConversation cid sconv epoch + embedClientWithKeyspace client (\keyspace -> setEpochForSubConversation keyspace cid sconv epoch) SetSubConversationCipherSuite cid sconv cs -> do logEffect "ConversationStore.SetSubConversationCipherSuite" - embedClient client $ setCipherSuiteForSubConversation cid sconv cs + embedClientWithKeyspace client (\keyspace -> setCipherSuiteForSubConversation keyspace cid sconv cs) ListSubConversations cid -> do logEffect "ConversationStore.ListSubConversations" - embedClient client $ listSubConversations cid + embedClientWithKeyspace client (\keyspace -> listSubConversations keyspace cid) DeleteSubConversation convId subConvId -> do logEffect "ConversationStore.DeleteSubConversation" - embedClient client $ deleteSubConversation convId subConvId + embedClientWithKeyspace client (\keyspace -> deleteSubConversation keyspace convId subConvId) SearchConversations _ -> do logEffect "ConversationStore.SearchConversations" pure [] SetConversationOutOfSync convId outOfSync -> do logEffect "ConversationStore.SetConversationOutOfSync" - runEmbedded (runClient client) $ embed $ setConversationOutOfSync convId outOfSync + embedClientWithKeyspace client (\keyspace -> setConversationOutOfSync keyspace convId outOfSync) IsConversationOutOfSync convId -> do logEffect "ConversationStore.IsConversationOutOfSync" - runEmbedded (runClient client) $ embed $ isConversationOutOfSync convId + embedClientWithKeyspace client (\keyspace -> isConversationOutOfSync keyspace convId) HaveRemoteConvs uids -> - embedClient client $ haveRemoteConvs uids + embedClientWithKeyspace client (\keyspace -> haveRemoteConvs keyspace uids) interpretConversationStoreToCassandraAndPostgres :: forall r a. @@ -1095,26 +1100,27 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case UpsertConversation lcnv nc -> do -- Save new convs in postgresql withMigrationLockAndCleanup client LockShared (Left $ tUnqualified lcnv) $ - embedClient client (getConversation (tUnqualified lcnv)) >>= \case + embedClientWithKeyspace client (\keyspace -> getConversation keyspace (tUnqualified lcnv)) >>= \case Nothing -> interpretConversationStoreToPostgres $ ConvStore.upsertConversation lcnv nc - Just _ -> embedClient client $ createConversation lcnv nc + Just _ -> embedClientWithKeyspace client (\keyspace -> createConversation keyspace lcnv nc) GetConversation cid -> do logEffect "ConversationStore.GetConversation" withMigrationLockAndCleanup client LockShared (Left cid) $ getConvWithPostgres cid >>= \case - Nothing -> embedClient client (getConversation cid) + Nothing -> embedClientWithKeyspace client (\keyspace -> getConversation keyspace cid) conv -> pure conv GetConversationEpoch cid -> do logEffect "ConversationStore.GetConversationEpoch" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client (getConvEpoch cid) + False -> embedClientWithKeyspace client (\keyspace -> getConvEpoch keyspace cid) True -> interpretConversationStoreToPostgres $ ConvStore.getConversationEpoch cid GetConversations cids -> do logEffect "ConversationStore.GetConversations" withMigrationLocksAndConvCleanup client LockShared (Seconds 2) cids $ do let indexByConvId = foldr (\storedConv -> Map.insert storedConv.id_ storedConv) Map.empty - cassConvs <- indexByConvId <$> localConversations client cids + keyspace <- embed (requireClientKeyspace client) + cassConvs <- indexByConvId <$> localConversations client keyspace cids pgConvs <- indexByConvId <$> interpretConversationStoreToPostgres (ConvStore.getConversations cids) pure $ mapMaybe (\cid -> Map.lookup cid pgConvs <|> Map.lookup cid cassConvs) cids GetLocalConversationIds uid start maxIds -> do @@ -1138,7 +1144,7 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case -- A solution could be to keep looping and locking until we get to a stable -- situation, but that could run into creating too many sessions with -- Postgres - cassConvIds <- embedClient client $ getLocalConvIds uid start maxIds + cassConvIds <- embedClientWithKeyspace client (\keyspace -> getLocalConvIds keyspace uid start maxIds) pgConvIds <- interpretConversationStoreToPostgres $ ConvStore.getLocalConversationIds uid start maxIds let allResults = @@ -1159,153 +1165,153 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case logEffect "ConversationStore.GetRemoteConversationIds" withMigrationLockAndCleanup client LockShared (Right uid) $ do isUserInPostgres uid >>= \case - False -> embedClient client $ getRemoteConvIds uid start maxIds + False -> embedClientWithKeyspace client (\keyspace -> getRemoteConvIds keyspace uid start maxIds) True -> interpretConversationStoreToPostgres $ ConvStore.getRemoteConversationIds uid start maxIds GetConversationMetadata cid -> do logEffect "ConversationStore.GetConversationMetadata" withMigrationLockAndCleanup client LockShared (Left cid) $ interpretConversationStoreToPostgres (ConvStore.getConversationMetadata cid) >>= \case - Nothing -> embedClient client (conversationMeta cid) + Nothing -> embedClientWithKeyspace client (\keyspace -> conversationMeta keyspace cid) meta -> pure meta GetGroupInfo cid -> do logEffect "ConversationStore.GetGroupInfo" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client (getGroupInfo cid) + False -> embedClientWithKeyspace client (\keyspace -> getGroupInfo keyspace cid) True -> interpretConversationStoreToPostgres (ConvStore.getGroupInfo cid) IsConversationAlive cid -> do logEffect "ConversationStore.IsConversationAlive" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client (isConvAlive cid) + False -> embedClientWithKeyspace client (\keyspace -> isConvAlive keyspace cid) True -> interpretConversationStoreToPostgres (ConvStore.isConversationAlive cid) SelectConversations uid cids -> do logEffect "ConversationStore.SelectConversations" withMigrationLocksAndConvCleanup client LockShared (Seconds 2) cids $ do - cassConvs <- embedClient client $ localConversationIdsOf uid cids + cassConvs <- embedClientWithKeyspace client (\keyspace -> localConversationIdsOf keyspace uid cids) pgConvs <- interpretConversationStoreToPostgres $ ConvStore.selectConversations uid cids pure $ List.nubOrd (pgConvs <> cassConvs) GetRemoteConversationStatus uid cids -> do logEffect "ConversationStore.GetRemoteConversationStatus" withMigrationLockAndCleanup client LockShared (Right uid) $ do isUserInPostgres uid >>= \case - False -> embedClient client $ remoteConversationStatus uid cids + False -> embedClientWithKeyspace client (\keyspace -> remoteConversationStatus keyspace uid cids) True -> interpretConversationStoreToPostgres $ ConvStore.getRemoteConversationStatus uid cids SetConversationType cid ty -> do logEffect "ConversationStore.SetConversationType" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvType cid ty + False -> embedClientWithKeyspace client (\keyspace -> updateConvType keyspace cid ty) True -> interpretConversationStoreToPostgres (ConvStore.setConversationType cid ty) SetConversationName cid value -> do logEffect "ConversationStore.SetConversationName" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvName cid value + False -> embedClientWithKeyspace client (\keyspace -> updateConvName keyspace cid value) True -> interpretConversationStoreToPostgres (ConvStore.setConversationName cid value) SetConversationAccess cid value -> do logEffect "ConversationStore.SetConversationAccess" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvAccess cid value + False -> embedClientWithKeyspace client (\keyspace -> updateConvAccess keyspace cid value) True -> interpretConversationStoreToPostgres (ConvStore.setConversationAccess cid value) SetConversationReceiptMode cid value -> do logEffect "ConversationStore.SetConversationReceiptMode" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvReceiptMode cid value + False -> embedClientWithKeyspace client (\keyspace -> updateConvReceiptMode keyspace cid value) True -> interpretConversationStoreToPostgres (ConvStore.setConversationReceiptMode cid value) SetConversationMessageTimer cid value -> do logEffect "ConversationStore.SetConversationMessageTimer" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvMessageTimer cid value + False -> embedClientWithKeyspace client (\keyspace -> updateConvMessageTimer keyspace cid value) True -> interpretConversationStoreToPostgres (ConvStore.setConversationMessageTimer cid value) SetConversationHistory cid value -> do logEffect "ConversationStore.SetConversationHistory" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvHistory cid value + False -> embedClientWithKeyspace client (\keyspace -> updateConvHistory keyspace cid value) True -> interpretConversationStoreToPostgres (ConvStore.setConversationHistory cid value) SetConversationEpoch cid epoch -> do logEffect "ConversationStore.SetConversationEpoch" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvEpoch cid epoch + False -> embedClientWithKeyspace client (\keyspace -> updateConvEpoch keyspace cid epoch) True -> interpretConversationStoreToPostgres (ConvStore.setConversationEpoch cid epoch) SetConversationCipherSuite cid cs -> do logEffect "ConversationStore.SetConversationCipherSuite" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvCipherSuite cid cs + False -> embedClientWithKeyspace client (\keyspace -> updateConvCipherSuite keyspace cid cs) True -> interpretConversationStoreToPostgres (ConvStore.setConversationCipherSuite cid cs) SetConversationCellsState cid ps -> do logEffect "ConversationStore.SetConversationCellsState" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateConvCellsState cid ps + False -> embedClientWithKeyspace client (\keyspace -> updateConvCellsState keyspace cid ps) True -> interpretConversationStoreToPostgres (ConvStore.setConversationCellsState cid ps) ResetConversation cid groupId -> do logEffect "ConversationStore.ResetConversation" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ resetConversation cid groupId + False -> embedClientWithKeyspace client (\keyspace -> resetConversation keyspace cid groupId) True -> interpretConversationStoreToPostgres (ConvStore.resetConversation cid groupId) DeleteConversation cid -> do logEffect "ConversationStore.DeleteConversation" withMigrationLockAndCleanup client LockShared (Left cid) $ do - embedClient client $ deleteConversation cid + embedClientWithKeyspace client (\keyspace -> deleteConversation keyspace cid) interpretConversationStoreToPostgres (ConvStore.deleteConversation cid) SetGroupInfo cid gib -> do logEffect "ConversationStore.SetGroupInfo" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ setGroupInfo cid gib + False -> embedClientWithKeyspace client (\keyspace -> setGroupInfo keyspace cid gib) True -> interpretConversationStoreToPostgres (ConvStore.setGroupInfo cid gib) UpdateToMixedProtocol cid groupId epoch -> do logEffect "ConversationStore.UpdateToMixedProtocol" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> updateToMixedProtocol client cid groupId epoch + False -> embedClientWithKeyspace client (\keyspace -> updateToMixedProtocol keyspace cid groupId epoch) True -> interpretConversationStoreToPostgres (ConvStore.updateToMixedProtocol cid groupId epoch) UpdateToMLSProtocol cid -> do logEffect "ConversationStore.UpdateToMLSProtocol" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> updateToMLSProtocol client cid + False -> embedClientWithKeyspace client (\keyspace -> updateToMLSProtocol keyspace cid) _ -> interpretConversationStoreToPostgres (ConvStore.updateToMLSProtocol cid) UpdateChannelAddPermissions cid cap -> do logEffect "ConversationStore.UpdateChannelAddPermissions" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ updateChannelAddPermissions cid cap + False -> embedClientWithKeyspace client (\keyspace -> updateChannelAddPermissions keyspace cid cap) _ -> interpretConversationStoreToPostgres (ConvStore.updateChannelAddPermissions cid cap) DeleteTeamConversation tid cid -> do logEffect "ConversationStore.DeleteTeamConversation" withMigrationLockAndCleanup client LockShared (Left cid) $ do - embedClient client $ removeTeamConv tid cid + embedClientWithKeyspace client (\keyspace -> removeTeamConv keyspace tid cid) interpretConversationStoreToPostgres (ConvStore.deleteTeamConversation tid cid) GetTeamConversation tid cid -> do logEffect "ConversationStore.GetTeamConversation" withMigrationLockAndCleanup client LockShared (Left cid) $ interpretConversationStoreToPostgres (ConvStore.getTeamConversation tid cid) >>= \case Just foundCid -> pure $ Just foundCid - Nothing -> embedClient client $ teamConversation tid cid + Nothing -> embedClientWithKeyspace client (\keyspace -> teamConversation keyspace tid cid) GetTeamConversations tid -> do logEffect "ConversationStore.GetTeamConversations" -- See [Migration Locking Limitation] - cassConvs <- embedClient client $ getTeamConversations tid + cassConvs <- embedClientWithKeyspace client (\keyspace -> getTeamConversations keyspace tid) pgConvs <- interpretConversationStoreToPostgres $ ConvStore.getTeamConversations tid pure $ List.nubOrd (pgConvs <> cassConvs) DeleteTeamConversations tid -> do logEffect "ConversationStore.DeleteTeamConversations" - embedClient client $ deleteTeamConversations tid + embedClientWithKeyspace client (\keyspace -> deleteTeamConversations keyspace tid) interpretConversationStoreToPostgres $ ConvStore.deleteTeamConversations tid UpsertMembers cid ul -> do logEffect "ConversationStore.CreateMembers" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ addMembers cid ul + False -> embedClientWithKeyspace client (\keyspace -> addMembers keyspace cid ul) _ -> interpretConversationStoreToPostgres (ConvStore.upsertMembers cid ul) UpsertMembersInRemoteConversation rcid uids -> do logEffect "ConversationStore.CreateMembersInRemoteConversation" @@ -1316,52 +1322,52 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case let -- These are not in Postgres, but that doesn't mean they're in -- cassandra nonPgUids = filter (`notElem` pgUids) uids - cassUids <- embedClient client $ haveRemoteConvs nonPgUids + cassUids <- embedClientWithKeyspace client (\keyspace -> haveRemoteConvs keyspace nonPgUids) let nonCassUids = filter (`notElem` cassUids) uids interpretConversationStoreToPostgres $ ConvStore.upsertMembersInRemoteConversation rcid nonCassUids - embedClient client $ addLocalMembersToRemoteConv rcid cassUids + embedClientWithKeyspace client (\keyspace -> addLocalMembersToRemoteConv keyspace rcid cassUids) CreateBotMember sr bid cid -> do logEffect "ConversationStore.CreateBotMember" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ addBotMember sr bid cid + False -> embedClientWithKeyspace client (\keyspace -> addBotMember keyspace sr bid cid) _ -> interpretConversationStoreToPostgres (ConvStore.createBotMember sr bid cid) GetLocalMember cid uid -> do logEffect "ConversationStore.GetLocalMember" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ member cid uid + False -> embedClientWithKeyspace client (\keyspace -> member keyspace cid uid) True -> interpretConversationStoreToPostgres (ConvStore.getLocalMember cid uid) GetLocalMembers cid -> do logEffect "ConversationStore.GetLocalMembers" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ members cid + False -> embedClientWithKeyspace client (\keyspace -> members keyspace cid) True -> interpretConversationStoreToPostgres (ConvStore.getLocalMembers cid) GetRemoteMember cid uid -> do logEffect "ConversationStore.GetRemoteMember" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ lookupRemoteMember cid (tDomain uid) (tUnqualified uid) + False -> embedClientWithKeyspace client (\keyspace -> lookupRemoteMember keyspace cid (tDomain uid) (tUnqualified uid)) True -> interpretConversationStoreToPostgres (ConvStore.getRemoteMember cid uid) GetRemoteMembers cid -> do logEffect "ConversationStore.GetRemoteMembers" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ lookupRemoteMembers cid + False -> embedClientWithKeyspace client (\keyspace -> lookupRemoteMembers keyspace cid) True -> interpretConversationStoreToPostgres (ConvStore.getRemoteMembers cid) CheckLocalMemberRemoteConv uid rcnv -> do logEffect "ConversationStore.CheckLocalMemberRemoteConv" withMigrationLockAndCleanup client LockShared (Right uid) $ do isUserInPostgres uid >>= \case - False -> fmap (not . null) $ embedClient client $ lookupLocalMemberRemoteConv uid rcnv + False -> fmap (not . null) $ embedClientWithKeyspace client (\keyspace -> lookupLocalMemberRemoteConv keyspace uid rcnv) True -> interpretConversationStoreToPostgres $ ConvStore.checkLocalMemberRemoteConv uid rcnv SelectRemoteMembers uids rcnv -> do logEffect "ConversationStore.SelectRemoteMembers" withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do filterUsersInPostgres uids >>= \pgUids -> do (pgUsers, _) <- interpretConversationStoreToPostgres $ ConvStore.selectRemoteMembers pgUids rcnv - (cassUsers, _) <- embedClient client $ filterRemoteConvMembers uids rcnv + (cassUsers, _) <- embedClientWithKeyspace client (\keyspace -> filterRemoteConvMembers keyspace uids rcnv) let foundUsers = pgUsers <> cassUsers pure (foundUsers, Set.fromList foundUsers == Set.fromList uids) SetSelfMember qcid luid upd -> do @@ -1377,119 +1383,119 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case let (withLock, isInPG) = foldQualified luid localConvFunctions remoteConvFunctions qcid withLock $ isInPG >>= \case - False -> embedClient client $ updateSelfMember qcid luid upd + False -> embedClientWithKeyspace client (\keyspace -> updateSelfMember keyspace qcid luid upd) True -> interpretConversationStoreToPostgres $ ConvStore.setSelfMember qcid luid upd SetOtherMember lcid quid upd -> do logEffect "ConversationStore.SetOtherMember" withMigrationLockAndCleanup client LockShared (Left $ tUnqualified lcid) $ isConvInPostgres (tUnqualified lcid) >>= \case - False -> embedClient client $ updateOtherMemberLocalConv lcid quid upd + False -> embedClientWithKeyspace client (\keyspace -> updateOtherMemberLocalConv keyspace lcid quid upd) True -> interpretConversationStoreToPostgres (ConvStore.setOtherMember lcid quid upd) DeleteMembers cid ul -> do logEffect "ConversationStore.DeleteMembers" withMigrationLockAndCleanup client LockShared (Left cid) $ do -- No need to check where these are, we just delete them from both places - embedClient client $ removeMembersFromLocalConv cid ul + embedClientWithKeyspace client (\keyspace -> removeMembersFromLocalConv keyspace cid ul) interpretConversationStoreToPostgres $ ConvStore.deleteMembers cid ul DeleteMembersInRemoteConversation rcnv uids -> do logEffect "ConversationStore.DeleteMembersInRemoteConversation" withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do -- No need to check where these are, we just delete them from both places - embedClient client $ removeLocalMembersFromRemoteConv rcnv uids + embedClientWithKeyspace client (\keyspace -> removeLocalMembersFromRemoteConv keyspace rcnv uids) interpretConversationStoreToPostgres $ ConvStore.deleteMembersInRemoteConversation rcnv uids AddMLSClients groupId quid cs -> do logEffect "ConversationStore.AddMLSClients" cid <- groupIdToConvId groupId withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ addMLSClients groupId quid cs + False -> embedClientWithKeyspace client (\keyspace -> addMLSClients keyspace groupId quid cs) True -> interpretConversationStoreToPostgres (ConvStore.addMLSClients groupId quid cs) PlanClientRemoval gid clients -> do logEffect "ConversationStore.PlanClientRemoval" cid <- groupIdToConvId gid withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ planMLSClientRemoval gid clients + False -> embedClientWithKeyspace client (\keyspace -> planMLSClientRemoval keyspace gid clients) True -> interpretConversationStoreToPostgres (ConvStore.planClientRemoval gid clients) RemoveMLSClients gid quid cs -> do logEffect "ConversationStore.RemoveMLSClients" cid <- groupIdToConvId gid withMigrationLockAndCleanup client LockShared (Left cid) $ do - embedClient client $ removeMLSClients gid quid cs + embedClientWithKeyspace client (\keyspace -> removeMLSClients keyspace gid quid cs) interpretConversationStoreToPostgres (ConvStore.removeMLSClients gid quid cs) RemoveAllMLSClients gid -> do logEffect "ConversationStore.RemoveAllMLSClients" cid <- groupIdToConvId gid withMigrationLockAndCleanup client LockShared (Left cid) $ do - embedClient client $ removeAllMLSClients gid + embedClientWithKeyspace client (\keyspace -> removeAllMLSClients keyspace gid) interpretConversationStoreToPostgres (ConvStore.removeAllMLSClients gid) LookupMLSClients gid -> do logEffect "ConversationStore.LookupMLSClients" cid <- groupIdToConvId gid withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ lookupMLSClients gid + False -> embedClientWithKeyspace client (\keyspace -> lookupMLSClients keyspace gid) True -> interpretConversationStoreToPostgres (ConvStore.lookupMLSClients gid) LookupMLSClientLeafIndices gid -> do logEffect "ConversationStore.LookupMLSClientLeafIndices" cid <- groupIdToConvId gid withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ lookupMLSClientLeafIndices gid + False -> embedClientWithKeyspace client (\keyspace -> lookupMLSClientLeafIndices keyspace gid) True -> interpretConversationStoreToPostgres (ConvStore.lookupMLSClientLeafIndices gid) UpsertSubConversation convId subConvId groupId -> do logEffect "ConversationStore.CreateSubConversation" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ insertSubConversation convId subConvId groupId + False -> embedClientWithKeyspace client (\keyspace -> insertSubConversation keyspace convId subConvId groupId) True -> interpretConversationStoreToPostgres (ConvStore.upsertSubConversation convId subConvId groupId) GetSubConversation convId subConvId -> do logEffect "ConversationStore.GetSubConversation" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ selectSubConversation convId subConvId + False -> embedClientWithKeyspace client (\keyspace -> selectSubConversation keyspace convId subConvId) True -> interpretConversationStoreToPostgres $ ConvStore.getSubConversation convId subConvId GetSubConversationGroupInfo convId subConvId -> do logEffect "ConversationStore.GetSubConversationGroupInfo" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ selectSubConvGroupInfo convId subConvId + False -> embedClientWithKeyspace client (\keyspace -> selectSubConvGroupInfo keyspace convId subConvId) True -> interpretConversationStoreToPostgres $ ConvStore.getSubConversationGroupInfo convId subConvId GetSubConversationEpoch convId subConvId -> do logEffect "ConversationStore.GetSubConversationEpoch" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ selectSubConvEpoch convId subConvId + False -> embedClientWithKeyspace client (\keyspace -> selectSubConvEpoch keyspace convId subConvId) True -> interpretConversationStoreToPostgres $ ConvStore.getSubConversationEpoch convId subConvId SetSubConversationGroupInfo convId subConvId mPgs -> do logEffect "ConversationStore.SetSubConversationGroupInfo" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ updateSubConvGroupInfo convId subConvId mPgs + False -> embedClientWithKeyspace client (\keyspace -> updateSubConvGroupInfo keyspace convId subConvId mPgs) True -> interpretConversationStoreToPostgres $ ConvStore.setSubConversationGroupInfo convId subConvId mPgs SetSubConversationEpoch cid sconv epoch -> do logEffect "ConversationStore.SetSubConversationEpoch" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ setEpochForSubConversation cid sconv epoch + False -> embedClientWithKeyspace client (\keyspace -> setEpochForSubConversation keyspace cid sconv epoch) True -> interpretConversationStoreToPostgres $ ConvStore.setSubConversationEpoch cid sconv epoch SetSubConversationCipherSuite cid sconv cs -> do logEffect "ConversationStore.SetSubConversationCipherSuite" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ setCipherSuiteForSubConversation cid sconv cs + False -> embedClientWithKeyspace client (\keyspace -> setCipherSuiteForSubConversation keyspace cid sconv cs) True -> interpretConversationStoreToPostgres $ ConvStore.setSubConversationCipherSuite cid sconv cs ListSubConversations cid -> do logEffect "ConversationStore.ListSubConversations" withMigrationLockAndCleanup client LockShared (Left cid) $ isConvInPostgres cid >>= \case - False -> embedClient client $ listSubConversations cid + False -> embedClientWithKeyspace client (\keyspace -> listSubConversations keyspace cid) True -> interpretConversationStoreToPostgres $ ConvStore.listSubConversations cid DeleteSubConversation convId subConvId -> do logEffect "ConversationStore.DeleteSubConversation" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ deleteSubConversation convId subConvId + False -> embedClientWithKeyspace client (\keyspace -> deleteSubConversation keyspace convId subConvId) True -> interpretConversationStoreToPostgres $ ConvStore.deleteSubConversation convId subConvId SearchConversations _ -> do -- In theory, it is possible to make this partially work. But we don't have @@ -1501,18 +1507,18 @@ interpretConversationStoreToCassandraAndPostgres client = interpret $ \case logEffect "ConversationStore.SetConversationOutOfSync" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ setConversationOutOfSync convId outOfSync + False -> embedClientWithKeyspace client (\keyspace -> setConversationOutOfSync keyspace convId outOfSync) True -> interpretConversationStoreToPostgres $ ConvStore.setConversationOutOfSync convId outOfSync IsConversationOutOfSync convId -> do logEffect "ConversationStore.SetConversationOutOfSync" withMigrationLockAndCleanup client LockShared (Left convId) $ isConvInPostgres convId >>= \case - False -> embedClient client $ isConversationOutOfSync convId + False -> embedClientWithKeyspace client (\keyspace -> isConversationOutOfSync keyspace convId) True -> interpretConversationStoreToPostgres $ ConvStore.isConversationOutOfSync convId HaveRemoteConvs uids -> do logEffect "ConversationStore.DeleteSubConversation" withMigrationLocksAndUserCleanup client LockShared (Seconds 2) uids $ do - remotesInCass <- embedClient client $ haveRemoteConvs uids + remotesInCass <- embedClientWithKeyspace client (\keyspace -> haveRemoteConvs keyspace uids) remotesInPG <- interpretConversationStoreToPostgres $ ConvStore.haveRemoteConvs uids pure $ List.nubOrd (remotesInPG <> remotesInCass) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs index ba30f2f8ab9..5a37de55876 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs @@ -44,23 +44,24 @@ import Wire.API.History import Wire.API.MLS.CipherSuite import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation (SubConvId) +import Wire.Util (qualifiedTableName) -- Teams -------------------------------------------------------------------- -insertTeamConv :: PrepQuery W (TeamId, ConvId) () -insertTeamConv = "insert into team_conv (team, conv) values (?, ?)" +insertTeamConv :: Keyspace -> PrepQuery W (TeamId, ConvId) () +insertTeamConv keyspace = fromString $ "insert into " <> table keyspace "team_conv" <> " (team, conv) values (?, ?)" -deleteTeamConv :: PrepQuery W (TeamId, ConvId) () -deleteTeamConv = "delete from team_conv where team = ? and conv = ?" +deleteTeamConv :: Keyspace -> PrepQuery W (TeamId, ConvId) () +deleteTeamConv keyspace = fromString $ "delete from " <> table keyspace "team_conv" <> " where team = ? and conv = ?" -selectTeamConv :: PrepQuery R (TeamId, ConvId) (Identity ConvId) -selectTeamConv = "select conv from team_conv where team = ? and conv = ?" +selectTeamConv :: Keyspace -> PrepQuery R (TeamId, ConvId) (Identity ConvId) +selectTeamConv keyspace = fromString $ "select conv from " <> table keyspace "team_conv" <> " where team = ? and conv = ?" -selectTeamConvs :: PrepQuery R (Identity TeamId) (Identity ConvId) -selectTeamConvs = "select conv from team_conv where team = ? order by conv" +selectTeamConvs :: Keyspace -> PrepQuery R (Identity TeamId) (Identity ConvId) +selectTeamConvs keyspace = fromString $ "select conv from " <> table keyspace "team_conv" <> " where team = ? order by conv" -selectTeamConvsFrom :: PrepQuery R (TeamId, ConvId) (Identity ConvId) -selectTeamConvsFrom = "select conv from team_conv where team = ? and conv > ? order by conv" +selectTeamConvsFrom :: Keyspace -> PrepQuery R (TeamId, ConvId) (Identity ConvId) +selectTeamConvsFrom keyspace = fromString $ "select conv from " <> table keyspace "team_conv" <> " where team = ? and conv > ? order by conv" -- Conversations ------------------------------------------------------------ @@ -87,14 +88,14 @@ type ConvRow = Maybe HistoryDuration ) -selectConv :: PrepQuery R (Identity ConvId) ConvRow -selectConv = "select type, creator, access, access_role, access_roles_v2, name, team, deleted, message_timer, receipt_mode, protocol, group_id, epoch, WRITETIME(epoch), cipher_suite, group_conv_type, channel_add_permission, cells_state, parent_conv, history_depth from conversation where conv = ?" +selectConv :: Keyspace -> PrepQuery R (Identity ConvId) ConvRow +selectConv keyspace = fromString $ "select type, creator, access, access_role, access_roles_v2, name, team, deleted, message_timer, receipt_mode, protocol, group_id, epoch, WRITETIME(epoch), cipher_suite, group_conv_type, channel_add_permission, cells_state, parent_conv, history_depth from " <> table keyspace "conversation" <> " where conv = ?" -isConvDeleted :: PrepQuery R (Identity ConvId) (Identity (Maybe Bool)) -isConvDeleted = "select deleted from conversation where conv = ?" +isConvDeleted :: Keyspace -> PrepQuery R (Identity ConvId) (Identity (Maybe Bool)) +isConvDeleted keyspace = fromString $ "select deleted from " <> table keyspace "conversation" <> " where conv = ?" -selectConvParent :: PrepQuery R (Identity ConvId) (Identity (Maybe ConvId)) -selectConvParent = "select parent_conv from conversation where conv = ?" +selectConvParent :: Keyspace -> PrepQuery R (Identity ConvId) (Identity (Maybe ConvId)) +selectConvParent keyspace = fromString $ "select parent_conv from " <> table keyspace "conversation" <> " where conv = ?" type ConvWriteRow = ( ConvId, @@ -119,10 +120,11 @@ type ConvWriteRow = instance Show ConvWriteRow where show _ = "(...)" -insertConv :: PrepQuery W ConvWriteRow () -insertConv = "insert into conversation (conv, type, creator, access, access_roles_v2, name, team, message_timer, receipt_mode, protocol, group_id, group_conv_type, channel_add_permission, cells_state, parent_conv, history_depth) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" +insertConv :: Keyspace -> PrepQuery W ConvWriteRow () +insertConv keyspace = fromString $ "insert into " <> table keyspace "conversation" <> " (conv, type, creator, access, access_roles_v2, name, team, message_timer, receipt_mode, protocol, group_id, group_conv_type, channel_add_permission, cells_state, parent_conv, history_depth) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" insertMLSSelfConv :: + Keyspace -> PrepQuery W ( ConvId, @@ -138,114 +140,116 @@ insertMLSSelfConv :: Maybe ConvId ) () -insertMLSSelfConv = +insertMLSSelfConv keyspace = fromString $ - "insert into conversation (conv, type, creator, access, \ + "insert into " + <> table keyspace "conversation" + <> " (conv, type, creator, access, \ \ access_roles_v2, name, team, message_timer, receipt_mode,\ \ protocol, group_id, parent_conv) values \ \ (?, ?, ?, ?, ?, ?, ?, ?, ?, " <> show (fromEnum ProtocolMLSTag) <> ", ?, ?)" -updateToMixedConv :: PrepQuery W (ConvId, ProtocolTag, GroupId, Epoch) () -updateToMixedConv = - "insert into conversation (conv, protocol, group_id, epoch) values (?, ?, ?, ?)" +updateToMixedConv :: Keyspace -> PrepQuery W (ConvId, ProtocolTag, GroupId, Epoch) () +updateToMixedConv keyspace = + fromString $ "insert into " <> table keyspace "conversation" <> " (conv, protocol, group_id, epoch) values (?, ?, ?, ?)" -updateToMLSConv :: PrepQuery W (ConvId, ProtocolTag) () -updateToMLSConv = "insert into conversation (conv, protocol, receipt_mode) values (?, ?, 0)" +updateToMLSConv :: Keyspace -> PrepQuery W (ConvId, ProtocolTag) () +updateToMLSConv keyspace = fromString $ "insert into " <> table keyspace "conversation" <> " (conv, protocol, receipt_mode) values (?, ?, 0)" -updateConvAccess :: PrepQuery W (C.Set Access, C.Set AccessRole, ConvId) () -updateConvAccess = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set access = ?, access_roles_v2 = ? where conv = ?" +updateConvAccess :: Keyspace -> PrepQuery W (C.Set Access, C.Set AccessRole, ConvId) () +updateConvAccess keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set access = ?, access_roles_v2 = ? where conv = ?" -updateConvReceiptMode :: PrepQuery W (ReceiptMode, ConvId) () -updateConvReceiptMode = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set receipt_mode = ? where conv = ?" +updateConvReceiptMode :: Keyspace -> PrepQuery W (ReceiptMode, ConvId) () +updateConvReceiptMode keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set receipt_mode = ? where conv = ?" -updateConvMessageTimer :: PrepQuery W (Maybe Milliseconds, ConvId) () -updateConvMessageTimer = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set message_timer = ? where conv = ?" +updateConvMessageTimer :: Keyspace -> PrepQuery W (Maybe Milliseconds, ConvId) () +updateConvMessageTimer keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set message_timer = ? where conv = ?" -updateConvName :: PrepQuery W (Text, ConvId) () -updateConvName = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set name = ? where conv = ?" +updateConvName :: Keyspace -> PrepQuery W (Text, ConvId) () +updateConvName keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set name = ? where conv = ?" -updateConvType :: PrepQuery W (ConvType, ConvId) () -updateConvType = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set type = ? where conv = ?" +updateConvType :: Keyspace -> PrepQuery W (ConvType, ConvId) () +updateConvType keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set type = ? where conv = ?" -getConvEpoch :: PrepQuery R (Identity ConvId) (Identity (Maybe Epoch)) -getConvEpoch = "select epoch from conversation where conv = ?" +getConvEpoch :: Keyspace -> PrepQuery R (Identity ConvId) (Identity (Maybe Epoch)) +getConvEpoch keyspace = fromString $ "select epoch from " <> table keyspace "conversation" <> " where conv = ?" -updateConvEpoch :: PrepQuery W (Epoch, ConvId) () -updateConvEpoch = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set epoch = ? where conv = ?" +updateConvEpoch :: Keyspace -> PrepQuery W (Epoch, ConvId) () +updateConvEpoch keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set epoch = ? where conv = ?" -updateConvHistory :: PrepQuery W (Maybe HistoryDuration, ConvId) () -updateConvHistory = "update conversation set history_depth = ? where conv = ?" +updateConvHistory :: Keyspace -> PrepQuery W (Maybe HistoryDuration, ConvId) () +updateConvHistory keyspace = fromString $ "update " <> table keyspace "conversation" <> " set history_depth = ? where conv = ?" -updateConvCipherSuite :: PrepQuery W (CipherSuiteTag, ConvId) () -updateConvCipherSuite = "update conversation set cipher_suite = ? where conv = ?" +updateConvCipherSuite :: Keyspace -> PrepQuery W (CipherSuiteTag, ConvId) () +updateConvCipherSuite keyspace = fromString $ "update " <> table keyspace "conversation" <> " set cipher_suite = ? where conv = ?" -updateConvCellsState :: PrepQuery W (CellsState, ConvId) () -updateConvCellsState = "update conversation set cells_state = ? where conv = ?" +updateConvCellsState :: Keyspace -> PrepQuery W (CellsState, ConvId) () +updateConvCellsState keyspace = fromString $ "update " <> table keyspace "conversation" <> " set cells_state = ? where conv = ?" -resetConversation :: PrepQuery W (GroupId, ConvId) () -resetConversation = "update conversation set group_id = ?, epoch = 0 where conv = ?" +resetConversation :: Keyspace -> PrepQuery W (GroupId, ConvId) () +resetConversation keyspace = fromString $ "update " <> table keyspace "conversation" <> " set group_id = ?, epoch = 0 where conv = ?" -deleteConv :: PrepQuery W (Identity ConvId) () -deleteConv = "delete from conversation using timestamp 32503680000000000 where conv = ?" +deleteConv :: Keyspace -> PrepQuery W (Identity ConvId) () +deleteConv keyspace = fromString $ "delete from " <> table keyspace "conversation" <> " using timestamp 32503680000000000 where conv = ?" -markConvDeleted :: PrepQuery W (Identity ConvId) () -markConvDeleted = {- `IF EXISTS`, but that requires benchmarking -} "update conversation set deleted = true where conv = ?" +markConvDeleted :: Keyspace -> PrepQuery W (Identity ConvId) () +markConvDeleted keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "conversation" <> " set deleted = true where conv = ?" -selectGroupInfo :: PrepQuery R (Identity ConvId) (Identity (Maybe GroupInfoData)) -selectGroupInfo = "select public_group_state from conversation where conv = ?" +selectGroupInfo :: Keyspace -> PrepQuery R (Identity ConvId) (Identity (Maybe GroupInfoData)) +selectGroupInfo keyspace = fromString $ "select public_group_state from " <> table keyspace "conversation" <> " where conv = ?" -updateGroupInfo :: PrepQuery W (GroupInfoData, ConvId) () -updateGroupInfo = "update conversation set public_group_state = ? where conv = ?" +updateGroupInfo :: Keyspace -> PrepQuery W (GroupInfoData, ConvId) () +updateGroupInfo keyspace = fromString $ "update " <> table keyspace "conversation" <> " set public_group_state = ? where conv = ?" -updateChannelAddPermission :: PrepQuery W (AddPermission, ConvId) () -updateChannelAddPermission = "update conversation set channel_add_permission = ? where conv = ?" +updateChannelAddPermission :: Keyspace -> PrepQuery W (AddPermission, ConvId) () +updateChannelAddPermission keyspace = fromString $ "update " <> table keyspace "conversation" <> " set channel_add_permission = ? where conv = ?" -- User Conversations ------------------------------------------------------- -selectUserConvsIn :: PrepQuery R (UserId, [ConvId]) (Identity ConvId) -selectUserConvsIn = "select conv from user where user = ? and conv in ? order by conv" +selectUserConvsIn :: Keyspace -> PrepQuery R (UserId, [ConvId]) (Identity ConvId) +selectUserConvsIn keyspace = fromString $ "select conv from " <> table keyspace "user" <> " where user = ? and conv in ? order by conv" -insertUserConv :: PrepQuery W (UserId, ConvId) () -insertUserConv = "insert into user (user, conv) values (?, ?)" +insertUserConv :: Keyspace -> PrepQuery W (UserId, ConvId) () +insertUserConv keyspace = fromString $ "insert into " <> table keyspace "user" <> " (user, conv) values (?, ?)" -deleteUserConv :: PrepQuery W (UserId, ConvId) () -deleteUserConv = "delete from user where user = ? and conv = ?" +deleteUserConv :: Keyspace -> PrepQuery W (UserId, ConvId) () +deleteUserConv keyspace = fromString $ "delete from " <> table keyspace "user" <> " where user = ? and conv = ?" -selectUserConvs :: PrepQuery R (Identity UserId) (Identity ConvId) -selectUserConvs = "select conv from user where user = ? order by conv" +selectUserConvs :: Keyspace -> PrepQuery R (Identity UserId) (Identity ConvId) +selectUserConvs keyspace = fromString $ "select conv from " <> table keyspace "user" <> " where user = ? order by conv" -selectUserConvsFrom :: PrepQuery R (UserId, ConvId) (Identity ConvId) -selectUserConvsFrom = "select conv from user where user = ? and conv > ? order by conv" +selectUserConvsFrom :: Keyspace -> PrepQuery R (UserId, ConvId) (Identity ConvId) +selectUserConvsFrom keyspace = fromString $ "select conv from " <> table keyspace "user" <> " where user = ? and conv > ? order by conv" -- Members ------------------------------------------------------------------ type MemberStatus = Int32 -selectMember :: PrepQuery R (ConvId, UserId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) -selectMember = "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from member where conv = ? and user = ?" +selectMember :: Keyspace -> PrepQuery R (ConvId, UserId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) +selectMember keyspace = fromString $ "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from " <> table keyspace "member" <> " where conv = ? and user = ?" -selectMembers :: PrepQuery R (Identity ConvId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) -selectMembers = "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from member where conv = ?" +selectMembers :: Keyspace -> PrepQuery R (Identity ConvId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) +selectMembers keyspace = fromString $ "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from " <> table keyspace "member" <> " where conv = ?" -insertMember :: PrepQuery W (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, RoleName) () -insertMember = "insert into member (conv, user, service, provider, status, conversation_role) values (?, ?, ?, ?, 0, ?)" +insertMember :: Keyspace -> PrepQuery W (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, RoleName) () +insertMember keyspace = fromString $ "insert into " <> table keyspace "member" <> " (conv, user, service, provider, status, conversation_role) values (?, ?, ?, ?, 0, ?)" -removeMember :: PrepQuery W (ConvId, UserId) () -removeMember = "delete from member where conv = ? and user = ?" +removeMember :: Keyspace -> PrepQuery W (ConvId, UserId) () +removeMember keyspace = fromString $ "delete from " <> table keyspace "member" <> " where conv = ? and user = ?" -updateOtrMemberMutedStatus :: PrepQuery W (MutedStatus, Maybe Text, ConvId, UserId) () -updateOtrMemberMutedStatus = {- `IF EXISTS`, but that requires benchmarking -} "update member set otr_muted_status = ?, otr_muted_ref = ? where conv = ? and user = ?" +updateOtrMemberMutedStatus :: Keyspace -> PrepQuery W (MutedStatus, Maybe Text, ConvId, UserId) () +updateOtrMemberMutedStatus keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "member" <> " set otr_muted_status = ?, otr_muted_ref = ? where conv = ? and user = ?" -updateOtrMemberArchived :: PrepQuery W (Bool, Maybe Text, ConvId, UserId) () -updateOtrMemberArchived = {- `IF EXISTS`, but that requires benchmarking -} "update member set otr_archived = ?, otr_archived_ref = ? where conv = ? and user = ?" +updateOtrMemberArchived :: Keyspace -> PrepQuery W (Bool, Maybe Text, ConvId, UserId) () +updateOtrMemberArchived keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "member" <> " set otr_archived = ?, otr_archived_ref = ? where conv = ? and user = ?" -updateMemberHidden :: PrepQuery W (Bool, Maybe Text, ConvId, UserId) () -updateMemberHidden = {- `IF EXISTS`, but that requires benchmarking -} "update member set hidden = ?, hidden_ref = ? where conv = ? and user = ?" +updateMemberHidden :: Keyspace -> PrepQuery W (Bool, Maybe Text, ConvId, UserId) () +updateMemberHidden keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "member" <> " set hidden = ?, hidden_ref = ? where conv = ? and user = ?" -updateMemberConvRoleName :: PrepQuery W (RoleName, ConvId, UserId) () -updateMemberConvRoleName = {- `IF EXISTS`, but that requires benchmarking -} "update member set conversation_role = ? where conv = ? and user = ?" +updateMemberConvRoleName :: Keyspace -> PrepQuery W (RoleName, ConvId, UserId) () +updateMemberConvRoleName keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "member" <> " set conversation_role = ? where conv = ? and user = ?" -- Federated conversations ----------------------------------------------------- -- @@ -253,129 +257,132 @@ updateMemberConvRoleName = {- `IF EXISTS`, but that requires benchmarking -} "up -- local conversation with remote members -selectUserRemoteConvs :: PrepQuery R (Identity UserId) (Domain, ConvId) -selectUserRemoteConvs = "select conv_remote_domain, conv_remote_id from user_remote_conv where user = ? order by conv_remote_domain, conv_remote_id" +selectUserRemoteConvs :: Keyspace -> PrepQuery R (Identity UserId) (Domain, ConvId) +selectUserRemoteConvs keyspace = fromString $ "select conv_remote_domain, conv_remote_id from " <> table keyspace "user_remote_conv" <> " where user = ? order by conv_remote_domain, conv_remote_id" -selectUserRemoteConvsFrom :: PrepQuery R (UserId, Domain, ConvId) (Domain, ConvId) -selectUserRemoteConvsFrom = "select conv_remote_domain, conv_remote_id from user_remote_conv where user = ? and (conv_remote_domain, conv_remote_id) > (?, ?) order by conv_remote_domain, conv_remote_id" +selectUserRemoteConvsFrom :: Keyspace -> PrepQuery R (UserId, Domain, ConvId) (Domain, ConvId) +selectUserRemoteConvsFrom keyspace = fromString $ "select conv_remote_domain, conv_remote_id from " <> table keyspace "user_remote_conv" <> " where user = ? and (conv_remote_domain, conv_remote_id) > (?, ?) order by conv_remote_domain, conv_remote_id" -insertRemoteMember :: PrepQuery W (ConvId, Domain, UserId, RoleName) () -insertRemoteMember = "insert into member_remote_user (conv, user_remote_domain, user_remote_id, conversation_role) values (?, ?, ?, ?)" +insertRemoteMember :: Keyspace -> PrepQuery W (ConvId, Domain, UserId, RoleName) () +insertRemoteMember keyspace = fromString $ "insert into " <> table keyspace "member_remote_user" <> " (conv, user_remote_domain, user_remote_id, conversation_role) values (?, ?, ?, ?)" -removeRemoteMember :: PrepQuery W (ConvId, Domain, UserId) () -removeRemoteMember = "delete from member_remote_user where conv = ? and user_remote_domain = ? and user_remote_id = ?" +removeRemoteMember :: Keyspace -> PrepQuery W (ConvId, Domain, UserId) () +removeRemoteMember keyspace = fromString $ "delete from " <> table keyspace "member_remote_user" <> " where conv = ? and user_remote_domain = ? and user_remote_id = ?" -selectRemoteMember :: PrepQuery R (ConvId, Domain, UserId) (Identity RoleName) -selectRemoteMember = "select conversation_role from member_remote_user where conv = ? and user_remote_domain = ? and user_remote_id = ?" +selectRemoteMember :: Keyspace -> PrepQuery R (ConvId, Domain, UserId) (Identity RoleName) +selectRemoteMember keyspace = fromString $ "select conversation_role from " <> table keyspace "member_remote_user" <> " where conv = ? and user_remote_domain = ? and user_remote_id = ?" -selectRemoteMembers :: PrepQuery R (Identity ConvId) (Domain, UserId, RoleName) -selectRemoteMembers = "select user_remote_domain, user_remote_id, conversation_role from member_remote_user where conv = ?" +selectRemoteMembers :: Keyspace -> PrepQuery R (Identity ConvId) (Domain, UserId, RoleName) +selectRemoteMembers keyspace = fromString $ "select user_remote_domain, user_remote_id, conversation_role from " <> table keyspace "member_remote_user" <> " where conv = ?" -updateRemoteMemberConvRoleName :: PrepQuery W (RoleName, ConvId, Domain, UserId) () -updateRemoteMemberConvRoleName = {- `IF EXISTS`, but that requires benchmarking -} "update member_remote_user set conversation_role = ? where conv = ? and user_remote_domain = ? and user_remote_id = ?" +updateRemoteMemberConvRoleName :: Keyspace -> PrepQuery W (RoleName, ConvId, Domain, UserId) () +updateRemoteMemberConvRoleName keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "member_remote_user" <> " set conversation_role = ? where conv = ? and user_remote_domain = ? and user_remote_id = ?" -- Used when removing a federation domain, so that we can quickly list all of the affected remote users and conversations -- This returns local conversation IDs and remote users -selectRemoteMembersByDomain :: PrepQuery R (Identity Domain) (ConvId, UserId, RoleName) -selectRemoteMembersByDomain = "select conv, user_remote_id, conversation_role from member_remote_user where user_remote_domain = ?" +selectRemoteMembersByDomain :: Keyspace -> PrepQuery R (Identity Domain) (ConvId, UserId, RoleName) +selectRemoteMembersByDomain keyspace = fromString $ "select conv, user_remote_id, conversation_role from " <> table keyspace "member_remote_user" <> " where user_remote_domain = ?" -- local user with remote conversations -insertUserRemoteConv :: PrepQuery W (UserId, Domain, ConvId) () -insertUserRemoteConv = "insert into user_remote_conv (user, conv_remote_domain, conv_remote_id) values (?, ?, ?)" +insertUserRemoteConv :: Keyspace -> PrepQuery W (UserId, Domain, ConvId) () +insertUserRemoteConv keyspace = fromString $ "insert into " <> table keyspace "user_remote_conv" <> " (user, conv_remote_domain, conv_remote_id) values (?, ?, ?)" -selectRemoteConvMemberStatuses :: PrepQuery R (UserId, Domain, [ConvId]) (ConvId, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text) -selectRemoteConvMemberStatuses = "select conv_remote_id, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref from user_remote_conv where user = ? and conv_remote_domain = ? and conv_remote_id in ?" +selectRemoteConvMemberStatuses :: Keyspace -> PrepQuery R (UserId, Domain, [ConvId]) (ConvId, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text) +selectRemoteConvMemberStatuses keyspace = fromString $ "select conv_remote_id, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref from " <> table keyspace "user_remote_conv" <> " where user = ? and conv_remote_domain = ? and conv_remote_id in ?" -selectRemoteConvMembers :: PrepQuery R (UserId, Domain, ConvId) (Identity UserId) -selectRemoteConvMembers = "select user from user_remote_conv where user = ? and conv_remote_domain = ? and conv_remote_id = ?" +selectRemoteConvMembers :: Keyspace -> PrepQuery R (UserId, Domain, ConvId) (Identity UserId) +selectRemoteConvMembers keyspace = fromString $ "select user from " <> table keyspace "user_remote_conv" <> " where user = ? and conv_remote_domain = ? and conv_remote_id = ?" -deleteUserRemoteConv :: PrepQuery W (UserId, Domain, ConvId) () -deleteUserRemoteConv = "delete from user_remote_conv where user = ? and conv_remote_domain = ? and conv_remote_id = ?" +deleteUserRemoteConv :: Keyspace -> PrepQuery W (UserId, Domain, ConvId) () +deleteUserRemoteConv keyspace = fromString $ "delete from " <> table keyspace "user_remote_conv" <> " where user = ? and conv_remote_domain = ? and conv_remote_id = ?" -- Used when removing a federation domain, so that we can quickly list all of the affected local users and conversations -- This returns remote conversation IDs and local users -selectLocalMembersByDomain :: PrepQuery R (Identity Domain) (ConvId, UserId) -selectLocalMembersByDomain = "select conv_remote_id, user from user_remote_conv where conv_remote_domain = ?" +selectLocalMembersByDomain :: Keyspace -> PrepQuery R (Identity Domain) (ConvId, UserId) +selectLocalMembersByDomain keyspace = fromString $ "select conv_remote_id, user from " <> table keyspace "user_remote_conv" <> " where conv_remote_domain = ?" -- remote conversation status for local user -updateRemoteOtrMemberMutedStatus :: PrepQuery W (MutedStatus, Maybe Text, Domain, ConvId, UserId) () -updateRemoteOtrMemberMutedStatus = {- `IF EXISTS`, but that requires benchmarking -} "update user_remote_conv set otr_muted_status = ?, otr_muted_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" +updateRemoteOtrMemberMutedStatus :: Keyspace -> PrepQuery W (MutedStatus, Maybe Text, Domain, ConvId, UserId) () +updateRemoteOtrMemberMutedStatus keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "user_remote_conv" <> " set otr_muted_status = ?, otr_muted_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" -updateRemoteOtrMemberArchived :: PrepQuery W (Bool, Maybe Text, Domain, ConvId, UserId) () -updateRemoteOtrMemberArchived = {- `IF EXISTS`, but that requires benchmarking -} "update user_remote_conv set otr_archived = ?, otr_archived_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" +updateRemoteOtrMemberArchived :: Keyspace -> PrepQuery W (Bool, Maybe Text, Domain, ConvId, UserId) () +updateRemoteOtrMemberArchived keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "user_remote_conv" <> " set otr_archived = ?, otr_archived_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" -updateRemoteMemberHidden :: PrepQuery W (Bool, Maybe Text, Domain, ConvId, UserId) () -updateRemoteMemberHidden = {- `IF EXISTS`, but that requires benchmarking -} "update user_remote_conv set hidden = ?, hidden_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" +updateRemoteMemberHidden :: Keyspace -> PrepQuery W (Bool, Maybe Text, Domain, ConvId, UserId) () +updateRemoteMemberHidden keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "update " <> table keyspace "user_remote_conv" <> " set hidden = ?, hidden_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" -- MLS SubConversations ----------------------------------------------------- -selectSubConversation :: PrepQuery R (ConvId, SubConvId) (Maybe CipherSuiteTag, Maybe Epoch, Maybe (Writetime Epoch), Maybe GroupId) -selectSubConversation = "SELECT cipher_suite, epoch, WRITETIME(epoch), group_id FROM subconversation WHERE conv_id = ? and subconv_id = ?" +selectSubConversation :: Keyspace -> PrepQuery R (ConvId, SubConvId) (Maybe CipherSuiteTag, Maybe Epoch, Maybe (Writetime Epoch), Maybe GroupId) +selectSubConversation keyspace = fromString $ "SELECT cipher_suite, epoch, WRITETIME(epoch), group_id FROM " <> table keyspace "subconversation" <> " WHERE conv_id = ? and subconv_id = ?" -insertSubConversation :: PrepQuery W (ConvId, SubConvId, Epoch, GroupId, Maybe GroupInfoData) () -insertSubConversation = "INSERT INTO subconversation (conv_id, subconv_id, epoch, group_id, public_group_state) VALUES (?, ?, ?, ?, ?)" +insertSubConversation :: Keyspace -> PrepQuery W (ConvId, SubConvId, Epoch, GroupId, Maybe GroupInfoData) () +insertSubConversation keyspace = fromString $ "INSERT INTO " <> table keyspace "subconversation" <> " (conv_id, subconv_id, epoch, group_id, public_group_state) VALUES (?, ?, ?, ?, ?)" -updateSubConvGroupInfo :: PrepQuery W (ConvId, SubConvId, Maybe GroupInfoData) () -updateSubConvGroupInfo = "INSERT INTO subconversation (conv_id, subconv_id, public_group_state) VALUES (?, ?, ?)" +updateSubConvGroupInfo :: Keyspace -> PrepQuery W (ConvId, SubConvId, Maybe GroupInfoData) () +updateSubConvGroupInfo keyspace = fromString $ "INSERT INTO " <> table keyspace "subconversation" <> " (conv_id, subconv_id, public_group_state) VALUES (?, ?, ?)" -selectSubConvGroupInfo :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe GroupInfoData)) -selectSubConvGroupInfo = "SELECT public_group_state FROM subconversation WHERE conv_id = ? AND subconv_id = ?" +selectSubConvGroupInfo :: Keyspace -> PrepQuery R (ConvId, SubConvId) (Identity (Maybe GroupInfoData)) +selectSubConvGroupInfo keyspace = fromString $ "SELECT public_group_state FROM " <> table keyspace "subconversation" <> " WHERE conv_id = ? AND subconv_id = ?" -selectSubConvEpoch :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe Epoch)) -selectSubConvEpoch = "SELECT epoch FROM subconversation WHERE conv_id = ? AND subconv_id = ?" +selectSubConvEpoch :: Keyspace -> PrepQuery R (ConvId, SubConvId) (Identity (Maybe Epoch)) +selectSubConvEpoch keyspace = fromString $ "SELECT epoch FROM " <> table keyspace "subconversation" <> " WHERE conv_id = ? AND subconv_id = ?" -insertEpochForSubConversation :: PrepQuery W (Epoch, ConvId, SubConvId) () -insertEpochForSubConversation = "UPDATE subconversation set epoch = ? WHERE conv_id = ? AND subconv_id = ?" +insertEpochForSubConversation :: Keyspace -> PrepQuery W (Epoch, ConvId, SubConvId) () +insertEpochForSubConversation keyspace = fromString $ "UPDATE " <> table keyspace "subconversation" <> " set epoch = ? WHERE conv_id = ? AND subconv_id = ?" -insertCipherSuiteForSubConversation :: PrepQuery W (CipherSuiteTag, ConvId, SubConvId) () -insertCipherSuiteForSubConversation = "UPDATE subconversation set cipher_suite = ? WHERE conv_id = ? AND subconv_id = ?" +insertCipherSuiteForSubConversation :: Keyspace -> PrepQuery W (CipherSuiteTag, ConvId, SubConvId) () +insertCipherSuiteForSubConversation keyspace = fromString $ "UPDATE " <> table keyspace "subconversation" <> " set cipher_suite = ? WHERE conv_id = ? AND subconv_id = ?" -listSubConversations :: PrepQuery R (Identity ConvId) (SubConvId, CipherSuiteTag, Epoch, Writetime Epoch, GroupId) -listSubConversations = "SELECT subconv_id, cipher_suite, epoch, WRITETIME(epoch), group_id FROM subconversation WHERE conv_id = ?" +listSubConversations :: Keyspace -> PrepQuery R (Identity ConvId) (SubConvId, CipherSuiteTag, Epoch, Writetime Epoch, GroupId) +listSubConversations keyspace = fromString $ "SELECT subconv_id, cipher_suite, epoch, WRITETIME(epoch), group_id FROM " <> table keyspace "subconversation" <> " WHERE conv_id = ?" -deleteSubConversation :: PrepQuery W (ConvId, SubConvId) () -deleteSubConversation = "DELETE FROM subconversation where conv_id = ? and subconv_id = ?" +deleteSubConversation :: Keyspace -> PrepQuery W (ConvId, SubConvId) () +deleteSubConversation keyspace = fromString $ "DELETE FROM " <> table keyspace "subconversation" <> " where conv_id = ? and subconv_id = ?" -- MLS Clients -------------------------------------------------------------- -addMLSClient :: PrepQuery W (GroupId, Domain, UserId, ClientId, Int32) () -addMLSClient = "insert into mls_group_member_client (group_id, user_domain, user, client, leaf_node_index, removal_pending) values (?, ?, ?, ?, ?, false)" +addMLSClient :: Keyspace -> PrepQuery W (GroupId, Domain, UserId, ClientId, Int32) () +addMLSClient keyspace = fromString $ "insert into " <> table keyspace "mls_group_member_client" <> " (group_id, user_domain, user, client, leaf_node_index, removal_pending) values (?, ?, ?, ?, ?, false)" -planMLSClientRemoval :: PrepQuery W (GroupId, Domain, UserId, ClientId) () -planMLSClientRemoval = "update mls_group_member_client set removal_pending = true where group_id = ? and user_domain = ? and user = ? and client = ?" +planMLSClientRemoval :: Keyspace -> PrepQuery W (GroupId, Domain, UserId, ClientId) () +planMLSClientRemoval keyspace = fromString $ "update " <> table keyspace "mls_group_member_client" <> " set removal_pending = true where group_id = ? and user_domain = ? and user = ? and client = ?" -removeMLSClient :: PrepQuery W (GroupId, Domain, UserId, ClientId) () -removeMLSClient = "delete from mls_group_member_client where group_id = ? and user_domain = ? and user = ? and client = ?" +removeMLSClient :: Keyspace -> PrepQuery W (GroupId, Domain, UserId, ClientId) () +removeMLSClient keyspace = fromString $ "delete from " <> table keyspace "mls_group_member_client" <> " where group_id = ? and user_domain = ? and user = ? and client = ?" -removeAllMLSClients :: PrepQuery W (Identity GroupId) () -removeAllMLSClients = "DELETE FROM mls_group_member_client WHERE group_id = ?" +removeAllMLSClients :: Keyspace -> PrepQuery W (Identity GroupId) () +removeAllMLSClients keyspace = fromString $ "DELETE FROM " <> table keyspace "mls_group_member_client" <> " WHERE group_id = ?" -lookupMLSClients :: PrepQuery R (Identity GroupId) (Domain, UserId, ClientId, Int32, Bool) -lookupMLSClients = "select user_domain, user, client, leaf_node_index, removal_pending from mls_group_member_client where group_id = ?" +lookupMLSClients :: Keyspace -> PrepQuery R (Identity GroupId) (Domain, UserId, ClientId, Int32, Bool) +lookupMLSClients keyspace = fromString $ "select user_domain, user, client, leaf_node_index, removal_pending from " <> table keyspace "mls_group_member_client" <> " where group_id = ?" -acquireCommitLock :: PrepQuery W (GroupId, Epoch, Int32) Row -acquireCommitLock = "insert into mls_commit_locks (group_id, epoch) values (?, ?) if not exists using ttl ?" +acquireCommitLock :: Keyspace -> PrepQuery W (GroupId, Epoch, Int32) Row +acquireCommitLock keyspace = fromString $ "insert into " <> table keyspace "mls_commit_locks" <> " (group_id, epoch) values (?, ?) if not exists using ttl ?" -releaseCommitLock :: PrepQuery W (GroupId, Epoch) () -releaseCommitLock = "delete from mls_commit_locks where group_id = ? and epoch = ?" +releaseCommitLock :: Keyspace -> PrepQuery W (GroupId, Epoch) () +releaseCommitLock keyspace = fromString $ "delete from " <> table keyspace "mls_commit_locks" <> " where group_id = ? and epoch = ?" -- Bots --------------------------------------------------------------------- -insertBot :: PrepQuery W (ConvId, BotId, ServiceId, ProviderId) () -insertBot = "insert into member (conv, user, service, provider, status) values (?, ?, ?, ?, 0)" +insertBot :: Keyspace -> PrepQuery W (ConvId, BotId, ServiceId, ProviderId) () +insertBot keyspace = fromString $ "insert into " <> table keyspace "member" <> " (conv, user, service, provider, status) values (?, ?, ?, ?, 0)" -- Out of Sync -------------------------------------------------------------- -insertConvOutOfSync :: PrepQuery W (ConvId, Bool) () -insertConvOutOfSync = "insert into conversation_out_of_sync (conv_id, out_of_sync) values (?, ?)" +insertConvOutOfSync :: Keyspace -> PrepQuery W (ConvId, Bool) () +insertConvOutOfSync keyspace = fromString $ "insert into " <> table keyspace "conversation_out_of_sync" <> " (conv_id, out_of_sync) values (?, ?)" -insertSubConvOutOfSync :: PrepQuery W (ConvId, SubConvId, Bool) () -insertSubConvOutOfSync = "insert into subconversation_out_of_sync (conv_id, subconv_id, out_of_sync) values (?, ?, ?)" +insertSubConvOutOfSync :: Keyspace -> PrepQuery W (ConvId, SubConvId, Bool) () +insertSubConvOutOfSync keyspace = fromString $ "insert into " <> table keyspace "subconversation_out_of_sync" <> " (conv_id, subconv_id, out_of_sync) values (?, ?, ?)" -lookupConvOutOfSync :: PrepQuery R (Identity ConvId) (Identity (Maybe Bool)) -lookupConvOutOfSync = "select out_of_sync from conversation_out_of_sync where conv_id = ?" +lookupConvOutOfSync :: Keyspace -> PrepQuery R (Identity ConvId) (Identity (Maybe Bool)) +lookupConvOutOfSync keyspace = fromString $ "select out_of_sync from " <> table keyspace "conversation_out_of_sync" <> " where conv_id = ?" -lookupSubConvOutOfSync :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe Bool)) -lookupSubConvOutOfSync = "select out_of_sync from subconversation_out_of_sync where conv_id = ? and subconv_id = ?" +lookupSubConvOutOfSync :: Keyspace -> PrepQuery R (ConvId, SubConvId) (Identity (Maybe Bool)) +lookupSubConvOutOfSync keyspace = fromString $ "select out_of_sync from " <> table keyspace "subconversation_out_of_sync" <> " where conv_id = ? and subconv_id = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs index f659dcb5cd9..6d56b6fb39e 100644 --- a/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs @@ -23,6 +23,7 @@ module Wire.DomainRegistrationStore.Cassandra where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Id (TeamId) import Database.CQL.Protocol (Record (..), TupleType, asTuple) import Imports hiding (lookup) @@ -30,6 +31,7 @@ import Polysemy import SAML2.WebSSO qualified as SAML import UnliftIO (pooledForConcurrentlyN) import Wire.DomainRegistrationStore +import Wire.Util (qualifiedTableName) deriving instance Cql SAML.IdPId @@ -40,49 +42,68 @@ interpretDomainRegistrationStoreToCassandra :: InterpreterFor DomainRegistrationStore r interpretDomainRegistrationStoreToCassandra casClient = interpret $ - embed @IO . runClient casClient . \case - UpsertInternal dr -> upsertImpl dr - LookupInternal domain -> lookupImpl domain - LookupByTeamInternal tid -> lookupByTeamInternalImpl tid - DeleteInternal domain -> deleteImpl domain + \case + UpsertInternal dr -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (upsertImpl keyspace dr) + LookupInternal domain -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (lookupImpl keyspace domain) + LookupByTeamInternal tid -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (lookupByTeamInternalImpl keyspace tid) + DeleteInternal domain -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + embed @IO $ runClient casClient (deleteImpl keyspace domain) -lookupByTeamInternalImpl :: (MonadClient m, MonadUnliftIO m) => TeamId -> m [StoredDomainRegistration] -lookupByTeamInternalImpl tid = do - domains <- lookupTeamDomains tid - catMaybes <$> pooledForConcurrentlyN 16 domains lookupImpl +lookupByTeamInternalImpl :: (MonadClient m, MonadUnliftIO m) => Keyspace -> TeamId -> m [StoredDomainRegistration] +lookupByTeamInternalImpl keyspace tid = do + domains <- lookupTeamDomains keyspace tid + catMaybes <$> pooledForConcurrentlyN 16 domains (lookupImpl keyspace) -lookupTeamDomains :: (MonadClient m) => TeamId -> m [DomainKey] -lookupTeamDomains tid = +lookupTeamDomains :: (MonadClient m) => Keyspace -> TeamId -> m [DomainKey] +lookupTeamDomains keyspace tid = fmap runIdentity <$> retry x1 (query cql (params LocalQuorum (Identity tid))) where cql :: PrepQuery R (Identity TeamId) (Identity DomainKey) - cql = "SELECT domain FROM domain_registration_by_team WHERE team = ?" + cql = fromString $ "SELECT domain FROM " <> table keyspace "domain_registration_by_team" <> " WHERE team = ?" -upsertImpl :: (MonadClient m) => StoredDomainRegistration -> m () -upsertImpl dr = do - for_ dr.authorizedTeam $ flip upsertTeamIndex dr.domain - retry x5 $ write cqlUpsert (params LocalQuorum (asTuple dr)) +upsertImpl :: (MonadClient m) => Keyspace -> StoredDomainRegistration -> m () +upsertImpl keyspace dr = do + for_ dr.authorizedTeam $ \teamId -> upsertTeamIndex keyspace teamId dr.domain + retry x5 $ write (cqlUpsert keyspace) (params LocalQuorum (asTuple dr)) -upsertTeamIndex :: (MonadClient m) => TeamId -> DomainKey -> m () -upsertTeamIndex tid domain = +upsertTeamIndex :: (MonadClient m) => Keyspace -> TeamId -> DomainKey -> m () +upsertTeamIndex keyspace tid domain = retry x5 $ write cql (params LocalQuorum (tid, domain)) where cql :: PrepQuery W (TeamId, DomainKey) () - cql = "INSERT INTO domain_registration_by_team (team, domain) VALUES (?,?)" + cql = fromString $ "INSERT INTO " <> table keyspace "domain_registration_by_team" <> " (team, domain) VALUES (?,?)" -lookupImpl :: (MonadClient m) => DomainKey -> m (Maybe StoredDomainRegistration) -lookupImpl domain = +lookupImpl :: (MonadClient m) => Keyspace -> DomainKey -> m (Maybe StoredDomainRegistration) +lookupImpl keyspace domain = fmap asRecord - <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity domain))) + <$> retry x1 (query1 (cqlSelect keyspace) (params LocalQuorum (Identity domain))) -deleteImpl :: (MonadClient m) => DomainKey -> m () -deleteImpl domain = retry x5 $ write cqlDelete (params LocalQuorum (Identity domain)) +deleteImpl :: (MonadClient m) => Keyspace -> DomainKey -> m () +deleteImpl keyspace domain = retry x5 $ write (cqlDelete keyspace) (params LocalQuorum (Identity domain)) -cqlUpsert :: PrepQuery W (TupleType StoredDomainRegistration) () -cqlUpsert = "INSERT INTO domain_registration (domain, domain_redirect, team_invite, idp_id, backend_url, team, dns_verification_token, ownership_token_hash, authorized_team, webapp_url) VALUES (?,?,?,?,?,?,?,?,?,?)" +cqlUpsert :: Keyspace -> PrepQuery W (TupleType StoredDomainRegistration) () +cqlUpsert keyspace = + fromString $ + "INSERT INTO " + <> table keyspace "domain_registration" + <> " (domain, domain_redirect, team_invite, idp_id, backend_url, team, dns_verification_token, ownership_token_hash, authorized_team, webapp_url) VALUES (?,?,?,?,?,?,?,?,?,?)" -cqlSelect :: PrepQuery R (Identity DomainKey) (TupleType StoredDomainRegistration) -cqlSelect = "SELECT domain, domain_redirect, team_invite, idp_id, backend_url, team, dns_verification_token, ownership_token_hash, authorized_team, webapp_url FROM domain_registration WHERE domain = ?" +cqlSelect :: Keyspace -> PrepQuery R (Identity DomainKey) (TupleType StoredDomainRegistration) +cqlSelect keyspace = + fromString $ + "SELECT domain, domain_redirect, team_invite, idp_id, backend_url, team, dns_verification_token, ownership_token_hash, authorized_team, webapp_url FROM " + <> table keyspace "domain_registration" + <> " WHERE domain = ?" -cqlDelete :: PrepQuery W (Identity DomainKey) () -cqlDelete = "DELETE FROM domain_registration WHERE domain = ?" +cqlDelete :: Keyspace -> PrepQuery W (Identity DomainKey) () +cqlDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "domain_registration" <> " WHERE domain = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/DomainVerificationChallengeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/DomainVerificationChallengeStore/Cassandra.hs index 44ed929a560..917869b9d38 100644 --- a/libs/wire-subsystems/src/Wire/DomainVerificationChallengeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/DomainVerificationChallengeStore/Cassandra.hs @@ -23,6 +23,7 @@ module Wire.DomainVerificationChallengeStore.Cassandra where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Id import Database.CQL.Protocol (Record (..), TupleType, asTuple) import Imports hiding (lookup) @@ -31,6 +32,7 @@ import Polysemy.Embed import Polysemy.Input import Util.Timeout import Wire.DomainVerificationChallengeStore +import Wire.Util (qualifiedTableName) interpretDomainVerificationChallengeStoreToCassandra :: forall r. @@ -43,22 +45,31 @@ interpretDomainVerificationChallengeStoreToCassandra casClient ttl = . runEmbedded (runClient casClient) . interpret ( \case - Insert challenge -> insertImpl challenge - Lookup challengeId -> lookupImpl challengeId - Delete challengeId -> deleteImpl challengeId + Insert challenge -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + insertImpl keyspace challenge + Lookup challengeId -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + lookupImpl keyspace challengeId + Delete challengeId -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + deleteImpl keyspace challengeId ) . raiseUnder2 insertImpl :: (Member (Embed Client) r, Member (Input Timeout) r) => + Keyspace -> StoredDomainVerificationChallenge -> Sem r () -insertImpl challenge = do +insertImpl keyspace challenge = do ttl <- input let q :: PrepQuery W (TupleType StoredDomainVerificationChallenge) () q = fromString $ - "INSERT INTO domain_registration_challenge\ + "INSERT INTO " + <> table keyspace "domain_registration_challenge" + <> "\ \ (id, domain, challenge_token_hash, dns_verification_token)\ \ VALUES (?,?,?,?) using ttl " <> show (round (nominalDiffTimeToSeconds (timeoutDiff ttl)) :: Integer) @@ -66,18 +77,27 @@ insertImpl challenge = do lookupImpl :: (Member (Embed Client) r) => + Keyspace -> ChallengeId -> Sem r (Maybe StoredDomainVerificationChallenge) -lookupImpl challengeId = +lookupImpl keyspace challengeId = embed $ fmap asRecord - <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity challengeId))) + <$> retry x1 (query1 (cqlSelect keyspace) (params LocalQuorum (Identity challengeId))) -cqlSelect :: PrepQuery R (Identity ChallengeId) (TupleType StoredDomainVerificationChallenge) -cqlSelect = "SELECT id, domain, challenge_token_hash, dns_verification_token FROM domain_registration_challenge WHERE id = ?" +cqlSelect :: Keyspace -> PrepQuery R (Identity ChallengeId) (TupleType StoredDomainVerificationChallenge) +cqlSelect keyspace = + fromString $ + "SELECT id, domain, challenge_token_hash, dns_verification_token FROM " + <> table keyspace "domain_registration_challenge" + <> " WHERE id = ?" -deleteImpl :: (Member (Embed Client) r) => ChallengeId -> Sem r () -deleteImpl challengeId = embed $ retry x5 $ write cqlDelete (params LocalQuorum (Identity challengeId)) +deleteImpl :: (Member (Embed Client) r) => Keyspace -> ChallengeId -> Sem r () +deleteImpl keyspace challengeId = + embed $ retry x5 $ write (cqlDelete keyspace) (params LocalQuorum (Identity challengeId)) -cqlDelete :: PrepQuery W (Identity ChallengeId) () -cqlDelete = "DELETE FROM domain_registration_challenge WHERE id = ?" +cqlDelete :: Keyspace -> PrepQuery W (Identity ChallengeId) () +cqlDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "domain_registration_challenge" <> " WHERE id = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra.hs index c767c64883b..dad2e5f5138 100644 --- a/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra.hs @@ -25,7 +25,7 @@ import Wire.LegalHoldStore (LegalHoldStore (..)) import Wire.LegalHoldStore.Cassandra.Queries qualified as Q import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.TeamStore.Cassandra.Queries qualified as QTS -import Wire.Util (embedClientInput, logEffect) +import Wire.Util (embedClientInputWithKeyspace, logEffect) interpretLegalHoldStoreToCassandra :: ( Member (Embed IO) r, @@ -39,34 +39,34 @@ interpretLegalHoldStoreToCassandra :: interpretLegalHoldStoreToCassandra lh = interpret $ \case CreateSettings s -> do logEffect "LegalHoldStore.CreateSettings" - embedClientInput $ createSettings s + embedClientInputWithKeyspace $ \keyspace -> createSettings keyspace s GetSettings tid -> do logEffect "LegalHoldStore.GetSettings" - embedClientInput $ getSettings tid + embedClientInputWithKeyspace $ \keyspace -> getSettings keyspace tid RemoveSettings tid -> do logEffect "LegalHoldStore.RemoveSettings" - embedClientInput $ removeSettings tid + embedClientInputWithKeyspace $ \keyspace -> removeSettings keyspace tid InsertPendingPrekeys uid pkeys -> do logEffect "LegalHoldStore.InsertPendingPrekeys" - embedClientInput $ insertPendingPrekeys uid pkeys + embedClientInputWithKeyspace $ \keyspace -> insertPendingPrekeys keyspace uid pkeys SelectPendingPrekeys uid -> do logEffect "LegalHoldStore.SelectPendingPrekeys" - embedClientInput $ selectPendingPrekeys uid + embedClientInputWithKeyspace $ \keyspace -> selectPendingPrekeys keyspace uid DropPendingPrekeys uid -> do logEffect "LegalHoldStore.DropPendingPrekeys" - embedClientInput $ dropPendingPrekeys uid + embedClientInputWithKeyspace $ \keyspace -> dropPendingPrekeys keyspace uid SetUserLegalHoldStatus tid uid st -> do logEffect "LegalHoldStore.SetUserLegalHoldStatus" - embedClientInput $ setUserLegalHoldStatus tid uid st + embedClientInputWithKeyspace $ \keyspace -> setUserLegalHoldStatus keyspace tid uid st SetTeamLegalholdWhitelisted tid -> do logEffect "LegalHoldStore.SetTeamLegalholdWhitelisted" - embedClientInput $ setTeamLegalholdWhitelisted tid + embedClientInputWithKeyspace $ \keyspace -> setTeamLegalholdWhitelisted keyspace tid UnsetTeamLegalholdWhitelisted tid -> do logEffect "LegalHoldStore.UnsetTeamLegalholdWhitelisted" - embedClientInput $ unsetTeamLegalholdWhitelisted tid + embedClientInputWithKeyspace $ \keyspace -> unsetTeamLegalholdWhitelisted keyspace tid IsTeamLegalholdWhitelisted tid -> do logEffect "LegalHoldStore.IsTeamLegalholdWhitelisted" - embedClientInput $ isTeamLegalholdWhitelisted lh tid + embedClientInputWithKeyspace $ \keyspace -> isTeamLegalholdWhitelisted lh keyspace tid MakeVerifiedRequestFreshManager fpr url r -> do logEffect "LegalHoldStore.MakeVerifiedRequestFreshManager" env <- input @@ -79,47 +79,47 @@ interpretLegalHoldStoreToCassandra lh = interpret $ \case logEffect "LegalHoldStore.ValidateServiceKey" embed @IO $ validateServiceKey sk -createSettings :: (MonadClient m) => LegalHoldService -> m () -createSettings (LegalHoldService tid url fpr tok key) = - retry x1 $ write Q.insertLegalHoldSettings (params LocalQuorum (url, fpr, tok, key, tid)) +createSettings :: (MonadClient m) => Keyspace -> LegalHoldService -> m () +createSettings keyspace (LegalHoldService tid url fpr tok key) = + retry x1 $ write (Q.insertLegalHoldSettings keyspace) (params LocalQuorum (url, fpr, tok, key, tid)) -getSettings :: (MonadClient m) => TeamId -> m (Maybe LegalHoldService) -getSettings tid = fmap toLegalHoldService <$> retry x1 (query1 Q.selectLegalHoldSettings (params LocalQuorum (Identity tid))) +getSettings :: (MonadClient m) => Keyspace -> TeamId -> m (Maybe LegalHoldService) +getSettings keyspace tid = fmap toLegalHoldService <$> retry x1 (query1 (Q.selectLegalHoldSettings keyspace) (params LocalQuorum (Identity tid))) where toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key -removeSettings :: (MonadClient m) => TeamId -> m () -removeSettings tid = retry x5 (write Q.removeLegalHoldSettings (params LocalQuorum (Identity tid))) +removeSettings :: (MonadClient m) => Keyspace -> TeamId -> m () +removeSettings keyspace tid = retry x5 (write (Q.removeLegalHoldSettings keyspace) (params LocalQuorum (Identity tid))) -insertPendingPrekeys :: (MonadClient m) => UserId -> [UncheckedPrekeyBundle] -> m () -insertPendingPrekeys uid keys = retry x5 . batch $ do - forM_ keys $ \(UncheckedPrekeyBundle keyId key) -> addPrepQuery Q.insertPendingPrekeys (uid, keyId, key) +insertPendingPrekeys :: (MonadClient m) => Keyspace -> UserId -> [UncheckedPrekeyBundle] -> m () +insertPendingPrekeys keyspace uid keys = retry x5 . batch $ do + forM_ keys $ \(UncheckedPrekeyBundle keyId key) -> addPrepQuery (Q.insertPendingPrekeys keyspace) (uid, keyId, key) -selectPendingPrekeys :: (MonadClient m) => UserId -> m (Maybe ([UncheckedPrekeyBundle], LastPrekey)) -selectPendingPrekeys uid = pickLastKey . fmap fromTuple <$> retry x1 (query Q.selectPendingPrekeys (params LocalQuorum (Identity uid))) +selectPendingPrekeys :: (MonadClient m) => Keyspace -> UserId -> m (Maybe ([UncheckedPrekeyBundle], LastPrekey)) +selectPendingPrekeys keyspace uid = pickLastKey . fmap fromTuple <$> retry x1 (query (Q.selectPendingPrekeys keyspace) (params LocalQuorum (Identity uid))) where fromTuple (keyId, key) = UncheckedPrekeyBundle keyId key pickLastKey allPrekeys = case unsnoc allPrekeys of Nothing -> Nothing Just (keys, lst) -> pure (keys, lastPrekey . prekeyKey $ lst) -dropPendingPrekeys :: (MonadClient m) => UserId -> m () -dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params LocalQuorum (Identity uid))) +dropPendingPrekeys :: (MonadClient m) => Keyspace -> UserId -> m () +dropPendingPrekeys keyspace uid = retry x5 (write (Q.dropPendingPrekeys keyspace) (params LocalQuorum (Identity uid))) -setUserLegalHoldStatus :: (MonadClient m) => TeamId -> UserId -> UserLegalHoldStatus -> m () -setUserLegalHoldStatus tid uid status = retry x5 (write Q.updateUserLegalHoldStatus (params LocalQuorum (status, tid, uid))) +setUserLegalHoldStatus :: (MonadClient m) => Keyspace -> TeamId -> UserId -> UserLegalHoldStatus -> m () +setUserLegalHoldStatus keyspace tid uid status = retry x5 (write (Q.updateUserLegalHoldStatus keyspace) (params LocalQuorum (status, tid, uid))) -setTeamLegalholdWhitelisted :: (MonadClient m) => TeamId -> m () -setTeamLegalholdWhitelisted tid = retry x5 (write Q.insertLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) +setTeamLegalholdWhitelisted :: (MonadClient m) => Keyspace -> TeamId -> m () +setTeamLegalholdWhitelisted keyspace tid = retry x5 (write (Q.insertLegalHoldWhitelistedTeam keyspace) (params LocalQuorum (Identity tid))) -unsetTeamLegalholdWhitelisted :: (MonadClient m) => TeamId -> m () -unsetTeamLegalholdWhitelisted tid = retry x5 (write Q.removeLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) +unsetTeamLegalholdWhitelisted :: (MonadClient m) => Keyspace -> TeamId -> m () +unsetTeamLegalholdWhitelisted keyspace tid = retry x5 (write (Q.removeLegalHoldWhitelistedTeam keyspace) (params LocalQuorum (Identity tid))) -isTeamLegalholdWhitelisted :: FeatureDefaults LegalholdConfig -> TeamId -> Client Bool -isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False -isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False -isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = - isJust <$> (runIdentity <$$> retry x5 (query1 QTS.selectLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid)))) +isTeamLegalholdWhitelisted :: FeatureDefaults LegalholdConfig -> Keyspace -> TeamId -> Client Bool +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent keyspace tid = + isJust <$> (runIdentity <$$> retry x5 (query1 (QTS.selectLegalHoldWhitelistedTeam keyspace) (params LocalQuorum (Identity tid)))) validateServiceKey :: (MonadIO m) => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) validateServiceKey pem = diff --git a/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra/Queries.hs b/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra/Queries.hs index 97c072a8903..c09b1b61657 100644 --- a/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra/Queries.hs +++ b/libs/wire-subsystems/src/Wire/LegalHoldStore/Cassandra/Queries.hs @@ -1,75 +1,52 @@ module Wire.LegalHoldStore.Cassandra.Queries where import Cassandra as C -import Data.Functor.Identity (Identity) import Data.Id import Data.LegalHold import Data.Misc -import Data.Text (Text) -import Text.RawString.QQ +import Imports import Wire.API.Provider.Service import Wire.API.User.Client.Prekey +import Wire.Util (qualifiedTableName) -insertLegalHoldSettings :: PrepQuery W (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey, TeamId) () -insertLegalHoldSettings = - [r| - update legalhold_service - set base_url = ?, - fingerprint = ?, - auth_token = ?, - pubkey = ? - where team_id = ? - |] +insertLegalHoldSettings :: Keyspace -> PrepQuery W (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey, TeamId) () +insertLegalHoldSettings keyspace = fromString $ + "update " + <> table keyspace "legalhold_service" + <> " set base_url = ?, fingerprint = ?, auth_token = ?, pubkey = ? where team_id = ?" -selectLegalHoldSettings :: PrepQuery R (Identity TeamId) (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey) -selectLegalHoldSettings = - [r| - select base_url, fingerprint, auth_token, pubkey - from legalhold_service - where team_id = ? - |] +selectLegalHoldSettings :: Keyspace -> PrepQuery R (Identity TeamId) (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey) +selectLegalHoldSettings keyspace = fromString $ + "select base_url, fingerprint, auth_token, pubkey from " + <> table keyspace "legalhold_service" + <> " where team_id = ?" -removeLegalHoldSettings :: PrepQuery W (Identity TeamId) () -removeLegalHoldSettings = "delete from legalhold_service where team_id = ?" +removeLegalHoldSettings :: Keyspace -> PrepQuery W (Identity TeamId) () +removeLegalHoldSettings keyspace = fromString $ "delete from " <> table keyspace "legalhold_service" <> " where team_id = ?" -insertPendingPrekeys :: PrepQuery W (UserId, PrekeyId, Text) () -insertPendingPrekeys = - [r| - insert into legalhold_pending_prekeys (user, key, data) values (?, ?, ?) - |] +insertPendingPrekeys :: Keyspace -> PrepQuery W (UserId, PrekeyId, Text) () +insertPendingPrekeys keyspace = fromString $ "insert into " <> table keyspace "legalhold_pending_prekeys" <> " (user, key, data) values (?, ?, ?)" -dropPendingPrekeys :: PrepQuery W (Identity UserId) () -dropPendingPrekeys = - [r| - delete from legalhold_pending_prekeys - where user = ? - |] +dropPendingPrekeys :: Keyspace -> PrepQuery W (Identity UserId) () +dropPendingPrekeys keyspace = fromString $ "delete from " <> table keyspace "legalhold_pending_prekeys" <> " where user = ?" -selectPendingPrekeys :: PrepQuery R (Identity UserId) (PrekeyId, Text) -selectPendingPrekeys = - [r| - select key, data - from legalhold_pending_prekeys - where user = ? - order by key asc - |] +selectPendingPrekeys :: Keyspace -> PrepQuery R (Identity UserId) (PrekeyId, Text) +selectPendingPrekeys keyspace = fromString $ + "select key, data from " + <> table keyspace "legalhold_pending_prekeys" + <> " where user = ? order by key asc" -updateUserLegalHoldStatus :: PrepQuery W (UserLegalHoldStatus, TeamId, UserId) () -updateUserLegalHoldStatus = - [r| - update team_member - set legalhold_status = ? - where team = ? and user = ? - |] +updateUserLegalHoldStatus :: Keyspace -> PrepQuery W (UserLegalHoldStatus, TeamId, UserId) () +updateUserLegalHoldStatus keyspace = fromString $ + "update " + <> table keyspace "team_member" + <> " set legalhold_status = ? where team = ? and user = ?" -insertLegalHoldWhitelistedTeam :: PrepQuery W (Identity TeamId) () -insertLegalHoldWhitelistedTeam = - [r| - insert into legalhold_whitelisted (team) values (?) - |] +insertLegalHoldWhitelistedTeam :: Keyspace -> PrepQuery W (Identity TeamId) () +insertLegalHoldWhitelistedTeam keyspace = fromString $ "insert into " <> table keyspace "legalhold_whitelisted" <> " (team) values (?)" -removeLegalHoldWhitelistedTeam :: PrepQuery W (Identity TeamId) () -removeLegalHoldWhitelistedTeam = - [r| - delete from legalhold_whitelisted where team = ? - |] +removeLegalHoldWhitelistedTeam :: Keyspace -> PrepQuery W (Identity TeamId) () +removeLegalHoldWhitelistedTeam keyspace = fromString $ "delete from " <> table keyspace "legalhold_whitelisted" <> " where team = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index 850fb2f7229..7400d9ce544 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -51,31 +51,35 @@ import Polysemy import Text.Printf import Wire.API.User.Password import Wire.PasswordResetCodeStore +import Wire.Util (qualifiedTableName) passwordResetCodeStoreToCassandra :: forall m r a. (MonadClient m, Member (Embed m) r) => + Keyspace -> Sem (PasswordResetCodeStore ': r) a -> Sem r a -passwordResetCodeStoreToCassandra = +passwordResetCodeStoreToCassandra keyspace = interpret $ - embed @m - . \case - GenerateEmailCode -> genEmailCode - GeneratePhoneCode -> genPhoneCode - CodeSelect prk -> + \case + GenerateEmailCode -> embed @m genEmailCode + GeneratePhoneCode -> embed @m genPhoneCode + CodeSelect prk -> + embed @m $ (fmap . fmap) toRecord . retry x1 - . query1 codeSelectQuery + . query1 (codeSelectQuery keyspace) . params LocalQuorum . Identity $ prk - CodeInsert prk (PRQueryData prc uid n ut) ttl -> + CodeInsert prk (PRQueryData prc uid n ut) ttl -> + embed @m $ retry x5 - . write codeInsertQuery + . write (codeInsertQuery keyspace) . params LocalQuorum $ (prk, prc, uid, runIdentity n, runIdentity ut, ttl) - CodeDelete prk -> codeDeleteImpl prk + CodeDelete prk -> + embed @m $ codeDeleteImpl keyspace prk where toRecord :: (PasswordResetCode, UserId, Maybe Int32, Maybe UTCTime) -> @@ -93,10 +97,10 @@ genPhoneCode = -- FUTUREWORK(fisx,elland): this should be replaced by a method in a -- future auth subsystem -codeDeleteImpl :: (MonadClient m) => PasswordResetKey -> m () -codeDeleteImpl prk = +codeDeleteImpl :: (MonadClient m) => Keyspace -> PasswordResetKey -> m () +codeDeleteImpl keyspace prk = retry x5 - . write codeDeleteQuery + . write (codeDeleteQuery keyspace) . params LocalQuorum . Identity $ prk @@ -112,11 +116,18 @@ interpretClientToIO ctx = interpret $ \case --------------------------------------------------------------------------------- -- Queries -codeSelectQuery :: PrepQuery R (Identity PasswordResetKey) (PasswordResetCode, UserId, Maybe Int32, Maybe UTCTime) -codeSelectQuery = "SELECT code, user, retries, timeout FROM password_reset WHERE key = ?" +codeSelectQuery :: Keyspace -> PrepQuery R (Identity PasswordResetKey) (PasswordResetCode, UserId, Maybe Int32, Maybe UTCTime) +codeSelectQuery keyspace = fromString $ "SELECT code, user, retries, timeout FROM " <> table keyspace "password_reset" <> " WHERE key = ?" -codeInsertQuery :: PrepQuery W (PasswordResetKey, PasswordResetCode, UserId, Int32, UTCTime, Int32) () -codeInsertQuery = "INSERT INTO password_reset (key, code, user, retries, timeout) VALUES (?, ?, ?, ?, ?) USING TTL ?" +codeInsertQuery :: Keyspace -> PrepQuery W (PasswordResetKey, PasswordResetCode, UserId, Int32, UTCTime, Int32) () +codeInsertQuery keyspace = + fromString $ + "INSERT INTO " + <> table keyspace "password_reset" + <> " (key, code, user, retries, timeout) VALUES (?, ?, ?, ?, ?) USING TTL ?" -codeDeleteQuery :: PrepQuery W (Identity PasswordResetKey) () -codeDeleteQuery = "DELETE FROM password_reset WHERE key = ?" +codeDeleteQuery :: Keyspace -> PrepQuery W (Identity PasswordResetKey) () +codeDeleteQuery keyspace = fromString $ "DELETE FROM " <> table keyspace "password_reset" <> " WHERE key = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs index 576ca6cceec..92d0d8365e5 100644 --- a/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs @@ -20,44 +20,55 @@ module Wire.PasswordStore.Cassandra (interpretPasswordStore) where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Id import Imports import Polysemy import Polysemy.Embed import Wire.API.Password (Password) import Wire.PasswordStore +import Wire.Util (qualifiedTableName) interpretPasswordStore :: (Member (Embed IO) r) => ClientState -> InterpreterFor PasswordStore r interpretPasswordStore casClient = interpret $ - runEmbedded (runClient casClient) . \case - UpsertHashedPassword uid password -> embed $ updatePasswordImpl uid password - LookupHashedPassword uid -> embed $ lookupPasswordImpl uid - LookupHashedProviderPassword pid -> embed $ lookupProviderPasswordImpl pid + \case + UpsertHashedPassword uid password -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ updatePasswordImpl keyspace uid password) + LookupHashedPassword uid -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ lookupPasswordImpl keyspace uid) + LookupHashedProviderPassword pid -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ lookupProviderPasswordImpl keyspace pid) -lookupProviderPasswordImpl :: (MonadClient m) => ProviderId -> m (Maybe Password) -lookupProviderPasswordImpl u = +lookupProviderPasswordImpl :: (MonadClient m) => Keyspace -> ProviderId -> m (Maybe Password) +lookupProviderPasswordImpl keyspace u = (runIdentity =<<) - <$> retry x1 (query1 providerPasswordSelect (params LocalQuorum (Identity u))) + <$> retry x1 (query1 (providerPasswordSelect keyspace) (params LocalQuorum (Identity u))) -lookupPasswordImpl :: (MonadClient m) => UserId -> m (Maybe Password) -lookupPasswordImpl u = +lookupPasswordImpl :: (MonadClient m) => Keyspace -> UserId -> m (Maybe Password) +lookupPasswordImpl keyspace u = (runIdentity =<<) - <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) + <$> retry x1 (query1 (passwordSelect keyspace) (params LocalQuorum (Identity u))) -updatePasswordImpl :: (MonadClient m) => UserId -> Password -> m () -updatePasswordImpl u p = do - retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) +updatePasswordImpl :: (MonadClient m) => Keyspace -> UserId -> Password -> m () +updatePasswordImpl keyspace u p = do + retry x5 $ write (userPasswordUpdate keyspace) (params LocalQuorum (p, u)) ------------------------------------------------------------------------ -- Queries -providerPasswordSelect :: PrepQuery R (Identity ProviderId) (Identity (Maybe Password)) -providerPasswordSelect = - "SELECT password FROM provider WHERE id = ?" +providerPasswordSelect :: Keyspace -> PrepQuery R (Identity ProviderId) (Identity (Maybe Password)) +providerPasswordSelect keyspace = + fromString $ "SELECT password FROM " <> table keyspace "provider" <> " WHERE id = ?" -passwordSelect :: PrepQuery R (Identity UserId) (Identity (Maybe Password)) -passwordSelect = "SELECT password FROM user WHERE id = ?" +passwordSelect :: Keyspace -> PrepQuery R (Identity UserId) (Identity (Maybe Password)) +passwordSelect keyspace = fromString $ "SELECT password FROM " <> table keyspace "user" <> " WHERE id = ?" -userPasswordUpdate :: PrepQuery W (Password, UserId) () -userPasswordUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET password = ? WHERE id = ?" +userPasswordUpdate :: Keyspace -> PrepQuery W (Password, UserId) () +userPasswordUpdate keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "UPDATE " <> table keyspace "user" <> " SET password = ? WHERE id = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/PropertyStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PropertyStore/Cassandra.hs index e6aace2772f..bd52ea0cc5e 100644 --- a/libs/wire-subsystems/src/Wire/PropertyStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PropertyStore/Cassandra.hs @@ -18,78 +18,98 @@ module Wire.PropertyStore.Cassandra where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Id import Imports import Polysemy import Polysemy.Embed import Wire.API.Properties import Wire.PropertyStore +import Wire.Util (qualifiedTableName) interpretPropertyStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor PropertyStore r interpretPropertyStoreCassandra casClient = interpret $ runEmbedded (runClient @IO casClient) . embed . \case - InsertProperty u k v -> insertPropertyImpl u k v - LookupProperty u k -> lookupPropertyImpl u k - CountProperties u -> countPropertiesImpl u - DeleteProperty u k -> deletePropertyImpl u k - ClearProperties u -> clearPropertieImpl u - GetPropertyKeys u -> lookupPropertyKeyImpl u - GetAllProperties u -> getAllPropertiesImpl u + InsertProperty u k v -> do + keyspace <- liftIO (requireClientKeyspace casClient) + insertPropertyImpl keyspace u k v + LookupProperty u k -> do + keyspace <- liftIO (requireClientKeyspace casClient) + lookupPropertyImpl keyspace u k + CountProperties u -> do + keyspace <- liftIO (requireClientKeyspace casClient) + countPropertiesImpl keyspace u + DeleteProperty u k -> do + keyspace <- liftIO (requireClientKeyspace casClient) + deletePropertyImpl keyspace u k + ClearProperties u -> do + keyspace <- liftIO (requireClientKeyspace casClient) + clearPropertieImpl keyspace u + GetPropertyKeys u -> do + keyspace <- liftIO (requireClientKeyspace casClient) + lookupPropertyKeyImpl keyspace u + GetAllProperties u -> do + keyspace <- liftIO (requireClientKeyspace casClient) + getAllPropertiesImpl keyspace u insertPropertyImpl :: (MonadClient m) => + Keyspace -> UserId -> PropertyKey -> RawPropertyValue -> m () -insertPropertyImpl u k v = - retry x5 $ write propertyInsert (params LocalQuorum (u, k, v)) +insertPropertyImpl keyspace u k v = + retry x5 $ write (propertyInsert keyspace) (params LocalQuorum (u, k, v)) -deletePropertyImpl :: (MonadClient m) => UserId -> PropertyKey -> m () -deletePropertyImpl u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) +deletePropertyImpl :: (MonadClient m) => Keyspace -> UserId -> PropertyKey -> m () +deletePropertyImpl keyspace u k = retry x5 $ write (propertyDelete keyspace) (params LocalQuorum (u, k)) -clearPropertieImpl :: (MonadClient m) => UserId -> m () -clearPropertieImpl u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) +clearPropertieImpl :: (MonadClient m) => Keyspace -> UserId -> m () +clearPropertieImpl keyspace u = retry x5 $ write (propertyReset keyspace) (params LocalQuorum (Identity u)) -lookupPropertyImpl :: (MonadClient m) => UserId -> PropertyKey -> m (Maybe RawPropertyValue) -lookupPropertyImpl u k = +lookupPropertyImpl :: (MonadClient m) => Keyspace -> UserId -> PropertyKey -> m (Maybe RawPropertyValue) +lookupPropertyImpl keyspace u k = fmap runIdentity - <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) + <$> retry x1 (query1 (propertySelect keyspace) (params LocalQuorum (u, k))) -lookupPropertyKeyImpl :: (MonadClient m) => UserId -> m [PropertyKey] -lookupPropertyKeyImpl u = +lookupPropertyKeyImpl :: (MonadClient m) => Keyspace -> UserId -> m [PropertyKey] +lookupPropertyKeyImpl keyspace u = map runIdentity - <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) + <$> retry x1 (query (propertyKeysSelect keyspace) (params LocalQuorum (Identity u))) -countPropertiesImpl :: (MonadClient m) => UserId -> m Int -countPropertiesImpl u = do - maybe 0 fromIntegral <$> retry x1 (query1 propertyCount (params LocalQuorum (Identity u))) +countPropertiesImpl :: (MonadClient m) => Keyspace -> UserId -> m Int +countPropertiesImpl keyspace u = do + maybe 0 fromIntegral <$> retry x1 (query1 (propertyCount keyspace) (params LocalQuorum (Identity u))) -getAllPropertiesImpl :: (MonadClient m) => UserId -> m [(PropertyKey, RawPropertyValue)] -getAllPropertiesImpl u = - retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) +getAllPropertiesImpl :: (MonadClient m) => Keyspace -> UserId -> m [(PropertyKey, RawPropertyValue)] +getAllPropertiesImpl keyspace u = + retry x1 (query (propertyKeysValuesSelect keyspace) (params LocalQuorum (Identity u))) ------------------------------------------------------------------------------- -- Queries -propertyInsert :: PrepQuery W (UserId, PropertyKey, RawPropertyValue) () -propertyInsert = "INSERT INTO properties (user, key, value) VALUES (?, ?, ?)" +propertyInsert :: Keyspace -> PrepQuery W (UserId, PropertyKey, RawPropertyValue) () +propertyInsert keyspace = fromString $ "INSERT INTO " <> table keyspace "properties" <> " (user, key, value) VALUES (?, ?, ?)" -propertyDelete :: PrepQuery W (UserId, PropertyKey) () -propertyDelete = "DELETE FROM properties where user = ? and key = ?" +propertyDelete :: Keyspace -> PrepQuery W (UserId, PropertyKey) () +propertyDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "properties" <> " where user = ? and key = ?" -propertyReset :: PrepQuery W (Identity UserId) () -propertyReset = "DELETE FROM properties where user = ?" +propertyReset :: Keyspace -> PrepQuery W (Identity UserId) () +propertyReset keyspace = fromString $ "DELETE FROM " <> table keyspace "properties" <> " where user = ?" -propertySelect :: PrepQuery R (UserId, PropertyKey) (Identity RawPropertyValue) -propertySelect = "SELECT value FROM properties where user = ? and key = ?" +propertySelect :: Keyspace -> PrepQuery R (UserId, PropertyKey) (Identity RawPropertyValue) +propertySelect keyspace = fromString $ "SELECT value FROM " <> table keyspace "properties" <> " where user = ? and key = ?" -propertyKeysSelect :: PrepQuery R (Identity UserId) (Identity PropertyKey) -propertyKeysSelect = "SELECT key FROM properties where user = ?" +propertyKeysSelect :: Keyspace -> PrepQuery R (Identity UserId) (Identity PropertyKey) +propertyKeysSelect keyspace = fromString $ "SELECT key FROM " <> table keyspace "properties" <> " where user = ?" -propertyKeysValuesSelect :: PrepQuery R (Identity UserId) (PropertyKey, RawPropertyValue) -propertyKeysValuesSelect = "SELECT key, value FROM properties where user = ?" +propertyKeysValuesSelect :: Keyspace -> PrepQuery R (Identity UserId) (PropertyKey, RawPropertyValue) +propertyKeysValuesSelect keyspace = fromString $ "SELECT key, value FROM " <> table keyspace "properties" <> " where user = ?" -propertyCount :: PrepQuery R (Identity UserId) (Identity Int64) -propertyCount = "SELECT COUNT(*) FROM properties where user = ?" +propertyCount :: Keyspace -> PrepQuery R (Identity UserId) (Identity Int64) +propertyCount keyspace = fromString $ "SELECT COUNT(*) FROM " <> table keyspace "properties" <> " where user = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/ProposalStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ProposalStore/Cassandra.hs index aab1f480fea..474247a0fb4 100644 --- a/libs/wire-subsystems/src/Wire/ProposalStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ProposalStore/Cassandra.hs @@ -32,7 +32,7 @@ import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.ConversationStore.Cassandra.Instances () import Wire.ProposalStore -import Wire.Util (embedClient) +import Wire.Util (embedClientInputWithKeyspace, qualifiedTableName) type ProposalRow = (ProposalRef, Maybe ProposalOrigin, RawMLS Proposal) @@ -50,38 +50,43 @@ interpretProposalStoreToCassandra :: Sem (ProposalStore ': r) a -> Sem r a interpretProposalStoreToCassandra = interpret $ \case - StoreProposal groupId epoch proposal -> do - client <- input - embedClient client . retry x5 $ - write (storeQuery defaultTTL) (params LocalQuorum (groupId, epoch, proposal.ref, proposal.origin, proposal.proposal)) - GetProposal groupId epoch ref -> do - client <- input - embedClient client (runIdentity <$$> retry x1 (query1 getQuery (params LocalQuorum (groupId, epoch, ref)))) - GetAllPendingProposalRefs groupId epoch -> do - client <- input - embedClient client (runIdentity <$$> retry x1 (query getAllPendingRef (params LocalQuorum (groupId, epoch)))) - GetAllPendingProposals groupId epoch -> do - client <- input - embedClient client $ map mkStoredProposal <$> retry x1 (query getAllPending (params LocalQuorum (groupId, epoch))) - DeleteAllProposals groupId -> do - client <- input - embedClient client $ retry x5 (write deleteAllProposalsForGroup (params LocalQuorum (Identity groupId))) + StoreProposal groupId epoch proposal -> + embedClientInputWithKeyspace $ \keyspace -> + retry x5 $ + write (storeQuery keyspace defaultTTL) (params LocalQuorum (groupId, epoch, proposal.ref, proposal.origin, proposal.proposal)) + GetProposal groupId epoch ref -> + embedClientInputWithKeyspace $ \keyspace -> + runIdentity <$$> retry x1 (query1 (getQuery keyspace) (params LocalQuorum (groupId, epoch, ref))) + GetAllPendingProposalRefs groupId epoch -> + embedClientInputWithKeyspace $ \keyspace -> + runIdentity <$$> retry x1 (query (getAllPendingRef keyspace) (params LocalQuorum (groupId, epoch))) + GetAllPendingProposals groupId epoch -> + embedClientInputWithKeyspace $ \keyspace -> + map mkStoredProposal <$> retry x1 (query (getAllPending keyspace) (params LocalQuorum (groupId, epoch))) + DeleteAllProposals groupId -> + embedClientInputWithKeyspace $ \keyspace -> + retry x5 (write (deleteAllProposalsForGroup keyspace) (params LocalQuorum (Identity groupId))) -storeQuery :: Timeout -> PrepQuery W (GroupId, Epoch, ProposalRef, Maybe ProposalOrigin, RawMLS Proposal) () -storeQuery ttl = +storeQuery :: Keyspace -> Timeout -> PrepQuery W (GroupId, Epoch, ProposalRef, Maybe ProposalOrigin, RawMLS Proposal) () +storeQuery keyspace ttl = fromString $ - "insert into mls_proposal_refs (group_id, epoch, ref, origin, proposal)\ + "insert into " + <> table keyspace "mls_proposal_refs" + <> " (group_id, epoch, ref, origin, proposal)\ \ values (?, ?, ?, ?, ?) using ttl " <> show (ttl #> Second) -getQuery :: PrepQuery R (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal)) -getQuery = "select proposal from mls_proposal_refs where group_id = ? and epoch = ? and ref = ?" +getQuery :: Keyspace -> PrepQuery R (GroupId, Epoch, ProposalRef) (Identity (RawMLS Proposal)) +getQuery keyspace = fromString $ "select proposal from " <> table keyspace "mls_proposal_refs" <> " where group_id = ? and epoch = ? and ref = ?" -getAllPendingRef :: PrepQuery R (GroupId, Epoch) (Identity ProposalRef) -getAllPendingRef = "select ref from mls_proposal_refs where group_id = ? and epoch = ?" +getAllPendingRef :: Keyspace -> PrepQuery R (GroupId, Epoch) (Identity ProposalRef) +getAllPendingRef keyspace = fromString $ "select ref from " <> table keyspace "mls_proposal_refs" <> " where group_id = ? and epoch = ?" -getAllPending :: PrepQuery R (GroupId, Epoch) ProposalRow -getAllPending = "select ref, origin, proposal from mls_proposal_refs where group_id = ? and epoch = ?" +getAllPending :: Keyspace -> PrepQuery R (GroupId, Epoch) ProposalRow +getAllPending keyspace = fromString $ "select ref, origin, proposal from " <> table keyspace "mls_proposal_refs" <> " where group_id = ? and epoch = ?" -deleteAllProposalsForGroup :: PrepQuery W (Identity GroupId) () -deleteAllProposalsForGroup = "delete from mls_proposal_refs where group_id = ?" +deleteAllProposalsForGroup :: Keyspace -> PrepQuery W (Identity GroupId) () +deleteAllProposalsForGroup keyspace = fromString $ "delete from " <> table keyspace "mls_proposal_refs" <> " where group_id = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/ServiceStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ServiceStore/Cassandra.hs index e51ab776832..12041d65ab3 100644 --- a/libs/wire-subsystems/src/Wire/ServiceStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ServiceStore/Cassandra.hs @@ -19,6 +19,7 @@ module Wire.ServiceStore.Cassandra where import Cassandra import Cassandra qualified as C +import Cassandra.Util (requireClientKeyspace) import Control.Lens import Data.Id import Data.Misc @@ -41,40 +42,45 @@ interpretServiceStoreToCassandra :: interpretServiceStoreToCassandra cassClient = interpret $ \case CreateService s -> do logEffect "ServiceStore.CreateService" - embedClient cassClient $ insertService s + keyspace <- embed @IO $ requireClientKeyspace cassClient + embedClient cassClient $ insertService keyspace s GetService sr -> do logEffect "ServiceStore.GetService" - embedClient cassClient $ lookupService sr + keyspace <- embed @IO $ requireClientKeyspace cassClient + embedClient cassClient $ lookupService keyspace sr DeleteService sr -> do logEffect "ServiceStore.DeleteService" - embedClient cassClient $ deleteService sr + keyspace <- embed @IO $ requireClientKeyspace cassClient + embedClient cassClient $ deleteService keyspace sr -insertService :: (MonadClient m) => Bot.Service -> m () -insertService s = do +insertService :: (MonadClient m) => Keyspace -> Bot.Service -> m () +insertService keyspace s = do let sid = s ^. Bot.serviceRef . serviceRefId let pid = s ^. Bot.serviceRef . serviceRefProvider let tok = s ^. Bot.serviceToken let url = s ^. Bot.serviceUrl let fps = Set (s ^. Bot.serviceFingerprints) let ena = s ^. Bot.serviceEnabled - retry x5 $ write insertSrv (params LocalQuorum (pid, sid, url, tok, fps, ena)) + retry x5 $ write (insertSrv keyspace) (params LocalQuorum (pid, sid, url, tok, fps, ena)) -lookupService :: (MonadClient m) => ServiceRef -> m (Maybe Bot.Service) -lookupService s = +lookupService :: (MonadClient m) => Keyspace -> ServiceRef -> m (Maybe Bot.Service) +lookupService keyspace s = fmap toService - <$> retry x1 (query1 selectSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) + <$> retry x1 (query1 (selectSrv keyspace) (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) where toService (url, tok, Set fps, ena) = Bot.newService s url tok fps & set Bot.serviceEnabled ena -deleteService :: (MonadClient m) => ServiceRef -> m () -deleteService s = retry x5 (write rmSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) +deleteService :: (MonadClient m) => Keyspace -> ServiceRef -> m () +deleteService keyspace s = retry x5 (write (rmSrv keyspace) (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) -rmSrv :: PrepQuery W (ProviderId, ServiceId) () -rmSrv = "delete from service where provider = ? AND id = ?" +rmSrv :: Keyspace -> PrepQuery W (ProviderId, ServiceId) () +rmSrv keyspace = fromString $ "delete from " <> qualifiedTableName keyspace "service" <> " where provider = ? AND id = ?" -insertSrv :: PrepQuery W (ProviderId, ServiceId, HttpsUrl, ServiceToken, C.Set (Fingerprint Rsa), Bool) () -insertSrv = "insert into service (provider, id, base_url, auth_token, fingerprints, enabled) values (?, ?, ?, ?, ?, ?)" +insertSrv :: Keyspace -> PrepQuery W (ProviderId, ServiceId, HttpsUrl, ServiceToken, C.Set (Fingerprint Rsa), Bool) () +insertSrv keyspace = + fromString $ "insert into " <> qualifiedTableName keyspace "service" <> " (provider, id, base_url, auth_token, fingerprints, enabled) values (?, ?, ?, ?, ?, ?)" -selectSrv :: PrepQuery R (ProviderId, ServiceId) (HttpsUrl, ServiceToken, C.Set (Fingerprint Rsa), Bool) -selectSrv = "select base_url, auth_token, fingerprints, enabled from service where provider = ? AND id = ?" +selectSrv :: Keyspace -> PrepQuery R (ProviderId, ServiceId) (HttpsUrl, ServiceToken, C.Set (Fingerprint Rsa), Bool) +selectSrv keyspace = + fromString $ "select base_url, auth_token, fingerprints, enabled from " <> qualifiedTableName keyspace "service" <> " where provider = ? AND id = ?" diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs index e21a4555c34..71e577653ed 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra.hs @@ -62,7 +62,8 @@ getDbFeatureImpl :: Sem r (Maybe DbFeaturePatch) getDbFeatureImpl sing tid = case featureSingIsFeature sing of Dict -> do - mRow <- (embedClientInput (retry x1 $ query1 select (params LocalQuorum (tid, featureName @cfg)))) + mRow <- embedClientInputWithKeyspace $ \keyspace -> + retry x1 $ query1 (select keyspace) (params LocalQuorum (tid, featureName @cfg)) pure $ (\(status, lockStatus, config) -> LockableFeaturePatch {..}) <$> mRow setDbFeatureImpl :: @@ -95,13 +96,13 @@ patchDbFeatureImpl :: LockableFeaturePatch cfg -> Sem r () patchDbFeatureImpl sing tid patch = case featureSingIsFeature sing of - Dict -> embedClientInput $ do + Dict -> embedClientInputWithKeyspace $ \keyspace -> do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - for_ patch.status $ \featureStatus -> addPrepQuery writeStatus (featureStatus, tid, featureName @cfg) - for_ patch.lockStatus $ \lockStatus -> addPrepQuery writeLockStatus (lockStatus, tid, featureName @cfg) - for_ patch.config $ \config -> addPrepQuery writeConfig (serialiseDbConfig config, tid, featureName @cfg) + for_ patch.status $ \featureStatus -> addPrepQuery (writeStatus keyspace) (featureStatus, tid, featureName @cfg) + for_ patch.lockStatus $ \lockStatus -> addPrepQuery (writeLockStatus keyspace) (lockStatus, tid, featureName @cfg) + for_ patch.config $ \config -> addPrepQuery (writeConfig keyspace) (serialiseDbConfig config, tid, featureName @cfg) setFeatureLockStatusImpl :: forall cfg r. @@ -114,9 +115,9 @@ setFeatureLockStatusImpl :: Sem r () setFeatureLockStatusImpl sing tid (Tagged lockStatus) = case featureSingIsFeature sing of Dict -> do - embedClientInput $ + embedClientInputWithKeyspace $ \keyspace -> retry x5 $ - write writeLockStatus (params LocalQuorum (lockStatus, tid, featureName @cfg)) + write (writeLockStatus keyspace) (params LocalQuorum (lockStatus, tid, featureName @cfg)) getAllDbFeaturesImpl :: ( Member (Embed IO) r, @@ -125,7 +126,8 @@ getAllDbFeaturesImpl :: TeamId -> Sem r AllDbFeaturePatches getAllDbFeaturesImpl tid = do - rows <- embedClientInput $ retry x1 $ query selectAllByTeam (params LocalQuorum (Identity tid)) + rows <- embedClientInputWithKeyspace $ \keyspace -> + retry x1 $ query (selectAllByTeam keyspace) (params LocalQuorum (Identity tid)) let m = Map.fromList $ do (name, status, lockStatus, config) <- rows pure (name, LockableFeaturePatch {..}) diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra/Queries.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra/Queries.hs index f2eb9537973..157ae293d8d 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra/Queries.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Cassandra/Queries.hs @@ -21,21 +21,25 @@ import Cassandra import Data.Id import Imports import Wire.API.Team.Feature +import Wire.Util (qualifiedTableName) -select :: PrepQuery R (TeamId, Text) (Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) -select = "select status, lock_status, config from team_features_dyn where team = ? and feature = ?" +select :: Keyspace -> PrepQuery R (TeamId, Text) (Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) +select keyspace = fromString $ "select status, lock_status, config from " <> table keyspace "team_features_dyn" <> " where team = ? and feature = ?" -writeStatus :: PrepQuery W (FeatureStatus, TeamId, Text) () -writeStatus = "update team_features_dyn set status = ? where team = ? and feature = ?" +writeStatus :: Keyspace -> PrepQuery W (FeatureStatus, TeamId, Text) () +writeStatus keyspace = fromString $ "update " <> table keyspace "team_features_dyn" <> " set status = ? where team = ? and feature = ?" -writeLockStatus :: PrepQuery W (LockStatus, TeamId, Text) () -writeLockStatus = "update team_features_dyn set lock_status = ? where team = ? and feature = ?" +writeLockStatus :: Keyspace -> PrepQuery W (LockStatus, TeamId, Text) () +writeLockStatus keyspace = fromString $ "update " <> table keyspace "team_features_dyn" <> " set lock_status = ? where team = ? and feature = ?" -writeConfig :: PrepQuery W (DbConfig, TeamId, Text) () -writeConfig = "update team_features_dyn set config = ? where team = ? and feature = ?" +writeConfig :: Keyspace -> PrepQuery W (DbConfig, TeamId, Text) () +writeConfig keyspace = fromString $ "update " <> table keyspace "team_features_dyn" <> " set config = ? where team = ? and feature = ?" -selectAllByTeam :: PrepQuery R (Identity TeamId) (Text, Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) -selectAllByTeam = "select feature, status, lock_status, config from team_features_dyn where team = ?" +selectAllByTeam :: Keyspace -> PrepQuery R (Identity TeamId) (Text, Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) +selectAllByTeam keyspace = fromString $ "select feature, status, lock_status, config from " <> table keyspace "team_features_dyn" <> " where team = ?" -selectAll :: PrepQuery R () (TeamId, Text, Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) -selectAll = "select team, feature, status, lock_status, config from team_features_dyn" +selectAll :: Keyspace -> PrepQuery R () (TeamId, Text, Maybe FeatureStatus, Maybe LockStatus, Maybe DbConfig) +selectAll keyspace = fromString $ "select team, feature, status, lock_status, config from " <> table keyspace "team_features_dyn" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migrating.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migrating.hs index e85b883c9ed..2e95e2e2563 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migrating.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migrating.hs @@ -177,7 +177,9 @@ withWritePathUnderLock _ tid action = then interpretTeamFeatureStoreToCassandra action else interpretTeamFeatureStoreToPostgres action where - runSelectCql = embedClientInput (retry x1 $ query1 Cql.select (params LocalQuorum (tid, featureName @cfg))) + runSelectCql = + embedClientInputWithKeyspace $ \keyspace -> + retry x1 $ query1 (Cql.select keyspace) (params LocalQuorum (tid, featureName @cfg)) withSharedLock :: ( PGConstraints r, diff --git a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migration.hs b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migration.hs index d072cc590ca..231e98c6880 100644 --- a/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migration.hs +++ b/libs/wire-subsystems/src/Wire/TeamFeatureStore/Migration.hs @@ -18,6 +18,7 @@ module Wire.TeamFeatureStore.Migration where import Cassandra hiding (Value) +import Cassandra.Util (requireClientKeyspace) import Data.ByteString.Conversion import Data.Conduit import Data.Conduit.List qualified as C @@ -57,7 +58,9 @@ migrateAllTeamFeatures :: ConduitM () Void (Sem r) () migrateAllTeamFeatures migOpts migCounter = do lift $ info $ Log.msg (Log.val "migrateAllTeamFeatures ") - withCount (paginateSem Cql.selectAll (paramsP LocalQuorum () migOpts.pageSize) x5) + cassClient <- lift input + keyspace <- lift . embed $ requireClientKeyspace cassClient + withCount (paginateSem (Cql.selectAll keyspace) (paramsP LocalQuorum () migOpts.pageSize) x5) .| logRetrievedPage migOpts.pageSize id .| C.mapM_ (traverse_ (\row@(tid, feat, _, _, _) -> handleErrors (toByteString' (idToText tid <> " - " <> feat)) (migrateTeamFeature migCounter row))) diff --git a/libs/wire-subsystems/src/Wire/TeamStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/TeamStore/Cassandra.hs index 5a5f52468da..da4a43770fd 100644 --- a/libs/wire-subsystems/src/Wire/TeamStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/TeamStore/Cassandra.hs @@ -49,7 +49,7 @@ import Wire.ConversationStore qualified as E import Wire.ConversationStore.Cassandra.Instances () import Wire.TeamStore (TeamStore (..)) import Wire.TeamStore.Cassandra.Queries qualified as Cql -import Wire.Util (embedClientInput, logEffect) +import Wire.Util (embedClientInput, embedClientInputWithKeyspace, logEffect) interpretTeamStoreToCassandra :: ( Member (Embed IO) r, @@ -62,31 +62,31 @@ interpretTeamStoreToCassandra :: interpretTeamStoreToCassandra = interpret $ \case CreateTeamMember tid mem -> do logEffect "TeamStore.CreateTeamMember" - embedClientInput (addTeamMember tid mem) + embedClientInputWithKeyspace (\keyspace -> addTeamMember keyspace tid mem) SetTeamMemberPermissions perm0 tid uid perm1 -> do logEffect "TeamStore.SetTeamMemberPermissions" - embedClientInput (updateTeamMember perm0 tid uid perm1) + embedClientInputWithKeyspace (\keyspace -> updateTeamMember keyspace perm0 tid uid perm1) CreateTeam t uid n i k b -> do logEffect "TeamStore.CreateTeam" createTeam t uid n i k b DeleteTeamMember tid uid -> do logEffect "TeamStore.DeleteTeamMember" - embedClientInput (removeTeamMember tid uid) + embedClientInputWithKeyspace (\keyspace -> removeTeamMember keyspace tid uid) GetBillingTeamMembers tid -> do logEffect "TeamStore.GetBillingTeamMembers" - embedClientInput (listBillingTeamMembers tid) + embedClientInputWithKeyspace (\keyspace -> listBillingTeamMembers keyspace tid) GetTeamAdmins tid -> do logEffect "TeamStore.GetTeamAdmins" - embedClientInput (listTeamAdmins tid) + embedClientInputWithKeyspace (\keyspace -> listTeamAdmins keyspace tid) GetTeam tid -> do logEffect "TeamStore.GetTeam" - embedClientInput (team tid) + embedClientInputWithKeyspace (\keyspace -> team keyspace tid) GetTeamName tid -> do logEffect "TeamStore.GetTeamName" - embedClientInput (getTeamName tid) + embedClientInputWithKeyspace (\keyspace -> getTeamName keyspace tid) SelectTeams uid tids -> do logEffect "TeamStore.SelectTeams" - embedClientInput (teamIdsOf uid tids) + embedClientInputWithKeyspace (\keyspace -> teamIdsOf keyspace uid tids) GetTeamMember tid uid -> do logEffect "TeamStore.GetTeamMember" teamMember tid uid @@ -101,34 +101,34 @@ interpretTeamStoreToCassandra = interpret $ \case teamMembersLimited tid uids SelectTeamMemberInfos tid uids -> do logEffect "TeamStore.SelectTeamMemberInfos" - embedClientInput (teamMemberInfos tid uids) + embedClientInputWithKeyspace (\keyspace -> teamMemberInfos keyspace tid uids) GetUserTeams uid -> do logEffect "TeamStore.GetUserTeams" - embedClientInput (userTeams uid) + embedClientInputWithKeyspace (\keyspace -> userTeams keyspace uid) GetUsersTeams uids -> do logEffect "TeamStore.GetUsersTeams" - embedClientInput (usersTeams uids) + embedClientInputWithKeyspace (\keyspace -> usersTeams keyspace uids) GetOneUserTeam uid -> do logEffect "TeamStore.GetOneUserTeam" - embedClientInput (oneUserTeam uid) + embedClientInputWithKeyspace (\keyspace -> oneUserTeam keyspace uid) GetTeamsBindings tid -> do logEffect "TeamStore.GetTeamsBindings" - embedClientInput (getTeamsBindings tid) + embedClientInputWithKeyspace (\keyspace -> getTeamsBindings keyspace tid) GetTeamBinding tid -> do logEffect "TeamStore.GetTeamBinding" - embedClientInput (getTeamBinding tid) + embedClientInputWithKeyspace (\keyspace -> getTeamBinding keyspace tid) GetTeamCreationTime tid -> do logEffect "TeamStore.GetTeamCreationTime" - embedClientInput (teamCreationTime tid) + embedClientInputWithKeyspace (\keyspace -> teamCreationTime keyspace tid) DeleteTeam tid -> do logEffect "TeamStore.DeleteTeam" deleteTeam tid SetTeamData tid upd -> do logEffect "TeamStore.SetTeamData" - embedClientInput (updateTeam tid upd) + embedClientInputWithKeyspace (\keyspace -> updateTeam keyspace tid upd) SetTeamStatus tid st -> do logEffect "TeamStore.SetTeamStatus" - embedClientInput (updateTeamStatus tid st) + embedClientInputWithKeyspace (\keyspace -> updateTeamStatus keyspace tid st) createTeam :: ( Member (Input ClientState) r, @@ -143,26 +143,27 @@ createTeam :: Sem r Team createTeam t uid (fromRange -> n) i k b = do tid <- embed @IO $ maybe (Id <$> liftIO nextRandom) pure t - embedClientInput $ retry x5 $ write Cql.insertTeam (params LocalQuorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) + embedClientInputWithKeyspace $ \keyspace -> + retry x5 $ write (Cql.insertTeam keyspace) (params LocalQuorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) where initialStatus Binding = PendingActive initialStatus NonBinding = Active -listBillingTeamMembers :: TeamId -> Client [UserId] -listBillingTeamMembers tid = fmap runIdentity <$> retry x1 (query Cql.listBillingTeamMembers (params LocalQuorum (Identity tid))) +listBillingTeamMembers :: Keyspace -> TeamId -> Client [UserId] +listBillingTeamMembers keyspace tid = fmap runIdentity <$> retry x1 (query (Cql.listBillingTeamMembers keyspace) (params LocalQuorum (Identity tid))) -listTeamAdmins :: TeamId -> Client [UserId] -listTeamAdmins tid = fmap runIdentity <$> retry x1 (query Cql.listTeamAdmins (params LocalQuorum (Identity tid))) +listTeamAdmins :: Keyspace -> TeamId -> Client [UserId] +listTeamAdmins keyspace tid = fmap runIdentity <$> retry x1 (query (Cql.listTeamAdmins keyspace) (params LocalQuorum (Identity tid))) -getTeamName :: TeamId -> Client (Maybe Text) -getTeamName tid = fmap runIdentity <$> retry x1 (query1 Cql.selectTeamName (params LocalQuorum (Identity tid))) +getTeamName :: Keyspace -> TeamId -> Client (Maybe Text) +getTeamName keyspace tid = fmap runIdentity <$> retry x1 (query1 (Cql.selectTeamName keyspace) (params LocalQuorum (Identity tid))) -teamIdsOf :: UserId -> [TeamId] -> Client [TeamId] -teamIdsOf uid tids = fmap runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params LocalQuorum (uid, tids))) +teamIdsOf :: Keyspace -> UserId -> [TeamId] -> Client [TeamId] +teamIdsOf keyspace uid tids = fmap runIdentity <$> retry x1 (query (Cql.selectUserTeamsIn keyspace) (params LocalQuorum (uid, tids))) -team :: TeamId -> Client (Maybe TeamData) -team tid = fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params LocalQuorum (Identity tid))) +team :: Keyspace -> TeamId -> Client (Maybe TeamData) +team keyspace tid = fmap toTeam <$> retry x1 (query1 (Cql.selectTeam keyspace) (params LocalQuorum (Identity tid))) where toTeam (u, n, i, k, d, s, st, b, ss) = let t = newTeam tid u n i (fromMaybe NonBinding b) & teamIconKey .~ k & teamSplashScreen .~ fromMaybe DefaultIcon ss @@ -177,65 +178,65 @@ teamMember :: UserId -> Sem r (Maybe TeamMember) teamMember t u = do - mres <- embedClientInput $ retry x1 (query1 Cql.selectTeamMember (params LocalQuorum (t, u))) + mres <- embedClientInputWithKeyspace $ \keyspace -> retry x1 (query1 (Cql.selectTeamMember keyspace) (params LocalQuorum (t, u))) pure $ fmap (\(perms, minvu, minvt, mulhStatus) -> newTeamMember' (u, perms, minvu, minvt, mulhStatus)) mres -addTeamMember :: TeamId -> TeamMember -> Client () -addTeamMember t m = +addTeamMember :: Keyspace -> TeamId -> TeamMember -> Client () +addTeamMember keyspace t m = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.insertTeamMember (t, m ^. userId, m ^. permissions, m ^? invitation . _Just . _1, m ^? invitation . _Just . _2) - addPrepQuery Cql.insertUserTeam (m ^. userId, t) - when (m `hasPermission` SetBilling) $ addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) - when (isAdminOrOwner (m ^. permissions)) $ addPrepQuery Cql.insertTeamAdmin (t, m ^. userId) + addPrepQuery (Cql.insertTeamMember keyspace) (t, m ^. userId, m ^. permissions, m ^? invitation . _Just . _1, m ^? invitation . _Just . _2) + addPrepQuery (Cql.insertUserTeam keyspace) (m ^. userId, t) + when (m `hasPermission` SetBilling) $ addPrepQuery (Cql.insertBillingTeamMember keyspace) (t, m ^. userId) + when (isAdminOrOwner (m ^. permissions)) $ addPrepQuery (Cql.insertTeamAdmin keyspace) (t, m ^. userId) -updateTeamMember :: Permissions -> TeamId -> UserId -> Permissions -> Client () -updateTeamMember oldPerms tid uid newPerms = do +updateTeamMember :: Keyspace -> Permissions -> TeamId -> UserId -> Permissions -> Client () +updateTeamMember keyspace oldPerms tid uid newPerms = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.updatePermissions (newPerms, tid, uid) + addPrepQuery (Cql.updatePermissions keyspace) (newPerms, tid, uid) let permDiff = Set.difference `on` self acquiredPerms = newPerms `permDiff` oldPerms lostPerms = oldPerms `permDiff` newPerms - when (SetBilling `Set.member` acquiredPerms) $ addPrepQuery Cql.insertBillingTeamMember (tid, uid) - when (SetBilling `Set.member` lostPerms) $ addPrepQuery Cql.deleteBillingTeamMember (tid, uid) - when (isAdminOrOwner newPerms && not (isAdminOrOwner oldPerms)) $ addPrepQuery Cql.insertTeamAdmin (tid, uid) - when (isAdminOrOwner oldPerms && not (isAdminOrOwner newPerms)) $ addPrepQuery Cql.deleteTeamAdmin (tid, uid) + when (SetBilling `Set.member` acquiredPerms) $ addPrepQuery (Cql.insertBillingTeamMember keyspace) (tid, uid) + when (SetBilling `Set.member` lostPerms) $ addPrepQuery (Cql.deleteBillingTeamMember keyspace) (tid, uid) + when (isAdminOrOwner newPerms && not (isAdminOrOwner oldPerms)) $ addPrepQuery (Cql.insertTeamAdmin keyspace) (tid, uid) + when (isAdminOrOwner oldPerms && not (isAdminOrOwner newPerms)) $ addPrepQuery (Cql.deleteTeamAdmin keyspace) (tid, uid) -removeTeamMember :: TeamId -> UserId -> Client () -removeTeamMember tid uid = do +removeTeamMember :: Keyspace -> TeamId -> UserId -> Client () +removeTeamMember keyspace tid uid = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.deleteTeamMember (tid, uid) - addPrepQuery Cql.deleteUserTeam (uid, tid) - addPrepQuery Cql.deleteBillingTeamMember (tid, uid) - addPrepQuery Cql.deleteTeamAdmin (tid, uid) + addPrepQuery (Cql.deleteTeamMember keyspace) (tid, uid) + addPrepQuery (Cql.deleteUserTeam keyspace) (uid, tid) + addPrepQuery (Cql.deleteBillingTeamMember keyspace) (tid, uid) + addPrepQuery (Cql.deleteTeamAdmin keyspace) (tid, uid) -userTeams :: UserId -> Client [TeamId] -userTeams u = map runIdentity <$> retry x1 (query Cql.selectUserTeams (params LocalQuorum (Identity u))) +userTeams :: Keyspace -> UserId -> Client [TeamId] +userTeams keyspace u = map runIdentity <$> retry x1 (query (Cql.selectUserTeams keyspace) (params LocalQuorum (Identity u))) -usersTeams :: [UserId] -> Client (Map UserId TeamId) -usersTeams uids = do - pairs :: [(UserId, TeamId)] <- catMaybes <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam uid) uids +usersTeams :: Keyspace -> [UserId] -> Client (Map UserId TeamId) +usersTeams keyspace uids = do + pairs :: [(UserId, TeamId)] <- catMaybes <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam keyspace uid) uids pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs -oneUserTeam :: UserId -> Client (Maybe TeamId) -oneUserTeam u = fmap runIdentity <$> retry x1 (query1 Cql.selectOneUserTeam (params LocalQuorum (Identity u))) +oneUserTeam :: Keyspace -> UserId -> Client (Maybe TeamId) +oneUserTeam keyspace u = fmap runIdentity <$> retry x1 (query1 (Cql.selectOneUserTeam keyspace) (params LocalQuorum (Identity u))) -teamCreationTime :: TeamId -> Client (Maybe TeamCreationTime) -teamCreationTime t = checkCreation . fmap runIdentity <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params LocalQuorum (Identity t))) +teamCreationTime :: Keyspace -> TeamId -> Client (Maybe TeamCreationTime) +teamCreationTime keyspace t = checkCreation . fmap runIdentity <$> retry x1 (query1 (Cql.selectTeamBindingWritetime keyspace) (params LocalQuorum (Identity t))) where checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts checkCreation _ = Nothing -getTeamBinding :: TeamId -> Client (Maybe TeamBinding) -getTeamBinding t = fmap (fromMaybe NonBinding . runIdentity) <$> retry x1 (query1 Cql.selectTeamBinding (params LocalQuorum (Identity t))) +getTeamBinding :: Keyspace -> TeamId -> Client (Maybe TeamBinding) +getTeamBinding keyspace t = fmap (fromMaybe NonBinding . runIdentity) <$> retry x1 (query1 (Cql.selectTeamBinding keyspace) (params LocalQuorum (Identity t))) -getTeamsBindings :: [TeamId] -> Client [TeamBinding] -getTeamsBindings = fmap catMaybes . UnliftIO.pooledMapConcurrentlyN 8 getTeamBinding +getTeamsBindings :: Keyspace -> [TeamId] -> Client [TeamBinding] +getTeamsBindings keyspace = fmap catMaybes . UnliftIO.pooledMapConcurrentlyN 8 (getTeamBinding keyspace) deleteTeam :: ( Member (Input ClientState) r, @@ -245,31 +246,31 @@ deleteTeam :: TeamId -> Sem r () deleteTeam tid = do - embedClientInput (markTeamDeletedAndRemoveTeamMembers tid) + embedClientInputWithKeyspace (\keyspace -> markTeamDeletedAndRemoveTeamMembers keyspace tid) E.deleteTeamConversations tid - embedClientInput (retry x5 $ write Cql.deleteTeam (params LocalQuorum (Deleted, tid))) + embedClientInputWithKeyspace (\keyspace -> retry x5 $ write (Cql.deleteTeam keyspace) (params LocalQuorum (Deleted, tid))) -markTeamDeletedAndRemoveTeamMembers :: TeamId -> Client () -markTeamDeletedAndRemoveTeamMembers tid = do - retry x5 $ write Cql.markTeamDeleted (params LocalQuorum (PendingDelete, tid)) - mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) +markTeamDeletedAndRemoveTeamMembers :: Keyspace -> TeamId -> Client () +markTeamDeletedAndRemoveTeamMembers keyspace tid = do + retry x5 $ write (Cql.markTeamDeleted keyspace) (params LocalQuorum (PendingDelete, tid)) + mems <- teamMembersForPagination keyspace tid Nothing (unsafeRange 2000) removeTeamMembers mems where removeTeamMembers mems = do - mapM_ (removeTeamMember tid . view _1) (result mems) + mapM_ (removeTeamMember keyspace tid . view _1) (result mems) unless (null $ result mems) $ removeTeamMembers =<< liftClient (nextPage mems) -updateTeamStatus :: TeamId -> TeamStatus -> Client () -updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params LocalQuorum (s, t)) +updateTeamStatus :: Keyspace -> TeamId -> TeamStatus -> Client () +updateTeamStatus keyspace t s = retry x5 $ write (Cql.updateTeamStatus keyspace) (params LocalQuorum (s, t)) -updateTeam :: TeamId -> TeamUpdateData -> Client () -updateTeam tid u = retry x5 . batch $ do +updateTeam :: Keyspace -> TeamId -> TeamUpdateData -> Client () +updateTeam keyspace tid u = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - for_ (u ^. nameUpdate) $ \n -> addPrepQuery Cql.updateTeamName (fromRange n, tid) - for_ (u ^. iconUpdate) $ \i -> addPrepQuery Cql.updateTeamIcon (decodeUtf8 . toByteString' $ i, tid) - for_ (u ^. iconKeyUpdate) $ \k -> addPrepQuery Cql.updateTeamIconKey (fromRange k, tid) - for_ (u ^. splashScreenUpdate) $ \ss -> addPrepQuery Cql.updateTeamSplashScreen (decodeUtf8 . toByteString' $ ss, tid) + for_ (u ^. nameUpdate) $ \n -> addPrepQuery (Cql.updateTeamName keyspace) (fromRange n, tid) + for_ (u ^. iconUpdate) $ \i -> addPrepQuery (Cql.updateTeamIcon keyspace) (decodeUtf8 . toByteString' $ i, tid) + for_ (u ^. iconKeyUpdate) $ \k -> addPrepQuery (Cql.updateTeamIconKey keyspace) (fromRange k, tid) + for_ (u ^. splashScreenUpdate) $ \ss -> addPrepQuery (Cql.updateTeamSplashScreen keyspace) (decodeUtf8 . toByteString' $ ss, tid) newTeamMember' :: (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> @@ -279,11 +280,11 @@ newTeamMember' (uid, perms, mInvUser, mInvTime, fromMaybe defUserLegalHoldStatus type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) -teamMembersForPagination tid start (fromRange -> max) = +teamMembersForPagination :: Keyspace -> TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) +teamMembersForPagination keyspace tid start (fromRange -> max) = case start of - Just u -> paginate Cql.selectTeamMembersFrom (paramsP LocalQuorum (tid, u) max) - Nothing -> paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity tid) max) + Just u -> paginate (Cql.selectTeamMembersFrom keyspace) (paramsP LocalQuorum (tid, u) max) + Nothing -> paginate (Cql.selectTeamMembers keyspace) (paramsP LocalQuorum (Identity tid) max) teamMembersCollectedWithPagination :: ( Member (Embed IO) r, @@ -292,7 +293,7 @@ teamMembersCollectedWithPagination :: TeamId -> Sem r [TeamMember] teamMembersCollectedWithPagination tid = do - mems <- embedClientInput $ teamMembersForPagination tid Nothing (unsafeRange 2000) + mems <- embedClientInputWithKeyspace $ \keyspace -> teamMembersForPagination keyspace tid Nothing (unsafeRange 2000) collect [] mems where collect acc page = do @@ -311,7 +312,7 @@ teamMembersWithLimit :: Range 1 HardTruncationLimit Int32 -> Sem r TeamMemberList teamMembersWithLimit t (fromRange -> limit) = do - page <- embedClientInput $ retry x1 (paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity t) (limit + 1))) + page <- embedClientInputWithKeyspace $ \keyspace -> retry x1 (paginate (Cql.selectTeamMembers keyspace) (paramsP LocalQuorum (Identity t) (limit + 1))) let ms = map newTeamMember' . take (fromIntegral limit) $ result page pure $ if hasMore page then newTeamMemberList ms ListTruncated else newTeamMemberList ms ListComplete @@ -323,11 +324,12 @@ teamMembersLimited :: [UserId] -> Sem r [TeamMember] teamMembersLimited t u = do - rows <- embedClientInput $ retry x1 (query Cql.selectTeamMembers' (params LocalQuorum (t, u))) + rows <- embedClientInputWithKeyspace $ \keyspace -> retry x1 (query (Cql.selectTeamMembers' keyspace) (params LocalQuorum (t, u))) pure $ map (\(uid, perms, _, minvu, minvt, mlh) -> newTeamMember' (uid, perms, minvu, minvt, mlh)) rows -teamMemberInfos :: TeamId -> [UserId] -> Client [TeamMemberInfo] -teamMemberInfos t u = mkTeamMemberInfo <$$> retry x1 (query Cql.selectTeamMembers' (params LocalQuorum (t, u))) +teamMemberInfos :: Keyspace -> TeamId -> [UserId] -> Client [TeamMemberInfo] +teamMemberInfos keyspace t u = + mkTeamMemberInfo <$$> retry x1 (query (Cql.selectTeamMembers' keyspace) (params LocalQuorum (t, u))) where mkTeamMemberInfo (uid, perms, permsWT, _, _, _) = TeamMemberInfo {Info.userId = uid, Info.permissions = perms, Info.permissionsWriteTime = toUTCTimeMillis $ writetimeToUTC permsWT} diff --git a/libs/wire-subsystems/src/Wire/TeamStore/Cassandra/Queries.hs b/libs/wire-subsystems/src/Wire/TeamStore/Cassandra/Queries.hs index 921c718030f..3b6f874067b 100644 --- a/libs/wire-subsystems/src/Wire/TeamStore/Cassandra/Queries.hs +++ b/libs/wire-subsystems/src/Wire/TeamStore/Cassandra/Queries.hs @@ -23,26 +23,27 @@ import Data.Id import Data.Json.Util import Data.LegalHold import Imports -import Text.RawString.QQ import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Team import Wire.API.Team.Permission +import Wire.Util (qualifiedTableName) -- Teams -------------------------------------------------------------------- -selectTeam :: PrepQuery R (Identity TeamId) (UserId, Text, Icon, Maybe Text, Bool, Maybe TeamStatus, Maybe (Writetime TeamStatus), Maybe TeamBinding, Maybe Icon) -selectTeam = "select creator, name, icon, icon_key, deleted, status, writetime(status), binding, splash_screen from team where team = ?" +selectTeam :: Keyspace -> PrepQuery R (Identity TeamId) (UserId, Text, Icon, Maybe Text, Bool, Maybe TeamStatus, Maybe (Writetime TeamStatus), Maybe TeamBinding, Maybe Icon) +selectTeam keyspace = fromString $ "select creator, name, icon, icon_key, deleted, status, writetime(status), binding, splash_screen from " <> table keyspace "team" <> " where team = ?" -selectTeamName :: PrepQuery R (Identity TeamId) (Identity Text) -selectTeamName = "select name from team where team = ?" +selectTeamName :: Keyspace -> PrepQuery R (Identity TeamId) (Identity Text) +selectTeamName keyspace = fromString $ "select name from " <> table keyspace "team" <> " where team = ?" -selectTeamBinding :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamBinding)) -selectTeamBinding = "select binding from team where team = ?" +selectTeamBinding :: Keyspace -> PrepQuery R (Identity TeamId) (Identity (Maybe TeamBinding)) +selectTeamBinding keyspace = fromString $ "select binding from " <> table keyspace "team" <> " where team = ?" -selectTeamBindingWritetime :: PrepQuery R (Identity TeamId) (Identity (Maybe Int64)) -selectTeamBindingWritetime = "select writetime(binding) from team where team = ?" +selectTeamBindingWritetime :: Keyspace -> PrepQuery R (Identity TeamId) (Identity (Maybe Int64)) +selectTeamBindingWritetime keyspace = fromString $ "select writetime(binding) from " <> table keyspace "team" <> " where team = ?" selectTeamMember :: + Keyspace -> PrepQuery R (TeamId, UserId) @@ -51,16 +52,17 @@ selectTeamMember :: Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -selectTeamMember = "select perms, invited_by, invited_at, legalhold_status from team_member where team = ? and user = ?" +selectTeamMember keyspace = fromString $ "select perms, invited_by, invited_at, legalhold_status from " <> table keyspace "team_member" <> " where team = ? and user = ?" -selectTeamMembersBase :: (IsString a) => [String] -> a -selectTeamMembersBase conds = fromString $ selectFrom <> " where team = ?" <> whereClause <> " order by user" +selectTeamMembersBase :: (IsString a) => Keyspace -> [String] -> a +selectTeamMembersBase keyspace conds = fromString $ selectFrom <> " where team = ?" <> whereClause <> " order by user" where - selectFrom = "select user, perms, invited_by, invited_at, legalhold_status from team_member" + selectFrom = "select user, perms, invited_by, invited_at, legalhold_status from " <> table keyspace "team_member" whereClause = concatMap (" and " <>) conds -- | This query fetches all members of a team, should be paginated. selectTeamMembers :: + Keyspace -> PrepQuery R (Identity TeamId) @@ -70,9 +72,10 @@ selectTeamMembers :: Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -selectTeamMembers = selectTeamMembersBase [] +selectTeamMembers keyspace = selectTeamMembersBase keyspace [] selectTeamMembersFrom :: + Keyspace -> PrepQuery R (TeamId, UserId) @@ -82,9 +85,10 @@ selectTeamMembersFrom :: Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -selectTeamMembersFrom = selectTeamMembersBase ["user > ?"] +selectTeamMembersFrom keyspace = selectTeamMembersBase keyspace ["user > ?"] selectTeamMembers' :: + Keyspace -> PrepQuery R (TeamId, [UserId]) @@ -95,86 +99,84 @@ selectTeamMembers' :: Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -selectTeamMembers' = - [r| - select user, perms, writetime(perms), invited_by, invited_at, legalhold_status - from team_member - where team = ? and user in ? order by user - |] +selectTeamMembers' keyspace = fromString $ + "select user, perms, writetime(perms), invited_by, invited_at, legalhold_status from " + <> table keyspace "team_member" + <> " where team = ? and user in ? order by user" -selectUserTeams :: PrepQuery R (Identity UserId) (Identity TeamId) -selectUserTeams = "select team from user_team where user = ? order by team" +selectUserTeams :: Keyspace -> PrepQuery R (Identity UserId) (Identity TeamId) +selectUserTeams keyspace = fromString $ "select team from " <> table keyspace "user_team" <> " where user = ? order by team" -selectOneUserTeam :: PrepQuery R (Identity UserId) (Identity TeamId) -selectOneUserTeam = "select team from user_team where user = ? limit 1" +selectOneUserTeam :: Keyspace -> PrepQuery R (Identity UserId) (Identity TeamId) +selectOneUserTeam keyspace = fromString $ "select team from " <> table keyspace "user_team" <> " where user = ? limit 1" -selectUserTeamsIn :: PrepQuery R (UserId, [TeamId]) (Identity TeamId) -selectUserTeamsIn = "select team from user_team where user = ? and team in ? order by team" +selectUserTeamsIn :: Keyspace -> PrepQuery R (UserId, [TeamId]) (Identity TeamId) +selectUserTeamsIn keyspace = fromString $ "select team from " <> table keyspace "user_team" <> " where user = ? and team in ? order by team" -selectUserTeamsFrom :: PrepQuery R (UserId, TeamId) (Identity TeamId) -selectUserTeamsFrom = "select team from user_team where user = ? and team > ? order by team" +selectUserTeamsFrom :: Keyspace -> PrepQuery R (UserId, TeamId) (Identity TeamId) +selectUserTeamsFrom keyspace = fromString $ "select team from " <> table keyspace "user_team" <> " where user = ? and team > ? order by team" -insertTeam :: PrepQuery W (TeamId, UserId, Text, Icon, Maybe Text, TeamStatus, TeamBinding) () -insertTeam = "insert into team (team, creator, name, icon, icon_key, deleted, status, binding) values (?, ?, ?, ?, ?, false, ?, ?)" +insertTeam :: Keyspace -> PrepQuery W (TeamId, UserId, Text, Icon, Maybe Text, TeamStatus, TeamBinding) () +insertTeam keyspace = fromString $ "insert into " <> table keyspace "team" <> " (team, creator, name, icon, icon_key, deleted, status, binding) values (?, ?, ?, ?, ?, false, ?, ?)" -insertTeamMember :: PrepQuery W (TeamId, UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis) () -insertTeamMember = "insert into team_member (team, user, perms, invited_by, invited_at) values (?, ?, ?, ?, ?)" +insertTeamMember :: Keyspace -> PrepQuery W (TeamId, UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis) () +insertTeamMember keyspace = fromString $ "insert into " <> table keyspace "team_member" <> " (team, user, perms, invited_by, invited_at) values (?, ?, ?, ?, ?)" -deleteTeamMember :: PrepQuery W (TeamId, UserId) () -deleteTeamMember = "delete from team_member where team = ? and user = ?" +deleteTeamMember :: Keyspace -> PrepQuery W (TeamId, UserId) () +deleteTeamMember keyspace = fromString $ "delete from " <> table keyspace "team_member" <> " where team = ? and user = ?" -insertBillingTeamMember :: PrepQuery W (TeamId, UserId) () -insertBillingTeamMember = "insert into billing_team_member (team, user) values (?, ?)" +insertBillingTeamMember :: Keyspace -> PrepQuery W (TeamId, UserId) () +insertBillingTeamMember keyspace = fromString $ "insert into " <> table keyspace "billing_team_member" <> " (team, user) values (?, ?)" -deleteBillingTeamMember :: PrepQuery W (TeamId, UserId) () -deleteBillingTeamMember = "delete from billing_team_member where team = ? and user = ?" +deleteBillingTeamMember :: Keyspace -> PrepQuery W (TeamId, UserId) () +deleteBillingTeamMember keyspace = fromString $ "delete from " <> table keyspace "billing_team_member" <> " where team = ? and user = ?" -listBillingTeamMembers :: PrepQuery R (Identity TeamId) (Identity UserId) -listBillingTeamMembers = "select user from billing_team_member where team = ?" +listBillingTeamMembers :: Keyspace -> PrepQuery R (Identity TeamId) (Identity UserId) +listBillingTeamMembers keyspace = fromString $ "select user from " <> table keyspace "billing_team_member" <> " where team = ?" -insertTeamAdmin :: PrepQuery W (TeamId, UserId) () -insertTeamAdmin = "insert into team_admin (team, user) values (?, ?)" +insertTeamAdmin :: Keyspace -> PrepQuery W (TeamId, UserId) () +insertTeamAdmin keyspace = fromString $ "insert into " <> table keyspace "team_admin" <> " (team, user) values (?, ?)" -deleteTeamAdmin :: PrepQuery W (TeamId, UserId) () -deleteTeamAdmin = "delete from team_admin where team = ? and user = ?" +deleteTeamAdmin :: Keyspace -> PrepQuery W (TeamId, UserId) () +deleteTeamAdmin keyspace = fromString $ "delete from " <> table keyspace "team_admin" <> " where team = ? and user = ?" -listTeamAdmins :: PrepQuery R (Identity TeamId) (Identity UserId) -listTeamAdmins = "select user from team_admin where team = ?" +listTeamAdmins :: Keyspace -> PrepQuery R (Identity TeamId) (Identity UserId) +listTeamAdmins keyspace = fromString $ "select user from " <> table keyspace "team_admin" <> " where team = ?" -updatePermissions :: PrepQuery W (Permissions, TeamId, UserId) () -updatePermissions = "update team_member set perms = ? where team = ? and user = ?" +updatePermissions :: Keyspace -> PrepQuery W (Permissions, TeamId, UserId) () +updatePermissions keyspace = fromString $ "update " <> table keyspace "team_member" <> " set perms = ? where team = ? and user = ?" -insertUserTeam :: PrepQuery W (UserId, TeamId) () -insertUserTeam = "insert into user_team (user, team) values (?, ?)" +insertUserTeam :: Keyspace -> PrepQuery W (UserId, TeamId) () +insertUserTeam keyspace = fromString $ "insert into " <> table keyspace "user_team" <> " (user, team) values (?, ?)" -deleteUserTeam :: PrepQuery W (UserId, TeamId) () -deleteUserTeam = "delete from user_team where user = ? and team = ?" +deleteUserTeam :: Keyspace -> PrepQuery W (UserId, TeamId) () +deleteUserTeam keyspace = fromString $ "delete from " <> table keyspace "user_team" <> " where user = ? and team = ?" -markTeamDeleted :: PrepQuery W (TeamStatus, TeamId) () -markTeamDeleted = "update team set status = ? where team = ?" +markTeamDeleted :: Keyspace -> PrepQuery W (TeamStatus, TeamId) () +markTeamDeleted keyspace = fromString $ "update " <> table keyspace "team" <> " set status = ? where team = ?" -deleteTeam :: PrepQuery W (TeamStatus, TeamId) () -deleteTeam = "update team using timestamp 32503680000000000 set name = 'default', icon = 'default', status = ? where team = ? " +deleteTeam :: Keyspace -> PrepQuery W (TeamStatus, TeamId) () +deleteTeam keyspace = fromString $ "update " <> table keyspace "team" <> " using timestamp 32503680000000000 set name = 'default', icon = 'default', status = ? where team = ? " -updateTeamName :: PrepQuery W (Text, TeamId) () -updateTeamName = "update team set name = ? where team = ?" +updateTeamName :: Keyspace -> PrepQuery W (Text, TeamId) () +updateTeamName keyspace = fromString $ "update " <> table keyspace "team" <> " set name = ? where team = ?" -updateTeamIcon :: PrepQuery W (Text, TeamId) () -updateTeamIcon = "update team set icon = ? where team = ?" +updateTeamIcon :: Keyspace -> PrepQuery W (Text, TeamId) () +updateTeamIcon keyspace = fromString $ "update " <> table keyspace "team" <> " set icon = ? where team = ?" -updateTeamIconKey :: PrepQuery W (Text, TeamId) () -updateTeamIconKey = "update team set icon_key = ? where team = ?" +updateTeamIconKey :: Keyspace -> PrepQuery W (Text, TeamId) () +updateTeamIconKey keyspace = fromString $ "update " <> table keyspace "team" <> " set icon_key = ? where team = ?" -updateTeamStatus :: PrepQuery W (TeamStatus, TeamId) () -updateTeamStatus = "update team set status = ? where team = ?" +updateTeamStatus :: Keyspace -> PrepQuery W (TeamStatus, TeamId) () +updateTeamStatus keyspace = fromString $ "update " <> table keyspace "team" <> " set status = ? where team = ?" -updateTeamSplashScreen :: PrepQuery W (Text, TeamId) () -updateTeamSplashScreen = "update team set splash_screen = ? where team = ?" +updateTeamSplashScreen :: Keyspace -> PrepQuery W (Text, TeamId) () +updateTeamSplashScreen keyspace = fromString $ "update " <> table keyspace "team" <> " set splash_screen = ? where team = ?" -- LegalHold whitelist ------------------------------------------------------- -selectLegalHoldWhitelistedTeam :: PrepQuery R (Identity TeamId) (Identity TeamId) -selectLegalHoldWhitelistedTeam = - [r| - select team from legalhold_whitelisted where team = ? - |] +selectLegalHoldWhitelistedTeam :: Keyspace -> PrepQuery R (Identity TeamId) (Identity TeamId) +selectLegalHoldWhitelistedTeam keyspace = fromString $ "select team from " <> table keyspace "legalhold_whitelisted" <> " where team = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs index d4ab58ac0d7..acf7926de86 100644 --- a/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs @@ -18,36 +18,51 @@ module Wire.UserKeyStore.Cassandra (interpretUserKeyStoreCassandra) where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Id import Imports import Polysemy import Polysemy.Embed import Wire.UserKeyStore import Wire.UserStore +import Wire.Util (qualifiedTableName) interpretUserKeyStoreCassandra :: (Member (Embed IO) r, Member UserStore r) => ClientState -> InterpreterFor UserKeyStore r interpretUserKeyStoreCassandra casClient = interpret $ - runEmbedded (runClient casClient) . \case - LookupKey key -> embed $ lookupKeyImpl key - InsertKey uid key -> embed $ insertKeyImpl uid key - DeleteKey key -> embed $ deleteKeyImpl key - DeleteKeyForUser uid key -> embed $ deleteKeyForUserImpl uid key - ClaimKey key uid -> claimKeyImpl casClient key uid - KeyAvailable key uid -> keyAvailableImpl casClient key uid + \case + LookupKey key -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ lookupKeyImpl keyspace key) + InsertKey uid key -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ insertKeyImpl keyspace uid key) + DeleteKey key -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ deleteKeyImpl keyspace key) + DeleteKeyForUser uid key -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed $ deleteKeyForUserImpl keyspace uid key) + ClaimKey key uid -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + claimKeyImpl casClient keyspace key uid + KeyAvailable key uid -> do + keyspace <- embed @IO $ requireClientKeyspace casClient + keyAvailableImpl casClient keyspace key uid -- | Claim an 'EmailKey' for a user. claimKeyImpl :: (Member (Embed IO) r, Member UserStore r) => ClientState -> + Keyspace -> -- | The key to claim. EmailKey -> -- | The user claiming the key. UserId -> Sem r Bool -claimKeyImpl client k u = do - free <- keyAvailableImpl client k (Just u) - when free (runClient client $ insertKeyImpl u k) +claimKeyImpl client keyspace k u = do + free <- keyAvailableImpl client keyspace k (Just u) + when free (runClient client $ insertKeyImpl keyspace u k) pure free -- | Check whether an 'EmailKey' is available. @@ -56,30 +71,31 @@ claimKeyImpl client k u = do keyAvailableImpl :: (Member (Embed IO) r, Member UserStore r) => ClientState -> + Keyspace -> -- | The key to check. EmailKey -> -- | The user looking to claim the key, if any. Maybe UserId -> Sem r Bool -keyAvailableImpl client k u = do - o <- runClient client $ lookupKeyImpl k +keyAvailableImpl client keyspace k u = do + o <- runClient client $ lookupKeyImpl keyspace k case (o, u) of (Nothing, _) -> pure True (Just x, Just y) | x == y -> pure True (Just x, _) -> not <$> isActivated x -lookupKeyImpl :: (MonadClient m) => EmailKey -> m (Maybe UserId) -lookupKeyImpl k = +lookupKeyImpl :: (MonadClient m) => Keyspace -> EmailKey -> m (Maybe UserId) +lookupKeyImpl keyspace k = fmap runIdentity - <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ emailKeyUniq k))) + <$> retry x1 (query1 (keySelect keyspace) (params LocalQuorum (Identity $ emailKeyUniq k))) -insertKeyImpl :: UserId -> EmailKey -> Client () -insertKeyImpl u k = do - retry x5 $ write keyInsert (params LocalQuorum (emailKeyUniq k, u)) +insertKeyImpl :: Keyspace -> UserId -> EmailKey -> Client () +insertKeyImpl keyspace u k = do + retry x5 $ write (keyInsert keyspace) (params LocalQuorum (emailKeyUniq k, u)) -deleteKeyImpl :: (MonadClient m) => EmailKey -> m () -deleteKeyImpl k = do - retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq k)) +deleteKeyImpl :: (MonadClient m) => Keyspace -> EmailKey -> m () +deleteKeyImpl keyspace k = do + retry x5 $ write (keyDelete keyspace) (params LocalQuorum (Identity $ emailKeyUniq k)) -- | Delete `EmailKey` for `UserId` -- @@ -89,21 +105,24 @@ deleteKeyImpl k = do -- executed several times due to cassandra not supporting transactions) -- `deleteKeyImplForUser` does not fail for missing keys or keys that belong to -- another user: It always returns `()` as result. -deleteKeyForUserImpl :: (MonadClient m) => UserId -> EmailKey -> m () -deleteKeyForUserImpl uid k = do - mbKeyUid <- lookupKeyImpl k +deleteKeyForUserImpl :: (MonadClient m) => Keyspace -> UserId -> EmailKey -> m () +deleteKeyForUserImpl keyspace uid k = do + mbKeyUid <- lookupKeyImpl keyspace k case mbKeyUid of - Just keyUid | keyUid == uid -> deleteKeyImpl k + Just keyUid | keyUid == uid -> deleteKeyImpl keyspace k _ -> pure () -------------------------------------------------------------------------------- -- Queries -keyInsert :: PrepQuery W (Text, UserId) () -keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)" +keyInsert :: Keyspace -> PrepQuery W (Text, UserId) () +keyInsert keyspace = fromString $ "INSERT INTO " <> table keyspace "user_keys" <> " (key, user) VALUES (?, ?)" -keySelect :: PrepQuery R (Identity Text) (Identity UserId) -keySelect = "SELECT user FROM user_keys WHERE key = ?" +keySelect :: Keyspace -> PrepQuery R (Identity Text) (Identity UserId) +keySelect keyspace = fromString $ "SELECT user FROM " <> table keyspace "user_keys" <> " WHERE key = ?" -keyDelete :: PrepQuery W (Identity Text) () -keyDelete = "DELETE FROM user_keys WHERE key = ?" +keyDelete :: Keyspace -> PrepQuery W (Identity Text) () +keyDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "user_keys" <> " WHERE key = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 21d54bdc976..be2ef03a566 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -19,6 +19,7 @@ module Wire.UserStore.Cassandra (interpretUserStoreCassandra) where import Cassandra import Cassandra.Exec (prepared) +import Cassandra.Util (requireClientKeyspace) import Control.Lens ((^.)) import Data.Handle import Data.Id @@ -37,98 +38,101 @@ import Wire.StoredUser import Wire.UserStore import Wire.UserStore.IndexUser hiding (userId) import Wire.UserStore.Unique +import Wire.Util (qualifiedTableName) interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor UserStore r interpretUserStoreCassandra casClient = interpret $ - runEmbedded (runClient casClient) . embed . \case - CreateUser new mbConv -> createUserImpl new mbConv - GetUsers uids -> getUsersImpl uids - DoesUserExist uid -> doesUserExistImpl uid - GetIndexUser uid -> getIndexUserImpl uid - GetIndexUsersPaginated pageSize mPagingState -> getIndexUserPaginatedImpl pageSize (paginationStateCassandra =<< mPagingState) - UpdateUser uid update -> updateUserImpl uid update - UpdateEmail uid email -> updateEmailImpl uid email - UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email - DeleteEmailUnvalidated uid -> deleteEmailUnvalidatedImpl uid - UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update - UpdateSSOId uid ssoId -> updateSSOIdImpl uid ssoId - UpdateManagedBy uid managedBy -> updateManagedByImpl uid managedBy - UpdateAccountStatus uid accountStatus -> updateAccountStatusImpl uid accountStatus - ActivateUser uid identity -> activateUserImpl uid identity - DeactivateUser uid -> deactivateUserImpl uid - UpdateRichInfo uid richInfo -> updateRichInfoImpl uid richInfo - UpdateFeatureConferenceCalling uid feat -> updateFeatureConferenceCallingImpl uid feat - LookupFeatureConferenceCalling uid -> lookupFeatureConferenceCallingImpl uid - DeleteUser user -> deleteUserImpl user - LookupName uid -> lookupNameImpl uid - LookupHandle hdl -> lookupHandleImpl LocalQuorum hdl - GlimpseHandle hdl -> lookupHandleImpl One hdl - LookupStatus uid -> lookupStatusImpl uid - IsActivated uid -> isActivatedImpl uid - LookupLocale uid -> lookupLocaleImpl uid - GetUserTeam uid -> getUserTeamImpl uid - UpdateUserTeam uid tid -> updateUserTeamImpl uid tid - GetRichInfo uid -> getRichInfoImpl uid - LookupRichInfos uids -> lookupRichInfosImpl uids - GetUserAuthenticationInfo uid -> getUserAuthenticationInfoImpl uid - DeleteEmail uid -> deleteEmailImpl uid - SetUserSearchable uid searchable -> setUserSearchableImpl uid searchable - DeleteServiceUser pid sid bid -> deleteServiceUserImpl pid sid bid - LookupServiceUsers pid sid mPagingState -> lookupServiceUsersImpl pid sid (paginationStateCassandra =<< mPagingState) - LookupServiceUsersForTeam pid sid tid mPagingState -> lookupServiceUsersForTeamImpl pid sid tid (paginationStateCassandra =<< mPagingState) - -createUserImpl :: NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> Client () -createUserImpl new mbConv = retry x5 . batch $ do + \case + CreateUser new mbConv -> runClientWithKeyspace casClient $ \keyspace -> createUserImpl keyspace new mbConv + GetUsers uids -> runClientWithKeyspace casClient $ \keyspace -> getUsersImpl keyspace uids + DoesUserExist uid -> runClientWithKeyspace casClient $ \keyspace -> doesUserExistImpl keyspace uid + GetIndexUser uid -> runClientWithKeyspace casClient $ \keyspace -> getIndexUserImpl keyspace uid + GetIndexUsersPaginated pageSize mPagingState -> runClientWithKeyspace casClient $ \keyspace -> getIndexUserPaginatedImpl keyspace pageSize (paginationStateCassandra =<< mPagingState) + UpdateUser uid update -> runClientWithKeyspace casClient $ \keyspace -> updateUserImpl keyspace uid update + UpdateEmail uid email -> runClientWithKeyspace casClient $ \keyspace -> updateEmailImpl keyspace uid email + UpdateEmailUnvalidated uid email -> runClientWithKeyspace casClient $ \keyspace -> updateEmailUnvalidatedImpl keyspace uid email + DeleteEmailUnvalidated uid -> runClientWithKeyspace casClient $ \keyspace -> deleteEmailUnvalidatedImpl keyspace uid + UpdateUserHandleEither uid update -> runClientWithKeyspace casClient $ \keyspace -> updateUserHandleEitherImpl keyspace uid update + UpdateSSOId uid ssoId -> runClientWithKeyspace casClient $ \keyspace -> updateSSOIdImpl keyspace uid ssoId + UpdateManagedBy uid managedBy -> runClientWithKeyspace casClient $ \keyspace -> updateManagedByImpl keyspace uid managedBy + UpdateAccountStatus uid accountStatus -> runClientWithKeyspace casClient $ \keyspace -> updateAccountStatusImpl keyspace uid accountStatus + ActivateUser uid identity -> runClientWithKeyspace casClient $ \keyspace -> activateUserImpl keyspace uid identity + DeactivateUser uid -> runClientWithKeyspace casClient $ \keyspace -> deactivateUserImpl keyspace uid + UpdateRichInfo uid richInfo -> runClientWithKeyspace casClient $ \keyspace -> updateRichInfoImpl keyspace uid richInfo + UpdateFeatureConferenceCalling uid feat -> runClientWithKeyspace casClient $ \keyspace -> updateFeatureConferenceCallingImpl keyspace uid feat + LookupFeatureConferenceCalling uid -> runClientWithKeyspace casClient $ \keyspace -> lookupFeatureConferenceCallingImpl keyspace uid + DeleteUser user -> runClientWithKeyspace casClient $ \keyspace -> deleteUserImpl keyspace user + LookupName uid -> runClientWithKeyspace casClient $ \keyspace -> lookupNameImpl keyspace uid + LookupHandle hdl -> runClientWithKeyspace casClient $ \keyspace -> lookupHandleImpl keyspace LocalQuorum hdl + GlimpseHandle hdl -> runClientWithKeyspace casClient $ \keyspace -> lookupHandleImpl keyspace One hdl + LookupStatus uid -> runClientWithKeyspace casClient $ \keyspace -> lookupStatusImpl keyspace uid + IsActivated uid -> runClientWithKeyspace casClient $ \keyspace -> isActivatedImpl keyspace uid + LookupLocale uid -> runClientWithKeyspace casClient $ \keyspace -> lookupLocaleImpl keyspace uid + GetUserTeam uid -> runClientWithKeyspace casClient $ \keyspace -> getUserTeamImpl keyspace uid + UpdateUserTeam uid tid -> runClientWithKeyspace casClient $ \keyspace -> updateUserTeamImpl keyspace uid tid + GetRichInfo uid -> runClientWithKeyspace casClient $ \keyspace -> getRichInfoImpl keyspace uid + LookupRichInfos uids -> runClientWithKeyspace casClient $ \keyspace -> lookupRichInfosImpl keyspace uids + GetUserAuthenticationInfo uid -> runClientWithKeyspace casClient $ \keyspace -> getUserAuthenticationInfoImpl keyspace uid + DeleteEmail uid -> runClientWithKeyspace casClient $ \keyspace -> deleteEmailImpl keyspace uid + SetUserSearchable uid searchable -> runClientWithKeyspace casClient $ \keyspace -> setUserSearchableImpl keyspace uid searchable + DeleteServiceUser pid sid bid -> runClientWithKeyspace casClient $ \keyspace -> deleteServiceUserImpl keyspace pid sid bid + LookupServiceUsers pid sid mPagingState -> runClientWithKeyspace casClient $ \keyspace -> lookupServiceUsersImpl keyspace pid sid (paginationStateCassandra =<< mPagingState) + LookupServiceUsersForTeam pid sid tid mPagingState -> runClientWithKeyspace casClient $ \keyspace -> lookupServiceUsersForTeamImpl keyspace pid sid tid (paginationStateCassandra =<< mPagingState) + +runClientWithKeyspace :: (Member (Embed IO) r) => ClientState -> (Keyspace -> Client a) -> Sem r a +runClientWithKeyspace casClient action = do + keyspace <- embed @IO $ requireClientKeyspace casClient + runEmbedded (runClient casClient) (embed (action keyspace)) + +createUserImpl :: Keyspace -> NewStoredUser -> Maybe (ConvId, Maybe TeamId) -> Client () +createUserImpl keyspace new mbConv = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery insertUser (asTuple new) + addPrepQuery (insertUser keyspace) (asTuple new) for_ ((,) <$> new.service <*> mbConv) $ \(sref, (cid, mbTid)) -> do let pid = sref ^. serviceRefProvider sid = sref ^. serviceRefId - addPrepQuery insertServiceUser (pid, sid, BotId new.id, cid, mbTid) + addPrepQuery (insertServiceUser keyspace) (pid, sid, BotId new.id, cid, mbTid) for_ mbTid $ \tid -> - addPrepQuery insertServiceTeam (pid, sid, BotId new.id, cid, tid) + addPrepQuery (insertServiceTeam keyspace) (pid, sid, BotId new.id, cid, tid) -getUserAuthenticationInfoImpl :: UserId -> Client (Maybe (Maybe Password, AccountStatus)) -getUserAuthenticationInfoImpl uid = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity uid))) +getUserAuthenticationInfoImpl :: Keyspace -> UserId -> Client (Maybe (Maybe Password, AccountStatus)) +getUserAuthenticationInfoImpl keyspace uid = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity uid))) where f (pw, st) = (pw, fromMaybe Active st) authSelect :: PrepQuery R (Identity UserId) (Maybe Password, Maybe AccountStatus) - authSelect = - [sql| - SELECT password, status FROM user WHERE id = ? - |] + authSelect = fromString $ "SELECT password, status FROM " <> tbl keyspace "user" <> " WHERE id = ?" -getUsersImpl :: [UserId] -> Client [StoredUser] -getUsersImpl usrs = +getUsersImpl :: Keyspace -> [UserId] -> Client [StoredUser] +getUsersImpl keyspace usrs = map asRecord - <$> retry x1 (query selectUsers (params LocalQuorum (Identity usrs))) + <$> retry x1 (query (selectUsers keyspace) (params LocalQuorum (Identity usrs))) -doesUserExistImpl :: UserId -> Client Bool -doesUserExistImpl uid = +doesUserExistImpl :: Keyspace -> UserId -> Client Bool +doesUserExistImpl keyspace uid = isJust <$> retry x1 (query1 idSelect (params LocalQuorum (Identity uid))) where idSelect :: PrepQuery R (Identity UserId) (Identity UserId) - idSelect = "SELECT id FROM user WHERE id = ?" + idSelect = fromString $ "SELECT id FROM " <> tbl keyspace "user" <> " WHERE id = ?" -getIndexUserImpl :: UserId -> Client (Maybe IndexUser) -getIndexUserImpl u = do +getIndexUserImpl :: Keyspace -> UserId -> Client (Maybe IndexUser) +getIndexUserImpl keyspace u = do mIndexUserTuple <- retry x1 $ query1 cql (params LocalQuorum (Identity u)) pure $ indexUserFromTuple <$> mIndexUserTuple where cql :: PrepQuery R (Identity UserId) (TupleType IndexUser) - cql = prepared . QueryString $ getIndexUserBaseQuery <> " WHERE id = ?" + cql = prepared . QueryString $ getIndexUserBaseQuery keyspace <> " WHERE id = ?" -getIndexUserPaginatedImpl :: Int32 -> Maybe PagingState -> Client (PageWithState x IndexUser) -getIndexUserPaginatedImpl pageSize mPagingState = +getIndexUserPaginatedImpl :: Keyspace -> Int32 -> Maybe PagingState -> Client (PageWithState x IndexUser) +getIndexUserPaginatedImpl keyspace pageSize mPagingState = indexUserFromTuple <$$> paginateWithState cql (paramsPagingState LocalQuorum () pageSize mPagingState) x1 where cql :: PrepQuery R () (TupleType IndexUser) - cql = prepared $ QueryString getIndexUserBaseQuery + cql = prepared $ QueryString (getIndexUserBaseQuery keyspace) -getIndexUserBaseQuery :: LText -getIndexUserBaseQuery = +getIndexUserBaseQuery :: Keyspace -> LText +getIndexUserBaseQuery keyspace = [sql| SELECT id, @@ -145,11 +149,13 @@ getIndexUserBaseQuery = email_unvalidated, writetime(email_unvalidated), searchable, writetime(searchable), writetime(write_time_bumper) - FROM user + FROM |] + <> fromString (tbl keyspace "user") + <> [sql| |] -updateUserImpl :: UserId -> StoredUserUpdate -> Client () -updateUserImpl uid update = +updateUserImpl :: Keyspace -> UserId -> StoredUserUpdate -> Client () +updateUserImpl keyspace uid update = retry x5 $ batch do -- PERFORMANCE(fisx): if a user changes 4 attributes with one request, the database will -- be hit with one request for each attribute. this is probably fine, since this @@ -157,42 +163,42 @@ updateUserImpl uid update = -- may not help.) setType BatchLogged setConsistency LocalQuorum - for_ update.name \n -> addPrepQuery userDisplayNameUpdate (n, uid) - for_ update.textStatus \s -> addPrepQuery userTextStatusUpdate (s, uid) - for_ update.pict \p -> addPrepQuery userPictUpdate (p, uid) - for_ update.assets \a -> addPrepQuery userAssetsUpdate (a, uid) - for_ update.locale \a -> addPrepQuery userLocaleUpdate (a.lLanguage, a.lCountry, uid) - for_ update.accentId \c -> addPrepQuery userAccentIdUpdate (c, uid) - for_ update.supportedProtocols \a -> addPrepQuery userSupportedProtocolsUpdate (a, uid) - -updateEmailImpl :: UserId -> EmailAddress -> Client () -updateEmailImpl u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) + for_ update.name \n -> addPrepQuery (userDisplayNameUpdate keyspace) (n, uid) + for_ update.textStatus \s -> addPrepQuery (userTextStatusUpdate keyspace) (s, uid) + for_ update.pict \p -> addPrepQuery (userPictUpdate keyspace) (p, uid) + for_ update.assets \a -> addPrepQuery (userAssetsUpdate keyspace) (a, uid) + for_ update.locale \a -> addPrepQuery (userLocaleUpdate keyspace) (a.lLanguage, a.lCountry, uid) + for_ update.accentId \c -> addPrepQuery (userAccentIdUpdate keyspace) (c, uid) + for_ update.supportedProtocols \a -> addPrepQuery (userSupportedProtocolsUpdate keyspace) (a, uid) + +updateEmailImpl :: Keyspace -> UserId -> EmailAddress -> Client () +updateEmailImpl keyspace u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) where userEmailUpdate :: PrepQuery W (EmailAddress, UserId) () - userEmailUpdate = "UPDATE user SET email = ? WHERE id = ?" + userEmailUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET email = ? WHERE id = ?" -updateEmailUnvalidatedImpl :: UserId -> EmailAddress -> Client () -updateEmailUnvalidatedImpl u e = +updateEmailUnvalidatedImpl :: Keyspace -> UserId -> EmailAddress -> Client () +updateEmailUnvalidatedImpl keyspace u e = retry x5 $ write userEmailUnvalidatedUpdate (params LocalQuorum (e, u)) where userEmailUnvalidatedUpdate :: PrepQuery W (EmailAddress, UserId) () - userEmailUnvalidatedUpdate = "UPDATE user SET email_unvalidated = ? WHERE id = ?" + userEmailUnvalidatedUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET email_unvalidated = ? WHERE id = ?" -deleteEmailUnvalidatedImpl :: UserId -> Client () -deleteEmailUnvalidatedImpl u = retry x5 $ write userEmailUnvalidatedDelete (params LocalQuorum (Identity u)) +deleteEmailUnvalidatedImpl :: Keyspace -> UserId -> Client () +deleteEmailUnvalidatedImpl keyspace u = retry x5 $ write userEmailUnvalidatedDelete (params LocalQuorum (Identity u)) where userEmailUnvalidatedDelete :: PrepQuery W (Identity UserId) () - userEmailUnvalidatedDelete = "UPDATE user SET email_unvalidated = null WHERE id = ?" + userEmailUnvalidatedDelete = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET email_unvalidated = null WHERE id = ?" -updateUserHandleEitherImpl :: UserId -> StoredUserHandleUpdate -> Client (Either StoredUserUpdateError ()) -updateUserHandleEitherImpl uid update = +updateUserHandleEitherImpl :: Keyspace -> UserId -> StoredUserHandleUpdate -> Client (Either StoredUserUpdateError ()) +updateUserHandleEitherImpl keyspace uid update = runM $ runError do - claimed <- embed $ claimHandleImpl uid update.old update.new + claimed <- embed $ claimHandleImpl keyspace uid update.old update.new unless claimed $ throw StoredUserUpdateHandleExists -updateSSOIdImpl :: UserId -> Maybe UserSSOId -> Client Bool -updateSSOIdImpl u ssoid = do - mteamid <- getUserTeamImpl u +updateSSOIdImpl :: Keyspace -> UserId -> Maybe UserSSOId -> Client Bool +updateSSOIdImpl keyspace u ssoid = do + mteamid <- getUserTeamImpl keyspace u case mteamid of Just _ -> do retry x5 $ write userSSOIdUpdate (params LocalQuorum (ssoid, u)) @@ -200,83 +206,83 @@ updateSSOIdImpl u ssoid = do Nothing -> pure False where userSSOIdUpdate :: PrepQuery W (Maybe UserSSOId, UserId) () - userSSOIdUpdate = "UPDATE user SET sso_id = ? WHERE id = ?" + userSSOIdUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET sso_id = ? WHERE id = ?" -updateManagedByImpl :: UserId -> ManagedBy -> Client () -updateManagedByImpl u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) +updateManagedByImpl :: Keyspace -> UserId -> ManagedBy -> Client () +updateManagedByImpl keyspace u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) where userManagedByUpdate :: PrepQuery W (ManagedBy, UserId) () - userManagedByUpdate = "UPDATE user SET managed_by = ? WHERE id = ?" + userManagedByUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET managed_by = ? WHERE id = ?" -updateAccountStatusImpl :: UserId -> AccountStatus -> Client () -updateAccountStatusImpl u s = +updateAccountStatusImpl :: Keyspace -> UserId -> AccountStatus -> Client () +updateAccountStatusImpl keyspace u s = retry x5 $ write userStatusUpdate (params LocalQuorum (s, u)) where userStatusUpdate :: PrepQuery W (AccountStatus, UserId) () - userStatusUpdate = "UPDATE user SET status = ? WHERE id = ?" + userStatusUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET status = ? WHERE id = ?" -activateUserImpl :: (MonadClient m) => UserId -> UserIdentity -> m () -activateUserImpl u ident = do +activateUserImpl :: (MonadClient m) => Keyspace -> UserId -> UserIdentity -> m () +activateUserImpl keyspace u ident = do let email = emailIdentity ident retry x5 $ write userActivatedUpdate (params LocalQuorum (email, u)) where userActivatedUpdate :: PrepQuery W (Maybe EmailAddress, UserId) () - userActivatedUpdate = "UPDATE user SET activated = true, email = ? WHERE id = ?" + userActivatedUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET activated = true, email = ? WHERE id = ?" -deactivateUserImpl :: (MonadClient m) => UserId -> m () -deactivateUserImpl u = +deactivateUserImpl :: (MonadClient m) => Keyspace -> UserId -> m () +deactivateUserImpl keyspace u = retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) where userDeactivatedUpdate :: PrepQuery W (Identity UserId) () - userDeactivatedUpdate = "UPDATE user SET activated = false WHERE id = ?" + userDeactivatedUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET activated = false WHERE id = ?" -lookupNameImpl :: (MonadClient m) => UserId -> m (Maybe Name) -lookupNameImpl u = +lookupNameImpl :: (MonadClient m) => Keyspace -> UserId -> m (Maybe Name) +lookupNameImpl keyspace u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) where nameSelect :: PrepQuery R (Identity UserId) (Identity Name) - nameSelect = "SELECT name FROM user WHERE id = ?" + nameSelect = fromString $ "SELECT name FROM " <> tbl keyspace "user" <> " WHERE id = ?" -- | Returned rich infos are in the same order as users -lookupRichInfosImpl :: (MonadClient m) => [UserId] -> m [(UserId, RichInfo)] -lookupRichInfosImpl users = do +lookupRichInfosImpl :: (MonadClient m) => Keyspace -> [UserId] -> m [(UserId, RichInfo)] +lookupRichInfosImpl keyspace users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) where richInfoSelectMulti :: PrepQuery R (Identity [UserId]) (UserId, Maybe RichInfoAssocList) - richInfoSelectMulti = "SELECT user, json FROM rich_info WHERE user in ?" + richInfoSelectMulti = fromString $ "SELECT user, json FROM " <> tbl keyspace "rich_info" <> " WHERE user in ?" -lookupFeatureConferenceCallingImpl :: (MonadClient m) => UserId -> m (Maybe FeatureStatus) -lookupFeatureConferenceCallingImpl uid = do +lookupFeatureConferenceCallingImpl :: (MonadClient m) => Keyspace -> UserId -> m (Maybe FeatureStatus) +lookupFeatureConferenceCallingImpl keyspace uid = do let q = query1 select (params LocalQuorum (Identity uid)) (>>= runIdentity) <$> retry x1 q where select :: PrepQuery R (Identity UserId) (Identity (Maybe FeatureStatus)) - select = fromString "select feature_conference_calling from user where id = ?" + select = fromString $ "select feature_conference_calling from " <> tbl keyspace "user" <> " where id = ?" ------------------------------------------------------------------------------- -- Queries -updateRichInfoImpl :: (MonadClient m) => UserId -> RichInfoAssocList -> m () -updateRichInfoImpl u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) +updateRichInfoImpl :: (MonadClient m) => Keyspace -> UserId -> RichInfoAssocList -> m () +updateRichInfoImpl keyspace u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) where userRichInfoUpdate :: PrepQuery W (RichInfoAssocList, UserId) () - userRichInfoUpdate = "UPDATE rich_info SET json = ? WHERE user = ?" + userRichInfoUpdate = fromString $ "UPDATE " <> tbl keyspace "rich_info" <> " SET json = ? WHERE user = ?" -updateFeatureConferenceCallingImpl :: (MonadClient m) => UserId -> Maybe FeatureStatus -> m () -updateFeatureConferenceCallingImpl uid mStatus = +updateFeatureConferenceCallingImpl :: (MonadClient m) => Keyspace -> UserId -> Maybe FeatureStatus -> m () +updateFeatureConferenceCallingImpl keyspace uid mStatus = retry x5 $ write update (params LocalQuorum (mStatus, uid)) where update :: PrepQuery W (Maybe FeatureStatus, UserId) () - update = fromString "update user set feature_conference_calling = ? where id = ?" + update = fromString $ "update " <> tbl keyspace "user" <> " set feature_conference_calling = ? where id = ?" -- | Claim a new handle for an existing 'User': validate it, and in case of success, assign it -- to user and mark it as taken. -claimHandleImpl :: UserId -> Maybe Handle -> Handle -> Client Bool -claimHandleImpl uid oldHandle newHandle = +claimHandleImpl :: Keyspace -> UserId -> Maybe Handle -> Handle -> Client Bool +claimHandleImpl keyspace uid oldHandle newHandle = isJust <$> do - owner <- lookupHandleImpl LocalQuorum newHandle + owner <- lookupHandleImpl keyspace LocalQuorum newHandle case owner of Just uid' | uid /= uid' -> pure Nothing _ -> do @@ -284,93 +290,93 @@ claimHandleImpl uid oldHandle newHandle = withClaim uid key (30 # Minute) $ do -- Record ownership - retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid)) + retry x5 $ write (handleInsert keyspace) (params LocalQuorum (newHandle, uid)) -- Update profile result <- updateHandle uid newHandle -- Free old handle (if it changed) for_ (mfilter (/= newHandle) oldHandle) $ - freeHandleImpl uid + freeHandleImpl keyspace uid pure result where updateHandle :: UserId -> Handle -> Client () - updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) + updateHandle u h = retry x5 $ write (userHandleUpdate keyspace) (params LocalQuorum (h, u)) -- | Free a 'Handle', making it available to be claimed again. -freeHandleImpl :: UserId -> Handle -> Client () -freeHandleImpl uid h = do - mbHandleUid <- lookupHandleImpl LocalQuorum h +freeHandleImpl :: Keyspace -> UserId -> Handle -> Client () +freeHandleImpl keyspace uid h = do + mbHandleUid <- lookupHandleImpl keyspace LocalQuorum h case mbHandleUid of Just handleUid | handleUid == uid -> do - retry x5 $ write handleDelete (params LocalQuorum (Identity h)) + retry x5 $ write (handleDelete keyspace) (params LocalQuorum (Identity h)) let key = "@" <> fromHandle h deleteClaim uid key (30 # Minute) _ -> pure () -- this shouldn't happen, the call side should always check that `h` and `uid` belong to the same account. -- | Sending an empty 'Handle' here causes C* to throw "Key may not be empty" -- error. -lookupHandleImpl :: Consistency -> Handle -> Client (Maybe UserId) -lookupHandleImpl consistencyLevel h = do +lookupHandleImpl :: Keyspace -> Consistency -> Handle -> Client (Maybe UserId) +lookupHandleImpl keyspace consistencyLevel h = do (runIdentity =<<) - <$> retry x1 (query1 handleSelect (params consistencyLevel (Identity h))) + <$> retry x1 (query1 (handleSelect keyspace) (params consistencyLevel (Identity h))) -deleteUserImpl :: User -> Client () -deleteUserImpl user = do +deleteUserImpl :: Keyspace -> User -> Client () +deleteUserImpl keyspace user = do for_ (userHandle user) \h -> - freeHandleImpl (userId user) h + freeHandleImpl keyspace (userId user) h retry x5 $ write - updateUserToTombstone + (updateUserToTombstone keyspace) ( params LocalQuorum (Deleted, Name "default", defaultAccentId, noPict, [], userId user) ) -lookupStatusImpl :: UserId -> Client (Maybe AccountStatus) -lookupStatusImpl u = +lookupStatusImpl :: Keyspace -> UserId -> Client (Maybe AccountStatus) +lookupStatusImpl keyspace u = (runIdentity =<<) - <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) + <$> retry x1 (query1 (statusSelect keyspace) (params LocalQuorum (Identity u))) -isActivatedImpl :: UserId -> Client Bool -isActivatedImpl uid = +isActivatedImpl :: Keyspace -> UserId -> Client Bool +isActivatedImpl keyspace uid = (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity uid))) + <$> retry x1 (query1 (activatedSelect keyspace) (params LocalQuorum (Identity uid))) -lookupLocaleImpl :: UserId -> Client (Maybe (Maybe Language, Maybe Country)) -lookupLocaleImpl u = do - retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) +lookupLocaleImpl :: Keyspace -> UserId -> Client (Maybe (Maybe Language, Maybe Country)) +lookupLocaleImpl keyspace u = do + retry x1 (query1 (localeSelect keyspace) (params LocalQuorum (Identity u))) -getUserTeamImpl :: UserId -> Client (Maybe TeamId) -getUserTeamImpl u = (runIdentity =<<) <$> retry x1 (query1 q (params LocalQuorum (Identity u))) +getUserTeamImpl :: Keyspace -> UserId -> Client (Maybe TeamId) +getUserTeamImpl keyspace u = (runIdentity =<<) <$> retry x1 (query1 q (params LocalQuorum (Identity u))) where q :: PrepQuery R (Identity UserId) (Identity (Maybe TeamId)) - q = "SELECT team FROM user WHERE id = ?" + q = fromString $ "SELECT team FROM " <> tbl keyspace "user" <> " WHERE id = ?" -updateUserTeamImpl :: UserId -> TeamId -> Client () -updateUserTeamImpl u t = retry x5 $ write userTeamUpdate (params LocalQuorum (t, u)) +updateUserTeamImpl :: Keyspace -> UserId -> TeamId -> Client () +updateUserTeamImpl keyspace u t = retry x5 $ write userTeamUpdate (params LocalQuorum (t, u)) where userTeamUpdate :: PrepQuery W (TeamId, UserId) () - userTeamUpdate = "UPDATE user SET team = ? WHERE id = ?" + userTeamUpdate = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET team = ? WHERE id = ?" -getRichInfoImpl :: UserId -> Client (Maybe RichInfoAssocList) -getRichInfoImpl uid = +getRichInfoImpl :: Keyspace -> UserId -> Client (Maybe RichInfoAssocList) +getRichInfoImpl keyspace uid = fmap runIdentity <$> retry x1 (query1 q (params LocalQuorum (Identity uid))) where q :: PrepQuery R (Identity UserId) (Identity RichInfoAssocList) - q = "SELECT json FROM rich_info WHERE user = ?" + q = fromString $ "SELECT json FROM " <> tbl keyspace "rich_info" <> " WHERE user = ?" -deleteEmailImpl :: UserId -> Client () -deleteEmailImpl u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) +deleteEmailImpl :: Keyspace -> UserId -> Client () +deleteEmailImpl keyspace u = retry x5 $ write (userEmailDelete keyspace) (params LocalQuorum (Identity u)) -setUserSearchableImpl :: UserId -> SetSearchable -> Client () -setUserSearchableImpl uid (SetSearchable searchable) = retry x5 $ write q (params LocalQuorum (searchable, uid)) +setUserSearchableImpl :: Keyspace -> UserId -> SetSearchable -> Client () +setUserSearchableImpl keyspace uid (SetSearchable searchable) = retry x5 $ write q (params LocalQuorum (searchable, uid)) where q :: PrepQuery W (Bool, UserId) () - q = "UPDATE user SET searchable = ? WHERE id = ?" + q = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET searchable = ? WHERE id = ?" -deleteServiceUserImpl :: ProviderId -> ServiceId -> BotId -> Client () -deleteServiceUserImpl pid sid bid = do - lookupServiceUser pid sid bid >>= \case +deleteServiceUserImpl :: Keyspace -> ProviderId -> ServiceId -> BotId -> Client () +deleteServiceUserImpl keyspace pid sid bid = do + lookupServiceUser keyspace pid sid bid >>= \case Nothing -> pure () Just (_, mbTid) -> retry x5 . batch $ do setType BatchLogged @@ -380,130 +386,136 @@ deleteServiceUserImpl pid sid bid = do addPrepQuery cqlTeam (pid, sid, tid, bid) where cql :: PrepQuery W (ProviderId, ServiceId, BotId) () - cql = - "DELETE FROM service_user \ - \WHERE provider = ? AND service = ? AND user = ?" + cql = fromString $ "DELETE FROM " <> tbl keyspace "service_user" <> " WHERE provider = ? AND service = ? AND user = ?" cqlTeam :: PrepQuery W (ProviderId, ServiceId, TeamId, BotId) () - cqlTeam = - "DELETE FROM service_team \ - \WHERE provider = ? AND service = ? AND team = ? AND user = ?" + cqlTeam = fromString $ "DELETE FROM " <> tbl keyspace "service_team" <> " WHERE provider = ? AND service = ? AND team = ? AND user = ?" lookupServiceUser :: + Keyspace -> ProviderId -> ServiceId -> BotId -> Client (Maybe (ConvId, Maybe TeamId)) -lookupServiceUser pid sid bid = +lookupServiceUser keyspace pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) - cql = - "SELECT conv, team FROM service_user \ - \WHERE provider = ? AND service = ? AND user = ?" + cql = fromString $ "SELECT conv, team FROM " <> tbl keyspace "service_user" <> " WHERE provider = ? AND service = ? AND user = ?" lookupServiceUsersImpl :: + Keyspace -> ProviderId -> ServiceId -> Maybe PagingState -> Client (PageWithState Void (BotId, ConvId, Maybe TeamId)) -lookupServiceUsersImpl pid sid mPagingState = +lookupServiceUsersImpl keyspace pid sid mPagingState = paginateWithState cql (paramsPagingState LocalQuorum (pid, sid) 100 mPagingState) x1 where cql :: PrepQuery R (ProviderId, ServiceId) (BotId, ConvId, Maybe TeamId) - cql = - "SELECT user, conv, team FROM service_user \ - \WHERE provider = ? AND service = ?" + cql = fromString $ "SELECT user, conv, team FROM " <> tbl keyspace "service_user" <> " WHERE provider = ? AND service = ?" lookupServiceUsersForTeamImpl :: + Keyspace -> ProviderId -> ServiceId -> TeamId -> Maybe PagingState -> Client (PageWithState Void (BotId, ConvId)) -lookupServiceUsersForTeamImpl pid sid tid mPagingState = +lookupServiceUsersForTeamImpl keyspace pid sid tid mPagingState = paginateWithState cql (paramsPagingState LocalQuorum (pid, sid, tid) 100 mPagingState) x1 where cql :: PrepQuery R (ProviderId, ServiceId, TeamId) (BotId, ConvId) - cql = - "SELECT user, conv FROM service_team \ - \WHERE provider = ? AND service = ? AND team = ?" + cql = fromString $ "SELECT user, conv FROM " <> tbl keyspace "service_team" <> " WHERE provider = ? AND service = ? AND team = ?" -------------------------------------------------------------------------------- -- Queries -insertUser :: PrepQuery W (TupleType NewStoredUser) () -insertUser = - "INSERT INTO user (id, user_type, name, text_status, picture, assets, email, sso_id, \ - \accent_id, password, activated, status, expires, language, \ - \country, provider, service, handle, team, managed_by, supported_protocols, searchable) \ - \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" - -insertServiceUser :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId) () -insertServiceUser = - "INSERT INTO service_user (provider, service, user, conv, team) \ - \VALUES (?, ?, ?, ?, ?)" - -insertServiceTeam :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, TeamId) () -insertServiceTeam = - "INSERT INTO service_team (provider, service, user, conv, team) \ - \VALUES (?, ?, ?, ?, ?)" - -selectUsers :: PrepQuery R (Identity [UserId]) (TupleType StoredUser) -selectUsers = - [sql| - SELECT id, user_type, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, - activated, status, expires, language, country, provider, - service, handle, team, managed_by, supported_protocols, searchable - FROM user WHERE id IN ? - |] - -userDisplayNameUpdate :: PrepQuery W (Name, UserId) () -userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?" - -userTextStatusUpdate :: PrepQuery W (TextStatus, UserId) () -userTextStatusUpdate = "UPDATE user SET text_status = ? WHERE id = ?" - -userPictUpdate :: PrepQuery W (Pict, UserId) () -userPictUpdate = "UPDATE user SET picture = ? WHERE id = ?" - -userAssetsUpdate :: PrepQuery W ([Asset], UserId) () -userAssetsUpdate = "UPDATE user SET assets = ? WHERE id = ?" - -userAccentIdUpdate :: PrepQuery W (ColourId, UserId) () -userAccentIdUpdate = "UPDATE user SET accent_id = ? WHERE id = ?" - -userLocaleUpdate :: PrepQuery W (Language, Maybe Country, UserId) () -userLocaleUpdate = "UPDATE user SET language = ?, country = ? WHERE id = ?" - -userSupportedProtocolsUpdate :: PrepQuery W (Imports.Set BaseProtocolTag, UserId) () -userSupportedProtocolsUpdate = "UPDATE user SET supported_protocols = ? WHERE id = ?" - -handleInsert :: PrepQuery W (Handle, UserId) () -handleInsert = "INSERT INTO user_handle (handle, user) VALUES (?, ?)" - -handleSelect :: PrepQuery R (Identity Handle) (Identity (Maybe UserId)) -handleSelect = "SELECT user FROM user_handle WHERE handle = ?" - -handleDelete :: PrepQuery W (Identity Handle) () -handleDelete = "DELETE FROM user_handle WHERE handle = ?" - -userHandleUpdate :: PrepQuery W (Handle, UserId) () -userHandleUpdate = "UPDATE user SET handle = ? WHERE id = ?" - -updateUserToTombstone :: PrepQuery W (AccountStatus, Name, ColourId, Pict, [Asset], UserId) () -updateUserToTombstone = - "UPDATE user SET status = ?, name = ?,\ - \ accent_id = ?, picture = ?, assets = ?, handle = null, country = null,\ - \ language = null, email = null, sso_id = null WHERE id = ?" - -statusSelect :: PrepQuery R (Identity UserId) (Identity (Maybe AccountStatus)) -statusSelect = "SELECT status FROM user WHERE id = ?" - -activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) -activatedSelect = "SELECT activated FROM user WHERE id = ?" - -localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) -localeSelect = "SELECT language, country FROM user WHERE id = ?" - -userEmailDelete :: PrepQuery W (Identity UserId) () -userEmailDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email = null, write_time_bumper = 0 WHERE id = ?" +insertUser :: Keyspace -> PrepQuery W (TupleType NewStoredUser) () +insertUser keyspace = + fromString $ + "INSERT INTO " + <> tbl keyspace "user" + <> " (id, user_type, name, text_status, picture, assets, email, sso_id, \ + \accent_id, password, activated, status, expires, language, \ + \country, provider, service, handle, team, managed_by, supported_protocols, searchable) \ + \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" + +insertServiceUser :: Keyspace -> PrepQuery W (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId) () +insertServiceUser keyspace = + fromString $ + "INSERT INTO " + <> tbl keyspace "service_user" + <> " (provider, service, user, conv, team) VALUES (?, ?, ?, ?, ?)" + +insertServiceTeam :: Keyspace -> PrepQuery W (ProviderId, ServiceId, BotId, ConvId, TeamId) () +insertServiceTeam keyspace = + fromString $ + "INSERT INTO " + <> tbl keyspace "service_team" + <> " (provider, service, user, conv, team) VALUES (?, ?, ?, ?, ?)" + +selectUsers :: Keyspace -> PrepQuery R (Identity [UserId]) (TupleType StoredUser) +selectUsers keyspace = + fromString $ + "SELECT id, user_type, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, \ + \activated, status, expires, language, country, provider, \ + \service, handle, team, managed_by, supported_protocols, searchable \ + \FROM " + <> tbl keyspace "user" + <> " WHERE id IN ?" + +userDisplayNameUpdate :: Keyspace -> PrepQuery W (Name, UserId) () +userDisplayNameUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET name = ? WHERE id = ?" + +userTextStatusUpdate :: Keyspace -> PrepQuery W (TextStatus, UserId) () +userTextStatusUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET text_status = ? WHERE id = ?" + +userPictUpdate :: Keyspace -> PrepQuery W (Pict, UserId) () +userPictUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET picture = ? WHERE id = ?" + +userAssetsUpdate :: Keyspace -> PrepQuery W ([Asset], UserId) () +userAssetsUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET assets = ? WHERE id = ?" + +userAccentIdUpdate :: Keyspace -> PrepQuery W (ColourId, UserId) () +userAccentIdUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET accent_id = ? WHERE id = ?" + +userLocaleUpdate :: Keyspace -> PrepQuery W (Language, Maybe Country, UserId) () +userLocaleUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET language = ?, country = ? WHERE id = ?" + +userSupportedProtocolsUpdate :: Keyspace -> PrepQuery W (Imports.Set BaseProtocolTag, UserId) () +userSupportedProtocolsUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET supported_protocols = ? WHERE id = ?" + +handleInsert :: Keyspace -> PrepQuery W (Handle, UserId) () +handleInsert keyspace = fromString $ "INSERT INTO " <> tbl keyspace "user_handle" <> " (handle, user) VALUES (?, ?)" + +handleSelect :: Keyspace -> PrepQuery R (Identity Handle) (Identity (Maybe UserId)) +handleSelect keyspace = fromString $ "SELECT user FROM " <> tbl keyspace "user_handle" <> " WHERE handle = ?" + +handleDelete :: Keyspace -> PrepQuery W (Identity Handle) () +handleDelete keyspace = fromString $ "DELETE FROM " <> tbl keyspace "user_handle" <> " WHERE handle = ?" + +userHandleUpdate :: Keyspace -> PrepQuery W (Handle, UserId) () +userHandleUpdate keyspace = fromString $ "UPDATE " <> tbl keyspace "user" <> " SET handle = ? WHERE id = ?" + +updateUserToTombstone :: Keyspace -> PrepQuery W (AccountStatus, Name, ColourId, Pict, [Asset], UserId) () +updateUserToTombstone keyspace = + fromString $ + "UPDATE " + <> tbl keyspace "user" + <> " SET status = ?, name = ?, accent_id = ?, picture = ?, assets = ?, \ + \handle = null, country = null, language = null, email = null, sso_id = null WHERE id = ?" + +statusSelect :: Keyspace -> PrepQuery R (Identity UserId) (Identity (Maybe AccountStatus)) +statusSelect keyspace = fromString $ "SELECT status FROM " <> tbl keyspace "user" <> " WHERE id = ?" + +activatedSelect :: Keyspace -> PrepQuery R (Identity UserId) (Identity Bool) +activatedSelect keyspace = fromString $ "SELECT activated FROM " <> tbl keyspace "user" <> " WHERE id = ?" + +localeSelect :: Keyspace -> PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) +localeSelect keyspace = fromString $ "SELECT language, country FROM " <> tbl keyspace "user" <> " WHERE id = ?" + +userEmailDelete :: Keyspace -> PrepQuery W (Identity UserId) () +userEmailDelete keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "UPDATE " <> tbl keyspace "user" <> " SET email = null, write_time_bumper = 0 WHERE id = ?" + +tbl :: Keyspace -> String -> String +tbl = qualifiedTableName diff --git a/libs/wire-subsystems/src/Wire/Util.hs b/libs/wire-subsystems/src/Wire/Util.hs index 6d660be24a8..528987eea87 100644 --- a/libs/wire-subsystems/src/Wire/Util.hs +++ b/libs/wire-subsystems/src/Wire/Util.hs @@ -18,6 +18,8 @@ module Wire.Util where import Cassandra hiding (Set) +import Cassandra.Util (requireClientKeyspace) +import Data.Text qualified as Text import Imports import Polysemy import Polysemy.Embed @@ -28,6 +30,11 @@ import System.Logger.Message embedClient :: (Member (Embed IO) r) => ClientState -> Client x -> Sem r x embedClient client = runEmbedded (runClient client) . embed +embedClientWithKeyspace :: (Member (Embed IO) r) => ClientState -> (Keyspace -> Client x) -> Sem r x +embedClientWithKeyspace client f = do + keyspace <- embed (requireClientKeyspace client) + embedClient client (f keyspace) + logEffect :: (Member TinyLog r) => ByteString -> Sem r () logEffect = debug . msg . val @@ -35,3 +42,11 @@ embedClientInput :: (Member (Embed IO) r, Member (Input ClientState) r) => Clien embedClientInput a = do client <- input embedClient client a + +embedClientInputWithKeyspace :: (Member (Embed IO) r, Member (Input ClientState) r) => (Keyspace -> Client x) -> Sem r x +embedClientInputWithKeyspace f = do + client <- input + embedClientWithKeyspace client f + +qualifiedTableName :: Keyspace -> String -> String +qualifiedTableName keyspace tableName = Text.unpack (unKeyspace keyspace) <> "." <> tableName diff --git a/services/brig/src/Brig/Budget.hs b/services/brig/src/Brig/Budget.hs index 2cd24cdee95..762d7574c8e 100644 --- a/services/brig/src/Brig/Budget.hs +++ b/services/brig/src/Brig/Budget.hs @@ -29,6 +29,8 @@ module Brig.Budget where import Cassandra +import Cassandra.Util (requireClientKeyspace) +import Data.Text qualified as Text import Data.Time.Clock import Imports @@ -80,19 +82,25 @@ checkBudget k b = do else BudgetedValue () remaining lookupBudget :: (MonadClient m) => BudgetKey -> m (Maybe Budget) -lookupBudget k = fmap mk <$> query1 budgetSelect (params One (Identity k)) +lookupBudget k = do + keyspace <- liftClient $ ask >>= liftIO . requireClientKeyspace + fmap mk <$> query1 (budgetSelect keyspace) (params One (Identity k)) where mk (val, ttl) = Budget (fromIntegral ttl) val insertBudget :: (MonadClient m) => BudgetKey -> Budget -> m () -insertBudget k (Budget ttl val) = - retry x5 $ write budgetInsert (params One (k, val, round ttl)) +insertBudget k (Budget ttl val) = do + keyspace <- liftClient $ ask >>= liftIO . requireClientKeyspace + retry x5 $ write (budgetInsert keyspace) (params One (k, val, round ttl)) ------------------------------------------------------------------------------- -- Queries -budgetInsert :: PrepQuery W (BudgetKey, Int32, Int32) () -budgetInsert = "INSERT INTO budget (key, budget) VALUES (?, ?) USING TTL ?" +budgetInsert :: Keyspace -> PrepQuery W (BudgetKey, Int32, Int32) () +budgetInsert keyspace = fromString $ "INSERT INTO " <> table keyspace "budget" <> " (key, budget) VALUES (?, ?) USING TTL ?" -budgetSelect :: PrepQuery R (Identity BudgetKey) (Int32, Int32) -budgetSelect = "SELECT budget, ttl(budget) FROM budget where key = ?" +budgetSelect :: Keyspace -> PrepQuery R (Identity BudgetKey) (Int32, Int32) +budgetSelect keyspace = fromString $ "SELECT budget, ttl(budget) FROM " <> table keyspace "budget" <> " where key = ?" + +table :: Keyspace -> String -> String +table keyspace tableName = Text.unpack (unKeyspace keyspace) <> "." <> tableName diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 5b8bcb912fe..f4817a401cb 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -33,6 +33,7 @@ import Brig.Options qualified as Opt import Brig.Template (InvitationUrlTemplates) import Brig.User.Search.Index (IndexEnv (..)) import Cassandra qualified as Cas +import Cassandra.Util (requireClientKeyspace) import Control.Exception (ErrorCall) import Control.Lens (to, (^.), _Just) import Control.Monad.Catch (throwM) @@ -252,6 +253,7 @@ type BrigLowerLevelEffects = runBrigToIO :: App.Env -> AppT BrigCanonicalEffects a -> IO a runBrigToIO e (AppT ma) = do + casKeyspace <- requireClientKeyspace e.casClient let blockedDomains = e ^. ( App.settingsLens @@ -358,7 +360,7 @@ runBrigToIO e (AppT ma) = do . emailSendingInterpreter e . interpretSparAPIAccessToRpc e.sparEndpoint . interpretGalleyAPIAccessToRpc e.disabledVersions e.galleyEndpoint - . passwordResetCodeStoreToCassandra @Cas.Client + . passwordResetCodeStoreToCassandra @Cas.Client casKeyspace . randomToIO . runDelay . nowToIOAction e.currentTime diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 3fcfc77d8d9..fb8e155bcae 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -29,8 +29,10 @@ where import Brig.App (AppT, adhocUserKeyStoreInterpreter, liftSem, qualifyLocal, wrapClientE) import Brig.Types.Intra import Cassandra +import Cassandra.Util (requireClientKeyspace) import Control.Error import Data.Id +import Data.Text qualified as Text import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as LT @@ -143,7 +145,14 @@ verifyCode :: ActivationCode -> ExceptT ActivationError m (EmailKey, Maybe UserId) verifyCode key code = do - s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) + keyspace <- lift $ liftClient $ ask >>= liftIO . requireClientKeyspace + let mkScope "email" k u = case emailAddressText k of + Just e -> pure (mkEmailKey e, u) + Nothing -> throwE invalidCode + mkScope _ _ _ = throwE invalidCode + countdown = lift . retry x5 . write (keyInsert keyspace) . params LocalQuorum + revoke = lift $ deleteActivationPair key + s <- lift . retry x1 . query1 (keySelect keyspace) $ params LocalQuorum (Identity key) case s of Just (ttl, Ascii t, k, c, u, r) -> if @@ -151,18 +160,6 @@ verifyCode key code = do | r >= 1 -> countdown (key, t, k, c, u, r - 1, ttl) >> throwE invalidCode | otherwise -> revoke >> throwE invalidCode Nothing -> throwE invalidCode - where - mkScope "email" k u = case emailAddressText k of - Just e -> pure (mkEmailKey e, u) - Nothing -> throwE invalidCode - mkScope _ _ _ = throwE invalidCode - countdown = lift . retry x5 . write keyInsert . params LocalQuorum - revoke = lift $ deleteActivationPair key - keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () - keyInsert = - "INSERT INTO activation_keys \ - \(key, key_type, key_text, code, user, retries) VALUES \ - \(? , ? , ? , ? , ? , ? ) USING TTL ?" mkActivationKey :: EmailKey -> IO ActivationKey mkActivationKey k = do @@ -172,7 +169,9 @@ mkActivationKey k = do pure . ActivationKey $ Ascii.encodeBase64Url bs deleteActivationPair :: (MonadClient m) => ActivationKey -> m () -deleteActivationPair = write keyDelete . params LocalQuorum . Identity +deleteActivationPair key = do + keyspace <- liftClient $ ask >>= liftIO . requireClientKeyspace + write (keyDelete keyspace) (params LocalQuorum (Identity key)) invalidUser :: ActivationError invalidUser = InvalidActivationCodeWrongUser -- "User does not exist." @@ -180,8 +179,19 @@ invalidUser = InvalidActivationCodeWrongUser -- "User does not exist." invalidCode :: ActivationError invalidCode = InvalidActivationCodeWrongCode -- "Invalid activation code" -keySelect :: PrepQuery R (Identity ActivationKey) (Int32, Ascii, Text, ActivationCode, Maybe UserId, Int32) -keySelect = "SELECT ttl(code) as ttl, key_type, key_text, code, user, retries FROM activation_keys WHERE key = ?" +keyInsert :: Keyspace -> PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () +keyInsert keyspace = + fromString $ + "INSERT INTO " + <> table keyspace "activation_keys" + <> " (key, key_type, key_text, code, user, retries) VALUES \ + \(? , ? , ? , ? , ? , ? ) USING TTL ?" + +keySelect :: Keyspace -> PrepQuery R (Identity ActivationKey) (Int32, Ascii, Text, ActivationCode, Maybe UserId, Int32) +keySelect keyspace = fromString $ "SELECT ttl(code) as ttl, key_type, key_text, code, user, retries FROM " <> table keyspace "activation_keys" <> " WHERE key = ?" + +keyDelete :: Keyspace -> PrepQuery W (Identity ActivationKey) () +keyDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "activation_keys" <> " WHERE key = ?" -keyDelete :: PrepQuery W (Identity ActivationKey) () -keyDelete = "DELETE FROM activation_keys WHERE key = ?" +table :: Keyspace -> String -> String +table keyspace tableName = Text.unpack (unKeyspace keyspace) <> "." <> tableName diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 41a6f9a8275..744a881fdaa 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -59,14 +59,22 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified import Data.Range +import Data.Text qualified as Text import Data.Time (getCurrentTime) import Imports hiding (local) +import Cassandra.Util (requireClientKeyspace) import UnliftIO.Async (pooledForConcurrentlyN_, pooledMapConcurrentlyN, pooledMapConcurrentlyN_) import Wire.API.Connection import Wire.API.Routes.Internal.Brig.Connection +withCasKeyspace :: (MonadReader Env m, MonadIO m) => (Keyspace -> m a) -> m a +withCasKeyspace action = do + cs <- asks (.casClient) + keyspace <- liftIO (requireClientKeyspace cs) + action keyspace + insertConnection :: - (MonadClient m) => + (MonadClient m, MonadReader Env m, MonadIO m) => Local UserId -> Qualified UserId -> RelationWithHistory -> @@ -74,13 +82,14 @@ insertConnection :: m UserConnection insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (tUnqualified -> ltarget) = - write connectionInsert $ - params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) - let remote (tUntagged -> Qualified rtarget domain) = - write remoteConnectionInsert $ - params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) - retry x5 $ foldQualified self local remote target + withCasKeyspace $ \keyspace -> do + let local (tUnqualified -> ltarget) = + write (connectionInsert keyspace) $ + params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) + let remote (tUntagged -> Qualified rtarget domain) = + write (remoteConnectionInsert keyspace) $ + params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + retry x5 $ foldQualified self local remote target pure $ UserConnection { ucFrom = tUnqualified self, @@ -100,32 +109,34 @@ updateConnection c status = do ucLastUpdate = now } -updateConnectionStatus :: (MonadClient m) => Local UserId -> Qualified UserId -> RelationWithHistory -> m UTCTimeMillis +updateConnectionStatus :: (MonadClient m, MonadReader Env m, MonadIO m) => Local UserId -> Qualified UserId -> RelationWithHistory -> m UTCTimeMillis updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (tUnqualified -> ltarget) = - write connectionUpdate $ - params LocalQuorum (status, now, tUnqualified self, ltarget) - let remote (tUntagged -> Qualified rtarget domain) = - write remoteConnectionUpdate $ - params LocalQuorum (status, now, tUnqualified self, domain, rtarget) - retry x5 $ foldQualified self local remote target + withCasKeyspace $ \keyspace -> do + let local (tUnqualified -> ltarget) = + write (connectionUpdate keyspace) $ + params LocalQuorum (status, now, tUnqualified self, ltarget) + let remote (tUntagged -> Qualified rtarget domain) = + write (remoteConnectionUpdate keyspace) $ + params LocalQuorum (status, now, tUnqualified self, domain, rtarget) + retry x5 $ foldQualified self local remote target pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupConnection :: (MonadClient m) => Local UserId -> Qualified UserId -> m (Maybe UserConnection) +lookupConnection :: (MonadClient m, MonadReader Env m, MonadIO m) => Local UserId -> Qualified UserId -> m (Maybe UserConnection) lookupConnection self target = runMaybeT $ do - let local (tUnqualified -> ltarget) = do - (_, _, rel, time, mcnv) <- - MaybeT . query1 connectionSelect $ - params LocalQuorum (tUnqualified self, ltarget) - pure (rel, time, fmap (tUntagged . qualifyAs self) mcnv) - let remote (tUntagged -> Qualified rtarget domain) = do - (rel, time, cdomain, cnv) <- - MaybeT . query1 remoteConnectionSelectFrom $ - params LocalQuorum (tUnqualified self, domain, rtarget) - pure (rel, time, Just (Qualified cnv cdomain)) - (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target + (rel, time, mqcnv) <- hoist (retry x1) . MaybeT $ withCasKeyspace $ \keyspace -> do + let local (tUnqualified -> ltarget) = do + (_, _, rel', time', mcnv) <- + MaybeT . query1 (connectionSelect keyspace) $ + params LocalQuorum (tUnqualified self, ltarget) + pure (rel', time', fmap (tUntagged . qualifyAs self) mcnv) + let remote (tUntagged -> Qualified rtarget domain) = do + (rel', time', cdomain, cnv) <- + MaybeT . query1 (remoteConnectionSelectFrom keyspace) $ + params LocalQuorum (tUnqualified self, domain, rtarget) + pure (rel', time', Just (Qualified cnv cdomain)) + runMaybeT (foldQualified self local remote target) pure $ UserConnection { ucFrom = tUnqualified self, @@ -137,34 +148,35 @@ lookupConnection self target = runMaybeT $ do -- | 'lookupConnection' with more 'Relation' info. lookupRelationWithHistory :: - (MonadClient m) => + (MonadClient m, MonadReader Env m, MonadIO m) => -- | User 'A' Local UserId -> -- | User 'B' Qualified UserId -> m (Maybe RelationWithHistory) lookupRelationWithHistory self target = do - let local (tUnqualified -> ltarget) = - query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) - let remote (tUntagged -> Qualified rtarget domain) = - query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) - runIdentity <$$> retry x1 (foldQualified self local remote target) + withCasKeyspace $ \keyspace -> do + let local (tUnqualified -> ltarget) = + query1 (relationSelect keyspace) (params LocalQuorum (tUnqualified self, ltarget)) + let remote (tUntagged -> Qualified rtarget domain) = + query1 (remoteRelationSelect keyspace) (params LocalQuorum (tUnqualified self, domain, rtarget)) + runIdentity <$$> retry x1 (foldQualified self local remote target) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. lookupLocalConnections :: - (MonadClient m) => + (MonadClient m, MonadReader Env m, MonadIO m) => Local UserId -> Maybe UserId -> Range 1 500 Int32 -> m (ResultPage UserConnection) -lookupLocalConnections lfrom start (fromRange -> size) = +lookupLocalConnections lfrom start (fromRange -> size) = withCasKeyspace $ \keyspace -> toResult <$> case start of Just u -> retry x1 $ - paginate connectionsSelectFrom (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) + paginate (connectionsSelectFrom keyspace) (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) Nothing -> retry x1 $ - paginate connectionsSelect (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) + paginate (connectionsSelect keyspace) (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) where toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} @@ -172,106 +184,109 @@ lookupLocalConnections lfrom start (fromRange -> size) = -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -- Similar to lookupLocalConnections lookupLocalConnectionsPage :: - (MonadClient m) => + (MonadClient m, MonadReader Env m, MonadIO m) => Local UserId -> Maybe PagingState -> Range 1 1000 Int32 -> m (PageWithState Void UserConnection) lookupLocalConnectionsPage self pagingState (fromRange -> size) = - fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) x1 + withCasKeyspace $ \keyspace -> + fmap (toLocalUserConnection self) <$> paginateWithState (connectionsSelect keyspace) (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) x1 -- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. lookupRemoteConnectionsPage :: - (MonadClient m) => + (MonadClient m, MonadReader Env m, MonadIO m) => Local UserId -> Maybe PagingState -> Int32 -> m (PageWithState Void UserConnection) lookupRemoteConnectionsPage self pagingState size = - fmap (toRemoteUserConnection self) - <$> paginateWithState - remoteConnectionSelect - (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) - x1 + withCasKeyspace $ \keyspace -> + fmap (toRemoteUserConnection self) + <$> paginateWithState + (remoteConnectionSelect keyspace) + (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) + x1 -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus :: (MonadClient m) => [UserId] -> [UserId] -> m [ConnectionStatus] -lookupConnectionStatus from to = +lookupConnectionStatus :: (MonadClient m, MonadReader Env m, MonadIO m) => [UserId] -> [UserId] -> m [ConnectionStatus] +lookupConnectionStatus from to = withCasKeyspace $ \keyspace -> map toConnectionStatus - <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) + <$> retry x1 (query (connectionStatusSelect keyspace) (params LocalQuorum (from, to))) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus' :: (MonadClient m) => [UserId] -> m [ConnectionStatus] -lookupConnectionStatus' from = +lookupConnectionStatus' :: (MonadClient m, MonadReader Env m, MonadIO m) => [UserId] -> m [ConnectionStatus] +lookupConnectionStatus' from = withCasKeyspace $ \keyspace -> map toConnectionStatus - <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) + <$> retry x1 (query (connectionStatusSelect' keyspace) (params LocalQuorum (Identity from))) lookupLocalConnectionStatuses :: ( MonadClient m, + MonadReader Env m, + MonadIO m, MonadUnliftIO m ) => [UserId] -> Local [UserId] -> m [ConnectionStatusV2] lookupLocalConnectionStatuses froms tos = do + keyspace <- withCasKeyspace pure + let lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query (relationsSelect keyspace) (params LocalQuorum (from, tUnqualified tos))) concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms - where - lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupStatuses from = - map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) lookupRemoteConnectionStatuses :: ( MonadClient m, + MonadReader Env m, + MonadIO m, MonadUnliftIO m ) => [UserId] -> Remote [UserId] -> m [ConnectionStatusV2] lookupRemoteConnectionStatuses froms tos = do + keyspace <- withCasKeyspace pure + let lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query (remoteRelationsSelect keyspace) (params LocalQuorum (from, tDomain tos, tUnqualified tos))) concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms - where - lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupStatuses from = - map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) lookupAllStatuses :: ( MonadClient m, + MonadReader Env m, + MonadIO m, MonadUnliftIO m ) => Local [UserId] -> m [ConnectionStatusV2] lookupAllStatuses lfroms = do + keyspace <- withCasKeyspace pure let froms = tUnqualified lfroms + lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u + lookupLocalStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) + <$> retry x1 (query (relationsSelectAll keyspace) (params LocalQuorum (Identity from))) + lookupRemoteStatuses from = + map (\(d, u, r) -> toConnectionStatusV2 from d u r) + <$> retry x1 (query (remoteRelationsSelectAll keyspace) (params LocalQuorum (Identity from))) concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms - where - lookupAndCombine :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u - - lookupLocalStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupLocalStatuses from = - map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) - <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) - lookupRemoteStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] - lookupRemoteStatuses from = - map (\(d, u, r) -> toConnectionStatusV2 from d u r) - <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) - -lookupRemoteConnectedUsersPaginated :: (MonadClient m) => Local UserId -> Int32 -> m (Page (Remote UserConnection)) -lookupRemoteConnectedUsersPaginated u maxResults = do - (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) + +lookupRemoteConnectedUsersPaginated :: (MonadClient m) => Keyspace -> Local UserId -> Int32 -> m (Page (Remote UserConnection)) +lookupRemoteConnectedUsersPaginated keyspace u maxResults = + (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate (remoteConnectionSelect keyspace) (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) -- | See 'lookupContactListWithRelation'. -lookupContactList :: (MonadClient m) => UserId -> m [UserId] +lookupContactList :: (MonadClient m, MonadReader Env m, MonadIO m) => UserId -> m [UserId] lookupContactList u = fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelation u) -- | For a given user 'A', lookup the list of users that form his contact list, -- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). -lookupContactListWithRelation :: (MonadClient m) => UserId -> m [(UserId, RelationWithHistory)] +lookupContactListWithRelation :: (MonadClient m, MonadReader Env m, MonadIO m) => UserId -> m [(UserId, RelationWithHistory)] lookupContactListWithRelation u = - retry x1 (query contactsSelect (params LocalQuorum (Identity u))) + withCasKeyspace $ \keyspace -> + retry x1 (query (contactsSelect keyspace) (params LocalQuorum (Identity u))) -- | Count the number of connections a user has in a specific relation status. -- (If you want to distinguish 'RelationWithHistory', write a new function.) @@ -292,102 +307,107 @@ countConnections u r = do count n (Identity s) | relationDropHistory s `elem` r = n + 1 count n _ = n -deleteConnections :: (MonadClient m, MonadUnliftIO m) => UserId -> m () -deleteConnections u = do +deleteConnections :: (MonadClient m, MonadReader Env m, MonadIO m, MonadUnliftIO m) => UserId -> m () +deleteConnections u = withCasKeyspace $ \keyspace -> do + let delete (other, _status) = write (connectionDelete keyspace) $ params LocalQuorum (other, u) runConduit $ - paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 + paginateC (contactsSelect keyspace) (paramsP LocalQuorum (Identity u) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 delete) do - retry x1 . write connectionClear $ params LocalQuorum (Identity u) - retry x1 . write remoteConnectionClear $ params LocalQuorum (Identity u) - where - delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) + retry x1 . write (connectionClear keyspace) $ params LocalQuorum (Identity u) + retry x1 . write (remoteConnectionClear keyspace) $ params LocalQuorum (Identity u) deleteRemoteConnections :: ( MonadClient m, + MonadReader Env m, + MonadIO m, MonadUnliftIO m ) => Remote UserId -> Range 1 1000 [UserId] -> m () deleteRemoteConnections (tUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = - pooledForConcurrentlyN_ 16 locals $ \u -> - write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) + withCasKeyspace $ \keyspace -> + pooledForConcurrentlyN_ 16 locals $ \u -> + write (remoteConnectionDelete keyspace) $ params LocalQuorum (u, remoteDomain, remoteUser) -- Queries -connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () -connectionInsert = "INSERT INTO connection (left, right, status, last_update, conv) VALUES (?, ?, ?, ?, ?)" +connectionInsert :: Keyspace -> PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () +connectionInsert keyspace = fromString $ "INSERT INTO " <> table keyspace "connection" <> " (left, right, status, last_update, conv) VALUES (?, ?, ?, ?, ?)" -connectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, UserId) () -connectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection SET status = ?, last_update = ? WHERE left = ? AND right = ?" +connectionUpdate :: Keyspace -> PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, UserId) () +connectionUpdate keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "UPDATE " <> table keyspace "connection" <> " SET status = ?, last_update = ? WHERE left = ? AND right = ?" -connectionSelect :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -connectionSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right = ?" +connectionSelect :: Keyspace -> PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionSelect keyspace = fromString $ "SELECT left, right, status, last_update, conv FROM " <> table keyspace "connection" <> " WHERE left = ? AND right = ?" -relationSelect :: PrepQuery R (UserId, UserId) (Identity RelationWithHistory) -relationSelect = "SELECT status FROM connection WHERE left = ? AND right = ?" +relationSelect :: Keyspace -> PrepQuery R (UserId, UserId) (Identity RelationWithHistory) +relationSelect keyspace = fromString $ "SELECT status FROM " <> table keyspace "connection" <> " WHERE left = ? AND right = ?" -relationsSelect :: PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) -relationsSelect = "SELECT right, status FROM connection where left = ? AND right IN ?" +relationsSelect :: Keyspace -> PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) +relationsSelect keyspace = fromString $ "SELECT right, status FROM " <> table keyspace "connection" <> " where left = ? AND right IN ?" -relationsSelectAll :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) -relationsSelectAll = "SELECT right, status FROM connection where left = ?" +relationsSelectAll :: Keyspace -> PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +relationsSelectAll keyspace = fromString $ "SELECT right, status FROM " <> table keyspace "connection" <> " where left = ?" -- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of -- the table. -connectionStatusSelect :: PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) -connectionStatusSelect = "SELECT left, right, status FROM connection WHERE left IN ? AND right IN ?" +connectionStatusSelect :: Keyspace -> PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) +connectionStatusSelect keyspace = fromString $ "SELECT left, right, status FROM " <> table keyspace "connection" <> " WHERE left IN ? AND right IN ?" -- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of -- the table. -connectionStatusSelect' :: PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) -connectionStatusSelect' = "SELECT left, right, status FROM connection WHERE left IN ?" +connectionStatusSelect' :: Keyspace -> PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) +connectionStatusSelect' keyspace = fromString $ "SELECT left, right, status FROM " <> table keyspace "connection" <> " WHERE left IN ?" -contactsSelect :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) -contactsSelect = "SELECT right, status FROM connection WHERE left = ?" +contactsSelect :: Keyspace -> PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +contactsSelect keyspace = fromString $ "SELECT right, status FROM " <> table keyspace "connection" <> " WHERE left = ?" -connectionsSelect :: PrepQuery R (Identity UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -connectionsSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? ORDER BY right ASC" +connectionsSelect :: Keyspace -> PrepQuery R (Identity UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionsSelect keyspace = fromString $ "SELECT left, right, status, last_update, conv FROM " <> table keyspace "connection" <> " WHERE left = ? ORDER BY right ASC" -connectionsSelectFrom :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -connectionsSelectFrom = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right > ? ORDER BY right ASC" +connectionsSelectFrom :: Keyspace -> PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionsSelectFrom keyspace = fromString $ "SELECT left, right, status, last_update, conv FROM " <> table keyspace "connection" <> " WHERE left = ? AND right > ? ORDER BY right ASC" -connectionDelete :: PrepQuery W (UserId, UserId) () -connectionDelete = "DELETE FROM connection WHERE left = ? AND right = ?" +connectionDelete :: Keyspace -> PrepQuery W (UserId, UserId) () +connectionDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "connection" <> " WHERE left = ? AND right = ?" -connectionClear :: PrepQuery W (Identity UserId) () -connectionClear = "DELETE FROM connection WHERE left = ?" +connectionClear :: Keyspace -> PrepQuery W (Identity UserId) () +connectionClear keyspace = fromString $ "DELETE FROM " <> table keyspace "connection" <> " WHERE left = ?" -- Remote connections -remoteConnectionInsert :: PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () -remoteConnectionInsert = "INSERT INTO connection_remote (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" +remoteConnectionInsert :: Keyspace -> PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () +remoteConnectionInsert keyspace = fromString $ "INSERT INTO " <> table keyspace "connection_remote" <> " (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" + +remoteConnectionSelect :: Keyspace -> PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelect keyspace = fromString $ "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM " <> table keyspace "connection_remote" <> " where left = ?" -remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -remoteConnectionSelect = "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM connection_remote where left = ?" +remoteConnectionSelectFrom :: Keyspace -> PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelectFrom keyspace = fromString $ "SELECT status, last_update, conv_domain, conv_id FROM " <> table keyspace "connection_remote" <> " where left = ? AND right_domain = ? AND right_user = ?" -remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) -remoteConnectionSelectFrom = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" +remoteConnectionUpdate :: Keyspace -> PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () +remoteConnectionUpdate keyspace = {- `IF EXISTS`, but that requires benchmarking -} fromString $ "UPDATE " <> table keyspace "connection_remote" <> " set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" -remoteConnectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () -remoteConnectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection_remote set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" +remoteConnectionDelete :: Keyspace -> PrepQuery W (UserId, Domain, UserId) () +remoteConnectionDelete keyspace = fromString $ "DELETE FROM " <> table keyspace "connection_remote" <> " where left = ? AND right_domain = ? AND right_user = ?" -remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () -remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" +remoteConnectionClear :: Keyspace -> PrepQuery W (Identity UserId) () +remoteConnectionClear keyspace = fromString $ "DELETE FROM " <> table keyspace "connection_remote" <> " where left = ?" -remoteConnectionClear :: PrepQuery W (Identity UserId) () -remoteConnectionClear = "DELETE FROM connection_remote where left = ?" +remoteRelationSelect :: Keyspace -> PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) +remoteRelationSelect keyspace = fromString $ "SELECT status FROM " <> table keyspace "connection_remote" <> " WHERE left = ? AND right_domain = ? AND right_user = ?" -remoteRelationSelect :: PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) -remoteRelationSelect = "SELECT status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user = ?" +remoteRelationsSelect :: Keyspace -> PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) +remoteRelationsSelect keyspace = fromString $ "SELECT right_user, status FROM " <> table keyspace "connection_remote" <> " WHERE left = ? AND right_domain = ? AND right_user IN ?" -remoteRelationsSelect :: PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) -remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user IN ?" +remoteRelationsSelectAll :: Keyspace -> PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) +remoteRelationsSelectAll keyspace = fromString $ "SELECT right_domain, right_user, status FROM " <> table keyspace "connection_remote" <> " WHERE left = ?" -remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) -remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" +table :: Keyspace -> String -> String +table keyspace tableName = Text.unpack (unKeyspace keyspace) <> "." <> tableName -- Conversions diff --git a/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs b/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs index 35f2444ab88..6f6f49815af 100644 --- a/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs @@ -22,6 +22,7 @@ module Brig.Effects.ConnectionStore.Cassandra where import Brig.Data.Connection import Brig.Effects.ConnectionStore import Cassandra +import Cassandra.Util (requireClientKeyspace) import Data.Range import Imports import Polysemy @@ -36,6 +37,8 @@ connectionStoreToCassandra :: connectionStoreToCassandra = interpretH $ liftT . embed @Client . \case - RemoteConnectedUsersPaginated uid mps bounds -> case mps of - Nothing -> flip mkInternalPage pure =<< lookupRemoteConnectedUsersPaginated uid (fromRange bounds) - Just ps -> ipNext ps + RemoteConnectedUsersPaginated uid mps bounds -> do + keyspace <- ask >>= liftIO . requireClientKeyspace + case mps of + Nothing -> flip mkInternalPage pure =<< lookupRemoteConnectedUsersPaginated keyspace uid (fromRange bounds) + Just ps -> ipNext ps diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 76aebdaff09..499d46788f0 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -27,6 +27,7 @@ import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Data.Connection (remoteConnectionInsert) import Cassandra qualified as DB +import Cassandra.Util (requireClientKeyspace) import Control.Arrow ((&&&)) import Data.ByteString.Conversion import Data.Domain @@ -649,8 +650,10 @@ testAllConnectionsPaging b db = do qOther <- (`Qualified` remoteDomain) <$> randomId qConv <- (`Qualified` remoteDomain) <$> randomId liftIO . DB.runClient db $ - DB.retry DB.x5 $ - DB.write remoteConnectionInsert $ + do + keyspace <- liftIO $ requireClientKeyspace db + DB.retry DB.x5 $ + DB.write (remoteConnectionInsert keyspace) $ DB.params DB.LocalQuorum (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) diff --git a/services/galley/src/Galley/Cassandra/CustomBackend.hs b/services/galley/src/Galley/Cassandra/CustomBackend.hs index 6cbec51e997..8a6ad8c3b70 100644 --- a/services/galley/src/Galley/Cassandra/CustomBackend.hs +++ b/services/galley/src/Galley/Cassandra/CustomBackend.hs @@ -42,26 +42,26 @@ interpretCustomBackendStoreToCassandra :: interpretCustomBackendStoreToCassandra = interpret $ \case GetCustomBackend dom -> do logEffect "CustomBackendStore.GetCustomBackend" - embedClient $ getCustomBackend dom + embedClientWithKeyspace $ \keyspace -> getCustomBackend keyspace dom SetCustomBackend dom b -> do logEffect "CustomBackendStore.SetCustomBackend" - embedClient $ setCustomBackend dom b + embedClientWithKeyspace $ \keyspace -> setCustomBackend keyspace dom b DeleteCustomBackend dom -> do logEffect "CustomBackendStore.DeleteCustomBackend" - embedClient $ deleteCustomBackend dom + embedClientWithKeyspace $ \keyspace -> deleteCustomBackend keyspace dom -getCustomBackend :: (MonadClient m) => Domain -> m (Maybe CustomBackend) -getCustomBackend domain = +getCustomBackend :: (MonadClient m) => Keyspace -> Domain -> m (Maybe CustomBackend) +getCustomBackend keyspace domain = fmap toCustomBackend <$> do - retry x1 $ query1 Cql.selectCustomBackend (params LocalQuorum (Identity domain)) + retry x1 $ query1 (Cql.selectCustomBackend keyspace) (params LocalQuorum (Identity domain)) where toCustomBackend (backendConfigJsonUrl, backendWebappWelcomeUrl) = CustomBackend {..} -setCustomBackend :: (MonadClient m) => Domain -> CustomBackend -> m () -setCustomBackend domain CustomBackend {..} = do - retry x5 $ write Cql.upsertCustomBackend (params LocalQuorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) +setCustomBackend :: (MonadClient m) => Keyspace -> Domain -> CustomBackend -> m () +setCustomBackend keyspace domain CustomBackend {..} = do + retry x5 $ write (Cql.upsertCustomBackend keyspace) (params LocalQuorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) -deleteCustomBackend :: (MonadClient m) => Domain -> m () -deleteCustomBackend domain = do - retry x5 $ write Cql.deleteCustomBackend (params LocalQuorum (Identity domain)) +deleteCustomBackend :: (MonadClient m) => Keyspace -> Domain -> m () +deleteCustomBackend keyspace domain = do + retry x5 $ write (Cql.deleteCustomBackend keyspace) (params LocalQuorum (Identity domain)) diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 789cf8b195c..85663a8c761 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -48,98 +48,85 @@ import Data.Id import Data.LegalHold import Data.Misc import Imports -import Text.RawString.QQ import Wire.API.Provider import Wire.API.Provider.Service import Wire.API.Team.SearchVisibility import Wire.API.User.Client.Prekey +import Wire.Util (qualifiedTableName) -- LegalHold ---------------------------------------------------------------- -insertLegalHoldSettings :: PrepQuery W (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey, TeamId) () -insertLegalHoldSettings = - [r| - update legalhold_service - set base_url = ?, - fingerprint = ?, - auth_token = ?, - pubkey = ? - where team_id = ? - |] - -selectLegalHoldSettings :: PrepQuery R (Identity TeamId) (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey) -selectLegalHoldSettings = - [r| - select base_url, fingerprint, auth_token, pubkey - from legalhold_service - where team_id = ? - |] - -removeLegalHoldSettings :: PrepQuery W (Identity TeamId) () -removeLegalHoldSettings = "delete from legalhold_service where team_id = ?" - -insertPendingPrekeys :: PrepQuery W (UserId, PrekeyId, Text) () -insertPendingPrekeys = - [r| - insert into legalhold_pending_prekeys (user, key, data) values (?, ?, ?) - |] - -dropPendingPrekeys :: PrepQuery W (Identity UserId) () -dropPendingPrekeys = - [r| - delete from legalhold_pending_prekeys - where user = ? - |] - -selectPendingPrekeys :: PrepQuery R (Identity UserId) (PrekeyId, Text) -selectPendingPrekeys = - [r| - select key, data - from legalhold_pending_prekeys - where user = ? - order by key asc - |] - -updateUserLegalHoldStatus :: PrepQuery W (UserLegalHoldStatus, TeamId, UserId) () -updateUserLegalHoldStatus = - [r| - update team_member - set legalhold_status = ? - where team = ? and user = ? - |] - -insertLegalHoldWhitelistedTeam :: PrepQuery W (Identity TeamId) () -insertLegalHoldWhitelistedTeam = - [r| - insert into legalhold_whitelisted (team) values (?) - |] - -removeLegalHoldWhitelistedTeam :: PrepQuery W (Identity TeamId) () -removeLegalHoldWhitelistedTeam = - [r| - delete from legalhold_whitelisted where team = ? - |] +insertLegalHoldSettings :: Keyspace -> PrepQuery W (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey, TeamId) () +insertLegalHoldSettings keyspace = + fromString $ + "update " + <> table keyspace "legalhold_service" + <> " set base_url = ?, fingerprint = ?, auth_token = ?, pubkey = ? where team_id = ?" + +selectLegalHoldSettings :: Keyspace -> PrepQuery R (Identity TeamId) (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey) +selectLegalHoldSettings keyspace = + fromString $ + "select base_url, fingerprint, auth_token, pubkey from " + <> table keyspace "legalhold_service" + <> " where team_id = ?" + +removeLegalHoldSettings :: Keyspace -> PrepQuery W (Identity TeamId) () +removeLegalHoldSettings keyspace = + fromString $ "delete from " <> table keyspace "legalhold_service" <> " where team_id = ?" + +insertPendingPrekeys :: Keyspace -> PrepQuery W (UserId, PrekeyId, Text) () +insertPendingPrekeys keyspace = + fromString $ "insert into " <> table keyspace "legalhold_pending_prekeys" <> " (user, key, data) values (?, ?, ?)" + +dropPendingPrekeys :: Keyspace -> PrepQuery W (Identity UserId) () +dropPendingPrekeys keyspace = + fromString $ "delete from " <> table keyspace "legalhold_pending_prekeys" <> " where user = ?" + +selectPendingPrekeys :: Keyspace -> PrepQuery R (Identity UserId) (PrekeyId, Text) +selectPendingPrekeys keyspace = + fromString $ + "select key, data from " + <> table keyspace "legalhold_pending_prekeys" + <> " where user = ? order by key asc" + +updateUserLegalHoldStatus :: Keyspace -> PrepQuery W (UserLegalHoldStatus, TeamId, UserId) () +updateUserLegalHoldStatus keyspace = + fromString $ + "update " + <> table keyspace "team_member" + <> " set legalhold_status = ? where team = ? and user = ?" + +insertLegalHoldWhitelistedTeam :: Keyspace -> PrepQuery W (Identity TeamId) () +insertLegalHoldWhitelistedTeam keyspace = + fromString $ "insert into " <> table keyspace "legalhold_whitelisted" <> " (team) values (?)" + +removeLegalHoldWhitelistedTeam :: Keyspace -> PrepQuery W (Identity TeamId) () +removeLegalHoldWhitelistedTeam keyspace = + fromString $ "delete from " <> table keyspace "legalhold_whitelisted" <> " where team = ?" -- Search Visibility -------------------------------------------------------- -selectSearchVisibility :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamSearchVisibility)) -selectSearchVisibility = - "select search_visibility from team where team = ?" +selectSearchVisibility :: Keyspace -> PrepQuery R (Identity TeamId) (Identity (Maybe TeamSearchVisibility)) +selectSearchVisibility keyspace = + fromString $ "select search_visibility from " <> table keyspace "team" <> " where team = ?" -updateSearchVisibility :: PrepQuery W (TeamSearchVisibility, TeamId) () -updateSearchVisibility = - {- `IF EXISTS`, but that requires benchmarking -} "update team set search_visibility = ? where team = ?" +updateSearchVisibility :: Keyspace -> PrepQuery W (TeamSearchVisibility, TeamId) () +updateSearchVisibility keyspace = + fromString $ "update " <> table keyspace "team" <> " set search_visibility = ? where team = ?" -- Custom Backend ----------------------------------------------------------- -selectCustomBackend :: PrepQuery R (Identity Domain) (HttpsUrl, HttpsUrl) -selectCustomBackend = - "select config_json_url, webapp_welcome_url from custom_backend where domain = ?" +selectCustomBackend :: Keyspace -> PrepQuery R (Identity Domain) (HttpsUrl, HttpsUrl) +selectCustomBackend keyspace = + fromString $ "select config_json_url, webapp_welcome_url from " <> table keyspace "custom_backend" <> " where domain = ?" -upsertCustomBackend :: PrepQuery W (HttpsUrl, HttpsUrl, Domain) () -upsertCustomBackend = - "update custom_backend set config_json_url = ?, webapp_welcome_url = ? where domain = ?" +upsertCustomBackend :: Keyspace -> PrepQuery W (HttpsUrl, HttpsUrl, Domain) () +upsertCustomBackend keyspace = + fromString $ "update " <> table keyspace "custom_backend" <> " set config_json_url = ?, webapp_welcome_url = ? where domain = ?" -deleteCustomBackend :: PrepQuery W (Identity Domain) () -deleteCustomBackend = - "delete from custom_backend where domain = ?" +deleteCustomBackend :: Keyspace -> PrepQuery W (Identity Domain) () +deleteCustomBackend keyspace = + fromString $ "delete from " <> table keyspace "custom_backend" <> " where domain = ?" + +table :: Keyspace -> String -> String +table = qualifiedTableName diff --git a/services/galley/src/Galley/Cassandra/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs index 9def57051e1..a5f7a1e6dd3 100644 --- a/services/galley/src/Galley/Cassandra/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -40,19 +40,19 @@ interpretSearchVisibilityStoreToCassandra :: interpretSearchVisibilityStoreToCassandra = interpret $ \case GetSearchVisibility tid -> do logEffect "SearchVisibilityStore.GetSearchVisibility" - embedClient $ getSearchVisibility tid + embedClientWithKeyspace $ \keyspace -> getSearchVisibility keyspace tid SetSearchVisibility tid value -> do logEffect "SearchVisibilityStore.SetSearchVisibility" - embedClient $ setSearchVisibility tid value + embedClientWithKeyspace $ \keyspace -> setSearchVisibility keyspace tid value ResetSearchVisibility tid -> do logEffect "SearchVisibilityStore.ResetSearchVisibility" - embedClient $ resetSearchVisibility tid + embedClientWithKeyspace $ \keyspace -> resetSearchVisibility keyspace tid -- | Return whether a given team is allowed to enable/disable sso -getSearchVisibility :: (MonadClient m) => TeamId -> m TeamSearchVisibility -getSearchVisibility tid = +getSearchVisibility :: (MonadClient m) => Keyspace -> TeamId -> m TeamSearchVisibility +getSearchVisibility keyspace tid = toSearchVisibility <$> do - retry x1 $ query1 selectSearchVisibility (params LocalQuorum (Identity tid)) + retry x1 $ query1 (selectSearchVisibility keyspace) (params LocalQuorum (Identity tid)) where -- The value is either set or we return the default toSearchVisibility :: Maybe (Identity (Maybe TeamSearchVisibility)) -> TeamSearchVisibility @@ -60,10 +60,10 @@ getSearchVisibility tid = toSearchVisibility _ = SearchVisibilityStandard -- | Determines whether a given team is allowed to enable/disable sso -setSearchVisibility :: (MonadClient m) => TeamId -> TeamSearchVisibility -> m () -setSearchVisibility tid visibilityType = do - retry x5 $ write updateSearchVisibility (params LocalQuorum (visibilityType, tid)) +setSearchVisibility :: (MonadClient m) => Keyspace -> TeamId -> TeamSearchVisibility -> m () +setSearchVisibility keyspace tid visibilityType = do + retry x5 $ write (updateSearchVisibility keyspace) (params LocalQuorum (visibilityType, tid)) -resetSearchVisibility :: (MonadClient m) => TeamId -> m () -resetSearchVisibility tid = do - retry x5 $ write updateSearchVisibility (params LocalQuorum (SearchVisibilityStandard, tid)) +resetSearchVisibility :: (MonadClient m) => Keyspace -> TeamId -> m () +resetSearchVisibility keyspace tid = do + retry x5 $ write (updateSearchVisibility keyspace) (params LocalQuorum (SearchVisibilityStandard, tid)) diff --git a/services/galley/src/Galley/Cassandra/Store.hs b/services/galley/src/Galley/Cassandra/Store.hs index 16794523557..60ee3509ebe 100644 --- a/services/galley/src/Galley/Cassandra/Store.hs +++ b/services/galley/src/Galley/Cassandra/Store.hs @@ -17,10 +17,12 @@ module Galley.Cassandra.Store ( embedClient, + embedClientWithKeyspace, ) where import Cassandra +import Cassandra.Util (requireClientKeyspace) import Imports import Polysemy import Polysemy.Input @@ -34,3 +36,14 @@ embedClient :: embedClient client = do cs <- input embed @IO $ runClient cs client + +embedClientWithKeyspace :: + ( Member (Embed IO) r, + Member (Input ClientState) r + ) => + (Keyspace -> Client a) -> + Sem r a +embedClientWithKeyspace client = do + cs <- input + keyspace <- embed @IO $ requireClientKeyspace cs + embed @IO $ runClient cs (client keyspace) diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index cb961573737..9ac2fda612b 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -57,7 +57,7 @@ interpretTeamListToCassandra :: interpretTeamListToCassandra = interpret $ \case ListItems uid ps lim -> do logEffect "TeamList.ListItems" - embedClient $ teamIdsFrom uid ps lim + embedClientWithKeyspace $ \keyspace -> teamIdsFrom keyspace uid ps lim interpretInternalTeamListToCassandra :: ( Member (Embed IO) r, @@ -69,9 +69,9 @@ interpretInternalTeamListToCassandra :: interpretInternalTeamListToCassandra = interpret $ \case ListItems uid mps lim -> do logEffect "InternalTeamList.ListItems" - embedClient $ case mps of + embedClientWithKeyspace $ \keyspace -> case mps of Nothing -> do - page <- teamIdsForPagination uid Nothing lim + page <- teamIdsForPagination keyspace uid Nothing lim mkInternalPage page pure Just ps -> ipNext ps @@ -86,10 +86,10 @@ interpretTeamMemberStoreToCassandra :: interpretTeamMemberStoreToCassandra lh = interpret $ \case ListTeamMembers tid mps lim -> do logEffect "TeamMemberStore.ListTeamMembers" - embedClient $ case mps of + embedClientWithKeyspace $ \keyspace -> case mps of Nothing -> do - page <- teamMembersForPagination tid Nothing lim - mkInternalPage page (newTeamMember' lh tid) + page <- teamMembersForPagination keyspace tid Nothing lim + mkInternalPage page (newTeamMember' lh keyspace tid) Just ps -> ipNext ps interpretTeamMemberStoreToCassandraWithPaging :: @@ -103,21 +103,21 @@ interpretTeamMemberStoreToCassandraWithPaging :: interpretTeamMemberStoreToCassandraWithPaging lh = interpret $ \case ListTeamMembers tid mps lim -> do logEffect "TeamMemberStore.ListTeamMembers" - embedClient $ teamMembersPageFrom lh tid mps lim + embedClientWithKeyspace $ \keyspace -> teamMembersPageFrom lh keyspace tid mps lim -teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) -teamIdsFrom usr range (fromRange -> max) = +teamIdsFrom :: Keyspace -> UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) +teamIdsFrom keyspace usr range (fromRange -> max) = mkResultSet . fmap runIdentity . strip <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) (max + 1)) + Just c -> paginate (Cql.selectUserTeamsFrom keyspace) (paramsP LocalQuorum (usr, c) (max + 1)) + Nothing -> paginate (Cql.selectUserTeams keyspace) (paramsP LocalQuorum (Identity usr) (max + 1)) where strip p = p {result = take (fromIntegral max) (result p)} -teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (Page TeamId) -teamIdsForPagination usr range (fromRange -> max) = +teamIdsForPagination :: Keyspace -> UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (Page TeamId) +teamIdsForPagination keyspace usr range (fromRange -> max) = fmap runIdentity <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) max) - Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) max) + Just c -> paginate (Cql.selectUserTeamsFrom keyspace) (paramsP LocalQuorum (usr, c) max) + Nothing -> paginate (Cql.selectUserTeams keyspace) (paramsP LocalQuorum (Identity usr) max) -- | Construct 'TeamMember' from database tuple. -- If FeatureLegalHoldWhitelistTeamsAndImplicitConsent is enabled set UserLegalHoldDisabled @@ -127,16 +127,17 @@ teamIdsForPagination usr range (fromRange -> max) = -- other is 'Just', which can only be caused by inconsistent database content. newTeamMember' :: FeatureDefaults LegalholdConfig -> + Keyspace -> TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> Client TeamMember -newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do +newTeamMember' lh keyspace tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do mk minvu minvt >>= maybeGrant where maybeGrant :: TeamMember -> Client TeamMember maybeGrant m = ifM - (isTeamLegalholdWhitelisted lh tid) + (isTeamLegalholdWhitelisted lh keyspace tid) (pure (grantImplicitConsent m)) (pure m) @@ -154,11 +155,11 @@ newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatu mk Nothing Nothing = pure $ mkTeamMember uid perms Nothing lhStatus mk _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." -isTeamLegalholdWhitelisted :: FeatureDefaults LegalholdConfig -> TeamId -> Client Bool -isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False -isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False -isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = - isJust <$> (runIdentity <$$> retry x5 (query1 Cql.selectLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid)))) +isTeamLegalholdWhitelisted :: FeatureDefaults LegalholdConfig -> Keyspace -> TeamId -> Client Bool +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent keyspace tid = + isJust <$> (runIdentity <$$> retry x5 (query1 (Cql.selectLegalHoldWhitelistedTeam keyspace) (params LocalQuorum (Identity tid)))) type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) @@ -166,19 +167,20 @@ type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Ma -- have a pure function of type RawTeamMember -> TeamMember so we cannot fmap -- over the ResultSet. We don't want to mess around with the Result size -- nextPage either otherwise -teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) -teamMembersForPagination tid start (fromRange -> max) = +teamMembersForPagination :: Keyspace -> TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) +teamMembersForPagination keyspace tid start (fromRange -> max) = case start of - Just u -> paginate Cql.selectTeamMembersFrom (paramsP LocalQuorum (tid, u) max) - Nothing -> paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity tid) max) + Just u -> paginate (Cql.selectTeamMembersFrom keyspace) (paramsP LocalQuorum (tid, u) max) + Nothing -> paginate (Cql.selectTeamMembers keyspace) (paramsP LocalQuorum (Identity tid) max) teamMembersPageFrom :: FeatureDefaults LegalholdConfig -> + Keyspace -> TeamId -> Maybe PagingState -> Range 1 HardTruncationLimit Int32 -> Client (PageWithState Void TeamMember) -teamMembersPageFrom lh tid pagingState (fromRange -> max) = do - page <- paginateWithState Cql.selectTeamMembers (paramsPagingState LocalQuorum (Identity tid) max pagingState) x1 - members <- mapM (newTeamMember' lh tid) (pwsResults page) +teamMembersPageFrom lh keyspace tid pagingState (fromRange -> max) = do + page <- paginateWithState (Cql.selectTeamMembers keyspace) (paramsPagingState LocalQuorum (Identity tid) max pagingState) x1 + members <- mapM (newTeamMember' lh keyspace tid) (pwsResults page) pure $ PageWithState members (pwsState page) diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index c6d3681b526..0f4f65ba23b 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -25,6 +25,7 @@ module Spar.CanonicalInterpreter where import qualified Cassandra as Cas +import Cassandra.Util (requireClientKeyspace) import Control.Monad.Except hiding (mapError) import Imports import Polysemy @@ -121,6 +122,7 @@ type LowerLevelCanonicalEffs = Logger String, Logger (TinyLog.Msg -> TinyLog.Msg), Input Opts, + Input Cas.Keyspace, Input TinyLog.Logger, Random, Now, @@ -129,12 +131,14 @@ type LowerLevelCanonicalEffs = ] runSparToIO :: Env -> Sem CanonicalEffs a -> IO (Either SparError a) -runSparToIO ctx = +runSparToIO ctx sem = do + casKeyspace <- requireClientKeyspace (sparCtxCas ctx) runFinal . embedToFinal @IO . nowToIO . randomToIO . runInputConst (sparCtxLogger ctx) + . runInputConst casKeyspace . runInputConst (sparCtxOpts ctx) . loggerToTinyLog (sparCtxLogger ctx) . stringLoggerToTinyLog @@ -168,6 +172,7 @@ runSparToIO ctx = (galley . sparCtxOpts $ ctx) . interpretScimSubsystem . interpretIdPSubsystem (enableIdPByEmailDiscovery . sparCtxOpts $ ctx) + $ sem iParseException :: (Member (Error SparError) r) => InterpreterFor (Error ParseException) r iParseException = Polysemy.Error.mapError (httpErrorToSparError . parseExceptionToHttpError) diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs index d708b2f011e..3c1375547ab 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs @@ -29,6 +29,7 @@ import Data.Id import Data.Time import Imports import Polysemy +import Polysemy.Input import qualified SAML2.WebSSO as SAML import Spar.Data.Instances () import Spar.Sem.ScimTokenStore @@ -36,22 +37,26 @@ import Text.RawString.QQ import Wire.API.User.Scim import {- instance Cql SAML.IdPId -} Wire.DomainRegistrationStore.Cassandra () import qualified Prelude +import Wire.Util (qualifiedTableName) scimTokenStoreToCassandra :: forall m r a. - (MonadClient m, Member (Embed m) r) => + (MonadClient m, Member (Embed m) r, Member (Input Keyspace) r) => Sem (ScimTokenStore ': r) a -> Sem r a scimTokenStoreToCassandra = - interpret $ - embed @m - . \case - Insert st sti -> insertScimToken st sti - Lookup st -> lookupScimToken st - LookupByTeam tid -> getScimTokens tid - UpdateName team token name -> updateScimTokenName team token name - Delete team token -> deleteScimToken team token - DeleteByTeam team -> deleteTeamScimTokens team + interpret $ \case + Insert st sti -> withKeyspace $ \keyspace -> embed @m $ insertScimToken keyspace st sti + Lookup st -> withKeyspace $ \keyspace -> embed @m $ lookupScimToken keyspace st + LookupByTeam tid -> withKeyspace $ \keyspace -> embed @m $ getScimTokens keyspace tid + UpdateName team token name -> withKeyspace $ \keyspace -> embed @m $ updateScimTokenName keyspace team token name + Delete team token -> withKeyspace $ \keyspace -> embed @m $ deleteScimToken keyspace team token + DeleteByTeam team -> withKeyspace $ \keyspace -> embed @m $ deleteTeamScimTokens keyspace team + where + withKeyspace :: (Keyspace -> Sem r x) -> Sem r x + withKeyspace action = do + keyspace <- input + action keyspace ---------------------------------------------------------------------- -- SCIM auth @@ -62,26 +67,27 @@ scimTokenStoreToCassandra = -- generated by the backend, not by the user. insertScimToken :: (HasCallStack, MonadClient m) => + Keyspace -> ScimToken -> ScimTokenInfo -> m () -insertScimToken token ScimTokenInfo {..} = retry x5 . batch $ do +insertScimToken keyspace token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum let tokenHash = hashScimToken token - addPrepQuery insByToken (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) - addPrepQuery insByTeam (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) + addPrepQuery (insByToken keyspace) (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) + addPrepQuery (insByTeam keyspace) (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) -insByToken, insByTeam :: PrepQuery W ScimTokenRow () -insByToken = +insByToken, insByTeam :: Keyspace -> PrepQuery W ScimTokenRow () +insByToken keyspace = fromString $ [r| - INSERT INTO team_provisioning_by_token + INSERT INTO |] <> table keyspace "team_provisioning_by_token" <> [r| (token_, team, id, created_at, idp, descr, name) VALUES (?, ?, ?, ?, ?, ?, ?) |] -insByTeam = +insByTeam keyspace = fromString $ [r| - INSERT INTO team_provisioning_by_team + INSERT INTO |] <> table keyspace "team_provisioning_by_team" <> [r| (token_, team, id, created_at, idp, descr, name) VALUES (?, ?, ?, ?, ?, ?, ?) |] @@ -93,148 +99,138 @@ scimTokenLookupKey (key, _, _, _, _, _, _) = key -- associated with it. lookupScimToken :: (HasCallStack, MonadClient m) => + Keyspace -> ScimToken -> m (Maybe ScimTokenInfo) -lookupScimToken token = do +lookupScimToken keyspace token = do let tokenHash = hashScimToken token - rows <- retry x1 . query sel $ params LocalQuorum (tokenHash, token) + rows <- retry x1 . query (sel keyspace) $ params LocalQuorum (tokenHash, token) case fmap (scimTokenLookupKey &&& Prelude.id) rows of [(ScimTokenLookupKeyHashed _, row)] -> pure (Just (fromScimTokenRow row)) [(ScimTokenLookupKeyPlaintext plain, row)] -> - convert plain row + convert keyspace plain row [(ScimTokenLookupKeyHashed _, _), (ScimTokenLookupKeyPlaintext plain, row)] -> - convert plain row + convert keyspace plain row [(ScimTokenLookupKeyPlaintext plain, row), (ScimTokenLookupKeyHashed _, _)] -> - convert plain row + convert keyspace plain row _ -> pure Nothing where - sel :: PrepQuery R (ScimTokenHash, ScimToken) ScimTokenRow - sel = - [r| - SELECT token_, team, id, created_at, idp, descr, name - FROM team_provisioning_by_token WHERE token_ in (?, ?) - |] - - convert :: (MonadClient m) => ScimToken -> ScimTokenRow -> m (Maybe ScimTokenInfo) - convert plain row = do + sel :: Keyspace -> PrepQuery R (ScimTokenHash, ScimToken) ScimTokenRow + sel ks = fromString $ + "SELECT token_, team, id, created_at, idp, descr, name FROM " + <> table ks "team_provisioning_by_token" + <> " WHERE token_ in (?, ?)" + + convert :: (MonadClient m) => Keyspace -> ScimToken -> ScimTokenRow -> m (Maybe ScimTokenInfo) + convert ks plain row = do let tokenInfo = fromScimTokenRow row - connvertPlaintextToken plain tokenInfo + connvertPlaintextToken ks plain tokenInfo pure (Just tokenInfo) connvertPlaintextToken :: (HasCallStack, MonadClient m) => + Keyspace -> ScimToken -> ScimTokenInfo -> m () -connvertPlaintextToken token ScimTokenInfo {..} = retry x5 . batch $ do +connvertPlaintextToken keyspace token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum let tokenHash = hashScimToken token -- enter by new lookup key - addPrepQuery insByToken (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) + addPrepQuery (insByToken keyspace) (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) -- update info table - addPrepQuery insByTeam (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) + addPrepQuery (insByTeam keyspace) (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, Just stiName) -- remove old lookup key - addPrepQuery delByTokenLookup (Identity (ScimTokenLookupKeyPlaintext token)) + addPrepQuery (delByTokenLookup keyspace) (Identity (ScimTokenLookupKeyPlaintext token)) -- | List all tokens associated with a team, in the order of their creation. getScimTokens :: (HasCallStack, MonadClient m) => + Keyspace -> TeamId -> m [ScimTokenInfo] -getScimTokens team = do +getScimTokens keyspace team = do -- We don't need pagination here because the limit should be pretty low -- (e.g. 16). If the limit grows, we might have to introduce pagination. - rows <- retry x1 . query sel $ params LocalQuorum (Identity team) + rows <- retry x1 . query (sel keyspace) $ params LocalQuorum (Identity team) pure $ sortOn (.stiCreatedAt) $ map fromScimTokenRow rows where - sel :: PrepQuery R (Identity TeamId) ScimTokenRow - sel = - [r| - SELECT token_, team, id, created_at, idp, descr, name - FROM team_provisioning_by_team WHERE team = ? - |] + sel :: Keyspace -> PrepQuery R (Identity TeamId) ScimTokenRow + sel ks = fromString $ + "SELECT token_, team, id, created_at, idp, descr, name FROM " + <> table ks "team_provisioning_by_team" + <> " WHERE team = ?" -- | Delete a token. deleteScimToken :: (HasCallStack, MonadClient m) => + Keyspace -> TeamId -> ScimTokenId -> m () -deleteScimToken team tokenid = do - mbToken <- retry x1 . query1 selById $ params LocalQuorum (team, tokenid) +deleteScimToken keyspace team tokenid = do + mbToken <- retry x1 . query1 (selById keyspace) $ params LocalQuorum (team, tokenid) retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery delById (team, tokenid) + addPrepQuery (delById keyspace) (team, tokenid) for_ mbToken $ \(Identity key) -> - addPrepQuery delByTokenLookup (Identity key) - -selById :: PrepQuery R (TeamId, ScimTokenId) (Identity ScimTokenLookupKey) -selById = - [r| - SELECT token_ FROM team_provisioning_by_team - WHERE team = ? AND id = ? -|] - -delById :: PrepQuery W (TeamId, ScimTokenId) () -delById = - [r| - DELETE FROM team_provisioning_by_team - WHERE team = ? AND id = ? - |] - -delByTokenLookup :: PrepQuery W (Identity ScimTokenLookupKey) () -delByTokenLookup = - [r| - DELETE FROM team_provisioning_by_token - WHERE token_ = ? -|] + addPrepQuery (delByTokenLookup keyspace) (Identity key) + +selById :: Keyspace -> PrepQuery R (TeamId, ScimTokenId) (Identity ScimTokenLookupKey) +selById keyspace = fromString $ + "SELECT token_ FROM " + <> table keyspace "team_provisioning_by_team" + <> " WHERE team = ? AND id = ?" + +delById :: Keyspace -> PrepQuery W (TeamId, ScimTokenId) () +delById keyspace = fromString $ + "DELETE FROM " + <> table keyspace "team_provisioning_by_team" + <> " WHERE team = ? AND id = ?" + +delByTokenLookup :: Keyspace -> PrepQuery W (Identity ScimTokenLookupKey) () +delByTokenLookup keyspace = fromString $ + "DELETE FROM " + <> table keyspace "team_provisioning_by_token" + <> " WHERE token_ = ?" -- | Delete all tokens belonging to a team. deleteTeamScimTokens :: (HasCallStack, MonadClient m) => + Keyspace -> TeamId -> m () -deleteTeamScimTokens team = do - tokens <- retry x5 $ query sel $ params LocalQuorum (Identity team) +deleteTeamScimTokens keyspace team = do + tokens <- retry x5 $ query (sel keyspace) $ params LocalQuorum (Identity team) retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery delByTeam (Identity team) - mapM_ (addPrepQuery delByTokenLookup) tokens + addPrepQuery (delByTeam keyspace) (Identity team) + mapM_ (addPrepQuery (delByTokenLookup keyspace)) tokens where - sel :: PrepQuery R (Identity TeamId) (Identity ScimTokenLookupKey) - sel = "SELECT token_ FROM team_provisioning_by_team WHERE team = ?" - delByTeam :: PrepQuery W (Identity TeamId) () - delByTeam = "DELETE FROM team_provisioning_by_team WHERE team = ?" - -updateScimTokenName :: (HasCallStack, MonadClient m) => TeamId -> ScimTokenId -> Text -> m () -updateScimTokenName team tokenid name = do - mbToken <- retry x1 . query1 selById $ params LocalQuorum (team, tokenid) + sel :: Keyspace -> PrepQuery R (Identity TeamId) (Identity ScimTokenLookupKey) + sel ks = fromString $ "SELECT token_ FROM " <> table ks "team_provisioning_by_team" <> " WHERE team = ?" + delByTeam :: Keyspace -> PrepQuery W (Identity TeamId) () + delByTeam ks = fromString $ "DELETE FROM " <> table ks "team_provisioning_by_team" <> " WHERE team = ?" + +updateScimTokenName :: (HasCallStack, MonadClient m) => Keyspace -> TeamId -> ScimTokenId -> Text -> m () +updateScimTokenName keyspace team tokenid name = do + mbToken <- retry x1 . query1 (selById keyspace) $ params LocalQuorum (team, tokenid) retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery updateNameById (name, team, tokenid) + addPrepQuery (updateNameById keyspace) (name, team, tokenid) for_ mbToken $ \(Identity key) -> - addPrepQuery updateNameByTokenLookup (name, key) + addPrepQuery (updateNameByTokenLookup keyspace) (name, key) where - updateNameById :: PrepQuery W (Text, TeamId, ScimTokenId) () - updateNameById = - [r| - UPDATE team_provisioning_by_team - SET name = ? - WHERE team = ? AND id = ? - |] - - updateNameByTokenLookup :: PrepQuery W (Text, ScimTokenLookupKey) () - updateNameByTokenLookup = - [r| - UPDATE team_provisioning_by_token - SET name = ? - WHERE token_ = ? - |] + updateNameById :: Keyspace -> PrepQuery W (Text, TeamId, ScimTokenId) () + updateNameById ks = fromString $ "UPDATE " <> table ks "team_provisioning_by_team" <> " SET name = ? WHERE team = ? AND id = ?" + + updateNameByTokenLookup :: Keyspace -> PrepQuery W (Text, ScimTokenLookupKey) () + updateNameByTokenLookup ks = fromString $ "UPDATE " <> table ks "team_provisioning_by_token" <> " SET name = ? WHERE token_ = ?" type ScimTokenRow = (ScimTokenLookupKey, TeamId, ScimTokenId, UTCTime, Maybe SAML.IdPId, Text, Maybe Text) @@ -248,3 +244,6 @@ fromScimTokenRow (_, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr, stiName) = stiDescr, stiName = fromMaybe (idToText stiId) stiName } + +table :: Keyspace -> String -> String +table = qualifiedTableName