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