From e0f022d9a80edc30407f095490b279c7042b9b9c Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 25 Oct 2026 18:40:13 +0000 Subject: [PATCH 1/3] agent, server: use stm-containers for STM maps and sets --- simplexmq.cabal | 5 +- src/Simplex/FileTransfer/Agent.hs | 2 +- src/Simplex/FileTransfer/Server/Store.hs | 26 ++-- .../FileTransfer/Server/Store/Postgres.hs | 9 +- src/Simplex/FileTransfer/Server/StoreLog.hs | 8 +- src/Simplex/Messaging/Agent.hs | 26 ++-- src/Simplex/Messaging/Agent/Client.hs | 142 +++++++++--------- .../Messaging/Agent/NtfSubSupervisor.hs | 3 +- .../Messaging/Agent/Store/SQLite/DB.hs | 5 + src/Simplex/Messaging/Agent/TSessionSubs.hs | 35 +++-- src/Simplex/Messaging/Client.hs | 2 +- src/Simplex/Messaging/Client/Agent.hs | 38 ++--- src/Simplex/Messaging/Crypto.hs | 5 +- .../Messaging/Notifications/Protocol.hs | 10 ++ src/Simplex/Messaging/Notifications/Server.hs | 17 ++- .../Messaging/Notifications/Server/Stats.hs | 4 +- .../Messaging/Notifications/Server/Store.hs | 15 +- src/Simplex/Messaging/Protocol.hs | 6 +- src/Simplex/Messaging/Server.hs | 76 +++++----- src/Simplex/Messaging/Server/Env/STM.hs | 34 +++-- src/Simplex/Messaging/Server/Main.hs | 5 +- src/Simplex/Messaging/Server/MsgStore/STM.hs | 5 +- src/Simplex/Messaging/Server/NtfStore.hs | 4 +- .../Messaging/Server/QueueStore/STM.hs | 71 ++++----- .../Messaging/Server/StoreLog/ReadWrite.hs | 3 +- src/Simplex/Messaging/Session.hs | 11 +- src/Simplex/Messaging/TMap.hs | 128 +++++++++++----- src/Simplex/Messaging/TSet.hs | 65 ++++++++ src/Simplex/Messaging/Transport.hs | 3 +- src/Simplex/Messaging/Transport/Client.hs | 8 + src/Simplex/Messaging/Transport/Server.hs | 18 +-- tests/AgentTests/FunctionalAPITests.hs | 3 +- tests/CoreTests/MsgStoreTests.hs | 6 +- tests/CoreTests/StoreLogTests.hs | 5 +- tests/CoreTests/TSessionSubs.hs | 3 +- tests/NtfClient.hs | 2 +- 36 files changed, 487 insertions(+), 321 deletions(-) create mode 100644 src/Simplex/Messaging/TSet.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 8a96732feb..728c10534b 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -161,6 +161,7 @@ library Simplex.Messaging.Session Simplex.Messaging.SystemTime Simplex.Messaging.TMap + Simplex.Messaging.TSet Simplex.Messaging.Transport Simplex.Messaging.Transport.Buffer Simplex.Messaging.Transport.Client @@ -375,11 +376,13 @@ library , data-default ==0.7.* , directory ==1.3.* , filepath ==1.4.* + , hashable ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 , iproute ==1.7.* , iso8601-time ==0.1.* + , list-t ==1.0.* , memory ==0.18.* , mtl >=2.3.1 && <3.0 , network >=3.1.2.7 && <3.2 @@ -391,6 +394,7 @@ library , simple-logger ==0.1.* , socks ==0.6.* , stm ==2.5.* + , stm-containers ==1.2.* , time ==1.12.* , time-manager ==0.0.* , tls >=1.9.0 && <1.10 @@ -405,7 +409,6 @@ library if !flag(client_library) build-depends: case-insensitive ==1.2.* - , hashable ==1.4.* , http-client >=0.7 && <0.8 , http-client-tls >=0.3 && <0.4 , ini ==0.4.1 diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index d839833630..a0aa559149 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -129,7 +129,7 @@ closeXFTPAgent a = do stopWorkers $ xftpSndWorkers a stopWorkers $ xftpDelWorkers a where - stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker) + stopWorkers workers = atomically (TM.flush workers) >>= mapM_ (liftIO . cancelWorker) xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId xftpReceiveFile' c userId vfd cfArgs approvedRelays = do diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 371a5eea45..e848ef3bf6 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -27,8 +27,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Int (Int64) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, isJust) -import Data.Set (Set) -import qualified Data.Set as S import Data.Word (Word32) import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId) import Simplex.FileTransfer.Transport (XFTPErrorType (..)) @@ -41,6 +39,8 @@ import System.IO (IOMode (..)) import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.TSet (TSet) +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (ifM) data FSType = FSMemory | FSPostgres @@ -53,7 +53,7 @@ data FileRec = FileRec { senderId :: SenderId, fileInfo :: FileInfo, filePath :: TVar (Maybe FilePath), - recipientIds :: TVar (Set RecipientId), + recipientIds :: TSet RecipientId, createdAt :: RoundedFileTime, expiresAt :: Maybe RoundedFileTime, fileStatus :: TVar ServerEntityStatus @@ -127,19 +127,19 @@ instance FileStoreClass STMFileStore where addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ withFile st senderId $ \FileRec {recipientIds} -> do - rIds <- readTVar recipientIds + memR <- TS.member rId recipientIds mem <- TM.member rId recipients - if rId `S.member` rIds || mem + if memR || mem then pure $ Left DUPLICATE_ else do - writeTVar recipientIds $! S.insert rId rIds + TS.insert rId recipientIds TM.insert rId (senderId, rKey) recipients pure $ Right () deleteFile STMFileStore {files, recipients} senderId = atomically $ do TM.lookupDelete senderId files >>= \case Just FileRec {recipientIds} -> do - readTVar recipientIds >>= mapM_ (`TM.delete` recipients) + TS.toSet recipientIds >>= mapM_ (`TM.delete` recipients) pure $ Right () _ -> pure $ Left AUTH @@ -150,7 +150,7 @@ instance FileStoreClass STMFileStore where deleteRecipient STMFileStore {recipients} rId FileRec {recipientIds} = atomically $ do TM.delete rId recipients - modifyTVar' recipientIds $ S.delete rId + TS.delete rId recipientIds getFile st party fId = atomically $ case party of SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f)) @@ -163,12 +163,12 @@ instance FileStoreClass STMFileStore where TM.lookupDelete recipientId recipients >>= \case Just (sId, _) -> withFile st sId $ \FileRec {recipientIds} -> do - modifyTVar' recipientIds $ S.delete recipientId + TS.delete recipientId recipientIds pure $ Right () _ -> pure $ Left AUTH expiredFiles STMFileStore {files} now old _limit = do - fs <- readTVarIO files + fs <- TM.toMapIO files fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) -> let expired = case expiresAt of Just e -> roundedSeconds e < roundedSeconds now @@ -179,18 +179,18 @@ instance FileStoreClass STMFileStore where pure $ Just (sId, path, size) else pure Nothing - getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files + getUsedStorage STMFileStore {files} = TM.foldIO (\acc -> addSize acc . snd) 0 files where addSize acc FileRec {fileInfo = FileInfo {size}, filePath} = ifM (isJust <$> readTVarIO filePath) (pure $! acc + fromIntegral size) (pure acc) - getFileCount STMFileStore {files} = M.size <$> readTVarIO files + getFileCount STMFileStore {files} = TM.sizeIO files -- Internal STM helpers newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec newFileRec senderId fileInfo createdAt expiresAt status = do - recipientIds <- newTVar S.empty + recipientIds <- TS.empty filePath <- newTVar Nothing fileStatus <- newTVar status pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index c9e83c4c5d..2dd35e0fab 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -30,7 +30,6 @@ import Data.Int (Int32, Int64) import Data.List (intersperse) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import qualified Data.Set as S import Data.Text (Text) import Data.Word (Word32) import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), SqlError, (:.) (..)) @@ -56,6 +55,8 @@ import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.QueueStore.Postgres () import Simplex.Messaging.Server.StoreLog (openWriteStoreLog) import Simplex.Messaging.SystemTime (roundedSeconds) +import qualified Simplex.Messaging.TMap as TM +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (firstRow, tshow) import System.Directory (renameFile) import System.Exit (exitFailure) @@ -178,7 +179,7 @@ instance FileStoreClass PostgresFileStore where mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec mkFileRec senderId fileInfo path createdAt expiresAt status = do filePath <- newTVarIO path - recipientIds <- newTVarIO S.empty + recipientIds <- TS.emptyIO fileStatus <- newTVarIO status pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} @@ -228,8 +229,8 @@ importFileStore storeLogFilePath dbCfg = do stmStore <- newFileStore () :: IO STMFileStore sl <- readWriteFileStore storeLogFilePath stmStore closeStoreLog sl - allFiles <- readTVarIO (files stmStore) - allRcps <- readTVarIO (recipients stmStore) + allFiles <- TM.toMapIO $ files stmStore + allRcps <- TM.toMapIO $ recipients stmStore let fileCount = M.size allFiles rcpCount = M.size allRcps putStrLn $ "Loaded " <> show fileCount <> " files, " <> show rcpCount <> " recipients." diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 5a6d99c7a3..a1cd17bafa 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -40,6 +40,8 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.StoreLog +import qualified Simplex.Messaging.TMap as TM +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (bshow) import System.FilePath (takeFileName) import System.IO @@ -132,14 +134,14 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO () writeFileStore s STMFileStore {files, recipients} = do - allRcps <- readTVarIO recipients - readTVarIO files >>= mapM_ (logFile allRcps) + allRcps <- TM.toMapIO recipients + TM.toMapIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus logAddFile s senderId fileInfo createdAt expiresAt status - (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds + (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> TS.toSetIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs readTVarIO filePath >>= mapM_ (logPutFile s senderId) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 5862f3b7cd..d6ed85afc2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -326,9 +326,9 @@ logServersStats c = do saveServersStats :: AgentClient -> AM' () saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats, ntfServersStats} = do - sss <- mapM (liftIO . getAgentSMPServerStats) =<< readTVarIO smpServersStats - xss <- mapM (liftIO . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats - nss <- mapM (liftIO . getAgentNtfServerStats) =<< readTVarIO ntfServersStats + sss <- mapM (liftIO . getAgentSMPServerStats) =<< liftIO (TM.toMapIO smpServersStats) + xss <- mapM (liftIO . getAgentXFTPServerStats) =<< liftIO (TM.toMapIO xftpServersStats) + nss <- mapM (liftIO . getAgentNtfServerStats) =<< liftIO (TM.toMapIO ntfServersStats) let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss} tryAllErrors' (withStore' c (`updateServersStats` stats)) >>= \case Left e -> atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) @@ -341,9 +341,9 @@ restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, ntfServers Right (startedAt, Nothing) -> atomically $ writeTVar srvStatsStartedAt startedAt Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss}) -> do atomically $ writeTVar srvStatsStartedAt startedAt - atomically . writeTVar smpServersStats =<< mapM (atomically . newAgentSMPServerStats') sss - atomically . writeTVar xftpServersStats =<< mapM (atomically . newAgentXFTPServerStats') xss - atomically . writeTVar ntfServersStats =<< mapM (atomically . newAgentNtfServerStats') nss + atomically . (`TM.replace` smpServersStats) =<< mapM (atomically . newAgentSMPServerStats') sss + atomically . (`TM.replace` xftpServersStats) =<< mapM (atomically . newAgentXFTPServerStats') xss + atomically . (`TM.replace` ntfServersStats) =<< mapM (atomically . newAgentNtfServerStats') nss disconnectAgentClient :: AgentClient -> IO () disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do @@ -719,7 +719,7 @@ setNetworkConfig :: AgentClient -> NetworkConfig -> AE () setNetworkConfig c@AgentClient {useNetworkConfig, proxySessTs} cfg' = do ts <- liftIO getCurrentTime (ok, changed) <- atomically $ do - useServices <- readTVar $ useClientServices c + useServices <- TM.toMap $ useClientServices c if any id useServices && sessionMode cfg' == TSMEntity then pure (False, False) else do @@ -918,10 +918,12 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue atomically $ TM.delete userId $ smpServers c atomically $ TM.delete userId $ xftpServers c atomically $ TM.delete userId $ useClientServices c - atomically $ modifyTVar' smpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) - atomically $ modifyTVar' xftpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) + atomically $ deleteUserStats smpServersStats + atomically $ deleteUserStats xftpServersStats lift $ saveServersStats c where + deleteUserStats :: TM.TMap (UserId, ProtocolServer p) s -> STM () + deleteUserStats m = TM.toMap m >>= mapM_ (`TM.delete` m) . filter ((userId ==) . fst) . M.keys delUser = whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId) @@ -1177,7 +1179,7 @@ createRcvQueue c nm userId connId srvWithAuth@(ProtoServerWithAuth srv _) enable checkClientNotices :: AgentClient -> SMPServerWithAuth -> AM () checkClientNotices AgentClient {clientNotices, presetServers} (ProtoServerWithAuth srv@(ProtocolServer {host}) _) = do - notices <- readTVarIO clientNotices + notices <- liftIO $ TM.toMapIO clientNotices unless (M.null notices) $ checkNotices notices =<< liftIO getSystemSeconds where srvKey @@ -1984,7 +1986,7 @@ subscribeAllConnections' c onlyNeeded activeUserId_ = handleErr $ do let userSrvs' = case activeUserId_ of Just activeUserId -> sortOn (\(uId, _) -> if uId == activeUserId then 0 else 1 :: Int) userSrvs Nothing -> userSrvs - useServices <- readTVarIO $ useClientServices c + useServices <- liftIO $ TM.toMapIO $ useClientServices c -- Service will be loaded for all user/server combinations: -- a) service is enabled for user ID and service record exists: subscription will be attempted, -- b) service is disabled and record exists: service record and all associations will be removed, @@ -3467,7 +3469,7 @@ debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do delLock <- atomically $ tryReadTMVar d pure AgentLocks {connLocks, invLocks, delLock} where - getLocks ls = atomically $ M.mapKeys (safeDecodeUtf8 . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls) + getLocks ls = atomically $ M.mapKeys (safeDecodeUtf8 . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< TM.toMap ls) getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth getSMPServer c userId = getNextSMPServer c userId [] diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index d892fcad03..e2da8e284e 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -214,6 +214,7 @@ import Data.Composition ((.:), (.:.)) import Data.Containers.ListUtils (nubOrd) import Data.Either (isRight, partitionEithers) import Data.Functor (($>)) +import Data.Hashable (Hashable) import Data.Int (Int64) import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty (..), (<|)) @@ -311,6 +312,8 @@ import Simplex.Messaging.Session import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.TSet (TSet) +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), newNtfCredsSMPVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials @@ -362,7 +365,7 @@ data AgentClient = AgentClient presetServers :: [SMPServer], userNetworkInfo :: TVar UserNetworkInfo, userNetworkUpdated :: TVar (Maybe UTCTime), - subscrConns :: TVar (Set ConnId), + subscrConns :: TSet ConnId, currentSubs :: TSessionSubs, removedSubs :: TMap (UserId, SMPServer) (TMap SMP.RecipientId SMPClientError), clientNotices :: TMap (Maybe SMPServer) (Maybe SystemSeconds), @@ -402,11 +405,11 @@ data SMPConnectedClient = SMPConnectedClient type ProxiedRelayVar = SessionVar (Either AgentErrorType ProxiedRelay) -getAgentWorker :: (Ord k, Show k, AnyError e, MonadUnliftIO m) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT e m ()) -> m Worker +getAgentWorker :: (Hashable k, Show k, AnyError e, MonadUnliftIO m) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT e m ()) -> m Worker getAgentWorker = getAgentWorker' id pure {-# INLINE getAgentWorker #-} -getAgentWorker' :: forall a k e m. (Ord k, Show k, AnyError e, MonadUnliftIO m) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT e m ()) -> m a +getAgentWorker' :: forall a k e m. (Hashable k, Show k, AnyError e, MonadUnliftIO m) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT e m ()) -> m a getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do atomically (getWorker >>= maybe createWorker whenExists) >>= \w -> runWorker w $> w where @@ -521,22 +524,22 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, entitlements, netCf active <- newTVarIO True subQ <- newTBQueueIO qSize msgQ <- newTBQueueIO qSize - smpServers <- newTVarIO $ M.map mkUserServers smp + smpServers <- TM.fromMapIO $ M.map mkUserServers smp smpClients <- TM.emptyIO - useClientServices <- newTVarIO useServices + useClientServices <- TM.fromMapIO useServices smpProxiedRelays <- TM.emptyIO ntfServers <- newTVarIO ntf ntfClients <- TM.emptyIO - xftpServers <- newTVarIO $ M.map mkUserServers xftp + xftpServers <- TM.fromMapIO $ M.map mkUserServers xftp xftpClients <- TM.emptyIO - userEntitlements <- newTVarIO entitlements + userEntitlements <- TM.fromMapIO entitlements useNetworkConfig <- newTVarIO (slowNetworkConfig netCfg, netCfg) userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True userNetworkUpdated <- newTVarIO Nothing - subscrConns <- newTVarIO S.empty + subscrConns <- TS.emptyIO currentSubs <- SS.emptyIO removedSubs <- TM.emptyIO - clientNotices <- newTVarIO notices + clientNotices <- TM.fromMapIO notices clientNoticesLock <- newTMVarIO () workerSeq <- newTVarIO 0 smpDeliveryWorkers <- TM.emptyIO @@ -796,7 +799,7 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess let qs = M.elems subs cs = nubOrd $ map qConnId qs -- this removes proxied relays that this client created sessions to - destSrvs <- M.keys <$> readTVar prs + destSrvs <- M.keys <$> TM.toMap prs forM_ destSrvs $ \destSrv -> TM.delete (userId, destSrv, cId) smpProxiedRelays pure (qs, cs, serviceSub_) @@ -1006,18 +1009,16 @@ closeAgentClient c = do closeProtocolServerClients c smpClients closeProtocolServerClients c ntfClients closeProtocolServerClients c xftpClients - atomically $ writeTVar (smpProxiedRelays c) M.empty - atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect + atomically $ TM.clear $ smpProxiedRelays c + atomically (TM.flush $ smpSubWorkers c) >>= mapM_ cancelReconnect clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst) clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker atomically $ SS.clear $ currentSubs c - clear subscrConns - clear getMsgLocks + atomically $ TS.clear $ subscrConns c + atomically $ TM.clear $ getMsgLocks c where clearWorkers :: Ord k => (AgentClient -> TMap k a) -> IO (Map k a) - clearWorkers workers = atomically $ swapTVar (workers c) mempty - clear :: Monoid m => (AgentClient -> TVar m) -> IO () - clear sel = atomically $ writeTVar (sel c) mempty + clearWorkers workers = atomically $ TM.flush $ workers c cancelReconnect :: SessionVar (Async ()) -> IO () cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel @@ -1041,15 +1042,15 @@ throwWhenNoDelivery c sq = closeProtocolServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO () closeProtocolServerClients c clientsSel = - atomically (clientsSel c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient_ c) + atomically (TM.flush $ clientsSel c) >>= mapM_ (forkIO . closeClient_ c) reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO () reconnectServerClients c clientsSel = - readTVarIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c) + TM.toMapIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c) reconnectSMPServer :: AgentClient -> UserId -> SMPServer -> IO () reconnectSMPServer c userId srv = do - cs <- readTVarIO $ smpClients c + cs <- TM.toMapIO $ smpClients c let vs = M.foldrWithKey srvClient [] cs mapM_ (forkIO . closeClient_ c) vs where @@ -1059,9 +1060,10 @@ reconnectSMPServer c userId srv = do closeUserXFTPClients :: AgentClient -> UserId -> IO () closeUserXFTPClients c userId = do - vs <- atomically $ stateTVar (xftpClients c) $ \cs -> - let (userCs, cs') = M.partitionWithKey (\(userId', _, _) _ -> userId == userId') cs - in (M.elems userCs, cs') + vs <- atomically $ do + userCs <- M.filterWithKey (\(userId', _, _) _ -> userId == userId') <$> TM.toMap (xftpClients c) + mapM_ (`TM.delete` xftpClients c) $ M.keys userCs + pure $ M.elems userCs mapM_ (forkIO . closeClient_ c) vs closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () @@ -1101,15 +1103,15 @@ withConnLocks :: AgentClient -> Set ConnId -> Text -> AM' a -> AM' a withConnLocks AgentClient {connLocks} = withLocksMap connLocks {-# INLINE withConnLocks #-} -withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a +withLockMap :: (Hashable k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a withLockMap = withGetLock . getMapLock {-# INLINE withLockMap #-} -withLocksMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a +withLocksMap :: (Hashable k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a withLocksMap = withGetLocks . getMapLock {-# INLINE withLocksMap #-} -getMapLock :: Ord k => TMap k Lock -> k -> STM Lock +getMapLock :: Hashable k => TMap k Lock -> k -> STM Lock getMapLock locks key = TM.lookup key locks >>= maybe newLock pure where newLock = createLock >>= \l -> TM.insert key l locks $> l @@ -1639,7 +1641,7 @@ subscribeQueues :: AgentClient -> Bool -> [RcvQueueSub] -> AM' [(RcvQueueSub, Ei subscribeQueues _ _ [] = pure [] subscribeQueues c withEvents qs = do (errs, qs') <- checkQueues c qs - atomically $ modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId qs')) + atomically $ mapM_ ((`TS.insert` subscrConns c) . qConnId) qs' qss <- batchQueues mkSMPTSession qs' <$> getSessionModeIO c mapM_ (addPendingSubs c) qss rs <- mapConcurrently (subscribeQueues_ c withEvents) qss @@ -1676,7 +1678,7 @@ subscribeUserServerQueues c userId srv qs = do let errs' = map (second Left) errs case L.nonEmpty qs_ of Just qs' -> do - atomically $ modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId $ L.toList qs')) + atomically $ mapM_ ((`TS.insert` subscrConns c) . qConnId) qs' addPendingSubs c (tSess, qs') rs <- subscribeQueues_ c True (tSess, qs') pure $ errs' <> L.toList rs @@ -1761,7 +1763,7 @@ processClientNotices c@AgentClient {presetServers} tSess notices = do tryAllErrors' (withStore' c $ \db -> (,) <$> updateClientNotices db tSess now notices <*> getClientNotices db presetServers) >>= \case Right (noticeIds, clntNotices) -> atomically $ do SS.updateClientNotices tSess noticeIds $ currentSubs c - writeTVar (clientNotices c) clntNotices + TM.replace clntNotices $ clientNotices c Left e -> do logError $ "processClientNotices error: " <> tshow e notifySub' c "" $ ERR e @@ -1879,7 +1881,7 @@ getRemovedSubs :: AgentClient -> (UserId, SMPServer) -> STM (TMap SMP.RecipientI getRemovedSubs AgentClient {removedSubs} k = TM.lookup k removedSubs >>= maybe new pure where new = do - s <- newTVar M.empty + s <- TM.empty TM.insert k s removedSubs pure s @@ -1887,7 +1889,7 @@ addNewQueueSubscription :: AgentClient -> RcvQueue -> SMPTransportSession -> Ses addNewQueueSubscription c rq' tSess sessId serviceId_ = do let rq = rcvQueueSub rq' same <- atomically $ do - modifyTVar' (subscrConns c) $ S.insert $ qConnId rq + TS.insert (qConnId rq) $ subscrConns c active <- activeClientSession c tSess sessId if active then SS.addActiveSub tSess sessId serviceId_ rq' $ currentSubs c @@ -1913,17 +1915,17 @@ hasRemovedSubscription c rq = do removeSubscription :: SomeRcvQueue q => AgentClient -> SMPTransportSession -> ConnId -> q -> STM () removeSubscription c tSess connId rq = do - modifyTVar' (subscrConns c) $ S.delete connId + TS.delete connId $ subscrConns c SS.deleteSub tSess (queueId rq) $ currentSubs c removeSubscriptions :: SomeRcvQueue q => AgentClient -> [ConnId] -> [q] -> STM () removeSubscriptions c connIds qs = do - unless (null connIds) $ modifyTVar' (subscrConns c) (`S.difference` (S.fromList connIds)) + mapM_ (`TS.delete` subscrConns c) connIds qss <- batchQueues mkSMPTSession qs <$> getSessionMode c forM_ qss $ \(tSess, qs') -> SS.batchDeleteSubs tSess (L.toList qs') $ currentSubs c getSubscriptions :: AgentClient -> IO (Set ConnId) -getSubscriptions = readTVarIO . subscrConns +getSubscriptions = TS.toSetIO . subscrConns {-# INLINE getSubscriptions #-} logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m () @@ -2095,11 +2097,9 @@ releaseGetLock c rq = releaseGetLocksIO :: SomeRcvQueue q => AgentClient -> [q] -> IO () releaseGetLocksIO _ [] = pure () -releaseGetLocksIO c rqs = do - locks <- readTVarIO $ getMsgLocks c +releaseGetLocksIO c rqs = forM_ rqs $ \rq -> - forM_ (M.lookup ((qServer rq, queueId rq)) locks) $ \lock -> - atomically $ tryPutTMVar lock () + TM.lookupIO (qServer rq, queueId rq) (getMsgLocks c) >>= mapM_ (\lock -> atomically $ tryPutTMVar lock ()) suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM () suspendQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = @@ -2643,7 +2643,7 @@ data ServerSessions = ServerSessions getAgentSubsTotal :: AgentClient -> [UserId] -> IO (SMPServerSubs, Bool) getAgentSubsTotal c userIds = do (ssActive, ssPending) <- SS.foldSessionSubs addSub (0, 0) $ currentSubs c - sess <- hasSession . M.toList =<< readTVarIO (smpClients c) + sess <- hasSession . M.toList =<< TM.toMapIO (smpClients c) pure (SMPServerSubs {ssActive, ssPending}, sess) where addSub :: (Int, Int) -> (SMPTransportSession, SS.SessSubs) -> IO (Int, Int) @@ -2662,17 +2662,17 @@ getAgentSubsTotal c userIds = do getAgentServersSummary :: AgentClient -> IO AgentServersSummary getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServersStats, srvStatsStartedAt, agentEnv} = do - sss <- mapM getAgentSMPServerStats =<< readTVarIO smpServersStats - xss <- mapM getAgentXFTPServerStats =<< readTVarIO xftpServersStats - nss <- mapM getAgentNtfServerStats =<< readTVarIO ntfServersStats + sss <- mapM getAgentSMPServerStats =<< TM.toMapIO smpServersStats + xss <- mapM getAgentXFTPServerStats =<< TM.toMapIO xftpServersStats + nss <- mapM getAgentNtfServerStats =<< TM.toMapIO ntfServersStats statsStartedAt <- readTVarIO srvStatsStartedAt - smpServersSessions <- countSessions =<< readTVarIO (smpClients c) + smpServersSessions <- countSessions =<< TM.toMapIO (smpClients c) smpServersSubs <- getServerSubs - xftpServersSessions <- countSessions =<< readTVarIO (xftpClients c) + xftpServersSessions <- countSessions =<< TM.toMapIO (xftpClients c) xftpRcvInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpRcvWorkers xftpSndInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpSndWorkers xftpDelInProgress <- getXFTPWorkerSrvs xftpDelWorkers - ntfServersSessions <- countSessions =<< readTVarIO (ntfClients c) + ntfServersSessions <- countSessions =<< TM.toMapIO (ntfClients c) pure AgentServersSummary { smpServersStats = sss, @@ -2695,7 +2695,7 @@ getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServ let add ss = ss {ssActive = ssActive ss + active, ssPending = ssPending ss + pending} pure $ M.alter (Just . add . fromMaybe (SMPServerSubs 0 0)) (userId, srv) subs Env {xftpAgent = XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}} = agentEnv - getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< readTVarIO workers + getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< TM.toMapIO workers where addSrv acc (srv, Worker {doWork}) = do hasWork <- atomically $ not <$> isEmptyTMVar doWork @@ -2734,11 +2734,11 @@ getAgentSubscriptions c = do (active', pending') <- SS.mapSubs (map (\rId -> subInfo (userId, srv, rId) Nothing) . M.keys) s pure (active' ++ active, pending' ++ pending) getRemoved :: IO [SubInfo] - getRemoved = foldM addSubInfo [] . M.assocs =<< readTVarIO (removedSubs c) + getRemoved = foldM addSubInfo [] . M.assocs =<< TM.toMapIO (removedSubs c) where addSubInfo :: [SubInfo] -> ((UserId, SMPServer), TMap SMP.RecipientId SMPClientError) -> IO [SubInfo] addSubInfo ss ((uId, srv), errs) = do - ss' <- map (\(rId, e) -> subInfo (uId, srv, rId) (Just e)) . M.assocs <$> readTVarIO errs + ss' <- map (\(rId, e) -> subInfo (uId, srv, rId) (Just e)) . M.assocs <$> TM.toMapIO errs pure $ ss' ++ ss subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err} @@ -2769,17 +2769,17 @@ data WorkersDetails = WorkersDetails getAgentWorkersDetails :: AgentClient -> IO AgentWorkersDetails getAgentWorkersDetails AgentClient {smpClients, ntfClients, xftpClients, smpDeliveryWorkers, asyncCmdWorkers, smpSubWorkers, agentEnv} = do - smpClients_ <- textKeys <$> readTVarIO smpClients - ntfClients_ <- textKeys <$> readTVarIO ntfClients - xftpClients_ <- textKeys <$> readTVarIO xftpClients - smpDeliveryWorkers_ <- workerStats . fmap fst =<< readTVarIO smpDeliveryWorkers - asyncCmdWorkers_ <- workerStats =<< readTVarIO asyncCmdWorkers - smpSubWorkers_ <- textKeys <$> readTVarIO smpSubWorkers - ntfWorkers_ <- workerStats =<< readTVarIO ntfWorkers - ntfSMPWorkers_ <- workerStats =<< readTVarIO ntfSMPWorkers - xftpRcvWorkers_ <- workerStats =<< readTVarIO xftpRcvWorkers - xftpSndWorkers_ <- workerStats =<< readTVarIO xftpSndWorkers - xftpDelWorkers_ <- workerStats =<< readTVarIO xftpDelWorkers + smpClients_ <- textKeys <$> TM.toMapIO smpClients + ntfClients_ <- textKeys <$> TM.toMapIO ntfClients + xftpClients_ <- textKeys <$> TM.toMapIO xftpClients + smpDeliveryWorkers_ <- workerStats . fmap fst =<< TM.toMapIO smpDeliveryWorkers + asyncCmdWorkers_ <- workerStats =<< TM.toMapIO asyncCmdWorkers + smpSubWorkers_ <- textKeys <$> TM.toMapIO smpSubWorkers + ntfWorkers_ <- workerStats =<< TM.toMapIO ntfWorkers + ntfSMPWorkers_ <- workerStats =<< TM.toMapIO ntfSMPWorkers + xftpRcvWorkers_ <- workerStats =<< TM.toMapIO xftpRcvWorkers + xftpSndWorkers_ <- workerStats =<< TM.toMapIO xftpSndWorkers + xftpDelWorkers_ <- workerStats =<< TM.toMapIO xftpDelWorkers pure AgentWorkersDetails { smpClients_, @@ -2833,17 +2833,17 @@ data WorkersSummary = WorkersSummary getAgentWorkersSummary :: AgentClient -> IO AgentWorkersSummary getAgentWorkersSummary AgentClient {smpClients, ntfClients, xftpClients, smpDeliveryWorkers, asyncCmdWorkers, smpSubWorkers, agentEnv} = do - smpClientsCount <- M.size <$> readTVarIO smpClients - ntfClientsCount <- M.size <$> readTVarIO ntfClients - xftpClientsCount <- M.size <$> readTVarIO xftpClients - smpDeliveryWorkersCount <- readTVarIO smpDeliveryWorkers >>= workerSummary . fmap fst - asyncCmdWorkersCount <- readTVarIO asyncCmdWorkers >>= workerSummary - smpSubWorkersCount <- M.size <$> readTVarIO smpSubWorkers - ntfWorkersCount <- readTVarIO ntfWorkers >>= workerSummary - ntfSMPWorkersCount <- readTVarIO ntfSMPWorkers >>= workerSummary - xftpRcvWorkersCount <- readTVarIO xftpRcvWorkers >>= workerSummary - xftpSndWorkersCount <- readTVarIO xftpSndWorkers >>= workerSummary - xftpDelWorkersCount <- readTVarIO xftpDelWorkers >>= workerSummary + smpClientsCount <- TM.sizeIO smpClients + ntfClientsCount <- TM.sizeIO ntfClients + xftpClientsCount <- TM.sizeIO xftpClients + smpDeliveryWorkersCount <- TM.toMapIO smpDeliveryWorkers >>= workerSummary . fmap fst + asyncCmdWorkersCount <- TM.toMapIO asyncCmdWorkers >>= workerSummary + smpSubWorkersCount <- TM.sizeIO smpSubWorkers + ntfWorkersCount <- TM.toMapIO ntfWorkers >>= workerSummary + ntfSMPWorkersCount <- TM.toMapIO ntfSMPWorkers >>= workerSummary + xftpRcvWorkersCount <- TM.toMapIO xftpRcvWorkers >>= workerSummary + xftpSndWorkersCount <- TM.toMapIO xftpSndWorkers >>= workerSummary + xftpDelWorkersCount <- TM.toMapIO xftpDelWorkers >>= workerSummary pure AgentWorkersSummary { smpClientsCount, @@ -2889,7 +2889,7 @@ getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo getAgentQueuesInfo AgentClient {msgQ, subQ, smpClients} = do msgQInfo <- atomically $ getTBQueueInfo msgQ subQInfo <- atomically $ getTBQueueInfo subQ - smpClientsMap <- readTVarIO smpClients + smpClientsMap <- TM.toMapIO smpClients let smpClientsMap' = M.mapKeys (decodeLatin1 . strEncode) smpClientsMap smpClientsQueues <- mapM getClientQueuesInfo smpClientsMap' pure AgentQueuesInfo {msgQInfo, subQInfo, smpClientsQueues} diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 7153abcbfd..c9424b2328 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -53,6 +53,7 @@ import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr) import qualified Simplex.Messaging.Protocol as SMP +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (catchAllErrors, catchAllErrors', diffToMicroseconds, threadDelay', tryAllErrors, tshow, whenM) import System.Random (randomR) import UnliftIO @@ -586,7 +587,7 @@ closeNtfSupervisor ns = do stopWorkers $ ntfSMPWorkers ns stopWorkers $ ntfTknDelWorkers ns where - stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker) + stopWorkers workers = atomically (TM.flush workers) >>= mapM_ (liftIO . cancelWorker) getNtfServer :: AgentClient -> AM' (Maybe NtfServer) getNtfServer c = do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 67cfa6213f..15cbb8756a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Agent.Store.SQLite.DB ( BoolInt (..), @@ -32,6 +33,7 @@ import Control.Exception import Control.Monad (when) import qualified Data.Aeson.TH as J import Data.ByteString (ByteString) +import Data.Hashable (Hashable (..)) import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -62,6 +64,9 @@ data Connection = Connection slow :: TMap Query SlowQueryStats } +instance Hashable Query where + hashWithSalt s = hashWithSalt s . SQL.fromQuery + data TrackQueries = TQAll | TQSlow Int64 | TQOff deriving (Eq) diff --git a/src/Simplex/Messaging/Agent/TSessionSubs.hs b/src/Simplex/Messaging/Agent/TSessionSubs.hs index a1db48c9ea..e8fe9e2a79 100644 --- a/src/Simplex/Messaging/Agent/TSessionSubs.hs +++ b/src/Simplex/Messaging/Agent/TSessionSubs.hs @@ -38,7 +38,6 @@ where import Control.Concurrent.STM import Control.Monad import Data.Int (Int64) -import Data.List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust) @@ -80,7 +79,7 @@ getSessSubs :: SMPTransportSession -> TSessionSubs -> STM SessSubs getSessSubs tSess ss = lookupSubs tSess ss >>= maybe new pure where new = do - s <- SessSubs <$> newTVar Nothing <*> newTVar M.empty <*> newTVar M.empty <*> newTVar Nothing <*> newTVar Nothing + s <- SessSubs <$> newTVar Nothing <*> TM.empty <*> TM.empty <*> newTVar Nothing <*> newTVar Nothing TM.insert tSess s $ sessionSubs ss pure s @@ -147,9 +146,9 @@ batchAddActiveSubs tSess sessId serviceId_ (rqs, serviceRQs) ss = do if Just sessId == sessId' then do TM.union qs $ activeSubs s - modifyTVar' (pendingSubs s) (`M.difference` qs) + mapM_ (`TM.delete` pendingSubs s) $ M.keys qs unless (null serviceRQs) $ forM_ serviceId_ $ \serviceId -> do - modifyTVar' (pendingSubs s) (`M.difference` serviceQs) + mapM_ (`TM.delete` pendingSubs s) $ M.keys serviceQs updateActiveService s serviceId (fromIntegral $ length serviceRQs) (mconcat $ map (queueIdHash . rcvId) serviceRQs) else do TM.union qs $ pendingSubs s @@ -167,7 +166,7 @@ updateActiveService s serviceId addN addIdsHash = do batchAddPendingSubs :: SMPTransportSession -> [RcvQueueSub] -> TSessionSubs -> STM () batchAddPendingSubs tSess rqs ss = do s <- getSessSubs tSess ss - modifyTVar' (pendingSubs s) $ M.union $ M.fromList $ map (\rq -> (rcvId rq, rq)) rqs + TM.union (M.fromList $ map (\rq -> (rcvId rq, rq)) rqs) $ pendingSubs s deletePendingSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM () deletePendingSub tSess rId = lookupSubs tSess >=> mapM_ (TM.delete rId . pendingSubs) @@ -175,7 +174,7 @@ deletePendingSub tSess rId = lookupSubs tSess >=> mapM_ (TM.delete rId . pending batchDeletePendingSubs :: SMPTransportSession -> S.Set RecipientId -> TSessionSubs -> STM () batchDeletePendingSubs tSess rIds = lookupSubs tSess >=> mapM_ (delete . pendingSubs) where - delete = (`modifyTVar'` (`M.withoutKeys` rIds)) + delete m = mapM_ (`TM.delete` m) rIds deleteSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM () deleteSub tSess rId = lookupSubs tSess >=> mapM_ (\s -> TM.delete rId (activeSubs s) >> TM.delete rId (pendingSubs s)) @@ -184,7 +183,7 @@ batchDeleteSubs :: SomeRcvQueue q => SMPTransportSession -> [q] -> TSessionSubs batchDeleteSubs tSess rqs = lookupSubs tSess >=> mapM_ (\s -> delete (activeSubs s) >> delete (pendingSubs s)) where rIds = S.fromList $ map queueId rqs - delete = (`modifyTVar'` (`M.withoutKeys` rIds)) + delete m = mapM_ (`TM.delete` m) rIds deleteServiceSub :: SMPTransportSession -> TSessionSubs -> STM () deleteServiceSub tSess = lookupSubs tSess >=> mapM_ (\s -> writeTVar (activeServiceSub s) Nothing >> writeTVar (pendingServiceSub s) Nothing) @@ -192,13 +191,13 @@ deleteServiceSub tSess = lookupSubs tSess >=> mapM_ (\s -> writeTVar (activeServ hasPendingSubs :: SMPTransportSession -> TSessionSubs -> STM Bool hasPendingSubs tSess = lookupSubs tSess >=> maybe (pure False) (\s -> anyM [hasSubs s, hasServiceSub s]) where - hasSubs = fmap (not . null) . readTVar . pendingSubs + hasSubs = fmap not . TM.null . pendingSubs hasServiceSub = fmap isJust . readTVar . pendingServiceSub getPendingSubs :: SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub, Maybe ServiceSub) getPendingSubs tSess = lookupSubs tSess >=> maybe (pure (M.empty, Nothing)) get where - get s = liftM2 (,) (readTVar $ pendingSubs s) (readTVar $ pendingServiceSub s) + get s = liftM2 (,) (TM.toMap $ pendingSubs s) (readTVar $ pendingServiceSub s) getPendingQueueSubs :: SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub) getPendingQueueSubs = getSubs_ pendingSubs @@ -209,7 +208,7 @@ getActiveSubs = getSubs_ activeSubs {-# INLINE getActiveSubs #-} getSubs_ :: (SessSubs -> TMap RecipientId RcvQueueSub) -> SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub) -getSubs_ subs tSess = lookupSubs tSess >=> maybe (pure M.empty) (readTVar . subs) +getSubs_ subs tSess = lookupSubs tSess >=> maybe (pure M.empty) (TM.toMap . subs) setSubsPending :: TransportSessionMode -> SMPTransportSession -> SessionId -> TSessionSubs -> STM (Map RecipientId RcvQueueSub, Maybe ServiceSub) setSubsPending mode tSess@(uId, srv, connId_) sessId tss@(TSessionSubs ss) @@ -226,7 +225,7 @@ setSubsPending mode tSess@(uId, srv, connId_) sessId tss@(TSessionSubs ss) sessId' <- readTVar $ subsSessId s if Just sessId == sessId' then run s else pure (M.empty, Nothing) setPendingChangeMode s = do - subs <- M.union <$> readTVar (activeSubs s) <*> readTVar (pendingSubs s) + subs <- M.union <$> TM.toMap (activeSubs s) <*> TM.toMap (pendingSubs s) unless (null subs) $ forM_ subs $ \rq -> addPendingSub (uId, srv, sessEntId (connId rq)) rq tss (subs,) <$> setServiceSubPending_ s @@ -235,10 +234,10 @@ setSubsPending_ :: SessSubs -> Maybe SessionId -> STM (Map RecipientId RcvQueueS setSubsPending_ s sessId_ = do writeTVar (subsSessId s) sessId_ let as = activeSubs s - subs <- readTVar as + subs <- TM.toMap as unless (null subs) $ do - writeTVar as M.empty - modifyTVar' (pendingSubs s) $ M.union subs + TM.clear as + TM.union subs $ pendingSubs s (subs,) <$> setServiceSubPending_ s setServiceSubPending_ :: SessSubs -> STM (Maybe ServiceSub) @@ -252,13 +251,13 @@ setServiceSubPending_ s = do updateClientNotices :: SMPTransportSession -> [(RecipientId, Maybe Int64)] -> TSessionSubs -> STM () updateClientNotices tSess noticeIds ss = do s <- getSessSubs tSess ss - modifyTVar' (pendingSubs s) $ \m -> foldl' (\m' (rcvId, clientNoticeId) -> M.adjust (\rq -> rq {clientNoticeId}) rcvId m') m noticeIds + forM_ noticeIds $ \(rcvId, clientNoticeId) -> TM.adjust (\rq -> rq {clientNoticeId}) rcvId $ pendingSubs s foldSessionSubs :: (a -> (SMPTransportSession, SessSubs) -> IO a) -> a -> TSessionSubs -> IO a -foldSessionSubs f a = foldM f a . M.assocs <=< readTVarIO . sessionSubs +foldSessionSubs f a = foldM f a . M.assocs <=< TM.toMapIO . sessionSubs mapSubs :: (Map RecipientId RcvQueueSub -> a) -> SessSubs -> IO (a, a) mapSubs f s = do - active <- readTVarIO $ activeSubs s - pending <- readTVarIO $ pendingSubs s + active <- TM.toMapIO $ activeSubs s + pending <- TM.toMapIO $ pendingSubs s pure (f active, f pending) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index ba4bceec5f..236435967b 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -655,7 +655,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS `E.finally` (failPendingRequests c >> disconnected c') failPendingRequests :: PClient v err msg -> IO () - failPendingRequests PClient {sentCommands} = atomically $ swapTVar sentCommands mempty >>= mapM_ failRequest + failPendingRequests PClient {sentCommands} = atomically $ TM.flush sentCommands >>= mapM_ failRequest where failRequest Request {pending, responseVar} = whenM (swapTVar pending False) $ void $ tryPutTMVar responseVar $ Left $ PCENetworkError NEFailedError diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 0d59f00b8f..47ea8a2c9b 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -298,7 +298,8 @@ connectClient ca@SMPClientAgent {agentCfg, dbService, smpClients, smpSessions, m updateQueueSubs qVar = do -- removing subscriptions that have matching sessionId to disconnected client -- and keep the other ones (they can be made by the new client) - subs <- M.map snd <$> stateTVar qVar (M.partition ((sessId ==) . fst)) + subs <- M.map snd . M.filter ((sessId ==) . fst) <$> TM.toMap qVar + mapM_ (`TM.delete` qVar) $ M.keys subs if M.null subs then pure Nothing else Just subs <$ addSubs_ (pendingQueueSubs ca) srv subs @@ -318,7 +319,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s where getWorkerVar ts = ifM - (noPending <$> getPending TM.lookup readTVar) + (noPending <$> getPending) (pure Nothing) -- prevent race with cleanup and adding pending queues in another call (Just <$> getSessVar workerSeq srv smpSubWorkers ts) newSubWorker :: SessionVar (Async ()) -> IO () @@ -328,7 +329,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s runSubWorker v = withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do subs_ <- atomically $ do - s <- getPending TM.lookup readTVar + s <- getPending if noPending s then cleanup v $> Nothing else pure $ Just s @@ -337,10 +338,10 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s loop ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs - getPending :: Monad m => (forall a. SMPServer -> TMap SMPServer a -> m (Maybe a)) -> (forall a. TVar a -> m a) -> m (Maybe ServiceSub, Maybe (Map QueueId C.APrivateAuthKey)) - getPending lkup rd = do - sSub <- lkup srv (pendingServiceSubs ca) $>>= rd - qSubs <- lkup srv (pendingQueueSubs ca) >>= mapM rd + getPending :: STM (Maybe ServiceSub, Maybe (Map QueueId C.APrivateAuthKey)) + getPending = do + sSub <- TM.lookup srv (pendingServiceSubs ca) $>>= readTVar + qSubs <- TM.lookup srv (pendingQueueSubs ca) >>= mapM TM.toMap pure (sSub, qSubs) cleanup :: SessionVar (Async ()) -> STM () cleanup v = do @@ -359,9 +360,9 @@ reconnectSMPClient ca@SMPClientAgent {agentCfg, agentParty} srv (sSub_, qSubs_) resubscribe smp = do mapM_ (smpSubscribeService ca smp srv) sSub_ forM_ qSubs_ $ \qSubs -> do - currSubs_ <- mapM readTVarIO =<< TM.lookupIO srv (activeQueueSubs ca) - let qSubs' :: [(QueueId, C.APrivateAuthKey)] = - maybe id (\currSubs -> filter ((`M.notMember` currSubs) . fst)) currSubs_ $ M.assocs qSubs + currSubs_ <- TM.lookupIO srv (activeQueueSubs ca) + qSubs' :: [(QueueId, C.APrivateAuthKey)] <- + maybe pure (\currSubs -> filterM (fmap not . (`TM.memberIO` currSubs) . fst)) currSubs_ $ M.assocs qSubs mapM_ (smpSubscribeQueues @p ca smp srv) $ toChunks (agentSubsBatchSize agentCfg) qSubs' notify :: MonadIO m => SMPClientAgent p -> SMPClientAgentEvent -> m () @@ -390,13 +391,13 @@ closeSMPClientAgent :: SMPClientAgent p -> IO () closeSMPClientAgent c = do atomically $ writeTVar (active c) False closeSMPServerClients c - atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect + atomically (TM.flush $ smpSubWorkers c) >>= mapM_ cancelReconnect where cancelReconnect :: SessionVar (Async ()) -> IO () cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel closeSMPServerClients :: SMPClientAgent p -> IO () -closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient) +closeSMPServerClients c = atomically (TM.flush $ smpClients c) >>= mapM_ (forkIO . closeClient) where closeClient v = atomically (readTMVar $ sessionVar v) >>= \case @@ -446,7 +447,7 @@ smpSubscribeQueues ca smp srv subs = do where processSubscriptions :: NonEmpty (Either SMPClientError (Maybe ServiceId)) -> STM (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) processSubscriptions rs = do - pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingQueueSubs ca) + pending <- maybe (pure S.empty) (\m -> S.fromList <$> filterM (`TM.member` m) (map fst $ L.toList subs)) =<< TM.lookup srv (pendingQueueSubs ca) let acc@(_, _, (qOks, sQs), notPending) = foldr (groupSub pending) (False, [], ([], []), []) (L.zip subs rs) unless (null qOks) $ addActiveSubs ca srv qOks unless (null sQs) $ forM_ smpServiceId $ \serviceId -> @@ -456,13 +457,13 @@ smpSubscribeQueues ca smp srv subs = do sessId = sessionId $ thParams smp smpServiceId = smpClientServiceId smp groupSub :: - Map QueueId C.APrivateAuthKey -> + S.Set QueueId -> ((QueueId, C.APrivateAuthKey), Either SMPClientError (Maybe ServiceId)) -> (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) -> (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks@(qOks, sQs), notPending) = case r of Right serviceId_ - | M.member qId pending -> + | S.member qId pending -> let oks' = case (smpServiceId, serviceId_) of (Just sId, Just sId') | sId == sId' -> (qOks, qId : sQs) _ -> ((qId, (sessId, pk)) : qOks, sQs) @@ -547,7 +548,10 @@ addSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> STM addSubs_ subs srv ss = TM.lookup srv subs >>= \case Just m -> TM.union ss m - _ -> TM.insertM srv (newTVar ss) subs + _ -> do + m <- TM.empty + TM.union ss m + TM.insert srv m subs setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe (ServiceSub, SessionId) -> STM () setActiveServiceSub = setServiceSub_ activeServiceSubs @@ -597,4 +601,4 @@ removePendingSubs = removeSubs_ . pendingQueueSubs {-# INLINE removePendingSubs #-} removeSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [QueueId] -> STM () -removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` S.fromList qs)) +removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (\m -> mapM_ (`TM.delete` m) qs) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index cc2d5cc508..fb0087727d 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -247,6 +247,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Constraint (Dict (..)) +import Data.Hashable (Hashable) import Data.Kind (Constraint, Type) import qualified Data.List.NonEmpty as L import Data.String @@ -1005,7 +1006,9 @@ instance Encoding AuthTag where -- | Certificate fingerpint newtype. -- -- Previously was used for server's public key hash in ad-hoc transport scheme, kept as is for compatibility. -newtype KeyHash = KeyHash {unKeyHash :: ByteString} deriving (Eq, Ord, Show) +newtype KeyHash = KeyHash {unKeyHash :: ByteString} + deriving (Eq, Ord, Show) + deriving newtype (Hashable) instance Encoding KeyHash where smpEncode = smpEncode . unKeyHash diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 44f096f9b4..5df8e13265 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -48,6 +48,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) +import Data.Hashable (Hashable (..)) import Data.Kind import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L @@ -381,6 +382,9 @@ data SMPQueueNtf = SMPQueueNtf } deriving (Eq, Ord, Show) +instance Hashable SMPQueueNtf where + hashWithSalt s SMPQueueNtf {smpServer, notifierId} = s `hashWithSalt` smpServer `hashWithSalt` notifierId + instance Encoding SMPQueueNtf where smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId) smpP = do @@ -402,6 +406,9 @@ data PushProvider | PPApnsNull -- used to test servers from the client - does not communicate with APNS deriving (Eq, Ord, Show) +instance Hashable PushProvider where + hashWithSalt s = hashWithSalt s . smpEncode + instance Encoding PushProvider where smpEncode = \case PPApnsDev -> "AD" @@ -437,6 +444,9 @@ instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode data DeviceToken = DeviceToken PushProvider ByteString deriving (Eq, Ord, Show) +instance Hashable DeviceToken where + hashWithSalt s (DeviceToken p t) = s `hashWithSalt` p `hashWithSalt` t + instance Encoding DeviceToken where smpEncode (DeviceToken p t) = smpEncode (p, t) smpP = DeviceToken <$> smpP <*> smpP diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 51687abddb..3454c38e87 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -78,6 +78,7 @@ import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), import Simplex.Messaging.Session import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer) @@ -147,9 +148,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} logNote "Saving server state..." saveServer NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber - liftIO $ readTVarIO smpSubscribers >>= mapM_ stopSubscriber + liftIO $ TM.toMapIO smpSubscribers >>= mapM_ stopSubscriber NtfPushServer {pushWorkers} <- asks pushServer - liftIO $ readTVarIO pushWorkers >>= mapM_ stopPushWorker + liftIO $ TM.toMapIO pushWorkers >>= mapM_ stopPushWorker liftIO $ closeSMPClientAgent smpAgent logNote "Server stopped" where @@ -272,7 +273,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} ntfActiveQueueSubs <- getSMPSubMetrics a activeQueueSubs ntfPendingServiceSubs <- getSMPServiceSubMetrics a pendingServiceSubs smpQueueCount ntfPendingQueueSubs <- getSMPSubMetrics a pendingQueueSubs - smpSessionCount <- M.size <$> readTVarIO smpSessions + smpSessionCount <- TM.sizeIO smpSessions apnsPushQLength <- pushWorkersQLength pushWorkers pure NtfRealTimeMetrics @@ -298,15 +299,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} getSMPSubMetrics a sel = getSubMetrics_ a sel countSubs where countSubs :: (NtfSMPSubMetrics, S.Set Text) -> (SMPServer, TMap NotifierId a) -> IO (NtfSMPSubMetrics, S.Set Text) - countSubs acc (srv, queueSubs) = subMetricsResult a acc srv . M.size <$> readTVarIO queueSubs + countSubs acc (srv, queueSubs) = subMetricsResult a acc srv <$> TM.sizeIO queueSubs getSubMetrics_ :: SMPClientAgent 'NotifierService -> - (SMPClientAgent 'NotifierService -> TVar (M.Map SMPServer sub')) -> + (SMPClientAgent 'NotifierService -> TMap SMPServer sub') -> ((NtfSMPSubMetrics, S.Set Text) -> (SMPServer, sub') -> IO (NtfSMPSubMetrics, S.Set Text)) -> IO NtfSMPSubMetrics getSubMetrics_ a sel countSubs = do - subs <- readTVarIO $ sel a + subs <- TM.toMapIO $ sel a let metrics = NtfSMPSubMetrics {ownSrvSubs = M.empty, otherServers = 0, otherSrvSubCount = 0} (metrics', otherSrvs) <- foldM countSubs (metrics, S.empty) $ M.assocs subs pure (metrics' :: NtfSMPSubMetrics) {otherServers = S.size otherSrvs} @@ -326,7 +327,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} host = safeDecodeUtf8 $ strEncode h getSMPWorkerMetrics :: SMPClientAgent 'NotifierService -> TMap SMPServer a -> IO NtfSMPWorkerMetrics - getSMPWorkerMetrics a v = workerMetrics a . M.keys <$> readTVarIO v + getSMPWorkerMetrics a v = workerMetrics a . M.keys <$> TM.toMapIO v workerMetrics :: SMPClientAgent 'NotifierService -> [SMPServer] -> NtfSMPWorkerMetrics workerMetrics a srvs = NtfSMPWorkerMetrics {ownServers = reverse ownSrvs, otherServers} where @@ -736,7 +737,7 @@ runPushWorker s srvHost_ isOwn q = forever $ do pushWorkersQLength :: TMap (Maybe T.Text, PushProvider, Int) PushWorkerVar -> IO Natural pushWorkersQLength workers = do - ws <- readTVarIO workers + ws <- TM.toMapIO workers foldM addQLength 0 ws where addQLength acc v = diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs index 18a746a8d8..0c294772d8 100644 --- a/src/Simplex/Messaging/Notifications/Server/Stats.hs +++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs @@ -333,10 +333,10 @@ instance StrEncoding StatsByServerData where serverP = (,) <$> strP_ <*> A.decimal getStatsByServer :: TMap Text (TVar Int) -> IO StatsByServerData -getStatsByServer s = readTVarIO s >>= fmap (StatsByServerData . M.toList) . mapM readTVarIO +getStatsByServer s = TM.toMapIO s >>= fmap (StatsByServerData . M.toList) . mapM readTVarIO setStatsByServer :: TMap Text (TVar Int) -> StatsByServerData -> IO () -setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . writeTVar s +setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . (`TM.replace` s) -- double lookup avoids STM transaction with a shared map in most cases incServerStat :: Text -> TMap Text (TVar Int) -> IO () diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index 294fe04989..e3d1fa4f75 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -36,7 +36,6 @@ import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) -import Data.Set (Set) import qualified Data.Set as S import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C @@ -46,6 +45,8 @@ import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServe import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.TSet (TSet) +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (whenM, ($>>=)) data NtfSTMStore = NtfSTMStore @@ -53,7 +54,7 @@ data NtfSTMStore = NtfSTMStore -- multiple registrations exist to protect from malicious registrations if token is compromised tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId), subscriptions :: TMap NtfSubscriptionId NtfSubData, - tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)), + tokenSubscriptions :: TMap NtfTokenId (TSet NtfSubscriptionId), subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId, tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData)), ntfServices :: TMap SMPServer ServiceId @@ -123,7 +124,7 @@ stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} = where removeRegs :: TMap ByteString NtfTokenId -> STM [NtfTokenId] removeRegs tknRegs = do - tIds <- filter ((/= tId) . snd) . M.assocs <$> readTVar tknRegs + tIds <- filter ((/= tId) . snd) . M.assocs <$> TM.toMap tknRegs forM_ tIds $ \(regKey, tId') -> do TM.delete regKey tknRegs TM.delete tId' $ tokens st @@ -157,7 +158,7 @@ deleteTokenSubs :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf] deleteTokenSubs st tknId = do qs <- TM.lookupDelete tknId (tokenSubscriptions st) - >>= mapM (readTVar >=> mapM deleteSub . S.toList) + >>= mapM (TS.toSet >=> mapM deleteSub . S.toList) pure $ maybe [] catMaybes qs where deleteSub subId = do @@ -173,11 +174,11 @@ stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} = TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub where newTokenSub = do - ts <- newTVar S.empty + ts <- TS.empty TM.insert tokenId ts $ tokenSubscriptions st pure ts insertSub ts = do - modifyTVar' ts $ S.insert subId + TS.insert subId ts TM.insert subId sub $ subscriptions st TM.insert smpQueue subId (subscriptionLookup st) -- return Nothing if subscription existed before @@ -190,7 +191,7 @@ stmDeleteNtfSubscription st subId = do ( \NtfSubData {smpQueue, tokenId} -> do TM.delete smpQueue $ subscriptionLookup st ts_ <- TM.lookup tokenId (tokenSubscriptions st) - forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId + forM_ ts_ $ TS.delete subId ) -- This function is expected to be called after store log is read, diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 8ff1bfcc0f..c9b036915a 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -258,6 +258,7 @@ import qualified Data.ByteString.Lazy as LB import Data.Char (isPrint, isSpace) import Data.Constraint (Dict (..)) import Data.Functor (($>)) +import Data.Hashable (Hashable (..)) import Data.Int (Int64) import Data.Kind import Data.List (foldl') @@ -1309,6 +1310,9 @@ data ProtocolServer p = ProtocolServer } deriving (Eq, Ord, Show) +instance Hashable (ProtocolServer p) where + hashWithSalt s ProtocolServer {host, port, keyHash} = s `hashWithSalt` host `hashWithSalt` port `hashWithSalt` keyHash + data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p) instance ProtocolTypeI p => IsString (ProtocolServer p) where @@ -1431,7 +1435,7 @@ serverStrP = do -- | Transmission correlation ID. newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show) - deriving newtype (Encoding) + deriving newtype (Encoding, Hashable) pattern NoCorrId :: CorrId pattern NoCorrId = CorrId "" diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index f38f0f829b..6e2cd93bd4 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -119,6 +119,7 @@ import Simplex.Messaging.Server.StoreLog (foldLogLines) import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server @@ -275,7 +276,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where updateSubConnected c = case clntSub of CSClient qId prevServiceId serviceId_ -> do - modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients + TS.insert clntId subClients -- add ID to server's subscribed cients as'' <- if prevServiceId == serviceId_ then pure [] else endServiceSub prevServiceId qId END case serviceId_ of Just serviceId -> do @@ -292,7 +293,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt as' <- endServiceSub serviceId qId DELD pure $ as ++ as' CSService serviceId changedSubs -> do - modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients + TS.insert clntId subClients -- add ID to server's subscribed cients modifyTVar' totalServiceSubs $ addServiceSubs changedSubs -- server count and IDs hash for all services cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers updateSubDisconnected = case clntSub of @@ -328,7 +329,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt endPreviousSubscriptions :: [PrevClientSub s] -> IO () endPreviousSubscriptions = mapM_ $ \(c, subAction, evt) -> do - atomically $ modifyTVar' pendingEvents $ IM.alter (Just . maybe [evt] (evt <|)) (clientId c) + atomically $ TM.alter (Just . maybe [evt] (evt <|)) (clientId c) pendingEvents case subAction of CSAEndSub qId -> atomically (endSub c qId) >>= unsubPrev -- like endSub, also removes the delivery subscription from the service client's subscriptions map, @@ -336,7 +337,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt CSAEndServiceSub qId -> atomically (endServiceQueueSub c qId) >>= unsubPrev CSADecreaseSubs changedSubs -> do atomically $ modifyTVar' totalServiceSubs $ subtractServiceSubs changedSubs - forM_ unsub_ $ \unsub -> atomically (swapTVar (clientSubs c) M.empty) >>= mapM_ unsub + forM_ unsub_ $ \unsub -> atomically (TM.flush $ clientSubs c) >>= mapM_ unsub where unsubPrev :: Maybe sub -> IO () unsubPrev s_ = sequence_ (unsub_ <*> s_) @@ -351,9 +352,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt decrease = subtractServiceSubs (1, queueIdHash qId) -- remove client from server's subscribed cients removeWhenNoSubs c = do - noClientSubs <- null <$> readTVar (clientSubs c) + noClientSubs <- TM.null $ clientSubs c noServiceSubs <- ((0 ==) . fst) <$> readTVar (clientServiceSubs c) - when (noClientSubs && noServiceSubs) $ modifyTVar' subClients $ IS.delete (clientId c) + when (noClientSubs && noServiceSubs) $ TS.delete (clientId c) subClients deliverNtfsThread :: Server s -> M s () deliverNtfsThread srv@Server {ntfSubscribers = ServerSubscribers {subClients, serviceSubscribers}} = do @@ -367,7 +368,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where runDeliverNtfs :: s -> NtfStore -> ServerStats -> IO () runDeliverNtfs ms ns'@(NtfStore ns) stats = do - ntfs <- M.assocs <$> readTVarIO ns + ntfs <- TM.foldIO (\acc ntf -> pure $ ntf : acc) [] ns unless (null ntfs) $ getQueueNtfServices @(StoreQueue s) (queueStore ms) ntfs >>= \case Left e -> logError $ "NOTIFICATIONS: getQueueNtfServices error " <> tshow e @@ -375,16 +376,15 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt forM_ sNtfs $ \(serviceId_, ntfs') -> case serviceId_ of Just sId -> getSubscribedClient sId serviceSubscribers >>= mapM_ (deliverServiceNtfs ntfs') Nothing -> do -- legacy code that does almost the same as before for non-service subscribers - cIds <- IS.toList <$> readTVarIO subClients + cIds <- S.toList <$> TS.toSetIO subClients forM_ cIds $ \cId -> getServerClient cId srv >>= mapM_ (deliverQueueNtfs ntfs') - atomically $ modifyTVar' ns (`M.withoutKeys` S.fromList (map fst deleted)) + atomically $ mapM_ ((`TM.delete` ns) . fst) deleted deleteEmptyNtfs ns' ntfs where deliverQueueNtfs ntfs' c@Client {ntfSubscriptions} = - whenM (currentClient readTVarIO c) $ do - subs <- readTVarIO ntfSubscriptions - unless (M.null subs) $ do - let ntfs'' = filter (\(nId, _) -> M.member nId subs) ntfs' + whenM (atomically $ currentClient c) $ + unlessM (atomically $ TM.null ntfSubscriptions) $ do + ntfs'' <- filterM (\(nId, _) -> TM.memberIO nId ntfSubscriptions) ntfs' tryAny (atomically $ flushSubscribedNtfs ntfs'' c) >>= updateNtfStats c deliverServiceNtfs ntfs' cv = readTVarIO cv >>= mapM_ deliver where @@ -396,12 +396,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ts_ <- foldM addNtfs [] ntfs forM_ (L.nonEmpty ts_) $ \ts -> do let cancelNtfs s = throwSTM $ userError $ s <> ", " <> show (length ts_) <> " ntfs kept" - unlessM (currentClient readTVar c) $ cancelNtfs "not current client" + unlessM (currentClient c) $ cancelNtfs "not current client" whenM (isFullTBQueue sndQ) $ cancelNtfs "sending queue full" writeTBQueue sndQ (ts, []) pure $ length ts_ - currentClient :: Monad m => (forall a. TVar a -> m a) -> Client s' -> m Bool - currentClient rd Client {clientId, connected} = (&&) <$> rd connected <*> (IS.member clientId <$> rd subClients) + currentClient :: Client s' -> STM Bool + currentClient Client {clientId, connected} = (&&) <$> readTVar connected <*> TS.member clientId subClients addNtfs :: [Transmission BrokerMsg] -> (NotifierId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg] addNtfs acc (nId, v) = readTVar v >>= \case @@ -429,8 +429,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt sendPending ntfSubscribers stats where sendPending ServerSubscribers {pendingEvents} stats = do - pending <- atomically $ swapTVar pendingEvents IM.empty - unless (null pending) $ forM_ (IM.assocs pending) $ \(cId, evts) -> + pending <- atomically $ TM.flush pendingEvents + unless (null pending) $ forM_ (M.assocs pending) $ \(cId, evts) -> getServerClient cId srv >>= mapM_ (enqueueEvts evts) where enqueueEvts evts c@Client {connected, sndQ} = @@ -712,15 +712,15 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts} where getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, totalServiceSubs, subClients} = do - subsCount <- M.size <$> getSubscribedClients queueSubscribers - subClientsCount <- IS.size <$> readTVarIO subClients - subServicesCount <- M.size <$> getSubscribedClients serviceSubscribers + subsCount <- getSubscribedClientsCount queueSubscribers + subClientsCount <- atomically $ TS.size subClients + subServicesCount <- getSubscribedClientsCount serviceSubscribers subServiceSubsCount <- fst <$> readTVarIO totalServiceSubs pure RTSubscriberMetrics {subsCount, subClientsCount, subServicesCount, subServiceSubsCount} getDeliveredMetrics ts' = foldM countClnt (RTSubscriberMetrics 0 0 0 0, emptyTimeBuckets) =<< getServerClients srv where countClnt acc@(metrics, times) Client {subscriptions} = do - (cnt, times') <- foldM countSubs (0, times) =<< readTVarIO subscriptions + (cnt, times') <- TM.foldIO (\r -> countSubs r . snd) (0, times) subscriptions pure $ if cnt > 0 then (metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, times') else acc @@ -804,7 +804,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt now <- liftIO getSystemTime let age = systemSeconds now - systemSeconds createdAt - subscriptions' <- bshow . M.size <$> readTVarIO subscriptions + subscriptions' <- bshow <$> TM.sizeIO subscriptions hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions'] CPStats -> withUserRole $ do ss <- unliftIO u $ asks serverStats @@ -855,7 +855,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt readTVarIO role >>= \case CPRAdmin -> do NtfStore ns <- unliftIO u $ asks ntfStore - ntfCount2 <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< readTVarIO ns + ntfCount2 <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< TM.toMapIO ns hPutStrLn h $ "ntfCount 2: " <> show ntfCount2 _ -> pure () putProxyStat "pRelays" pRelays @@ -893,8 +893,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt unliftIO u (asks sockets) >>= readTVarIO >>= mapM_ putSocketThreads where putSocketThreads (tcpPort, (_, _, active')) = do - active <- readTVarIO active' - forM_ (IM.toList active) $ \(sid, tid') -> + active <- TM.toMapIO active' + forM_ (M.toList active) $ \(sid, tid') -> deRefWeak tid' >>= \case Nothing -> hPutStrLn h $ intercalate "," [tcpPort, show sid, "", "gone", ""] Just tid -> do @@ -940,8 +940,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt -- TODO [certs rcv] service subscriptions clnts <- countSubClients activeSubs hPutStrLn h $ protoName <> " subscribed clients: " <> show (IS.size clnts) <> (if showIds then " " <> show (IS.toList clnts) else "") - clnts' <- readTVarIO subClients - hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (IS.size clnts') <> (if showIds then " " <> show clnts' else "") + clnts' <- TS.toSetIO subClients + hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (S.size clnts') <> (if showIds then " " <> show clnts' else "") where countSubClients :: Map QueueId (TVar (Maybe (Client s))) -> IO IS.IntSet countSubClients = foldM (\ !s c -> maybe s ((`IS.insert` s) . clientId) <$> readTVarIO c) IS.empty @@ -950,7 +950,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> Client s -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) cl = do - subs <- readTVarIO $ subSel cl + subs <- TM.toMapIO $ subSel cl cnts' <- case countSubs_ of Nothing -> pure cnts Just countSubs -> do @@ -1083,7 +1083,7 @@ runClientTransport h@THandle {params = thParams@THandleParams {sessionId}} = do noSubscriptions Client {clientId} s = not <$> anyM [hasSubs (subscribers s), hasSubs (ntfSubscribers s)] where - hasSubs ServerSubscribers {subClients} = IS.member clientId <$> readTVarIO subClients + hasSubs ServerSubscribers {subClients} = atomically $ TS.member clientId subClients controlPortAuth :: Handle -> Maybe BasicAuth -> Maybe BasicAuth -> TVar CPClientRole -> BasicAuth -> IO () controlPortAuth h user admin role auth = do @@ -1106,8 +1106,8 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, serviceS -- these can be in separate transactions, -- because the client already disconnected and they won't change atomically $ writeTVar connected False - subs <- atomically $ swapTVar subscriptions M.empty - ntfSubs <- atomically $ swapTVar ntfSubscriptions M.empty + subs <- atomically $ TM.flush subscriptions + ntfSubs <- atomically $ TM.flush ntfSubscriptions liftIO $ mapM_ cancelSub subs whenM (asks serverActive >>= readTVarIO) $ do srv@Server {subscribers, ntfSubscribers} <- asks server @@ -1120,13 +1120,13 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, serviceS | serviceRole == SRMessaging -> updateServiceSubs serviceId serviceSubsCount subscribers | serviceRole == SRNotifier -> updateServiceSubs serviceId ntfServiceSubsCount ntfSubscribers _ -> pure () - tIds <- atomically $ swapTVar endThreads IM.empty + tIds <- atomically $ TM.flush endThreads liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds where updateSubscribers :: Map QueueId a -> ServerSubscribers s -> IO () updateSubscribers subs ServerSubscribers {queueSubscribers, subClients} = do mapM_ (\qId -> deleteSubcribedClient qId c queueSubscribers) (M.keys subs) - atomically $ modifyTVar' subClients $ IS.delete clientId + atomically $ TS.delete clientId subClients updateServiceSubs :: ServiceId -> TVar (Int64, IdsHash) -> ServerSubscribers s -> IO () updateServiceSubs serviceId subsCount ServerSubscribers {totalServiceSubs, serviceSubscribers} = do deleteSubcribedClient serviceId c serviceSubscribers @@ -1402,8 +1402,8 @@ forkClient Client {endThreads, endThreadSeq} label action = do tId <- atomically $ stateTVar endThreadSeq $ \next -> (next, next + 1) t <- forkIO $ do labelMyThread label - action `finally` atomically (modifyTVar' endThreads $ IM.delete tId) - mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId + action `finally` atomically (TM.delete tId endThreads) + mkWeakThreadId t >>= \w -> atomically $ TM.insert tId w endThreads client :: forall s. MsgStoreClass s => Server s -> s -> Client s -> M s () client @@ -2472,7 +2472,7 @@ saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs logNote $ "saving notifications to file " <> T.pack f NtfStore ns <- asks ntfStore liftIO . withFile f WriteMode $ \h -> - readTVarIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs + TM.toMapIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs logNote "notifications saved" where -- reverse on save, to save notifications in order, will become reversed again when restoring. @@ -2497,7 +2497,7 @@ restoreServerNtfs = Right (lineCount, storedMsgsCount, expiredMsgsCount) -> do renameFile f $ f <> ".bak" let NtfStore ns' = ns - storedQueues <- M.size <$> readTVarIO ns' + storedQueues <- TM.sizeIO ns' logNote $ "notifications restored, " <> tshow lineCount <> " lines processed" pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 4c0b1d566e..5a7503aeb5 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -50,6 +50,7 @@ module Simplex.Messaging.Server.Env.STM insertServerClient, deleteServerClient, getSubscribedClients, + getSubscribedClientsCount, getSubscribedClient, upsertSubscribedClient, lookupSubscribedClient, @@ -85,8 +86,6 @@ import Crypto.Random import Data.Int (Int64) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM -import Data.IntSet (IntSet) -import qualified Data.IntSet as IS import Data.Kind (Constraint) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) @@ -124,6 +123,8 @@ import Simplex.Messaging.Server.StoreLog.ReadWrite import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.TSet (TSet) +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP) import Simplex.Messaging.Transport.Server import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=)) @@ -344,15 +345,15 @@ data Server s = Server } -- not exported, to prevent concurrent IntMap lookups inside STM transactions. -newtype ServerClients s = ServerClients {serverClients :: TVar (IntMap (Client s))} +newtype ServerClients s = ServerClients {serverClients :: TMap ClientId (Client s)} data ServerSubscribers s = ServerSubscribers { subQ :: TQueue (ClientSub, ClientId), queueSubscribers :: SubscribedClients s, serviceSubscribers :: SubscribedClients s, -- service clients with long-term certificates that have subscriptions totalServiceSubs :: TVar (Int64, IdsHash), - subClients :: TVar IntSet, -- clients with individual or service subscriptions - pendingEvents :: TVar (IntMap (NonEmpty (EntityId, BrokerMsg))) + subClients :: TSet ClientId, -- clients with individual or service subscriptions + pendingEvents :: TMap ClientId (NonEmpty (EntityId, BrokerMsg)) } -- not exported, to prevent accidental concurrent Map lookups inside STM transactions. @@ -365,7 +366,10 @@ data ServerSubscribers s = ServerSubscribers data SubscribedClients s = SubscribedClients (TMap EntityId (TVar (Maybe (Client s)))) getSubscribedClients :: SubscribedClients s -> IO (Map EntityId (TVar (Maybe (Client s)))) -getSubscribedClients (SubscribedClients cs) = readTVarIO cs +getSubscribedClients (SubscribedClients cs) = TM.toMapIO cs + +getSubscribedClientsCount :: SubscribedClients s -> IO Int +getSubscribedClientsCount (SubscribedClients cs) = TM.sizeIO cs getSubscribedClient :: EntityId -> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s)))) getSubscribedClient entId (SubscribedClients cs) = TM.lookupIO entId cs @@ -433,7 +437,7 @@ data Client s = Client sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]), msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), procThreads :: TVar Int, - endThreads :: TVar (IntMap (Weak ThreadId)), + endThreads :: TMap Int (Weak ThreadId), endThreadSeq :: TVar Int, clientTHParams :: THandleParams SMPVersion 'TServer, connected :: TVar Bool, @@ -457,18 +461,18 @@ data Sub = Sub newServer :: IO (Server s) newServer = do - clients <- ServerClients <$> newTVarIO mempty + clients <- ServerClients <$> TM.emptyIO subscribers <- newServerSubscribers ntfSubscribers <- newServerSubscribers savingLock <- createLockIO return Server {clients, subscribers, ntfSubscribers, savingLock} getServerClients :: Server s -> IO (IntMap (Client s)) -getServerClients = readTVarIO . serverClients . clients +getServerClients = TM.foldIO (\cs (cId, c) -> pure $! IM.insert cId c cs) IM.empty . serverClients . clients {-# INLINE getServerClients #-} getServerClient :: ClientId -> Server s -> IO (Maybe (Client s)) -getServerClient cId s = IM.lookup cId <$> getServerClients s +getServerClient cId = TM.lookupIO cId . serverClients . clients {-# INLINE getServerClient #-} insertServerClient :: Client s -> Server s -> IO Bool @@ -476,12 +480,12 @@ insertServerClient c@Client {clientId, connected} Server {clients} = atomically $ ifM (readTVar connected) - (True <$ modifyTVar' (serverClients clients) (IM.insert clientId c)) + (True <$ TM.insert clientId c (serverClients clients)) (pure False) {-# INLINE insertServerClient #-} deleteServerClient :: ClientId -> Server s -> IO () -deleteServerClient cId Server {clients} = atomically $ modifyTVar' (serverClients clients) $ IM.delete cId +deleteServerClient cId Server {clients} = atomically $ TM.delete cId $ serverClients clients {-# INLINE deleteServerClient #-} newServerSubscribers :: IO (ServerSubscribers s) @@ -490,8 +494,8 @@ newServerSubscribers = do queueSubscribers <- SubscribedClients <$> TM.emptyIO serviceSubscribers <- SubscribedClients <$> TM.emptyIO totalServiceSubs <- newTVarIO (0, mempty) - subClients <- newTVarIO IS.empty - pendingEvents <- newTVarIO IM.empty + subClients <- TS.emptyIO + pendingEvents <- TM.emptyIO pure ServerSubscribers {subQ, queueSubscribers, serviceSubscribers, totalServiceSubs, subClients, pendingEvents} newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> IO (Client s) @@ -506,7 +510,7 @@ newClient clientId qSize clientTHParams createdAt = do sndQ <- newTBQueueIO qSize msgQ <- newTBQueueIO qSize procThreads <- newTVarIO 0 - endThreads <- newTVarIO IM.empty + endThreads <- TM.emptyIO endThreadSeq <- newTVarIO 0 connected <- newTVarIO True rcvActiveAt <- newTVarIO createdAt diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 9966248388..50bc8778a8 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -101,6 +101,7 @@ import Simplex.Messaging.Server.QueueStore.Postgres (PostgresQueueStore, batchIn import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM) import System.Directory (renameFile) import System.IO (IOMode (..), withFile) @@ -618,8 +619,8 @@ importStoreLogToDatabase storeLogFile dbOpts = do let st = queueStore ms sl <- readWriteQueueStore True (mkQueue ms) storeLogFile st closeStoreLog sl - qs <- readTVarIO $ queues st - services' <- M.elems <$> readTVarIO (services st) + qs <- TM.toMapIO $ queues st + services' <- M.elems <$> TM.toMapIO (services st) let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL} ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg sCnt <- batchInsertServices services' ps diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 1f9b7a256b..b3ca84de0f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -36,6 +36,7 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.QueueStore.Types +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util ((<$$>), ($>>=)) data STMMsgStore = STMMsgStore @@ -95,8 +96,8 @@ instance MsgStoreClass STMMsgStore where loadedQueueCounts :: STMMsgStore -> IO LoadedQueueCounts loadedQueueCounts STMMsgStore {queueStore_ = st} = do - loadedQueueCount <- M.size <$> readTVarIO (queues st) - loadedNotifierCount <- M.size <$> readTVarIO (notifiers st) + loadedQueueCount <- TM.sizeIO $ queues st + loadedNotifierCount <- TM.sizeIO $ notifiers st pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount} mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing diff --git a/src/Simplex/Messaging/Server/NtfStore.hs b/src/Simplex/Messaging/Server/NtfStore.hs index 7673d5b9af..d8e7ef367c 100644 --- a/src/Simplex/Messaging/Server/NtfStore.hs +++ b/src/Simplex/Messaging/Server/NtfStore.hs @@ -14,10 +14,8 @@ module Simplex.Messaging.Server.NtfStore ) where import Control.Concurrent.STM -import Control.Monad (foldM) import Data.Functor (($>)) import Data.Int (Int64) -import qualified Data.Map.Strict as M import Data.Time.Clock.System (SystemTime (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -47,7 +45,7 @@ deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pu deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int deleteExpiredNtfs (NtfStore ns) old = - foldM (\expired -> fmap (expired +) . expireQueue) 0 . M.keys =<< readTVarIO ns + TM.foldIO (\expired -> fmap (expired +) . expireQueue . fst) 0 ns where expireQueue nId = atomically $ TM.lookup nId ns >>= maybe (pure 0) (expire nId) expire nId v = readTVar v >>= \case diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 8d56897b5c..f13ac871b3 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -36,7 +36,6 @@ import Data.Int (Int64) import Data.List (partition) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M -import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.X509.Validation as XV @@ -47,6 +46,8 @@ import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.TSet (TSet) +import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport (SMPServiceRole (..)) import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>)) import System.IO @@ -64,8 +65,8 @@ data STMQueueStore q = STMQueueStore data STMService = STMService { serviceRec :: ServiceRec, - serviceRcvQueues :: TVar (Set RecipientId, IdsHash), - serviceNtfQueues :: TVar (Set NotifierId, IdsHash) + serviceRcvQueues :: (TSet RecipientId, TVar IdsHash), + serviceNtfQueues :: (TSet NotifierId, TVar IdsHash) } setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO () @@ -97,9 +98,9 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where getEntityCounts :: STMQueueStore q -> IO EntityCounts getEntityCounts st = do - queueCount <- M.size <$> readTVarIO (queues st) - notifierCount <- M.size <$> readTVarIO (notifiers st) - ss <- readTVarIO (services st) + queueCount <- TM.sizeIO $ queues st + notifierCount <- TM.sizeIO $ notifiers st + ss <- TM.toMapIO $ services st rcvServiceQueuesCount <- serviceQueuesCount serviceRcvQueues ss ntfServiceQueuesCount <- serviceQueuesCount serviceNtfQueues ss pure @@ -113,7 +114,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where } where serviceCount role = M.foldl' (\ !n s -> if serviceRole (serviceRec s) == role then n + 1 else n) 0 - serviceQueuesCount serviceSel = foldM (\n s -> (n +) . S.size . fst <$> readTVarIO (serviceSel s)) 0 + serviceQueuesCount serviceSel = foldM (\n s -> (n +) <$> atomically (TS.size $ fst $ serviceSel s)) 0 addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData, rcvServiceId} = do @@ -145,17 +146,12 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where getQueues_ :: BatchParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] getQueues_ st _ party qIds = case party of - SRecipient -> do - qs <- readTVarIO queues - pure $ map (get qs) qIds - SNotifier -> do - ns <- readTVarIO notifiers - qs <- readTVarIO queues - pure $ map (get qs <=< get ns) qIds + SRecipient -> mapM (get queues) qIds + SNotifier -> mapM (\nId -> get notifiers nId $>>= get queues) qIds where STMQueueStore {queues, notifiers} = st - get :: M.Map QueueId a -> QueueId -> Either ErrorType a - get m = maybe (Left AUTH) Right . (`M.lookup` m) + get :: TMap QueueId a -> QueueId -> IO (Either ErrorType a) + get m qId = maybe (Left AUTH) Right <$> TM.lookupIO qId m getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData) getQueueLinkData _ q lnkId = atomically $ readQueueRec (queueRec q) $>>= pure . getData @@ -310,8 +306,8 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where TM.insert fp newSrvId serviceCerts pure $ Right (newSrvId, True) newSTMService = do - serviceRcvQueues <- newTVar (S.empty, mempty) - serviceNtfQueues <- newTVar (S.empty, mempty) + serviceRcvQueues <- (,) <$> TS.empty <*> newTVar mempty + serviceNtfQueues <- (,) <$> TS.empty <*> newTVar mempty pure STMService {serviceRec = sr, serviceRcvQueues, serviceNtfQueues} setQueueService :: (PartyI p, ServiceParty p) => STMQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ()) @@ -337,7 +333,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where let !q' = Just q {notifier = Just nc {ntfServiceId = serviceId}} updateServiceQueues serviceNtfQueues nId prevNtfSrvId writeTVar qr q' $> Right () - updateServiceQueues :: (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> Maybe ServiceId -> STM () + updateServiceQueues :: (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> Maybe ServiceId -> STM () updateServiceQueues serviceSel qId prevSrvId = do mapM_ (removeServiceQueue st serviceSel qId) prevSrvId mapM_ (addServiceQueue st serviceSel qId) serviceId @@ -348,24 +344,25 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where getQueueNtfServices :: STMQueueStore q -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)])) getQueueNtfServices st ntfs = do - ss <- readTVarIO (services st) + ss <- TM.toMapIO $ services st (ssNtfs, noServiceNtfs) <- if M.null ss then pure ([], ntfs) else foldM addService ([], ntfs) (M.assocs ss) - ns <- readTVarIO (notifiers st) - let (ntfs', deleteNtfs) = partition (\(nId, _) -> M.member nId ns) noServiceNtfs + ns <- S.fromList <$> filterM (`TM.memberIO` notifiers st) (map fst noServiceNtfs) + let (ntfs', deleteNtfs) = partition (\(nId, _) -> S.member nId ns) noServiceNtfs ssNtfs' = (Nothing, ntfs') : ssNtfs pure $ Right (ssNtfs', deleteNtfs) where addService (ssNtfs, ntfs') (serviceId, s) = do - (snIds, _) <- readTVarIO $ serviceNtfQueues s + snIds <- S.fromList <$> filterM (atomically . (`TS.member` fst (serviceNtfQueues s))) (map fst ntfs') let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs' pure ((Just serviceId, sNtfs) : ssNtfs, restNtfs) getServiceQueueCountHash :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType (Int64, IdsHash)) getServiceQueueCountHash st party serviceId = TM.lookupIO serviceId (services st) >>= - maybe (pure $ Left AUTH) (fmap (Right . first (fromIntegral . S.size)) . readTVarIO . serviceSel) + maybe (pure $ Left AUTH) (fmap (Right . first fromIntegral) . readCountHash . serviceSel) where - serviceSel :: STMService -> TVar (Set QueueId, IdsHash) + readCountHash (qs, idsHash) = atomically $ (,) <$> TS.size qs <*> readTVar idsHash + serviceSel :: STMService -> (TSet QueueId, TVar IdsHash) serviceSel = case party of SRecipientService -> serviceRcvQueues SNotifierService -> serviceNtfQueues @@ -375,13 +372,12 @@ foldRcvServiceQueues st serviceId f acc = TM.lookupIO serviceId (services st) >>= \case Nothing -> pure acc Just s -> - readTVarIO (serviceRcvQueues s) - >>= foldM (\a -> get >=> maybe (pure a) (f a)) acc . fst + TS.foldIO (\a -> get >=> maybe (pure a) (f a)) acc $ fst $ serviceRcvQueues s where get rId = TM.lookupIO rId (queues st) $>>= \q -> (q,) <$$> readTVarIO (queueRec q) withLoadedQueues :: Monoid a => STMQueueStore q -> (q -> IO a) -> IO a -withLoadedQueues st f = readTVarIO (queues st) >>= foldM run mempty +withLoadedQueues st f = TM.foldIO (\acc -> run acc . snd) mempty $ queues st where run !acc = fmap (acc <>) . f @@ -394,22 +390,21 @@ setStatus qr status = Just q -> (Right (), Just q {status}) Nothing -> (Left AUTH, Nothing) -addServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> ServiceId -> STM () -addServiceQueue = setServiceQueues_ S.insert +addServiceQueue :: STMQueueStore q -> (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> ServiceId -> STM () +addServiceQueue = setServiceQueues_ TS.insert {-# INLINE addServiceQueue #-} -removeServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> ServiceId -> STM () -removeServiceQueue = setServiceQueues_ S.delete +removeServiceQueue :: STMQueueStore q -> (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> ServiceId -> STM () +removeServiceQueue = setServiceQueues_ TS.delete {-# INLINE removeServiceQueue #-} -setServiceQueues_ :: (QueueId -> Set QueueId -> Set QueueId) -> STMQueueStore q -> (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> ServiceId -> STM () +setServiceQueues_ :: (QueueId -> TSet QueueId -> STM ()) -> STMQueueStore q -> (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> ServiceId -> STM () setServiceQueues_ updateSet st serviceSel qId serviceId = - TM.lookup serviceId (services st) >>= mapM_ (\v -> modifyTVar' (serviceSel v) update) + TM.lookup serviceId (services st) >>= mapM_ (update . serviceSel) where - update (s, idsHash) = - let !s' = updateSet qId s - !idsHash' = queueIdHash qId <> idsHash - in (s', idsHash') + update (s, idsHash) = do + updateSet qId s + modifyTVar' idsHash (queueIdHash qId <>) removeNotifier :: STMQueueStore q -> NtfCreds -> STM () removeNotifier st NtfCreds {notifierId = nId, ntfServiceId} = do diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs index 21a5470aaa..dd85f892c7 100644 --- a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -23,12 +23,13 @@ import Simplex.Messaging.Server.QueueStore (QueueRec, ServiceRec (..)) import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..), withLoadedQueues) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (tshow, ($>>=)) import System.IO writeQueueStore :: forall q. StoreQueueClass q => StoreLog 'WriteMode -> STMQueueStore q -> IO () writeQueueStore s st = do - readTVarIO (services st) >>= mapM_ (logNewService s . serviceRec) + TM.toMapIO (services st) >>= mapM_ (logNewService s . serviceRec) withLoadedQueues st $ writeQueue where writeQueue :: q -> IO () diff --git a/src/Simplex/Messaging/Session.hs b/src/Simplex/Messaging/Session.hs index 16ff3c934e..5f72c238f6 100644 --- a/src/Simplex/Messaging/Session.hs +++ b/src/Simplex/Messaging/Session.hs @@ -15,6 +15,7 @@ import Control.Concurrent.STM import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Hashable (Hashable) import Data.Time (UTCTime) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -27,7 +28,7 @@ data SessionVar a = SessionVar sessionVarTs :: UTCTime } -getSessVar :: forall k a. Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> STM (Either (SessionVar a) (SessionVar a)) +getSessVar :: forall k a. Hashable k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> STM (Either (SessionVar a) (SessionVar a)) getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup sessKey vs where newSessionVar :: STM (SessionVar a) @@ -38,7 +39,7 @@ getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pur TM.insert sessKey v vs pure v -removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM () +removeSessVar :: Hashable k => SessionVar a -> k -> TMap k (SessionVar a) -> STM () removeSessVar v sessKey vs = TM.lookup sessKey vs >>= \case Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs @@ -51,7 +52,7 @@ removeSessVar v sessKey vs = -- A thrown ExceptT error is a normal result (the var keeps the error it was filled with) - only -- an interrupting exception drops the empty var. withGetSessVar :: - (Ord k, MonadUnliftIO m) => + (Hashable k, MonadUnliftIO m) => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> (SessionVar a -> ExceptT e m b) -> (SessionVar a -> ExceptT e m b) -> ExceptT e m b withGetSessVar sessSeq sessKey vs ts onNew onExisting = @@ -59,7 +60,7 @@ withGetSessVar sessSeq sessKey vs ts onNew onExisting = -- | withGetSessVar for actions in the underlying monad (without ExceptT). withGetSessVar' :: - (Ord k, MonadUnliftIO m) => + (Hashable k, MonadUnliftIO m) => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> (SessionVar a -> m b) -> (SessionVar a -> m b) -> m b withGetSessVar' sessSeq sessKey vs ts onNew onExisting = @@ -70,5 +71,5 @@ withGetSessVar' sessSeq sessKey vs ts onNew onExisting = where dropEmptySessVar v = whenM (isEmptyTMVar $ sessionVar v) $ removeSessVar v sessKey vs -tryReadSessVar :: Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a) +tryReadSessVar :: Hashable k => k -> TMap k (SessionVar a) -> STM (Maybe a) tryReadSessVar sessKey vs = TM.lookup sessKey vs $>>= (tryReadTMVar . sessionVar) diff --git a/src/Simplex/Messaging/TMap.hs b/src/Simplex/Messaging/TMap.hs index b09158d5fb..7b2a95396d 100644 --- a/src/Simplex/Messaging/TMap.hs +++ b/src/Simplex/Messaging/TMap.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE TupleSections #-} - module Simplex.Messaging.TMap ( TMap, emptyIO, + empty, + fromMapIO, singleton, clear, Simplex.Messaging.TMap.null, @@ -20,85 +20,137 @@ module Simplex.Messaging.TMap alter, alterF, union, + replace, + toMap, + toMapIO, + flush, + foldIO, + sizeIO, ) where import Control.Concurrent.STM +import Data.Hashable (Hashable) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Maybe (isJust) +import qualified ListT +import qualified StmContainers.Map as SM -type TMap k a = TVar (Map k a) +type TMap k a = SM.Map k a emptyIO :: IO (TMap k a) -emptyIO = newTVarIO M.empty +emptyIO = SM.newIO {-# INLINE emptyIO #-} -singleton :: k -> a -> STM (TMap k a) -singleton k v = newTVar $ M.singleton k v +empty :: STM (TMap k a) +empty = SM.new +{-# INLINE empty #-} + +fromMapIO :: Hashable k => Map k a -> IO (TMap k a) +fromMapIO m' = do + m <- SM.newIO + atomically $ union m' m + pure m +{-# INLINE fromMapIO #-} + +singleton :: Hashable k => k -> a -> STM (TMap k a) +singleton k v = do + m <- SM.new + SM.insert v k m + pure m {-# INLINE singleton #-} clear :: TMap k a -> STM () -clear m = writeTVar m M.empty +clear = SM.reset {-# INLINE clear #-} null :: TMap k a -> STM Bool -null m = M.null <$> readTVar m +null = SM.null {-# INLINE null #-} -lookup :: Ord k => k -> TMap k a -> STM (Maybe a) -lookup k m = M.lookup k <$> readTVar m +lookup :: Hashable k => k -> TMap k a -> STM (Maybe a) +lookup = SM.lookup {-# INLINE lookup #-} -lookupIO :: Ord k => k -> TMap k a -> IO (Maybe a) -lookupIO k m = M.lookup k <$> readTVarIO m +lookupIO :: Hashable k => k -> TMap k a -> IO (Maybe a) +lookupIO k = atomically . SM.lookup k {-# INLINE lookupIO #-} -member :: Ord k => k -> TMap k a -> STM Bool -member k m = M.member k <$> readTVar m +member :: Hashable k => k -> TMap k a -> STM Bool +member k m = isJust <$> SM.lookup k m {-# INLINE member #-} -memberIO :: Ord k => k -> TMap k a -> IO Bool -memberIO k m = M.member k <$> readTVarIO m +memberIO :: Hashable k => k -> TMap k a -> IO Bool +memberIO k = atomically . member k {-# INLINE memberIO #-} -insert :: Ord k => k -> a -> TMap k a -> STM () -insert k v m = modifyTVar' m $ M.insert k v +insert :: Hashable k => k -> a -> TMap k a -> STM () +insert k v = SM.insert v k {-# INLINE insert #-} -insertM :: Ord k => k -> STM a -> TMap k a -> STM () -insertM k f m = modifyTVar' m . M.insert k =<< f +insertM :: Hashable k => k -> STM a -> TMap k a -> STM () +insertM k f m = (\v -> SM.insert v k m) =<< f {-# INLINE insertM #-} -delete :: Ord k => k -> TMap k a -> STM () -delete k m = modifyTVar' m $ M.delete k +delete :: Hashable k => k -> TMap k a -> STM () +delete = SM.delete {-# INLINE delete #-} -lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a) -lookupInsert k v m = stateTVar m $ M.alterF (,Just v) k +lookupInsert :: Hashable k => k -> a -> TMap k a -> STM (Maybe a) +lookupInsert k v m = SM.lookup k m <* SM.insert v k m {-# INLINE lookupInsert #-} -lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a) -lookupDelete k m = stateTVar m $ M.alterF (,Nothing) k +lookupDelete :: Hashable k => k -> TMap k a -> STM (Maybe a) +lookupDelete k m = SM.lookup k m <* SM.delete k m {-# INLINE lookupDelete #-} -adjust :: Ord k => (a -> a) -> k -> TMap k a -> STM () -adjust f k m = modifyTVar' m $ M.adjust f k +adjust :: Hashable k => (a -> a) -> k -> TMap k a -> STM () +adjust f k m = mapM_ (\v -> SM.insert (f v) k m) =<< SM.lookup k m {-# INLINE adjust #-} -update :: Ord k => (a -> Maybe a) -> k -> TMap k a -> STM () -update f k m = modifyTVar' m $ M.update f k +update :: Hashable k => (a -> Maybe a) -> k -> TMap k a -> STM () +update f k m = mapM_ (set k m . f) =<< SM.lookup k m {-# INLINE update #-} -alter :: Ord k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM () -alter f k m = modifyTVar' m $ M.alter f k +alter :: Hashable k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM () +alter f k m = set k m . f =<< SM.lookup k m {-# INLINE alter #-} -alterF :: Ord k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM () -alterF f k m = do - mv <- M.alterF f k =<< readTVar m - writeTVar m $! mv +alterF :: Hashable k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM () +alterF f k m = set k m =<< f =<< SM.lookup k m {-# INLINE alterF #-} -union :: Ord k => Map k a -> TMap k a -> STM () -union m' m = modifyTVar' m $ M.union m' +union :: Hashable k => Map k a -> TMap k a -> STM () +union m' m = mapM_ (\(k, v) -> SM.insert v k m) $ M.toList m' {-# INLINE union #-} + +replace :: Hashable k => Map k a -> TMap k a -> STM () +replace m' m = SM.reset m >> union m' m +{-# INLINE replace #-} + +toMap :: Ord k => TMap k a -> STM (Map k a) +toMap = fmap M.fromList . ListT.toList . SM.listT +{-# INLINE toMap #-} + +toMapIO :: Ord k => TMap k a -> IO (Map k a) +toMapIO = foldIO (\m (k, v) -> pure $! M.insert k v m) M.empty +{-# INLINE toMapIO #-} + +flush :: Ord k => TMap k a -> STM (Map k a) +flush m = toMap m <* SM.reset m +{-# INLINE flush #-} + +foldIO :: (b -> (k, a) -> IO b) -> b -> TMap k a -> IO b +foldIO f acc0 = go acc0 . SM.listT + where + go acc l = atomically (ListT.uncons l) >>= maybe (pure acc) (\(kv, l') -> f acc kv >>= (`go` l')) +{-# INLINE foldIO #-} + +sizeIO :: TMap k a -> IO Int +sizeIO = foldIO (\n _ -> pure $! n + 1) 0 +{-# INLINE sizeIO #-} + +set :: Hashable k => k -> TMap k a -> Maybe a -> STM () +set k m = maybe (SM.delete k m) (\v -> SM.insert v k m) +{-# INLINE set #-} diff --git a/src/Simplex/Messaging/TSet.hs b/src/Simplex/Messaging/TSet.hs new file mode 100644 index 0000000000..4f1f09ac41 --- /dev/null +++ b/src/Simplex/Messaging/TSet.hs @@ -0,0 +1,65 @@ +module Simplex.Messaging.TSet + ( TSet, + emptyIO, + empty, + clear, + size, + member, + insert, + delete, + toSet, + toSetIO, + foldIO, + ) +where + +import Control.Concurrent.STM +import Data.Hashable (Hashable) +import Data.Set (Set) +import qualified Data.Set as S +import qualified ListT +import qualified StmContainers.Set as SS + +type TSet a = SS.Set a + +emptyIO :: IO (TSet a) +emptyIO = SS.newIO +{-# INLINE emptyIO #-} + +empty :: STM (TSet a) +empty = SS.new +{-# INLINE empty #-} + +clear :: TSet a -> STM () +clear = SS.reset +{-# INLINE clear #-} + +size :: TSet a -> STM Int +size = SS.size +{-# INLINE size #-} + +member :: Hashable a => a -> TSet a -> STM Bool +member = SS.lookup +{-# INLINE member #-} + +insert :: Hashable a => a -> TSet a -> STM () +insert = SS.insert +{-# INLINE insert #-} + +delete :: Hashable a => a -> TSet a -> STM () +delete = SS.delete +{-# INLINE delete #-} + +toSet :: Ord a => TSet a -> STM (Set a) +toSet = fmap S.fromList . ListT.toList . SS.listT +{-# INLINE toSet #-} + +toSetIO :: Ord a => TSet a -> IO (Set a) +toSetIO = foldIO (\s x -> pure $! S.insert x s) S.empty +{-# INLINE toSetIO #-} + +foldIO :: (b -> a -> IO b) -> b -> TSet a -> IO b +foldIO f acc0 = go acc0 . SS.listT + where + go acc l = atomically (ListT.uncons l) >>= maybe (pure acc) (\(x, l') -> f acc x >>= (`go` l')) +{-# INLINE foldIO #-} diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 32e33ad1a1..102f9fd2b6 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -122,6 +122,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Default (def) import Data.Functor (($>)) +import Data.Hashable (Hashable) import Data.Int (Int64) import Data.Kind (Type) import Data.Tuple (swap) @@ -528,7 +529,7 @@ type ServiceId = EntityId -- this type is used for server entities only newtype EntityId = EntityId {unEntityId :: ByteString} deriving (Eq, Ord, Show) - deriving newtype (Encoding, StrEncoding) + deriving newtype (Encoding, Hashable, StrEncoding) pattern NoEntity :: EntityId pattern NoEntity = EntityId "" diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index ab693ad69b..430e9efa1f 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -38,6 +38,7 @@ import qualified Data.ByteString.Char8 as B import Data.Char (isAsciiLower, isDigit, isHexDigit) import Data.Default (def) import Data.Functor (($>)) +import Data.Hashable (Hashable (..)) import Data.IORef import Data.IP import Data.List.NonEmpty (NonEmpty (..)) @@ -74,6 +75,13 @@ data TransportHost | THDomainName HostName deriving (Eq, Ord, Show) +instance Hashable TransportHost where + hashWithSalt s = \case + THIPv4 addr -> s `hashWithSalt` (0 :: Int) `hashWithSalt` addr + THIPv6 addr -> s `hashWithSalt` (1 :: Int) `hashWithSalt` addr + THOnionHost host -> s `hashWithSalt` (2 :: Int) `hashWithSalt` host + THDomainName host -> s `hashWithSalt` (3 :: Int) `hashWithSalt` host + instance Encoding TransportHost where smpEncode = smpEncode . strEncode smpP = parseAll strP <$?> smpP diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 568efb3bc6..456e94ac6f 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -37,8 +37,6 @@ import Control.Monad import qualified Crypto.Store.X509 as SX import qualified Data.ByteString as B import Data.Default (def) -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IM import Data.List (find) import Data.Maybe (fromJust, fromMaybe, maybeToList) import qualified Data.X509 as X @@ -48,6 +46,8 @@ import Foreign.C.Error import GHC.IO.Exception (ioe_errno) import Network.Socket import qualified Network.TLS as T +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Shared import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow, unlessM) @@ -177,11 +177,11 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId' `seq` (cId', cId') closed <- newTVarIO False let closeConn _ = do - atomically $ writeTVar closed True >> modifyTVar' clients (IM.delete cId) + atomically $ writeTVar closed True >> TM.delete cId clients gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier atomically $ modifyTVar' gracefullyClosed (+ 1) tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn - atomically $ unlessM (readTVar closed) $ modifyTVar' clients $ IM.insert cId tId + atomically $ unlessM (readTVar closed) $ TM.insert cId tId clients -- | Recover from errors in `accept` whenever it is safe. -- Some errors are safe to ignore, while blindly restaring `accept` may trigger a busy loop. @@ -206,7 +206,7 @@ safeAccept sock = err = "socket accept error: " <> tshow e <> maybe "" ((", errno=" <>) . tshow) errno errno = ioe_errno e -type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId))) +type SocketState = (TVar Int, TVar Int, TMap Int (Weak ThreadId)) data SocketStats = SocketStats { socketsAccepted :: Int, @@ -216,20 +216,20 @@ data SocketStats = SocketStats } newSocketState :: IO SocketState -newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO mempty +newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> TM.emptyIO getSocketStats :: SocketState -> IO SocketStats getSocketStats (accepted, closed, active) = do socketsAccepted <- readTVarIO accepted socketsClosed <- readTVarIO closed - socketsActive <- IM.size <$> readTVarIO active + socketsActive <- TM.sizeIO active let socketsLeaked = socketsAccepted - socketsClosed - socketsActive pure SocketStats {socketsAccepted, socketsClosed, socketsActive, socketsLeaked} -closeServer :: TMVar Bool -> TVar (IntMap (Weak ThreadId)) -> Socket -> IO () +closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO () closeServer started clients sock = do close sock - readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread) + TM.toMapIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread) void . atomically $ tryPutTMVar started False startTCPServer :: TMVar Bool -> Maybe HostName -> ServiceName -> IO Socket diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 7ed0d17b82..d5a17ca57d 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -115,6 +115,7 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..)) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, alpnSupportedSMPHandshakes) import Simplex.Messaging.Transport.Server (TransportServerConfig (..)) import Simplex.Messaging.Util (bshow, diffToMicroseconds) @@ -4524,7 +4525,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do exchangeGreetingsMsgId 6 a bId2' b aId2' where hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () - hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n + hasClients c n = liftIO $ TM.sizeIO (smpClients c) `shouldReturn` n reconnected :: HasCallStack => AgentClient -> [[ConnId]] -> [ConnId] -> ExceptT AgentErrorType IO () reconnected c downs ups = liftIO $ getInAnyOrder c $ map down downs <> map up ups where diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index badf7f2f13..e07727d4e9 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -246,7 +246,7 @@ queueMapSizes ms = (,,,) <$> size queues <*> size senders <*> size links <*> siz where STMQueueStore {queues, senders, links, notifiers} = queueStore ms size :: TMap k v -> IO Int - size = fmap M.size . readTVarIO + size = TM.sizeIO testDeleteQueueMaps :: STMMsgStore -> IO () testDeleteQueueMaps ms = do @@ -292,7 +292,7 @@ mkMsgNtf g ts = do pure MsgNtf {ntfMsgId, ntfTs = MkSystemTime ts 0, ntfNonce, ntfEncMeta = "meta"} ntfCounts :: NtfStore -> IO [(NotifierId, Int)] -ntfCounts (NtfStore ns) = M.assocs <$> (mapM (fmap length . readTVarIO) =<< readTVarIO ns) +ntfCounts (NtfStore ns) = M.assocs <$> (mapM (fmap length . readTVarIO) =<< TM.toMapIO ns) testExpireNtfs :: IO () testExpireNtfs = do @@ -324,7 +324,7 @@ testDeleteEmptyNtfs = do nId3 = EntityId "notifier 3" nId4 = EntityId "notifier 4" forM_ ([nId1, nId2, nId3, nId4] :: [NotifierId]) $ \nId -> storeNtf st nId =<< mkMsgNtf g now - ntfs <- M.assocs <$> readTVarIO ns + ntfs <- M.assocs <$> TM.toMapIO ns let flush nId = forM_ (lookup nId ntfs) $ \v -> atomically $ writeTVar v [] mapM_ flush ([nId1, nId2, nId4] :: [NotifierId]) storeNtf st nId2 =<< mkMsgNtf g now diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 45116d4a50..25d733f7ac 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -35,6 +35,7 @@ import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.SystemTime +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPServiceRole (..)) import Simplex.Messaging.Transport.Credentials (genCredentials) import System.FilePath (()) @@ -191,7 +192,7 @@ testSMPStoreLog testSuite tests = ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted storeState :: STMMsgStore -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (readTVarIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec)) + storeState st = M.mapMaybe id <$> (TM.toMapIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec)) type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) @@ -297,7 +298,7 @@ testXFTPStoreLog testSuite tests = ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile compacted' `shouldBe` compacted storeState :: STMFileStore -> IO (M.Map SenderId FileRecState) - storeState st = readTVarIO (files st) >>= mapM fileState + storeState st = TM.toMapIO (files st) >>= mapM fileState fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus pure (fileInfo, createdAt, expiresAt, status) diff --git a/tests/CoreTests/TSessionSubs.hs b/tests/CoreTests/TSessionSubs.hs index 96975e9efe..d4261f62e2 100644 --- a/tests/CoreTests/TSessionSubs.hs +++ b/tests/CoreTests/TSessionSubs.hs @@ -19,6 +19,7 @@ import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client (SMPTransportSession, TransportSessionMode (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SessionId) import Test.Hspec hiding (fit, it) import UnliftIO @@ -31,7 +32,7 @@ instance IsString EntityId where fromString = EntityId . B.pack dumpSessionSubs :: SS.TSessionSubs -> IO (M.Map SMPTransportSession (Maybe SessionId, (M.Map RecipientId RcvQueueSub, M.Map RecipientId RcvQueueSub))) dumpSessionSubs = - readTVarIO . SS.sessionSubs + TM.toMapIO . SS.sessionSubs >=> mapM (\s -> (,) <$> readTVarIO (SS.subsSessId s) <*> SS.mapSubs id s) srv1 :: SMPServer diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 79dac6dd39..9c4f7b78c8 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -303,7 +303,7 @@ getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest getAnyMockNotification APNSMockServer {notifications} = do - atomically $ readTVar notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf + atomically $ TM.toMap notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf closeAPNSMockServer :: APNSMockServer -> IO () closeAPNSMockServer APNSMockServer {action, http2Server} = do From 37ef0956fbbf4b2241c4cd12737a7adbf325f10b Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 25 Oct 2026 19:23:31 +0000 Subject: [PATCH 2/3] smp server: use stm-containers for the notification store --- simplexmq.cabal | 6 +- src/Simplex/FileTransfer/Agent.hs | 2 +- src/Simplex/FileTransfer/Server/Store.hs | 26 ++-- .../FileTransfer/Server/Store/Postgres.hs | 9 +- src/Simplex/FileTransfer/Server/StoreLog.hs | 8 +- src/Simplex/Messaging/Agent.hs | 26 ++-- src/Simplex/Messaging/Agent/Client.hs | 142 +++++++++--------- .../Messaging/Agent/NtfSubSupervisor.hs | 3 +- .../Messaging/Agent/Store/SQLite/DB.hs | 5 - src/Simplex/Messaging/Agent/TSessionSubs.hs | 35 ++--- src/Simplex/Messaging/Client.hs | 2 +- src/Simplex/Messaging/Client/Agent.hs | 38 +++-- src/Simplex/Messaging/Crypto.hs | 5 +- .../Messaging/Notifications/Protocol.hs | 10 -- src/Simplex/Messaging/Notifications/Server.hs | 17 +-- .../Messaging/Notifications/Server/Stats.hs | 4 +- .../Messaging/Notifications/Server/Store.hs | 15 +- src/Simplex/Messaging/Protocol.hs | 6 +- src/Simplex/Messaging/Server.hs | 84 +++++------ src/Simplex/Messaging/Server/Env/STM.hs | 37 +++-- src/Simplex/Messaging/Server/Main.hs | 5 +- src/Simplex/Messaging/Server/MsgStore/STM.hs | 5 +- src/Simplex/Messaging/Server/NtfStore.hs | 29 ++-- .../Messaging/Server/QueueStore/STM.hs | 71 +++++---- .../Messaging/Server/StoreLog/ReadWrite.hs | 3 +- src/Simplex/Messaging/Session.hs | 11 +- src/Simplex/Messaging/TMap.hs | 128 +++++----------- src/Simplex/Messaging/TSet.hs | 65 -------- src/Simplex/Messaging/Transport/Client.hs | 8 - src/Simplex/Messaging/Transport/Server.hs | 18 +-- tests/AgentTests/FunctionalAPITests.hs | 3 +- tests/CoreTests/MsgStoreTests.hs | 14 +- tests/CoreTests/StoreLogTests.hs | 5 +- tests/CoreTests/TSessionSubs.hs | 3 +- tests/NtfClient.hs | 2 +- 35 files changed, 346 insertions(+), 504 deletions(-) delete mode 100644 src/Simplex/Messaging/TSet.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 728c10534b..fbe8174109 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -161,7 +161,6 @@ library Simplex.Messaging.Session Simplex.Messaging.SystemTime Simplex.Messaging.TMap - Simplex.Messaging.TSet Simplex.Messaging.Transport Simplex.Messaging.Transport.Buffer Simplex.Messaging.Transport.Client @@ -382,7 +381,6 @@ library , http2 >=4.2.2 && <4.3 , iproute ==1.7.* , iso8601-time ==0.1.* - , list-t ==1.0.* , memory ==0.18.* , mtl >=2.3.1 && <3.0 , network >=3.1.2.7 && <3.2 @@ -394,7 +392,6 @@ library , simple-logger ==0.1.* , socks ==0.6.* , stm ==2.5.* - , stm-containers ==1.2.* , time ==1.12.* , time-manager ==0.0.* , tls >=1.9.0 && <1.10 @@ -412,9 +409,11 @@ library , http-client >=0.7 && <0.8 , http-client-tls >=0.3 && <0.4 , ini ==0.4.1 + , list-t ==1.0.* , network-uri >=2.6 && <2.7 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , stm-containers ==1.2.* , temporary ==1.3.* , wai >=3.2 && <3.3 , wai-app-static >=3.1 && <3.2 @@ -641,6 +640,7 @@ test-suite simplexmq-test , simple-logger , simplexmq , stm + , stm-containers , text , time , tls >=1.9.0 && <1.10 diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index a0aa559149..d839833630 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -129,7 +129,7 @@ closeXFTPAgent a = do stopWorkers $ xftpSndWorkers a stopWorkers $ xftpDelWorkers a where - stopWorkers workers = atomically (TM.flush workers) >>= mapM_ (liftIO . cancelWorker) + stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker) xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId xftpReceiveFile' c userId vfd cfArgs approvedRelays = do diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index e848ef3bf6..371a5eea45 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -27,6 +27,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Int (Int64) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, isJust) +import Data.Set (Set) +import qualified Data.Set as S import Data.Word (Word32) import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId) import Simplex.FileTransfer.Transport (XFTPErrorType (..)) @@ -39,8 +41,6 @@ import System.IO (IOMode (..)) import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.TSet (TSet) -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (ifM) data FSType = FSMemory | FSPostgres @@ -53,7 +53,7 @@ data FileRec = FileRec { senderId :: SenderId, fileInfo :: FileInfo, filePath :: TVar (Maybe FilePath), - recipientIds :: TSet RecipientId, + recipientIds :: TVar (Set RecipientId), createdAt :: RoundedFileTime, expiresAt :: Maybe RoundedFileTime, fileStatus :: TVar ServerEntityStatus @@ -127,19 +127,19 @@ instance FileStoreClass STMFileStore where addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ withFile st senderId $ \FileRec {recipientIds} -> do - memR <- TS.member rId recipientIds + rIds <- readTVar recipientIds mem <- TM.member rId recipients - if memR || mem + if rId `S.member` rIds || mem then pure $ Left DUPLICATE_ else do - TS.insert rId recipientIds + writeTVar recipientIds $! S.insert rId rIds TM.insert rId (senderId, rKey) recipients pure $ Right () deleteFile STMFileStore {files, recipients} senderId = atomically $ do TM.lookupDelete senderId files >>= \case Just FileRec {recipientIds} -> do - TS.toSet recipientIds >>= mapM_ (`TM.delete` recipients) + readTVar recipientIds >>= mapM_ (`TM.delete` recipients) pure $ Right () _ -> pure $ Left AUTH @@ -150,7 +150,7 @@ instance FileStoreClass STMFileStore where deleteRecipient STMFileStore {recipients} rId FileRec {recipientIds} = atomically $ do TM.delete rId recipients - TS.delete rId recipientIds + modifyTVar' recipientIds $ S.delete rId getFile st party fId = atomically $ case party of SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f)) @@ -163,12 +163,12 @@ instance FileStoreClass STMFileStore where TM.lookupDelete recipientId recipients >>= \case Just (sId, _) -> withFile st sId $ \FileRec {recipientIds} -> do - TS.delete recipientId recipientIds + modifyTVar' recipientIds $ S.delete recipientId pure $ Right () _ -> pure $ Left AUTH expiredFiles STMFileStore {files} now old _limit = do - fs <- TM.toMapIO files + fs <- readTVarIO files fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) -> let expired = case expiresAt of Just e -> roundedSeconds e < roundedSeconds now @@ -179,18 +179,18 @@ instance FileStoreClass STMFileStore where pure $ Just (sId, path, size) else pure Nothing - getUsedStorage STMFileStore {files} = TM.foldIO (\acc -> addSize acc . snd) 0 files + getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files where addSize acc FileRec {fileInfo = FileInfo {size}, filePath} = ifM (isJust <$> readTVarIO filePath) (pure $! acc + fromIntegral size) (pure acc) - getFileCount STMFileStore {files} = TM.sizeIO files + getFileCount STMFileStore {files} = M.size <$> readTVarIO files -- Internal STM helpers newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec newFileRec senderId fileInfo createdAt expiresAt status = do - recipientIds <- TS.empty + recipientIds <- newTVar S.empty filePath <- newTVar Nothing fileStatus <- newTVar status pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 2dd35e0fab..c9e83c4c5d 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -30,6 +30,7 @@ import Data.Int (Int32, Int64) import Data.List (intersperse) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M +import qualified Data.Set as S import Data.Text (Text) import Data.Word (Word32) import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), SqlError, (:.) (..)) @@ -55,8 +56,6 @@ import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.QueueStore.Postgres () import Simplex.Messaging.Server.StoreLog (openWriteStoreLog) import Simplex.Messaging.SystemTime (roundedSeconds) -import qualified Simplex.Messaging.TMap as TM -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (firstRow, tshow) import System.Directory (renameFile) import System.Exit (exitFailure) @@ -179,7 +178,7 @@ instance FileStoreClass PostgresFileStore where mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec mkFileRec senderId fileInfo path createdAt expiresAt status = do filePath <- newTVarIO path - recipientIds <- TS.emptyIO + recipientIds <- newTVarIO S.empty fileStatus <- newTVarIO status pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} @@ -229,8 +228,8 @@ importFileStore storeLogFilePath dbCfg = do stmStore <- newFileStore () :: IO STMFileStore sl <- readWriteFileStore storeLogFilePath stmStore closeStoreLog sl - allFiles <- TM.toMapIO $ files stmStore - allRcps <- TM.toMapIO $ recipients stmStore + allFiles <- readTVarIO (files stmStore) + allRcps <- readTVarIO (recipients stmStore) let fileCount = M.size allFiles rcpCount = M.size allRcps putStrLn $ "Loaded " <> show fileCount <> " files, " <> show rcpCount <> " recipients." diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index a1cd17bafa..5a6d99c7a3 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -40,8 +40,6 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.StoreLog -import qualified Simplex.Messaging.TMap as TM -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (bshow) import System.FilePath (takeFileName) import System.IO @@ -134,14 +132,14 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO () writeFileStore s STMFileStore {files, recipients} = do - allRcps <- TM.toMapIO recipients - TM.toMapIO files >>= mapM_ (logFile allRcps) + allRcps <- readTVarIO recipients + readTVarIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus logAddFile s senderId fileInfo createdAt expiresAt status - (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> TS.toSetIO recipientIds + (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs readTVarIO filePath >>= mapM_ (logPutFile s senderId) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d6ed85afc2..5862f3b7cd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -326,9 +326,9 @@ logServersStats c = do saveServersStats :: AgentClient -> AM' () saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats, ntfServersStats} = do - sss <- mapM (liftIO . getAgentSMPServerStats) =<< liftIO (TM.toMapIO smpServersStats) - xss <- mapM (liftIO . getAgentXFTPServerStats) =<< liftIO (TM.toMapIO xftpServersStats) - nss <- mapM (liftIO . getAgentNtfServerStats) =<< liftIO (TM.toMapIO ntfServersStats) + sss <- mapM (liftIO . getAgentSMPServerStats) =<< readTVarIO smpServersStats + xss <- mapM (liftIO . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats + nss <- mapM (liftIO . getAgentNtfServerStats) =<< readTVarIO ntfServersStats let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss} tryAllErrors' (withStore' c (`updateServersStats` stats)) >>= \case Left e -> atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) @@ -341,9 +341,9 @@ restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, ntfServers Right (startedAt, Nothing) -> atomically $ writeTVar srvStatsStartedAt startedAt Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss}) -> do atomically $ writeTVar srvStatsStartedAt startedAt - atomically . (`TM.replace` smpServersStats) =<< mapM (atomically . newAgentSMPServerStats') sss - atomically . (`TM.replace` xftpServersStats) =<< mapM (atomically . newAgentXFTPServerStats') xss - atomically . (`TM.replace` ntfServersStats) =<< mapM (atomically . newAgentNtfServerStats') nss + atomically . writeTVar smpServersStats =<< mapM (atomically . newAgentSMPServerStats') sss + atomically . writeTVar xftpServersStats =<< mapM (atomically . newAgentXFTPServerStats') xss + atomically . writeTVar ntfServersStats =<< mapM (atomically . newAgentNtfServerStats') nss disconnectAgentClient :: AgentClient -> IO () disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do @@ -719,7 +719,7 @@ setNetworkConfig :: AgentClient -> NetworkConfig -> AE () setNetworkConfig c@AgentClient {useNetworkConfig, proxySessTs} cfg' = do ts <- liftIO getCurrentTime (ok, changed) <- atomically $ do - useServices <- TM.toMap $ useClientServices c + useServices <- readTVar $ useClientServices c if any id useServices && sessionMode cfg' == TSMEntity then pure (False, False) else do @@ -918,12 +918,10 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue atomically $ TM.delete userId $ smpServers c atomically $ TM.delete userId $ xftpServers c atomically $ TM.delete userId $ useClientServices c - atomically $ deleteUserStats smpServersStats - atomically $ deleteUserStats xftpServersStats + atomically $ modifyTVar' smpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) + atomically $ modifyTVar' xftpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) lift $ saveServersStats c where - deleteUserStats :: TM.TMap (UserId, ProtocolServer p) s -> STM () - deleteUserStats m = TM.toMap m >>= mapM_ (`TM.delete` m) . filter ((userId ==) . fst) . M.keys delUser = whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId) @@ -1179,7 +1177,7 @@ createRcvQueue c nm userId connId srvWithAuth@(ProtoServerWithAuth srv _) enable checkClientNotices :: AgentClient -> SMPServerWithAuth -> AM () checkClientNotices AgentClient {clientNotices, presetServers} (ProtoServerWithAuth srv@(ProtocolServer {host}) _) = do - notices <- liftIO $ TM.toMapIO clientNotices + notices <- readTVarIO clientNotices unless (M.null notices) $ checkNotices notices =<< liftIO getSystemSeconds where srvKey @@ -1986,7 +1984,7 @@ subscribeAllConnections' c onlyNeeded activeUserId_ = handleErr $ do let userSrvs' = case activeUserId_ of Just activeUserId -> sortOn (\(uId, _) -> if uId == activeUserId then 0 else 1 :: Int) userSrvs Nothing -> userSrvs - useServices <- liftIO $ TM.toMapIO $ useClientServices c + useServices <- readTVarIO $ useClientServices c -- Service will be loaded for all user/server combinations: -- a) service is enabled for user ID and service record exists: subscription will be attempted, -- b) service is disabled and record exists: service record and all associations will be removed, @@ -3469,7 +3467,7 @@ debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do delLock <- atomically $ tryReadTMVar d pure AgentLocks {connLocks, invLocks, delLock} where - getLocks ls = atomically $ M.mapKeys (safeDecodeUtf8 . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< TM.toMap ls) + getLocks ls = atomically $ M.mapKeys (safeDecodeUtf8 . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls) getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth getSMPServer c userId = getNextSMPServer c userId [] diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index e2da8e284e..d892fcad03 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -214,7 +214,6 @@ import Data.Composition ((.:), (.:.)) import Data.Containers.ListUtils (nubOrd) import Data.Either (isRight, partitionEithers) import Data.Functor (($>)) -import Data.Hashable (Hashable) import Data.Int (Int64) import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty (..), (<|)) @@ -312,8 +311,6 @@ import Simplex.Messaging.Session import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.TSet (TSet) -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), newNtfCredsSMPVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials @@ -365,7 +362,7 @@ data AgentClient = AgentClient presetServers :: [SMPServer], userNetworkInfo :: TVar UserNetworkInfo, userNetworkUpdated :: TVar (Maybe UTCTime), - subscrConns :: TSet ConnId, + subscrConns :: TVar (Set ConnId), currentSubs :: TSessionSubs, removedSubs :: TMap (UserId, SMPServer) (TMap SMP.RecipientId SMPClientError), clientNotices :: TMap (Maybe SMPServer) (Maybe SystemSeconds), @@ -405,11 +402,11 @@ data SMPConnectedClient = SMPConnectedClient type ProxiedRelayVar = SessionVar (Either AgentErrorType ProxiedRelay) -getAgentWorker :: (Hashable k, Show k, AnyError e, MonadUnliftIO m) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT e m ()) -> m Worker +getAgentWorker :: (Ord k, Show k, AnyError e, MonadUnliftIO m) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT e m ()) -> m Worker getAgentWorker = getAgentWorker' id pure {-# INLINE getAgentWorker #-} -getAgentWorker' :: forall a k e m. (Hashable k, Show k, AnyError e, MonadUnliftIO m) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT e m ()) -> m a +getAgentWorker' :: forall a k e m. (Ord k, Show k, AnyError e, MonadUnliftIO m) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT e m ()) -> m a getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do atomically (getWorker >>= maybe createWorker whenExists) >>= \w -> runWorker w $> w where @@ -524,22 +521,22 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, entitlements, netCf active <- newTVarIO True subQ <- newTBQueueIO qSize msgQ <- newTBQueueIO qSize - smpServers <- TM.fromMapIO $ M.map mkUserServers smp + smpServers <- newTVarIO $ M.map mkUserServers smp smpClients <- TM.emptyIO - useClientServices <- TM.fromMapIO useServices + useClientServices <- newTVarIO useServices smpProxiedRelays <- TM.emptyIO ntfServers <- newTVarIO ntf ntfClients <- TM.emptyIO - xftpServers <- TM.fromMapIO $ M.map mkUserServers xftp + xftpServers <- newTVarIO $ M.map mkUserServers xftp xftpClients <- TM.emptyIO - userEntitlements <- TM.fromMapIO entitlements + userEntitlements <- newTVarIO entitlements useNetworkConfig <- newTVarIO (slowNetworkConfig netCfg, netCfg) userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True userNetworkUpdated <- newTVarIO Nothing - subscrConns <- TS.emptyIO + subscrConns <- newTVarIO S.empty currentSubs <- SS.emptyIO removedSubs <- TM.emptyIO - clientNotices <- TM.fromMapIO notices + clientNotices <- newTVarIO notices clientNoticesLock <- newTMVarIO () workerSeq <- newTVarIO 0 smpDeliveryWorkers <- TM.emptyIO @@ -799,7 +796,7 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess let qs = M.elems subs cs = nubOrd $ map qConnId qs -- this removes proxied relays that this client created sessions to - destSrvs <- M.keys <$> TM.toMap prs + destSrvs <- M.keys <$> readTVar prs forM_ destSrvs $ \destSrv -> TM.delete (userId, destSrv, cId) smpProxiedRelays pure (qs, cs, serviceSub_) @@ -1009,16 +1006,18 @@ closeAgentClient c = do closeProtocolServerClients c smpClients closeProtocolServerClients c ntfClients closeProtocolServerClients c xftpClients - atomically $ TM.clear $ smpProxiedRelays c - atomically (TM.flush $ smpSubWorkers c) >>= mapM_ cancelReconnect + atomically $ writeTVar (smpProxiedRelays c) M.empty + atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst) clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker atomically $ SS.clear $ currentSubs c - atomically $ TS.clear $ subscrConns c - atomically $ TM.clear $ getMsgLocks c + clear subscrConns + clear getMsgLocks where clearWorkers :: Ord k => (AgentClient -> TMap k a) -> IO (Map k a) - clearWorkers workers = atomically $ TM.flush $ workers c + clearWorkers workers = atomically $ swapTVar (workers c) mempty + clear :: Monoid m => (AgentClient -> TVar m) -> IO () + clear sel = atomically $ writeTVar (sel c) mempty cancelReconnect :: SessionVar (Async ()) -> IO () cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel @@ -1042,15 +1041,15 @@ throwWhenNoDelivery c sq = closeProtocolServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO () closeProtocolServerClients c clientsSel = - atomically (TM.flush $ clientsSel c) >>= mapM_ (forkIO . closeClient_ c) + atomically (clientsSel c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient_ c) reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO () reconnectServerClients c clientsSel = - TM.toMapIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c) + readTVarIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c) reconnectSMPServer :: AgentClient -> UserId -> SMPServer -> IO () reconnectSMPServer c userId srv = do - cs <- TM.toMapIO $ smpClients c + cs <- readTVarIO $ smpClients c let vs = M.foldrWithKey srvClient [] cs mapM_ (forkIO . closeClient_ c) vs where @@ -1060,10 +1059,9 @@ reconnectSMPServer c userId srv = do closeUserXFTPClients :: AgentClient -> UserId -> IO () closeUserXFTPClients c userId = do - vs <- atomically $ do - userCs <- M.filterWithKey (\(userId', _, _) _ -> userId == userId') <$> TM.toMap (xftpClients c) - mapM_ (`TM.delete` xftpClients c) $ M.keys userCs - pure $ M.elems userCs + vs <- atomically $ stateTVar (xftpClients c) $ \cs -> + let (userCs, cs') = M.partitionWithKey (\(userId', _, _) _ -> userId == userId') cs + in (M.elems userCs, cs') mapM_ (forkIO . closeClient_ c) vs closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () @@ -1103,15 +1101,15 @@ withConnLocks :: AgentClient -> Set ConnId -> Text -> AM' a -> AM' a withConnLocks AgentClient {connLocks} = withLocksMap connLocks {-# INLINE withConnLocks #-} -withLockMap :: (Hashable k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a +withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a withLockMap = withGetLock . getMapLock {-# INLINE withLockMap #-} -withLocksMap :: (Hashable k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a +withLocksMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a withLocksMap = withGetLocks . getMapLock {-# INLINE withLocksMap #-} -getMapLock :: Hashable k => TMap k Lock -> k -> STM Lock +getMapLock :: Ord k => TMap k Lock -> k -> STM Lock getMapLock locks key = TM.lookup key locks >>= maybe newLock pure where newLock = createLock >>= \l -> TM.insert key l locks $> l @@ -1641,7 +1639,7 @@ subscribeQueues :: AgentClient -> Bool -> [RcvQueueSub] -> AM' [(RcvQueueSub, Ei subscribeQueues _ _ [] = pure [] subscribeQueues c withEvents qs = do (errs, qs') <- checkQueues c qs - atomically $ mapM_ ((`TS.insert` subscrConns c) . qConnId) qs' + atomically $ modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId qs')) qss <- batchQueues mkSMPTSession qs' <$> getSessionModeIO c mapM_ (addPendingSubs c) qss rs <- mapConcurrently (subscribeQueues_ c withEvents) qss @@ -1678,7 +1676,7 @@ subscribeUserServerQueues c userId srv qs = do let errs' = map (second Left) errs case L.nonEmpty qs_ of Just qs' -> do - atomically $ mapM_ ((`TS.insert` subscrConns c) . qConnId) qs' + atomically $ modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId $ L.toList qs')) addPendingSubs c (tSess, qs') rs <- subscribeQueues_ c True (tSess, qs') pure $ errs' <> L.toList rs @@ -1763,7 +1761,7 @@ processClientNotices c@AgentClient {presetServers} tSess notices = do tryAllErrors' (withStore' c $ \db -> (,) <$> updateClientNotices db tSess now notices <*> getClientNotices db presetServers) >>= \case Right (noticeIds, clntNotices) -> atomically $ do SS.updateClientNotices tSess noticeIds $ currentSubs c - TM.replace clntNotices $ clientNotices c + writeTVar (clientNotices c) clntNotices Left e -> do logError $ "processClientNotices error: " <> tshow e notifySub' c "" $ ERR e @@ -1881,7 +1879,7 @@ getRemovedSubs :: AgentClient -> (UserId, SMPServer) -> STM (TMap SMP.RecipientI getRemovedSubs AgentClient {removedSubs} k = TM.lookup k removedSubs >>= maybe new pure where new = do - s <- TM.empty + s <- newTVar M.empty TM.insert k s removedSubs pure s @@ -1889,7 +1887,7 @@ addNewQueueSubscription :: AgentClient -> RcvQueue -> SMPTransportSession -> Ses addNewQueueSubscription c rq' tSess sessId serviceId_ = do let rq = rcvQueueSub rq' same <- atomically $ do - TS.insert (qConnId rq) $ subscrConns c + modifyTVar' (subscrConns c) $ S.insert $ qConnId rq active <- activeClientSession c tSess sessId if active then SS.addActiveSub tSess sessId serviceId_ rq' $ currentSubs c @@ -1915,17 +1913,17 @@ hasRemovedSubscription c rq = do removeSubscription :: SomeRcvQueue q => AgentClient -> SMPTransportSession -> ConnId -> q -> STM () removeSubscription c tSess connId rq = do - TS.delete connId $ subscrConns c + modifyTVar' (subscrConns c) $ S.delete connId SS.deleteSub tSess (queueId rq) $ currentSubs c removeSubscriptions :: SomeRcvQueue q => AgentClient -> [ConnId] -> [q] -> STM () removeSubscriptions c connIds qs = do - mapM_ (`TS.delete` subscrConns c) connIds + unless (null connIds) $ modifyTVar' (subscrConns c) (`S.difference` (S.fromList connIds)) qss <- batchQueues mkSMPTSession qs <$> getSessionMode c forM_ qss $ \(tSess, qs') -> SS.batchDeleteSubs tSess (L.toList qs') $ currentSubs c getSubscriptions :: AgentClient -> IO (Set ConnId) -getSubscriptions = TS.toSetIO . subscrConns +getSubscriptions = readTVarIO . subscrConns {-# INLINE getSubscriptions #-} logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m () @@ -2097,9 +2095,11 @@ releaseGetLock c rq = releaseGetLocksIO :: SomeRcvQueue q => AgentClient -> [q] -> IO () releaseGetLocksIO _ [] = pure () -releaseGetLocksIO c rqs = +releaseGetLocksIO c rqs = do + locks <- readTVarIO $ getMsgLocks c forM_ rqs $ \rq -> - TM.lookupIO (qServer rq, queueId rq) (getMsgLocks c) >>= mapM_ (\lock -> atomically $ tryPutTMVar lock ()) + forM_ (M.lookup ((qServer rq, queueId rq)) locks) $ \lock -> + atomically $ tryPutTMVar lock () suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM () suspendQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = @@ -2643,7 +2643,7 @@ data ServerSessions = ServerSessions getAgentSubsTotal :: AgentClient -> [UserId] -> IO (SMPServerSubs, Bool) getAgentSubsTotal c userIds = do (ssActive, ssPending) <- SS.foldSessionSubs addSub (0, 0) $ currentSubs c - sess <- hasSession . M.toList =<< TM.toMapIO (smpClients c) + sess <- hasSession . M.toList =<< readTVarIO (smpClients c) pure (SMPServerSubs {ssActive, ssPending}, sess) where addSub :: (Int, Int) -> (SMPTransportSession, SS.SessSubs) -> IO (Int, Int) @@ -2662,17 +2662,17 @@ getAgentSubsTotal c userIds = do getAgentServersSummary :: AgentClient -> IO AgentServersSummary getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServersStats, srvStatsStartedAt, agentEnv} = do - sss <- mapM getAgentSMPServerStats =<< TM.toMapIO smpServersStats - xss <- mapM getAgentXFTPServerStats =<< TM.toMapIO xftpServersStats - nss <- mapM getAgentNtfServerStats =<< TM.toMapIO ntfServersStats + sss <- mapM getAgentSMPServerStats =<< readTVarIO smpServersStats + xss <- mapM getAgentXFTPServerStats =<< readTVarIO xftpServersStats + nss <- mapM getAgentNtfServerStats =<< readTVarIO ntfServersStats statsStartedAt <- readTVarIO srvStatsStartedAt - smpServersSessions <- countSessions =<< TM.toMapIO (smpClients c) + smpServersSessions <- countSessions =<< readTVarIO (smpClients c) smpServersSubs <- getServerSubs - xftpServersSessions <- countSessions =<< TM.toMapIO (xftpClients c) + xftpServersSessions <- countSessions =<< readTVarIO (xftpClients c) xftpRcvInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpRcvWorkers xftpSndInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpSndWorkers xftpDelInProgress <- getXFTPWorkerSrvs xftpDelWorkers - ntfServersSessions <- countSessions =<< TM.toMapIO (ntfClients c) + ntfServersSessions <- countSessions =<< readTVarIO (ntfClients c) pure AgentServersSummary { smpServersStats = sss, @@ -2695,7 +2695,7 @@ getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServ let add ss = ss {ssActive = ssActive ss + active, ssPending = ssPending ss + pending} pure $ M.alter (Just . add . fromMaybe (SMPServerSubs 0 0)) (userId, srv) subs Env {xftpAgent = XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}} = agentEnv - getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< TM.toMapIO workers + getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< readTVarIO workers where addSrv acc (srv, Worker {doWork}) = do hasWork <- atomically $ not <$> isEmptyTMVar doWork @@ -2734,11 +2734,11 @@ getAgentSubscriptions c = do (active', pending') <- SS.mapSubs (map (\rId -> subInfo (userId, srv, rId) Nothing) . M.keys) s pure (active' ++ active, pending' ++ pending) getRemoved :: IO [SubInfo] - getRemoved = foldM addSubInfo [] . M.assocs =<< TM.toMapIO (removedSubs c) + getRemoved = foldM addSubInfo [] . M.assocs =<< readTVarIO (removedSubs c) where addSubInfo :: [SubInfo] -> ((UserId, SMPServer), TMap SMP.RecipientId SMPClientError) -> IO [SubInfo] addSubInfo ss ((uId, srv), errs) = do - ss' <- map (\(rId, e) -> subInfo (uId, srv, rId) (Just e)) . M.assocs <$> TM.toMapIO errs + ss' <- map (\(rId, e) -> subInfo (uId, srv, rId) (Just e)) . M.assocs <$> readTVarIO errs pure $ ss' ++ ss subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err} @@ -2769,17 +2769,17 @@ data WorkersDetails = WorkersDetails getAgentWorkersDetails :: AgentClient -> IO AgentWorkersDetails getAgentWorkersDetails AgentClient {smpClients, ntfClients, xftpClients, smpDeliveryWorkers, asyncCmdWorkers, smpSubWorkers, agentEnv} = do - smpClients_ <- textKeys <$> TM.toMapIO smpClients - ntfClients_ <- textKeys <$> TM.toMapIO ntfClients - xftpClients_ <- textKeys <$> TM.toMapIO xftpClients - smpDeliveryWorkers_ <- workerStats . fmap fst =<< TM.toMapIO smpDeliveryWorkers - asyncCmdWorkers_ <- workerStats =<< TM.toMapIO asyncCmdWorkers - smpSubWorkers_ <- textKeys <$> TM.toMapIO smpSubWorkers - ntfWorkers_ <- workerStats =<< TM.toMapIO ntfWorkers - ntfSMPWorkers_ <- workerStats =<< TM.toMapIO ntfSMPWorkers - xftpRcvWorkers_ <- workerStats =<< TM.toMapIO xftpRcvWorkers - xftpSndWorkers_ <- workerStats =<< TM.toMapIO xftpSndWorkers - xftpDelWorkers_ <- workerStats =<< TM.toMapIO xftpDelWorkers + smpClients_ <- textKeys <$> readTVarIO smpClients + ntfClients_ <- textKeys <$> readTVarIO ntfClients + xftpClients_ <- textKeys <$> readTVarIO xftpClients + smpDeliveryWorkers_ <- workerStats . fmap fst =<< readTVarIO smpDeliveryWorkers + asyncCmdWorkers_ <- workerStats =<< readTVarIO asyncCmdWorkers + smpSubWorkers_ <- textKeys <$> readTVarIO smpSubWorkers + ntfWorkers_ <- workerStats =<< readTVarIO ntfWorkers + ntfSMPWorkers_ <- workerStats =<< readTVarIO ntfSMPWorkers + xftpRcvWorkers_ <- workerStats =<< readTVarIO xftpRcvWorkers + xftpSndWorkers_ <- workerStats =<< readTVarIO xftpSndWorkers + xftpDelWorkers_ <- workerStats =<< readTVarIO xftpDelWorkers pure AgentWorkersDetails { smpClients_, @@ -2833,17 +2833,17 @@ data WorkersSummary = WorkersSummary getAgentWorkersSummary :: AgentClient -> IO AgentWorkersSummary getAgentWorkersSummary AgentClient {smpClients, ntfClients, xftpClients, smpDeliveryWorkers, asyncCmdWorkers, smpSubWorkers, agentEnv} = do - smpClientsCount <- TM.sizeIO smpClients - ntfClientsCount <- TM.sizeIO ntfClients - xftpClientsCount <- TM.sizeIO xftpClients - smpDeliveryWorkersCount <- TM.toMapIO smpDeliveryWorkers >>= workerSummary . fmap fst - asyncCmdWorkersCount <- TM.toMapIO asyncCmdWorkers >>= workerSummary - smpSubWorkersCount <- TM.sizeIO smpSubWorkers - ntfWorkersCount <- TM.toMapIO ntfWorkers >>= workerSummary - ntfSMPWorkersCount <- TM.toMapIO ntfSMPWorkers >>= workerSummary - xftpRcvWorkersCount <- TM.toMapIO xftpRcvWorkers >>= workerSummary - xftpSndWorkersCount <- TM.toMapIO xftpSndWorkers >>= workerSummary - xftpDelWorkersCount <- TM.toMapIO xftpDelWorkers >>= workerSummary + smpClientsCount <- M.size <$> readTVarIO smpClients + ntfClientsCount <- M.size <$> readTVarIO ntfClients + xftpClientsCount <- M.size <$> readTVarIO xftpClients + smpDeliveryWorkersCount <- readTVarIO smpDeliveryWorkers >>= workerSummary . fmap fst + asyncCmdWorkersCount <- readTVarIO asyncCmdWorkers >>= workerSummary + smpSubWorkersCount <- M.size <$> readTVarIO smpSubWorkers + ntfWorkersCount <- readTVarIO ntfWorkers >>= workerSummary + ntfSMPWorkersCount <- readTVarIO ntfSMPWorkers >>= workerSummary + xftpRcvWorkersCount <- readTVarIO xftpRcvWorkers >>= workerSummary + xftpSndWorkersCount <- readTVarIO xftpSndWorkers >>= workerSummary + xftpDelWorkersCount <- readTVarIO xftpDelWorkers >>= workerSummary pure AgentWorkersSummary { smpClientsCount, @@ -2889,7 +2889,7 @@ getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo getAgentQueuesInfo AgentClient {msgQ, subQ, smpClients} = do msgQInfo <- atomically $ getTBQueueInfo msgQ subQInfo <- atomically $ getTBQueueInfo subQ - smpClientsMap <- TM.toMapIO smpClients + smpClientsMap <- readTVarIO smpClients let smpClientsMap' = M.mapKeys (decodeLatin1 . strEncode) smpClientsMap smpClientsQueues <- mapM getClientQueuesInfo smpClientsMap' pure AgentQueuesInfo {msgQInfo, subQInfo, smpClientsQueues} diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index c9424b2328..7153abcbfd 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -53,7 +53,6 @@ import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr) import qualified Simplex.Messaging.Protocol as SMP -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (catchAllErrors, catchAllErrors', diffToMicroseconds, threadDelay', tryAllErrors, tshow, whenM) import System.Random (randomR) import UnliftIO @@ -587,7 +586,7 @@ closeNtfSupervisor ns = do stopWorkers $ ntfSMPWorkers ns stopWorkers $ ntfTknDelWorkers ns where - stopWorkers workers = atomically (TM.flush workers) >>= mapM_ (liftIO . cancelWorker) + stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker) getNtfServer :: AgentClient -> AM' (Maybe NtfServer) getNtfServer c = do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 15cbb8756a..67cfa6213f 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Agent.Store.SQLite.DB ( BoolInt (..), @@ -33,7 +32,6 @@ import Control.Exception import Control.Monad (when) import qualified Data.Aeson.TH as J import Data.ByteString (ByteString) -import Data.Hashable (Hashable (..)) import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -64,9 +62,6 @@ data Connection = Connection slow :: TMap Query SlowQueryStats } -instance Hashable Query where - hashWithSalt s = hashWithSalt s . SQL.fromQuery - data TrackQueries = TQAll | TQSlow Int64 | TQOff deriving (Eq) diff --git a/src/Simplex/Messaging/Agent/TSessionSubs.hs b/src/Simplex/Messaging/Agent/TSessionSubs.hs index e8fe9e2a79..a1db48c9ea 100644 --- a/src/Simplex/Messaging/Agent/TSessionSubs.hs +++ b/src/Simplex/Messaging/Agent/TSessionSubs.hs @@ -38,6 +38,7 @@ where import Control.Concurrent.STM import Control.Monad import Data.Int (Int64) +import Data.List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust) @@ -79,7 +80,7 @@ getSessSubs :: SMPTransportSession -> TSessionSubs -> STM SessSubs getSessSubs tSess ss = lookupSubs tSess ss >>= maybe new pure where new = do - s <- SessSubs <$> newTVar Nothing <*> TM.empty <*> TM.empty <*> newTVar Nothing <*> newTVar Nothing + s <- SessSubs <$> newTVar Nothing <*> newTVar M.empty <*> newTVar M.empty <*> newTVar Nothing <*> newTVar Nothing TM.insert tSess s $ sessionSubs ss pure s @@ -146,9 +147,9 @@ batchAddActiveSubs tSess sessId serviceId_ (rqs, serviceRQs) ss = do if Just sessId == sessId' then do TM.union qs $ activeSubs s - mapM_ (`TM.delete` pendingSubs s) $ M.keys qs + modifyTVar' (pendingSubs s) (`M.difference` qs) unless (null serviceRQs) $ forM_ serviceId_ $ \serviceId -> do - mapM_ (`TM.delete` pendingSubs s) $ M.keys serviceQs + modifyTVar' (pendingSubs s) (`M.difference` serviceQs) updateActiveService s serviceId (fromIntegral $ length serviceRQs) (mconcat $ map (queueIdHash . rcvId) serviceRQs) else do TM.union qs $ pendingSubs s @@ -166,7 +167,7 @@ updateActiveService s serviceId addN addIdsHash = do batchAddPendingSubs :: SMPTransportSession -> [RcvQueueSub] -> TSessionSubs -> STM () batchAddPendingSubs tSess rqs ss = do s <- getSessSubs tSess ss - TM.union (M.fromList $ map (\rq -> (rcvId rq, rq)) rqs) $ pendingSubs s + modifyTVar' (pendingSubs s) $ M.union $ M.fromList $ map (\rq -> (rcvId rq, rq)) rqs deletePendingSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM () deletePendingSub tSess rId = lookupSubs tSess >=> mapM_ (TM.delete rId . pendingSubs) @@ -174,7 +175,7 @@ deletePendingSub tSess rId = lookupSubs tSess >=> mapM_ (TM.delete rId . pending batchDeletePendingSubs :: SMPTransportSession -> S.Set RecipientId -> TSessionSubs -> STM () batchDeletePendingSubs tSess rIds = lookupSubs tSess >=> mapM_ (delete . pendingSubs) where - delete m = mapM_ (`TM.delete` m) rIds + delete = (`modifyTVar'` (`M.withoutKeys` rIds)) deleteSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM () deleteSub tSess rId = lookupSubs tSess >=> mapM_ (\s -> TM.delete rId (activeSubs s) >> TM.delete rId (pendingSubs s)) @@ -183,7 +184,7 @@ batchDeleteSubs :: SomeRcvQueue q => SMPTransportSession -> [q] -> TSessionSubs batchDeleteSubs tSess rqs = lookupSubs tSess >=> mapM_ (\s -> delete (activeSubs s) >> delete (pendingSubs s)) where rIds = S.fromList $ map queueId rqs - delete m = mapM_ (`TM.delete` m) rIds + delete = (`modifyTVar'` (`M.withoutKeys` rIds)) deleteServiceSub :: SMPTransportSession -> TSessionSubs -> STM () deleteServiceSub tSess = lookupSubs tSess >=> mapM_ (\s -> writeTVar (activeServiceSub s) Nothing >> writeTVar (pendingServiceSub s) Nothing) @@ -191,13 +192,13 @@ deleteServiceSub tSess = lookupSubs tSess >=> mapM_ (\s -> writeTVar (activeServ hasPendingSubs :: SMPTransportSession -> TSessionSubs -> STM Bool hasPendingSubs tSess = lookupSubs tSess >=> maybe (pure False) (\s -> anyM [hasSubs s, hasServiceSub s]) where - hasSubs = fmap not . TM.null . pendingSubs + hasSubs = fmap (not . null) . readTVar . pendingSubs hasServiceSub = fmap isJust . readTVar . pendingServiceSub getPendingSubs :: SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub, Maybe ServiceSub) getPendingSubs tSess = lookupSubs tSess >=> maybe (pure (M.empty, Nothing)) get where - get s = liftM2 (,) (TM.toMap $ pendingSubs s) (readTVar $ pendingServiceSub s) + get s = liftM2 (,) (readTVar $ pendingSubs s) (readTVar $ pendingServiceSub s) getPendingQueueSubs :: SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub) getPendingQueueSubs = getSubs_ pendingSubs @@ -208,7 +209,7 @@ getActiveSubs = getSubs_ activeSubs {-# INLINE getActiveSubs #-} getSubs_ :: (SessSubs -> TMap RecipientId RcvQueueSub) -> SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub) -getSubs_ subs tSess = lookupSubs tSess >=> maybe (pure M.empty) (TM.toMap . subs) +getSubs_ subs tSess = lookupSubs tSess >=> maybe (pure M.empty) (readTVar . subs) setSubsPending :: TransportSessionMode -> SMPTransportSession -> SessionId -> TSessionSubs -> STM (Map RecipientId RcvQueueSub, Maybe ServiceSub) setSubsPending mode tSess@(uId, srv, connId_) sessId tss@(TSessionSubs ss) @@ -225,7 +226,7 @@ setSubsPending mode tSess@(uId, srv, connId_) sessId tss@(TSessionSubs ss) sessId' <- readTVar $ subsSessId s if Just sessId == sessId' then run s else pure (M.empty, Nothing) setPendingChangeMode s = do - subs <- M.union <$> TM.toMap (activeSubs s) <*> TM.toMap (pendingSubs s) + subs <- M.union <$> readTVar (activeSubs s) <*> readTVar (pendingSubs s) unless (null subs) $ forM_ subs $ \rq -> addPendingSub (uId, srv, sessEntId (connId rq)) rq tss (subs,) <$> setServiceSubPending_ s @@ -234,10 +235,10 @@ setSubsPending_ :: SessSubs -> Maybe SessionId -> STM (Map RecipientId RcvQueueS setSubsPending_ s sessId_ = do writeTVar (subsSessId s) sessId_ let as = activeSubs s - subs <- TM.toMap as + subs <- readTVar as unless (null subs) $ do - TM.clear as - TM.union subs $ pendingSubs s + writeTVar as M.empty + modifyTVar' (pendingSubs s) $ M.union subs (subs,) <$> setServiceSubPending_ s setServiceSubPending_ :: SessSubs -> STM (Maybe ServiceSub) @@ -251,13 +252,13 @@ setServiceSubPending_ s = do updateClientNotices :: SMPTransportSession -> [(RecipientId, Maybe Int64)] -> TSessionSubs -> STM () updateClientNotices tSess noticeIds ss = do s <- getSessSubs tSess ss - forM_ noticeIds $ \(rcvId, clientNoticeId) -> TM.adjust (\rq -> rq {clientNoticeId}) rcvId $ pendingSubs s + modifyTVar' (pendingSubs s) $ \m -> foldl' (\m' (rcvId, clientNoticeId) -> M.adjust (\rq -> rq {clientNoticeId}) rcvId m') m noticeIds foldSessionSubs :: (a -> (SMPTransportSession, SessSubs) -> IO a) -> a -> TSessionSubs -> IO a -foldSessionSubs f a = foldM f a . M.assocs <=< TM.toMapIO . sessionSubs +foldSessionSubs f a = foldM f a . M.assocs <=< readTVarIO . sessionSubs mapSubs :: (Map RecipientId RcvQueueSub -> a) -> SessSubs -> IO (a, a) mapSubs f s = do - active <- TM.toMapIO $ activeSubs s - pending <- TM.toMapIO $ pendingSubs s + active <- readTVarIO $ activeSubs s + pending <- readTVarIO $ pendingSubs s pure (f active, f pending) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 236435967b..ba4bceec5f 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -655,7 +655,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS `E.finally` (failPendingRequests c >> disconnected c') failPendingRequests :: PClient v err msg -> IO () - failPendingRequests PClient {sentCommands} = atomically $ TM.flush sentCommands >>= mapM_ failRequest + failPendingRequests PClient {sentCommands} = atomically $ swapTVar sentCommands mempty >>= mapM_ failRequest where failRequest Request {pending, responseVar} = whenM (swapTVar pending False) $ void $ tryPutTMVar responseVar $ Left $ PCENetworkError NEFailedError diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 47ea8a2c9b..c110953de7 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -298,8 +298,7 @@ connectClient ca@SMPClientAgent {agentCfg, dbService, smpClients, smpSessions, m updateQueueSubs qVar = do -- removing subscriptions that have matching sessionId to disconnected client -- and keep the other ones (they can be made by the new client) - subs <- M.map snd . M.filter ((sessId ==) . fst) <$> TM.toMap qVar - mapM_ (`TM.delete` qVar) $ M.keys subs + subs <- M.map snd <$> stateTVar qVar (M.partition ((sessId ==) . fst)) if M.null subs then pure Nothing else Just subs <$ addSubs_ (pendingQueueSubs ca) srv subs @@ -319,7 +318,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s where getWorkerVar ts = ifM - (noPending <$> getPending) + (noPending <$> getPending TM.lookup readTVar) (pure Nothing) -- prevent race with cleanup and adding pending queues in another call (Just <$> getSessVar workerSeq srv smpSubWorkers ts) newSubWorker :: SessionVar (Async ()) -> IO () @@ -329,7 +328,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s runSubWorker v = withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do subs_ <- atomically $ do - s <- getPending + s <- getPending TM.lookup readTVar if noPending s then cleanup v $> Nothing else pure $ Just s @@ -338,10 +337,10 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s loop ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs - getPending :: STM (Maybe ServiceSub, Maybe (Map QueueId C.APrivateAuthKey)) - getPending = do - sSub <- TM.lookup srv (pendingServiceSubs ca) $>>= readTVar - qSubs <- TM.lookup srv (pendingQueueSubs ca) >>= mapM TM.toMap + getPending :: Monad m => (forall a. SMPServer -> TMap SMPServer a -> m (Maybe a)) -> (forall a. TVar a -> m a) -> m (Maybe ServiceSub, Maybe (Map QueueId C.APrivateAuthKey)) + getPending lkup rd = do + sSub <- lkup srv (pendingServiceSubs ca) $>>= rd + qSubs <- lkup srv (pendingQueueSubs ca) >>= mapM rd pure (sSub, qSubs) cleanup :: SessionVar (Async ()) -> STM () cleanup v = do @@ -360,9 +359,9 @@ reconnectSMPClient ca@SMPClientAgent {agentCfg, agentParty} srv (sSub_, qSubs_) resubscribe smp = do mapM_ (smpSubscribeService ca smp srv) sSub_ forM_ qSubs_ $ \qSubs -> do - currSubs_ <- TM.lookupIO srv (activeQueueSubs ca) - qSubs' :: [(QueueId, C.APrivateAuthKey)] <- - maybe pure (\currSubs -> filterM (fmap not . (`TM.memberIO` currSubs) . fst)) currSubs_ $ M.assocs qSubs + currSubs_ <- mapM readTVarIO =<< TM.lookupIO srv (activeQueueSubs ca) + let qSubs' :: [(QueueId, C.APrivateAuthKey)] = + maybe id (\currSubs -> filter ((`M.notMember` currSubs) . fst)) currSubs_ $ M.assocs qSubs mapM_ (smpSubscribeQueues @p ca smp srv) $ toChunks (agentSubsBatchSize agentCfg) qSubs' notify :: MonadIO m => SMPClientAgent p -> SMPClientAgentEvent -> m () @@ -391,13 +390,13 @@ closeSMPClientAgent :: SMPClientAgent p -> IO () closeSMPClientAgent c = do atomically $ writeTVar (active c) False closeSMPServerClients c - atomically (TM.flush $ smpSubWorkers c) >>= mapM_ cancelReconnect + atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect where cancelReconnect :: SessionVar (Async ()) -> IO () cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel closeSMPServerClients :: SMPClientAgent p -> IO () -closeSMPServerClients c = atomically (TM.flush $ smpClients c) >>= mapM_ (forkIO . closeClient) +closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient) where closeClient v = atomically (readTMVar $ sessionVar v) >>= \case @@ -447,7 +446,7 @@ smpSubscribeQueues ca smp srv subs = do where processSubscriptions :: NonEmpty (Either SMPClientError (Maybe ServiceId)) -> STM (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) processSubscriptions rs = do - pending <- maybe (pure S.empty) (\m -> S.fromList <$> filterM (`TM.member` m) (map fst $ L.toList subs)) =<< TM.lookup srv (pendingQueueSubs ca) + pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingQueueSubs ca) let acc@(_, _, (qOks, sQs), notPending) = foldr (groupSub pending) (False, [], ([], []), []) (L.zip subs rs) unless (null qOks) $ addActiveSubs ca srv qOks unless (null sQs) $ forM_ smpServiceId $ \serviceId -> @@ -457,13 +456,13 @@ smpSubscribeQueues ca smp srv subs = do sessId = sessionId $ thParams smp smpServiceId = smpClientServiceId smp groupSub :: - S.Set QueueId -> + Map QueueId C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError (Maybe ServiceId)) -> (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) -> (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks@(qOks, sQs), notPending) = case r of Right serviceId_ - | S.member qId pending -> + | M.member qId pending -> let oks' = case (smpServiceId, serviceId_) of (Just sId, Just sId') | sId == sId' -> (qOks, qId : sQs) _ -> ((qId, (sessId, pk)) : qOks, sQs) @@ -548,10 +547,7 @@ addSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> STM addSubs_ subs srv ss = TM.lookup srv subs >>= \case Just m -> TM.union ss m - _ -> do - m <- TM.empty - TM.union ss m - TM.insert srv m subs + _ -> TM.insertM srv (newTVar ss) subs setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe (ServiceSub, SessionId) -> STM () setActiveServiceSub = setServiceSub_ activeServiceSubs @@ -601,4 +597,4 @@ removePendingSubs = removeSubs_ . pendingQueueSubs {-# INLINE removePendingSubs #-} removeSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [QueueId] -> STM () -removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (\m -> mapM_ (`TM.delete` m) qs) +removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` S.fromList qs)) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index fb0087727d..cc2d5cc508 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -247,7 +247,6 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Constraint (Dict (..)) -import Data.Hashable (Hashable) import Data.Kind (Constraint, Type) import qualified Data.List.NonEmpty as L import Data.String @@ -1006,9 +1005,7 @@ instance Encoding AuthTag where -- | Certificate fingerpint newtype. -- -- Previously was used for server's public key hash in ad-hoc transport scheme, kept as is for compatibility. -newtype KeyHash = KeyHash {unKeyHash :: ByteString} - deriving (Eq, Ord, Show) - deriving newtype (Hashable) +newtype KeyHash = KeyHash {unKeyHash :: ByteString} deriving (Eq, Ord, Show) instance Encoding KeyHash where smpEncode = smpEncode . unKeyHash diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 5df8e13265..44f096f9b4 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -48,7 +48,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) -import Data.Hashable (Hashable (..)) import Data.Kind import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L @@ -382,9 +381,6 @@ data SMPQueueNtf = SMPQueueNtf } deriving (Eq, Ord, Show) -instance Hashable SMPQueueNtf where - hashWithSalt s SMPQueueNtf {smpServer, notifierId} = s `hashWithSalt` smpServer `hashWithSalt` notifierId - instance Encoding SMPQueueNtf where smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId) smpP = do @@ -406,9 +402,6 @@ data PushProvider | PPApnsNull -- used to test servers from the client - does not communicate with APNS deriving (Eq, Ord, Show) -instance Hashable PushProvider where - hashWithSalt s = hashWithSalt s . smpEncode - instance Encoding PushProvider where smpEncode = \case PPApnsDev -> "AD" @@ -444,9 +437,6 @@ instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode data DeviceToken = DeviceToken PushProvider ByteString deriving (Eq, Ord, Show) -instance Hashable DeviceToken where - hashWithSalt s (DeviceToken p t) = s `hashWithSalt` p `hashWithSalt` t - instance Encoding DeviceToken where smpEncode (DeviceToken p t) = smpEncode (p, t) smpP = DeviceToken <$> smpP <*> smpP diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 3454c38e87..51687abddb 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -78,7 +78,6 @@ import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), import Simplex.Messaging.Session import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer) @@ -148,9 +147,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} logNote "Saving server state..." saveServer NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber - liftIO $ TM.toMapIO smpSubscribers >>= mapM_ stopSubscriber + liftIO $ readTVarIO smpSubscribers >>= mapM_ stopSubscriber NtfPushServer {pushWorkers} <- asks pushServer - liftIO $ TM.toMapIO pushWorkers >>= mapM_ stopPushWorker + liftIO $ readTVarIO pushWorkers >>= mapM_ stopPushWorker liftIO $ closeSMPClientAgent smpAgent logNote "Server stopped" where @@ -273,7 +272,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} ntfActiveQueueSubs <- getSMPSubMetrics a activeQueueSubs ntfPendingServiceSubs <- getSMPServiceSubMetrics a pendingServiceSubs smpQueueCount ntfPendingQueueSubs <- getSMPSubMetrics a pendingQueueSubs - smpSessionCount <- TM.sizeIO smpSessions + smpSessionCount <- M.size <$> readTVarIO smpSessions apnsPushQLength <- pushWorkersQLength pushWorkers pure NtfRealTimeMetrics @@ -299,15 +298,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} getSMPSubMetrics a sel = getSubMetrics_ a sel countSubs where countSubs :: (NtfSMPSubMetrics, S.Set Text) -> (SMPServer, TMap NotifierId a) -> IO (NtfSMPSubMetrics, S.Set Text) - countSubs acc (srv, queueSubs) = subMetricsResult a acc srv <$> TM.sizeIO queueSubs + countSubs acc (srv, queueSubs) = subMetricsResult a acc srv . M.size <$> readTVarIO queueSubs getSubMetrics_ :: SMPClientAgent 'NotifierService -> - (SMPClientAgent 'NotifierService -> TMap SMPServer sub') -> + (SMPClientAgent 'NotifierService -> TVar (M.Map SMPServer sub')) -> ((NtfSMPSubMetrics, S.Set Text) -> (SMPServer, sub') -> IO (NtfSMPSubMetrics, S.Set Text)) -> IO NtfSMPSubMetrics getSubMetrics_ a sel countSubs = do - subs <- TM.toMapIO $ sel a + subs <- readTVarIO $ sel a let metrics = NtfSMPSubMetrics {ownSrvSubs = M.empty, otherServers = 0, otherSrvSubCount = 0} (metrics', otherSrvs) <- foldM countSubs (metrics, S.empty) $ M.assocs subs pure (metrics' :: NtfSMPSubMetrics) {otherServers = S.size otherSrvs} @@ -327,7 +326,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} host = safeDecodeUtf8 $ strEncode h getSMPWorkerMetrics :: SMPClientAgent 'NotifierService -> TMap SMPServer a -> IO NtfSMPWorkerMetrics - getSMPWorkerMetrics a v = workerMetrics a . M.keys <$> TM.toMapIO v + getSMPWorkerMetrics a v = workerMetrics a . M.keys <$> readTVarIO v workerMetrics :: SMPClientAgent 'NotifierService -> [SMPServer] -> NtfSMPWorkerMetrics workerMetrics a srvs = NtfSMPWorkerMetrics {ownServers = reverse ownSrvs, otherServers} where @@ -737,7 +736,7 @@ runPushWorker s srvHost_ isOwn q = forever $ do pushWorkersQLength :: TMap (Maybe T.Text, PushProvider, Int) PushWorkerVar -> IO Natural pushWorkersQLength workers = do - ws <- TM.toMapIO workers + ws <- readTVarIO workers foldM addQLength 0 ws where addQLength acc v = diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs index 0c294772d8..18a746a8d8 100644 --- a/src/Simplex/Messaging/Notifications/Server/Stats.hs +++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs @@ -333,10 +333,10 @@ instance StrEncoding StatsByServerData where serverP = (,) <$> strP_ <*> A.decimal getStatsByServer :: TMap Text (TVar Int) -> IO StatsByServerData -getStatsByServer s = TM.toMapIO s >>= fmap (StatsByServerData . M.toList) . mapM readTVarIO +getStatsByServer s = readTVarIO s >>= fmap (StatsByServerData . M.toList) . mapM readTVarIO setStatsByServer :: TMap Text (TVar Int) -> StatsByServerData -> IO () -setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . (`TM.replace` s) +setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . writeTVar s -- double lookup avoids STM transaction with a shared map in most cases incServerStat :: Text -> TMap Text (TVar Int) -> IO () diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index e3d1fa4f75..294fe04989 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -36,6 +36,7 @@ import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) +import Data.Set (Set) import qualified Data.Set as S import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C @@ -45,8 +46,6 @@ import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServe import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.TSet (TSet) -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Util (whenM, ($>>=)) data NtfSTMStore = NtfSTMStore @@ -54,7 +53,7 @@ data NtfSTMStore = NtfSTMStore -- multiple registrations exist to protect from malicious registrations if token is compromised tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId), subscriptions :: TMap NtfSubscriptionId NtfSubData, - tokenSubscriptions :: TMap NtfTokenId (TSet NtfSubscriptionId), + tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)), subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId, tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData)), ntfServices :: TMap SMPServer ServiceId @@ -124,7 +123,7 @@ stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} = where removeRegs :: TMap ByteString NtfTokenId -> STM [NtfTokenId] removeRegs tknRegs = do - tIds <- filter ((/= tId) . snd) . M.assocs <$> TM.toMap tknRegs + tIds <- filter ((/= tId) . snd) . M.assocs <$> readTVar tknRegs forM_ tIds $ \(regKey, tId') -> do TM.delete regKey tknRegs TM.delete tId' $ tokens st @@ -158,7 +157,7 @@ deleteTokenSubs :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf] deleteTokenSubs st tknId = do qs <- TM.lookupDelete tknId (tokenSubscriptions st) - >>= mapM (TS.toSet >=> mapM deleteSub . S.toList) + >>= mapM (readTVar >=> mapM deleteSub . S.toList) pure $ maybe [] catMaybes qs where deleteSub subId = do @@ -174,11 +173,11 @@ stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} = TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub where newTokenSub = do - ts <- TS.empty + ts <- newTVar S.empty TM.insert tokenId ts $ tokenSubscriptions st pure ts insertSub ts = do - TS.insert subId ts + modifyTVar' ts $ S.insert subId TM.insert subId sub $ subscriptions st TM.insert smpQueue subId (subscriptionLookup st) -- return Nothing if subscription existed before @@ -191,7 +190,7 @@ stmDeleteNtfSubscription st subId = do ( \NtfSubData {smpQueue, tokenId} -> do TM.delete smpQueue $ subscriptionLookup st ts_ <- TM.lookup tokenId (tokenSubscriptions st) - forM_ ts_ $ TS.delete subId + forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId ) -- This function is expected to be called after store log is read, diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index c9b036915a..8ff1bfcc0f 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -258,7 +258,6 @@ import qualified Data.ByteString.Lazy as LB import Data.Char (isPrint, isSpace) import Data.Constraint (Dict (..)) import Data.Functor (($>)) -import Data.Hashable (Hashable (..)) import Data.Int (Int64) import Data.Kind import Data.List (foldl') @@ -1310,9 +1309,6 @@ data ProtocolServer p = ProtocolServer } deriving (Eq, Ord, Show) -instance Hashable (ProtocolServer p) where - hashWithSalt s ProtocolServer {host, port, keyHash} = s `hashWithSalt` host `hashWithSalt` port `hashWithSalt` keyHash - data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p) instance ProtocolTypeI p => IsString (ProtocolServer p) where @@ -1435,7 +1431,7 @@ serverStrP = do -- | Transmission correlation ID. newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show) - deriving newtype (Encoding, Hashable) + deriving newtype (Encoding) pattern NoCorrId :: CorrId pattern NoCorrId = CorrId "" diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 6e2cd93bd4..c9fd743ce8 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -75,7 +75,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Semigroup (Sum (..)) -import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) @@ -119,7 +118,6 @@ import Simplex.Messaging.Server.StoreLog (foldLogLines) import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server @@ -276,7 +274,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where updateSubConnected c = case clntSub of CSClient qId prevServiceId serviceId_ -> do - TS.insert clntId subClients -- add ID to server's subscribed cients + modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients as'' <- if prevServiceId == serviceId_ then pure [] else endServiceSub prevServiceId qId END case serviceId_ of Just serviceId -> do @@ -293,7 +291,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt as' <- endServiceSub serviceId qId DELD pure $ as ++ as' CSService serviceId changedSubs -> do - TS.insert clntId subClients -- add ID to server's subscribed cients + modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients modifyTVar' totalServiceSubs $ addServiceSubs changedSubs -- server count and IDs hash for all services cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers updateSubDisconnected = case clntSub of @@ -329,7 +327,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt endPreviousSubscriptions :: [PrevClientSub s] -> IO () endPreviousSubscriptions = mapM_ $ \(c, subAction, evt) -> do - atomically $ TM.alter (Just . maybe [evt] (evt <|)) (clientId c) pendingEvents + atomically $ modifyTVar' pendingEvents $ IM.alter (Just . maybe [evt] (evt <|)) (clientId c) case subAction of CSAEndSub qId -> atomically (endSub c qId) >>= unsubPrev -- like endSub, also removes the delivery subscription from the service client's subscriptions map, @@ -337,7 +335,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt CSAEndServiceSub qId -> atomically (endServiceQueueSub c qId) >>= unsubPrev CSADecreaseSubs changedSubs -> do atomically $ modifyTVar' totalServiceSubs $ subtractServiceSubs changedSubs - forM_ unsub_ $ \unsub -> atomically (TM.flush $ clientSubs c) >>= mapM_ unsub + forM_ unsub_ $ \unsub -> atomically (swapTVar (clientSubs c) M.empty) >>= mapM_ unsub where unsubPrev :: Maybe sub -> IO () unsubPrev s_ = sequence_ (unsub_ <*> s_) @@ -352,9 +350,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt decrease = subtractServiceSubs (1, queueIdHash qId) -- remove client from server's subscribed cients removeWhenNoSubs c = do - noClientSubs <- TM.null $ clientSubs c + noClientSubs <- null <$> readTVar (clientSubs c) noServiceSubs <- ((0 ==) . fst) <$> readTVar (clientServiceSubs c) - when (noClientSubs && noServiceSubs) $ TS.delete (clientId c) subClients + when (noClientSubs && noServiceSubs) $ modifyTVar' subClients $ IS.delete (clientId c) deliverNtfsThread :: Server s -> M s () deliverNtfsThread srv@Server {ntfSubscribers = ServerSubscribers {subClients, serviceSubscribers}} = do @@ -367,8 +365,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt runDeliverNtfs ms ns' stats where runDeliverNtfs :: s -> NtfStore -> ServerStats -> IO () - runDeliverNtfs ms ns'@(NtfStore ns) stats = do - ntfs <- TM.foldIO (\acc ntf -> pure $ ntf : acc) [] ns + runDeliverNtfs ms ns' stats = do + ntfs <- getNtfs ns' unless (null ntfs) $ getQueueNtfServices @(StoreQueue s) (queueStore ms) ntfs >>= \case Left e -> logError $ "NOTIFICATIONS: getQueueNtfServices error " <> tshow e @@ -376,15 +374,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt forM_ sNtfs $ \(serviceId_, ntfs') -> case serviceId_ of Just sId -> getSubscribedClient sId serviceSubscribers >>= mapM_ (deliverServiceNtfs ntfs') Nothing -> do -- legacy code that does almost the same as before for non-service subscribers - cIds <- S.toList <$> TS.toSetIO subClients + cIds <- IS.toList <$> readTVarIO subClients forM_ cIds $ \cId -> getServerClient cId srv >>= mapM_ (deliverQueueNtfs ntfs') - atomically $ mapM_ ((`TM.delete` ns) . fst) deleted + mapM_ (deleteNtfs ns' . fst) deleted deleteEmptyNtfs ns' ntfs where deliverQueueNtfs ntfs' c@Client {ntfSubscriptions} = - whenM (atomically $ currentClient c) $ - unlessM (atomically $ TM.null ntfSubscriptions) $ do - ntfs'' <- filterM (\(nId, _) -> TM.memberIO nId ntfSubscriptions) ntfs' + whenM (currentClient readTVarIO c) $ do + subs <- readTVarIO ntfSubscriptions + unless (M.null subs) $ do + let ntfs'' = filter (\(nId, _) -> M.member nId subs) ntfs' tryAny (atomically $ flushSubscribedNtfs ntfs'' c) >>= updateNtfStats c deliverServiceNtfs ntfs' cv = readTVarIO cv >>= mapM_ deliver where @@ -396,12 +395,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ts_ <- foldM addNtfs [] ntfs forM_ (L.nonEmpty ts_) $ \ts -> do let cancelNtfs s = throwSTM $ userError $ s <> ", " <> show (length ts_) <> " ntfs kept" - unlessM (currentClient c) $ cancelNtfs "not current client" + unlessM (currentClient readTVar c) $ cancelNtfs "not current client" whenM (isFullTBQueue sndQ) $ cancelNtfs "sending queue full" writeTBQueue sndQ (ts, []) pure $ length ts_ - currentClient :: Client s' -> STM Bool - currentClient Client {clientId, connected} = (&&) <$> readTVar connected <*> TS.member clientId subClients + currentClient :: Monad m => (forall a. TVar a -> m a) -> Client s' -> m Bool + currentClient rd Client {clientId, connected} = (&&) <$> rd connected <*> (IS.member clientId <$> rd subClients) addNtfs :: [Transmission BrokerMsg] -> (NotifierId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg] addNtfs acc (nId, v) = readTVar v >>= \case @@ -429,8 +428,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt sendPending ntfSubscribers stats where sendPending ServerSubscribers {pendingEvents} stats = do - pending <- atomically $ TM.flush pendingEvents - unless (null pending) $ forM_ (M.assocs pending) $ \(cId, evts) -> + pending <- atomically $ swapTVar pendingEvents IM.empty + unless (null pending) $ forM_ (IM.assocs pending) $ \(cId, evts) -> getServerClient cId srv >>= mapM_ (enqueueEvts evts) where enqueueEvts evts c@Client {connected, sndQ} = @@ -712,15 +711,15 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts} where getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, totalServiceSubs, subClients} = do - subsCount <- getSubscribedClientsCount queueSubscribers - subClientsCount <- atomically $ TS.size subClients - subServicesCount <- getSubscribedClientsCount serviceSubscribers + subsCount <- M.size <$> getSubscribedClients queueSubscribers + subClientsCount <- IS.size <$> readTVarIO subClients + subServicesCount <- M.size <$> getSubscribedClients serviceSubscribers subServiceSubsCount <- fst <$> readTVarIO totalServiceSubs pure RTSubscriberMetrics {subsCount, subClientsCount, subServicesCount, subServiceSubsCount} getDeliveredMetrics ts' = foldM countClnt (RTSubscriberMetrics 0 0 0 0, emptyTimeBuckets) =<< getServerClients srv where countClnt acc@(metrics, times) Client {subscriptions} = do - (cnt, times') <- TM.foldIO (\r -> countSubs r . snd) (0, times) subscriptions + (cnt, times') <- foldM countSubs (0, times) =<< readTVarIO subscriptions pure $ if cnt > 0 then (metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, times') else acc @@ -804,7 +803,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt now <- liftIO getSystemTime let age = systemSeconds now - systemSeconds createdAt - subscriptions' <- bshow <$> TM.sizeIO subscriptions + subscriptions' <- bshow . M.size <$> readTVarIO subscriptions hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions'] CPStats -> withUserRole $ do ss <- unliftIO u $ asks serverStats @@ -854,8 +853,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt putStat "ntfCount" ntfCount readTVarIO role >>= \case CPRAdmin -> do - NtfStore ns <- unliftIO u $ asks ntfStore - ntfCount2 <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< TM.toMapIO ns + ns <- unliftIO u $ asks ntfStore + ntfCount2 <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 . map snd =<< getNtfs ns hPutStrLn h $ "ntfCount 2: " <> show ntfCount2 _ -> pure () putProxyStat "pRelays" pRelays @@ -893,8 +892,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt unliftIO u (asks sockets) >>= readTVarIO >>= mapM_ putSocketThreads where putSocketThreads (tcpPort, (_, _, active')) = do - active <- TM.toMapIO active' - forM_ (M.toList active) $ \(sid, tid') -> + active <- readTVarIO active' + forM_ (IM.toList active) $ \(sid, tid') -> deRefWeak tid' >>= \case Nothing -> hPutStrLn h $ intercalate "," [tcpPort, show sid, "", "gone", ""] Just tid -> do @@ -940,8 +939,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt -- TODO [certs rcv] service subscriptions clnts <- countSubClients activeSubs hPutStrLn h $ protoName <> " subscribed clients: " <> show (IS.size clnts) <> (if showIds then " " <> show (IS.toList clnts) else "") - clnts' <- TS.toSetIO subClients - hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (S.size clnts') <> (if showIds then " " <> show clnts' else "") + clnts' <- readTVarIO subClients + hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (IS.size clnts') <> (if showIds then " " <> show clnts' else "") where countSubClients :: Map QueueId (TVar (Maybe (Client s))) -> IO IS.IntSet countSubClients = foldM (\ !s c -> maybe s ((`IS.insert` s) . clientId) <$> readTVarIO c) IS.empty @@ -950,7 +949,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> Client s -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) cl = do - subs <- TM.toMapIO $ subSel cl + subs <- readTVarIO $ subSel cl cnts' <- case countSubs_ of Nothing -> pure cnts Just countSubs -> do @@ -1083,7 +1082,7 @@ runClientTransport h@THandle {params = thParams@THandleParams {sessionId}} = do noSubscriptions Client {clientId} s = not <$> anyM [hasSubs (subscribers s), hasSubs (ntfSubscribers s)] where - hasSubs ServerSubscribers {subClients} = atomically $ TS.member clientId subClients + hasSubs ServerSubscribers {subClients} = IS.member clientId <$> readTVarIO subClients controlPortAuth :: Handle -> Maybe BasicAuth -> Maybe BasicAuth -> TVar CPClientRole -> BasicAuth -> IO () controlPortAuth h user admin role auth = do @@ -1106,8 +1105,8 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, serviceS -- these can be in separate transactions, -- because the client already disconnected and they won't change atomically $ writeTVar connected False - subs <- atomically $ TM.flush subscriptions - ntfSubs <- atomically $ TM.flush ntfSubscriptions + subs <- atomically $ swapTVar subscriptions M.empty + ntfSubs <- atomically $ swapTVar ntfSubscriptions M.empty liftIO $ mapM_ cancelSub subs whenM (asks serverActive >>= readTVarIO) $ do srv@Server {subscribers, ntfSubscribers} <- asks server @@ -1120,13 +1119,13 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, serviceS | serviceRole == SRMessaging -> updateServiceSubs serviceId serviceSubsCount subscribers | serviceRole == SRNotifier -> updateServiceSubs serviceId ntfServiceSubsCount ntfSubscribers _ -> pure () - tIds <- atomically $ TM.flush endThreads + tIds <- atomically $ swapTVar endThreads IM.empty liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds where updateSubscribers :: Map QueueId a -> ServerSubscribers s -> IO () updateSubscribers subs ServerSubscribers {queueSubscribers, subClients} = do mapM_ (\qId -> deleteSubcribedClient qId c queueSubscribers) (M.keys subs) - atomically $ TS.delete clientId subClients + atomically $ modifyTVar' subClients $ IS.delete clientId updateServiceSubs :: ServiceId -> TVar (Int64, IdsHash) -> ServerSubscribers s -> IO () updateServiceSubs serviceId subsCount ServerSubscribers {totalServiceSubs, serviceSubscribers} = do deleteSubcribedClient serviceId c serviceSubscribers @@ -1402,8 +1401,8 @@ forkClient Client {endThreads, endThreadSeq} label action = do tId <- atomically $ stateTVar endThreadSeq $ \next -> (next, next + 1) t <- forkIO $ do labelMyThread label - action `finally` atomically (TM.delete tId endThreads) - mkWeakThreadId t >>= \w -> atomically $ TM.insert tId w endThreads + action `finally` atomically (modifyTVar' endThreads $ IM.delete tId) + mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId client :: forall s. MsgStoreClass s => Server s -> s -> Client s -> M s () client @@ -2470,9 +2469,9 @@ saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs where saveNtfs f = do logNote $ "saving notifications to file " <> T.pack f - NtfStore ns <- asks ntfStore + ns <- asks ntfStore liftIO . withFile f WriteMode $ \h -> - TM.toMapIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs + getNtfs ns >>= mapM_ (saveQueueNtfs h) logNote "notifications saved" where -- reverse on save, to save notifications in order, will become reversed again when restoring. @@ -2496,8 +2495,7 @@ restoreServerNtfs = liftIO exitFailure Right (lineCount, storedMsgsCount, expiredMsgsCount) -> do renameFile f $ f <> ".bak" - let NtfStore ns' = ns - storedQueues <- TM.sizeIO ns' + storedQueues <- length <$> getNtfs ns logNote $ "notifications restored, " <> tshow lineCount <> " lines processed" pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 5a7503aeb5..ab73484b38 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -50,7 +50,6 @@ module Simplex.Messaging.Server.Env.STM insertServerClient, deleteServerClient, getSubscribedClients, - getSubscribedClientsCount, getSubscribedClient, upsertSubscribedClient, lookupSubscribedClient, @@ -86,6 +85,8 @@ import Crypto.Random import Data.Int (Int64) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS import Data.Kind (Constraint) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) @@ -123,11 +124,10 @@ import Simplex.Messaging.Server.StoreLog.ReadWrite import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.TSet (TSet) -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP) import Simplex.Messaging.Transport.Server import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=)) +import qualified StmContainers.Map as SM import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.IO (IOMode (..)) @@ -345,15 +345,15 @@ data Server s = Server } -- not exported, to prevent concurrent IntMap lookups inside STM transactions. -newtype ServerClients s = ServerClients {serverClients :: TMap ClientId (Client s)} +newtype ServerClients s = ServerClients {serverClients :: TVar (IntMap (Client s))} data ServerSubscribers s = ServerSubscribers { subQ :: TQueue (ClientSub, ClientId), queueSubscribers :: SubscribedClients s, serviceSubscribers :: SubscribedClients s, -- service clients with long-term certificates that have subscriptions totalServiceSubs :: TVar (Int64, IdsHash), - subClients :: TSet ClientId, -- clients with individual or service subscriptions - pendingEvents :: TMap ClientId (NonEmpty (EntityId, BrokerMsg)) + subClients :: TVar IntSet, -- clients with individual or service subscriptions + pendingEvents :: TVar (IntMap (NonEmpty (EntityId, BrokerMsg))) } -- not exported, to prevent accidental concurrent Map lookups inside STM transactions. @@ -366,10 +366,7 @@ data ServerSubscribers s = ServerSubscribers data SubscribedClients s = SubscribedClients (TMap EntityId (TVar (Maybe (Client s)))) getSubscribedClients :: SubscribedClients s -> IO (Map EntityId (TVar (Maybe (Client s)))) -getSubscribedClients (SubscribedClients cs) = TM.toMapIO cs - -getSubscribedClientsCount :: SubscribedClients s -> IO Int -getSubscribedClientsCount (SubscribedClients cs) = TM.sizeIO cs +getSubscribedClients (SubscribedClients cs) = readTVarIO cs getSubscribedClient :: EntityId -> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s)))) getSubscribedClient entId (SubscribedClients cs) = TM.lookupIO entId cs @@ -437,7 +434,7 @@ data Client s = Client sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]), msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), procThreads :: TVar Int, - endThreads :: TMap Int (Weak ThreadId), + endThreads :: TVar (IntMap (Weak ThreadId)), endThreadSeq :: TVar Int, clientTHParams :: THandleParams SMPVersion 'TServer, connected :: TVar Bool, @@ -461,18 +458,18 @@ data Sub = Sub newServer :: IO (Server s) newServer = do - clients <- ServerClients <$> TM.emptyIO + clients <- ServerClients <$> newTVarIO mempty subscribers <- newServerSubscribers ntfSubscribers <- newServerSubscribers savingLock <- createLockIO return Server {clients, subscribers, ntfSubscribers, savingLock} getServerClients :: Server s -> IO (IntMap (Client s)) -getServerClients = TM.foldIO (\cs (cId, c) -> pure $! IM.insert cId c cs) IM.empty . serverClients . clients +getServerClients = readTVarIO . serverClients . clients {-# INLINE getServerClients #-} getServerClient :: ClientId -> Server s -> IO (Maybe (Client s)) -getServerClient cId = TM.lookupIO cId . serverClients . clients +getServerClient cId s = IM.lookup cId <$> getServerClients s {-# INLINE getServerClient #-} insertServerClient :: Client s -> Server s -> IO Bool @@ -480,12 +477,12 @@ insertServerClient c@Client {clientId, connected} Server {clients} = atomically $ ifM (readTVar connected) - (True <$ TM.insert clientId c (serverClients clients)) + (True <$ modifyTVar' (serverClients clients) (IM.insert clientId c)) (pure False) {-# INLINE insertServerClient #-} deleteServerClient :: ClientId -> Server s -> IO () -deleteServerClient cId Server {clients} = atomically $ TM.delete cId $ serverClients clients +deleteServerClient cId Server {clients} = atomically $ modifyTVar' (serverClients clients) $ IM.delete cId {-# INLINE deleteServerClient #-} newServerSubscribers :: IO (ServerSubscribers s) @@ -494,8 +491,8 @@ newServerSubscribers = do queueSubscribers <- SubscribedClients <$> TM.emptyIO serviceSubscribers <- SubscribedClients <$> TM.emptyIO totalServiceSubs <- newTVarIO (0, mempty) - subClients <- TS.emptyIO - pendingEvents <- TM.emptyIO + subClients <- newTVarIO IS.empty + pendingEvents <- newTVarIO IM.empty pure ServerSubscribers {subQ, queueSubscribers, serviceSubscribers, totalServiceSubs, subClients, pendingEvents} newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> IO (Client s) @@ -510,7 +507,7 @@ newClient clientId qSize clientTHParams createdAt = do sndQ <- newTBQueueIO qSize msgQ <- newTBQueueIO qSize procThreads <- newTVarIO 0 - endThreads <- TM.emptyIO + endThreads <- newTVarIO IM.empty endThreadSeq <- newTVarIO 0 connected <- newTVarIO True rcvActiveAt <- newTVarIO createdAt @@ -568,7 +565,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg StoreDatabase <$> newMsgStore cfg #endif - ntfStore <- NtfStore <$> TM.emptyIO + ntfStore <- NtfStore <$> SM.newIO random <- C.newRandom tlsServerCreds <- getCredentials "SMP" smpCredentials httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 50bc8778a8..9966248388 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -101,7 +101,6 @@ import Simplex.Messaging.Server.QueueStore.Postgres (PostgresQueueStore, batchIn import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM) import System.Directory (renameFile) import System.IO (IOMode (..), withFile) @@ -619,8 +618,8 @@ importStoreLogToDatabase storeLogFile dbOpts = do let st = queueStore ms sl <- readWriteQueueStore True (mkQueue ms) storeLogFile st closeStoreLog sl - qs <- TM.toMapIO $ queues st - services' <- M.elems <$> TM.toMapIO (services st) + qs <- readTVarIO $ queues st + services' <- M.elems <$> readTVarIO (services st) let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL} ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg sCnt <- batchInsertServices services' ps diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index b3ca84de0f..1f9b7a256b 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -36,7 +36,6 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.QueueStore.Types -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util ((<$$>), ($>>=)) data STMMsgStore = STMMsgStore @@ -96,8 +95,8 @@ instance MsgStoreClass STMMsgStore where loadedQueueCounts :: STMMsgStore -> IO LoadedQueueCounts loadedQueueCounts STMMsgStore {queueStore_ = st} = do - loadedQueueCount <- TM.sizeIO $ queues st - loadedNotifierCount <- TM.sizeIO $ notifiers st + loadedQueueCount <- M.size <$> readTVarIO (queues st) + loadedNotifierCount <- M.size <$> readTVarIO (notifiers st) pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount} mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing diff --git a/src/Simplex/Messaging/Server/NtfStore.hs b/src/Simplex/Messaging/Server/NtfStore.hs index d8e7ef367c..279ceae855 100644 --- a/src/Simplex/Messaging/Server/NtfStore.hs +++ b/src/Simplex/Messaging/Server/NtfStore.hs @@ -11,20 +11,22 @@ module Simplex.Messaging.Server.NtfStore deleteNtfs, deleteExpiredNtfs, deleteEmptyNtfs, + getNtfs, ) where import Control.Concurrent.STM +import Control.Monad (foldM) import Data.Functor (($>)) import Data.Int (Int64) import Data.Time.Clock.System (SystemTime (..)) +import qualified ListT import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (EncNMsgMeta, MsgId, NotifierId) -import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (whenM) +import qualified StmContainers.Map as SM -newtype NtfStore = NtfStore (TMap NotifierId (TVar [MsgNtf])) +newtype NtfStore = NtfStore (SM.Map NotifierId (TVar [MsgNtf])) data MsgNtf = MsgNtf { ntfMsgId :: MsgId, @@ -35,25 +37,25 @@ data MsgNtf = MsgNtf storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO () storeNtf (NtfStore ns) nId ntf = - atomically $ TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :)) + atomically $ SM.lookup nId ns >>= maybe (newTVar [ntf] >>= \v -> SM.insert v nId ns) (`modifyTVar'` (ntf :)) -- TODO [ntfdb] coalesce messages here once the client is updated to process multiple messages -- for single notification. -- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats deleteNtfs :: NtfStore -> NotifierId -> IO Int -deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO) +deleteNtfs (NtfStore ns) nId = atomically (SM.lookup nId ns <* SM.delete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO) deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int -deleteExpiredNtfs (NtfStore ns) old = - TM.foldIO (\expired -> fmap (expired +) . expireQueue . fst) 0 ns +deleteExpiredNtfs st@(NtfStore ns) old = + foldM (\expired -> fmap (expired +) . expireQueue) 0 . map fst =<< getNtfs st where - expireQueue nId = atomically $ TM.lookup nId ns >>= maybe (pure 0) (expire nId) + expireQueue nId = atomically $ SM.lookup nId ns >>= maybe (pure 0) (expire nId) expire nId v = readTVar v >>= \case - [] -> TM.delete nId ns $> 0 + [] -> SM.delete nId ns $> 0 -- check the last message first, it is the earliest ntfs | systemSeconds (ntfTs $ last $ ntfs) < old -> do let !ntfs' = filter (\MsgNtf {ntfTs = ts} -> systemSeconds ts >= old) ntfs - if null ntfs' then TM.delete nId ns else writeTVar v ntfs' + if null ntfs' then SM.delete nId ns else writeTVar v ntfs' pure $! length ntfs - length ntfs' _ -> pure 0 @@ -63,7 +65,12 @@ deleteEmptyNtfs (NtfStore ns) = mapM_ deleteEmpty deleteEmpty (nId, v) = whenM (null <$> readTVarIO v) $ atomically $ - TM.lookup nId ns >>= mapM_ (\v' -> whenM (null <$> readTVar v') $ TM.delete nId ns) + SM.lookup nId ns >>= mapM_ (\v' -> whenM (null <$> readTVar v') $ SM.delete nId ns) + +getNtfs :: NtfStore -> IO [(NotifierId, TVar [MsgNtf])] +getNtfs (NtfStore ns) = go [] $ SM.listT ns + where + go ntfs l = atomically (ListT.uncons l) >>= maybe (pure ntfs) (\(ntf, l') -> go (ntf : ntfs) l') data NtfLogRecord = NLRv1 NotifierId MsgNtf diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index f13ac871b3..8d56897b5c 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -36,6 +36,7 @@ import Data.Int (Int64) import Data.List (partition) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M +import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.X509.Validation as XV @@ -46,8 +47,6 @@ import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.TSet (TSet) -import qualified Simplex.Messaging.TSet as TS import Simplex.Messaging.Transport (SMPServiceRole (..)) import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>)) import System.IO @@ -65,8 +64,8 @@ data STMQueueStore q = STMQueueStore data STMService = STMService { serviceRec :: ServiceRec, - serviceRcvQueues :: (TSet RecipientId, TVar IdsHash), - serviceNtfQueues :: (TSet NotifierId, TVar IdsHash) + serviceRcvQueues :: TVar (Set RecipientId, IdsHash), + serviceNtfQueues :: TVar (Set NotifierId, IdsHash) } setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO () @@ -98,9 +97,9 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where getEntityCounts :: STMQueueStore q -> IO EntityCounts getEntityCounts st = do - queueCount <- TM.sizeIO $ queues st - notifierCount <- TM.sizeIO $ notifiers st - ss <- TM.toMapIO $ services st + queueCount <- M.size <$> readTVarIO (queues st) + notifierCount <- M.size <$> readTVarIO (notifiers st) + ss <- readTVarIO (services st) rcvServiceQueuesCount <- serviceQueuesCount serviceRcvQueues ss ntfServiceQueuesCount <- serviceQueuesCount serviceNtfQueues ss pure @@ -114,7 +113,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where } where serviceCount role = M.foldl' (\ !n s -> if serviceRole (serviceRec s) == role then n + 1 else n) 0 - serviceQueuesCount serviceSel = foldM (\n s -> (n +) <$> atomically (TS.size $ fst $ serviceSel s)) 0 + serviceQueuesCount serviceSel = foldM (\n s -> (n +) . S.size . fst <$> readTVarIO (serviceSel s)) 0 addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData, rcvServiceId} = do @@ -146,12 +145,17 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where getQueues_ :: BatchParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] getQueues_ st _ party qIds = case party of - SRecipient -> mapM (get queues) qIds - SNotifier -> mapM (\nId -> get notifiers nId $>>= get queues) qIds + SRecipient -> do + qs <- readTVarIO queues + pure $ map (get qs) qIds + SNotifier -> do + ns <- readTVarIO notifiers + qs <- readTVarIO queues + pure $ map (get qs <=< get ns) qIds where STMQueueStore {queues, notifiers} = st - get :: TMap QueueId a -> QueueId -> IO (Either ErrorType a) - get m qId = maybe (Left AUTH) Right <$> TM.lookupIO qId m + get :: M.Map QueueId a -> QueueId -> Either ErrorType a + get m = maybe (Left AUTH) Right . (`M.lookup` m) getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData) getQueueLinkData _ q lnkId = atomically $ readQueueRec (queueRec q) $>>= pure . getData @@ -306,8 +310,8 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where TM.insert fp newSrvId serviceCerts pure $ Right (newSrvId, True) newSTMService = do - serviceRcvQueues <- (,) <$> TS.empty <*> newTVar mempty - serviceNtfQueues <- (,) <$> TS.empty <*> newTVar mempty + serviceRcvQueues <- newTVar (S.empty, mempty) + serviceNtfQueues <- newTVar (S.empty, mempty) pure STMService {serviceRec = sr, serviceRcvQueues, serviceNtfQueues} setQueueService :: (PartyI p, ServiceParty p) => STMQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ()) @@ -333,7 +337,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where let !q' = Just q {notifier = Just nc {ntfServiceId = serviceId}} updateServiceQueues serviceNtfQueues nId prevNtfSrvId writeTVar qr q' $> Right () - updateServiceQueues :: (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> Maybe ServiceId -> STM () + updateServiceQueues :: (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> Maybe ServiceId -> STM () updateServiceQueues serviceSel qId prevSrvId = do mapM_ (removeServiceQueue st serviceSel qId) prevSrvId mapM_ (addServiceQueue st serviceSel qId) serviceId @@ -344,25 +348,24 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where getQueueNtfServices :: STMQueueStore q -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)])) getQueueNtfServices st ntfs = do - ss <- TM.toMapIO $ services st + ss <- readTVarIO (services st) (ssNtfs, noServiceNtfs) <- if M.null ss then pure ([], ntfs) else foldM addService ([], ntfs) (M.assocs ss) - ns <- S.fromList <$> filterM (`TM.memberIO` notifiers st) (map fst noServiceNtfs) - let (ntfs', deleteNtfs) = partition (\(nId, _) -> S.member nId ns) noServiceNtfs + ns <- readTVarIO (notifiers st) + let (ntfs', deleteNtfs) = partition (\(nId, _) -> M.member nId ns) noServiceNtfs ssNtfs' = (Nothing, ntfs') : ssNtfs pure $ Right (ssNtfs', deleteNtfs) where addService (ssNtfs, ntfs') (serviceId, s) = do - snIds <- S.fromList <$> filterM (atomically . (`TS.member` fst (serviceNtfQueues s))) (map fst ntfs') + (snIds, _) <- readTVarIO $ serviceNtfQueues s let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs' pure ((Just serviceId, sNtfs) : ssNtfs, restNtfs) getServiceQueueCountHash :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType (Int64, IdsHash)) getServiceQueueCountHash st party serviceId = TM.lookupIO serviceId (services st) >>= - maybe (pure $ Left AUTH) (fmap (Right . first fromIntegral) . readCountHash . serviceSel) + maybe (pure $ Left AUTH) (fmap (Right . first (fromIntegral . S.size)) . readTVarIO . serviceSel) where - readCountHash (qs, idsHash) = atomically $ (,) <$> TS.size qs <*> readTVar idsHash - serviceSel :: STMService -> (TSet QueueId, TVar IdsHash) + serviceSel :: STMService -> TVar (Set QueueId, IdsHash) serviceSel = case party of SRecipientService -> serviceRcvQueues SNotifierService -> serviceNtfQueues @@ -372,12 +375,13 @@ foldRcvServiceQueues st serviceId f acc = TM.lookupIO serviceId (services st) >>= \case Nothing -> pure acc Just s -> - TS.foldIO (\a -> get >=> maybe (pure a) (f a)) acc $ fst $ serviceRcvQueues s + readTVarIO (serviceRcvQueues s) + >>= foldM (\a -> get >=> maybe (pure a) (f a)) acc . fst where get rId = TM.lookupIO rId (queues st) $>>= \q -> (q,) <$$> readTVarIO (queueRec q) withLoadedQueues :: Monoid a => STMQueueStore q -> (q -> IO a) -> IO a -withLoadedQueues st f = TM.foldIO (\acc -> run acc . snd) mempty $ queues st +withLoadedQueues st f = readTVarIO (queues st) >>= foldM run mempty where run !acc = fmap (acc <>) . f @@ -390,21 +394,22 @@ setStatus qr status = Just q -> (Right (), Just q {status}) Nothing -> (Left AUTH, Nothing) -addServiceQueue :: STMQueueStore q -> (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> ServiceId -> STM () -addServiceQueue = setServiceQueues_ TS.insert +addServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> ServiceId -> STM () +addServiceQueue = setServiceQueues_ S.insert {-# INLINE addServiceQueue #-} -removeServiceQueue :: STMQueueStore q -> (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> ServiceId -> STM () -removeServiceQueue = setServiceQueues_ TS.delete +removeServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> ServiceId -> STM () +removeServiceQueue = setServiceQueues_ S.delete {-# INLINE removeServiceQueue #-} -setServiceQueues_ :: (QueueId -> TSet QueueId -> STM ()) -> STMQueueStore q -> (STMService -> (TSet QueueId, TVar IdsHash)) -> QueueId -> ServiceId -> STM () +setServiceQueues_ :: (QueueId -> Set QueueId -> Set QueueId) -> STMQueueStore q -> (STMService -> TVar (Set QueueId, IdsHash)) -> QueueId -> ServiceId -> STM () setServiceQueues_ updateSet st serviceSel qId serviceId = - TM.lookup serviceId (services st) >>= mapM_ (update . serviceSel) + TM.lookup serviceId (services st) >>= mapM_ (\v -> modifyTVar' (serviceSel v) update) where - update (s, idsHash) = do - updateSet qId s - modifyTVar' idsHash (queueIdHash qId <>) + update (s, idsHash) = + let !s' = updateSet qId s + !idsHash' = queueIdHash qId <> idsHash + in (s', idsHash') removeNotifier :: STMQueueStore q -> NtfCreds -> STM () removeNotifier st NtfCreds {notifierId = nId, ntfServiceId} = do diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs index dd85f892c7..21a5470aaa 100644 --- a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -23,13 +23,12 @@ import Simplex.Messaging.Server.QueueStore (QueueRec, ServiceRec (..)) import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..), withLoadedQueues) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (tshow, ($>>=)) import System.IO writeQueueStore :: forall q. StoreQueueClass q => StoreLog 'WriteMode -> STMQueueStore q -> IO () writeQueueStore s st = do - TM.toMapIO (services st) >>= mapM_ (logNewService s . serviceRec) + readTVarIO (services st) >>= mapM_ (logNewService s . serviceRec) withLoadedQueues st $ writeQueue where writeQueue :: q -> IO () diff --git a/src/Simplex/Messaging/Session.hs b/src/Simplex/Messaging/Session.hs index 5f72c238f6..16ff3c934e 100644 --- a/src/Simplex/Messaging/Session.hs +++ b/src/Simplex/Messaging/Session.hs @@ -15,7 +15,6 @@ import Control.Concurrent.STM import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) -import Data.Hashable (Hashable) import Data.Time (UTCTime) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -28,7 +27,7 @@ data SessionVar a = SessionVar sessionVarTs :: UTCTime } -getSessVar :: forall k a. Hashable k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> STM (Either (SessionVar a) (SessionVar a)) +getSessVar :: forall k a. Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> STM (Either (SessionVar a) (SessionVar a)) getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup sessKey vs where newSessionVar :: STM (SessionVar a) @@ -39,7 +38,7 @@ getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pur TM.insert sessKey v vs pure v -removeSessVar :: Hashable k => SessionVar a -> k -> TMap k (SessionVar a) -> STM () +removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM () removeSessVar v sessKey vs = TM.lookup sessKey vs >>= \case Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs @@ -52,7 +51,7 @@ removeSessVar v sessKey vs = -- A thrown ExceptT error is a normal result (the var keeps the error it was filled with) - only -- an interrupting exception drops the empty var. withGetSessVar :: - (Hashable k, MonadUnliftIO m) => + (Ord k, MonadUnliftIO m) => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> (SessionVar a -> ExceptT e m b) -> (SessionVar a -> ExceptT e m b) -> ExceptT e m b withGetSessVar sessSeq sessKey vs ts onNew onExisting = @@ -60,7 +59,7 @@ withGetSessVar sessSeq sessKey vs ts onNew onExisting = -- | withGetSessVar for actions in the underlying monad (without ExceptT). withGetSessVar' :: - (Hashable k, MonadUnliftIO m) => + (Ord k, MonadUnliftIO m) => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> (SessionVar a -> m b) -> (SessionVar a -> m b) -> m b withGetSessVar' sessSeq sessKey vs ts onNew onExisting = @@ -71,5 +70,5 @@ withGetSessVar' sessSeq sessKey vs ts onNew onExisting = where dropEmptySessVar v = whenM (isEmptyTMVar $ sessionVar v) $ removeSessVar v sessKey vs -tryReadSessVar :: Hashable k => k -> TMap k (SessionVar a) -> STM (Maybe a) +tryReadSessVar :: Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a) tryReadSessVar sessKey vs = TM.lookup sessKey vs $>>= (tryReadTMVar . sessionVar) diff --git a/src/Simplex/Messaging/TMap.hs b/src/Simplex/Messaging/TMap.hs index 7b2a95396d..b09158d5fb 100644 --- a/src/Simplex/Messaging/TMap.hs +++ b/src/Simplex/Messaging/TMap.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE TupleSections #-} + module Simplex.Messaging.TMap ( TMap, emptyIO, - empty, - fromMapIO, singleton, clear, Simplex.Messaging.TMap.null, @@ -20,137 +20,85 @@ module Simplex.Messaging.TMap alter, alterF, union, - replace, - toMap, - toMapIO, - flush, - foldIO, - sizeIO, ) where import Control.Concurrent.STM -import Data.Hashable (Hashable) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (isJust) -import qualified ListT -import qualified StmContainers.Map as SM -type TMap k a = SM.Map k a +type TMap k a = TVar (Map k a) emptyIO :: IO (TMap k a) -emptyIO = SM.newIO +emptyIO = newTVarIO M.empty {-# INLINE emptyIO #-} -empty :: STM (TMap k a) -empty = SM.new -{-# INLINE empty #-} - -fromMapIO :: Hashable k => Map k a -> IO (TMap k a) -fromMapIO m' = do - m <- SM.newIO - atomically $ union m' m - pure m -{-# INLINE fromMapIO #-} - -singleton :: Hashable k => k -> a -> STM (TMap k a) -singleton k v = do - m <- SM.new - SM.insert v k m - pure m +singleton :: k -> a -> STM (TMap k a) +singleton k v = newTVar $ M.singleton k v {-# INLINE singleton #-} clear :: TMap k a -> STM () -clear = SM.reset +clear m = writeTVar m M.empty {-# INLINE clear #-} null :: TMap k a -> STM Bool -null = SM.null +null m = M.null <$> readTVar m {-# INLINE null #-} -lookup :: Hashable k => k -> TMap k a -> STM (Maybe a) -lookup = SM.lookup +lookup :: Ord k => k -> TMap k a -> STM (Maybe a) +lookup k m = M.lookup k <$> readTVar m {-# INLINE lookup #-} -lookupIO :: Hashable k => k -> TMap k a -> IO (Maybe a) -lookupIO k = atomically . SM.lookup k +lookupIO :: Ord k => k -> TMap k a -> IO (Maybe a) +lookupIO k m = M.lookup k <$> readTVarIO m {-# INLINE lookupIO #-} -member :: Hashable k => k -> TMap k a -> STM Bool -member k m = isJust <$> SM.lookup k m +member :: Ord k => k -> TMap k a -> STM Bool +member k m = M.member k <$> readTVar m {-# INLINE member #-} -memberIO :: Hashable k => k -> TMap k a -> IO Bool -memberIO k = atomically . member k +memberIO :: Ord k => k -> TMap k a -> IO Bool +memberIO k m = M.member k <$> readTVarIO m {-# INLINE memberIO #-} -insert :: Hashable k => k -> a -> TMap k a -> STM () -insert k v = SM.insert v k +insert :: Ord k => k -> a -> TMap k a -> STM () +insert k v m = modifyTVar' m $ M.insert k v {-# INLINE insert #-} -insertM :: Hashable k => k -> STM a -> TMap k a -> STM () -insertM k f m = (\v -> SM.insert v k m) =<< f +insertM :: Ord k => k -> STM a -> TMap k a -> STM () +insertM k f m = modifyTVar' m . M.insert k =<< f {-# INLINE insertM #-} -delete :: Hashable k => k -> TMap k a -> STM () -delete = SM.delete +delete :: Ord k => k -> TMap k a -> STM () +delete k m = modifyTVar' m $ M.delete k {-# INLINE delete #-} -lookupInsert :: Hashable k => k -> a -> TMap k a -> STM (Maybe a) -lookupInsert k v m = SM.lookup k m <* SM.insert v k m +lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a) +lookupInsert k v m = stateTVar m $ M.alterF (,Just v) k {-# INLINE lookupInsert #-} -lookupDelete :: Hashable k => k -> TMap k a -> STM (Maybe a) -lookupDelete k m = SM.lookup k m <* SM.delete k m +lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a) +lookupDelete k m = stateTVar m $ M.alterF (,Nothing) k {-# INLINE lookupDelete #-} -adjust :: Hashable k => (a -> a) -> k -> TMap k a -> STM () -adjust f k m = mapM_ (\v -> SM.insert (f v) k m) =<< SM.lookup k m +adjust :: Ord k => (a -> a) -> k -> TMap k a -> STM () +adjust f k m = modifyTVar' m $ M.adjust f k {-# INLINE adjust #-} -update :: Hashable k => (a -> Maybe a) -> k -> TMap k a -> STM () -update f k m = mapM_ (set k m . f) =<< SM.lookup k m +update :: Ord k => (a -> Maybe a) -> k -> TMap k a -> STM () +update f k m = modifyTVar' m $ M.update f k {-# INLINE update #-} -alter :: Hashable k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM () -alter f k m = set k m . f =<< SM.lookup k m +alter :: Ord k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM () +alter f k m = modifyTVar' m $ M.alter f k {-# INLINE alter #-} -alterF :: Hashable k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM () -alterF f k m = set k m =<< f =<< SM.lookup k m +alterF :: Ord k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM () +alterF f k m = do + mv <- M.alterF f k =<< readTVar m + writeTVar m $! mv {-# INLINE alterF #-} -union :: Hashable k => Map k a -> TMap k a -> STM () -union m' m = mapM_ (\(k, v) -> SM.insert v k m) $ M.toList m' +union :: Ord k => Map k a -> TMap k a -> STM () +union m' m = modifyTVar' m $ M.union m' {-# INLINE union #-} - -replace :: Hashable k => Map k a -> TMap k a -> STM () -replace m' m = SM.reset m >> union m' m -{-# INLINE replace #-} - -toMap :: Ord k => TMap k a -> STM (Map k a) -toMap = fmap M.fromList . ListT.toList . SM.listT -{-# INLINE toMap #-} - -toMapIO :: Ord k => TMap k a -> IO (Map k a) -toMapIO = foldIO (\m (k, v) -> pure $! M.insert k v m) M.empty -{-# INLINE toMapIO #-} - -flush :: Ord k => TMap k a -> STM (Map k a) -flush m = toMap m <* SM.reset m -{-# INLINE flush #-} - -foldIO :: (b -> (k, a) -> IO b) -> b -> TMap k a -> IO b -foldIO f acc0 = go acc0 . SM.listT - where - go acc l = atomically (ListT.uncons l) >>= maybe (pure acc) (\(kv, l') -> f acc kv >>= (`go` l')) -{-# INLINE foldIO #-} - -sizeIO :: TMap k a -> IO Int -sizeIO = foldIO (\n _ -> pure $! n + 1) 0 -{-# INLINE sizeIO #-} - -set :: Hashable k => k -> TMap k a -> Maybe a -> STM () -set k m = maybe (SM.delete k m) (\v -> SM.insert v k m) -{-# INLINE set #-} diff --git a/src/Simplex/Messaging/TSet.hs b/src/Simplex/Messaging/TSet.hs deleted file mode 100644 index 4f1f09ac41..0000000000 --- a/src/Simplex/Messaging/TSet.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Simplex.Messaging.TSet - ( TSet, - emptyIO, - empty, - clear, - size, - member, - insert, - delete, - toSet, - toSetIO, - foldIO, - ) -where - -import Control.Concurrent.STM -import Data.Hashable (Hashable) -import Data.Set (Set) -import qualified Data.Set as S -import qualified ListT -import qualified StmContainers.Set as SS - -type TSet a = SS.Set a - -emptyIO :: IO (TSet a) -emptyIO = SS.newIO -{-# INLINE emptyIO #-} - -empty :: STM (TSet a) -empty = SS.new -{-# INLINE empty #-} - -clear :: TSet a -> STM () -clear = SS.reset -{-# INLINE clear #-} - -size :: TSet a -> STM Int -size = SS.size -{-# INLINE size #-} - -member :: Hashable a => a -> TSet a -> STM Bool -member = SS.lookup -{-# INLINE member #-} - -insert :: Hashable a => a -> TSet a -> STM () -insert = SS.insert -{-# INLINE insert #-} - -delete :: Hashable a => a -> TSet a -> STM () -delete = SS.delete -{-# INLINE delete #-} - -toSet :: Ord a => TSet a -> STM (Set a) -toSet = fmap S.fromList . ListT.toList . SS.listT -{-# INLINE toSet #-} - -toSetIO :: Ord a => TSet a -> IO (Set a) -toSetIO = foldIO (\s x -> pure $! S.insert x s) S.empty -{-# INLINE toSetIO #-} - -foldIO :: (b -> a -> IO b) -> b -> TSet a -> IO b -foldIO f acc0 = go acc0 . SS.listT - where - go acc l = atomically (ListT.uncons l) >>= maybe (pure acc) (\(x, l') -> f acc x >>= (`go` l')) -{-# INLINE foldIO #-} diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 430e9efa1f..ab693ad69b 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -38,7 +38,6 @@ import qualified Data.ByteString.Char8 as B import Data.Char (isAsciiLower, isDigit, isHexDigit) import Data.Default (def) import Data.Functor (($>)) -import Data.Hashable (Hashable (..)) import Data.IORef import Data.IP import Data.List.NonEmpty (NonEmpty (..)) @@ -75,13 +74,6 @@ data TransportHost | THDomainName HostName deriving (Eq, Ord, Show) -instance Hashable TransportHost where - hashWithSalt s = \case - THIPv4 addr -> s `hashWithSalt` (0 :: Int) `hashWithSalt` addr - THIPv6 addr -> s `hashWithSalt` (1 :: Int) `hashWithSalt` addr - THOnionHost host -> s `hashWithSalt` (2 :: Int) `hashWithSalt` host - THDomainName host -> s `hashWithSalt` (3 :: Int) `hashWithSalt` host - instance Encoding TransportHost where smpEncode = smpEncode . strEncode smpP = parseAll strP <$?> smpP diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 456e94ac6f..568efb3bc6 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -37,6 +37,8 @@ import Control.Monad import qualified Crypto.Store.X509 as SX import qualified Data.ByteString as B import Data.Default (def) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IM import Data.List (find) import Data.Maybe (fromJust, fromMaybe, maybeToList) import qualified Data.X509 as X @@ -46,8 +48,6 @@ import Foreign.C.Error import GHC.IO.Exception (ioe_errno) import Network.Socket import qualified Network.TLS as T -import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Shared import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow, unlessM) @@ -177,11 +177,11 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId' `seq` (cId', cId') closed <- newTVarIO False let closeConn _ = do - atomically $ writeTVar closed True >> TM.delete cId clients + atomically $ writeTVar closed True >> modifyTVar' clients (IM.delete cId) gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier atomically $ modifyTVar' gracefullyClosed (+ 1) tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn - atomically $ unlessM (readTVar closed) $ TM.insert cId tId clients + atomically $ unlessM (readTVar closed) $ modifyTVar' clients $ IM.insert cId tId -- | Recover from errors in `accept` whenever it is safe. -- Some errors are safe to ignore, while blindly restaring `accept` may trigger a busy loop. @@ -206,7 +206,7 @@ safeAccept sock = err = "socket accept error: " <> tshow e <> maybe "" ((", errno=" <>) . tshow) errno errno = ioe_errno e -type SocketState = (TVar Int, TVar Int, TMap Int (Weak ThreadId)) +type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId))) data SocketStats = SocketStats { socketsAccepted :: Int, @@ -216,20 +216,20 @@ data SocketStats = SocketStats } newSocketState :: IO SocketState -newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> TM.emptyIO +newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO mempty getSocketStats :: SocketState -> IO SocketStats getSocketStats (accepted, closed, active) = do socketsAccepted <- readTVarIO accepted socketsClosed <- readTVarIO closed - socketsActive <- TM.sizeIO active + socketsActive <- IM.size <$> readTVarIO active let socketsLeaked = socketsAccepted - socketsClosed - socketsActive pure SocketStats {socketsAccepted, socketsClosed, socketsActive, socketsLeaked} -closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO () +closeServer :: TMVar Bool -> TVar (IntMap (Weak ThreadId)) -> Socket -> IO () closeServer started clients sock = do close sock - TM.toMapIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread) + readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread) void . atomically $ tryPutTMVar started False startTCPServer :: TMVar Bool -> Maybe HostName -> ServiceName -> IO Socket diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index d5a17ca57d..7ed0d17b82 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -115,7 +115,6 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..)) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, alpnSupportedSMPHandshakes) import Simplex.Messaging.Transport.Server (TransportServerConfig (..)) import Simplex.Messaging.Util (bshow, diffToMicroseconds) @@ -4525,7 +4524,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do exchangeGreetingsMsgId 6 a bId2' b aId2' where hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () - hasClients c n = liftIO $ TM.sizeIO (smpClients c) `shouldReturn` n + hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n reconnected :: HasCallStack => AgentClient -> [[ConnId]] -> [ConnId] -> ExceptT AgentErrorType IO () reconnected c downs ups = liftIO $ getInAnyOrder c $ map down downs <> map up ups where diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index e07727d4e9..8214792a34 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -36,7 +36,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM +import qualified StmContainers.Map as SM import Test.Hspec hiding (fit, it) import Util @@ -246,7 +246,7 @@ queueMapSizes ms = (,,,) <$> size queues <*> size senders <*> size links <*> siz where STMQueueStore {queues, senders, links, notifiers} = queueStore ms size :: TMap k v -> IO Int - size = TM.sizeIO + size = fmap M.size . readTVarIO testDeleteQueueMaps :: STMMsgStore -> IO () testDeleteQueueMaps ms = do @@ -292,12 +292,12 @@ mkMsgNtf g ts = do pure MsgNtf {ntfMsgId, ntfTs = MkSystemTime ts 0, ntfNonce, ntfEncMeta = "meta"} ntfCounts :: NtfStore -> IO [(NotifierId, Int)] -ntfCounts (NtfStore ns) = M.assocs <$> (mapM (fmap length . readTVarIO) =<< TM.toMapIO ns) +ntfCounts st = M.assocs <$> (mapM (fmap length . readTVarIO) . M.fromList =<< getNtfs st) testExpireNtfs :: IO () testExpireNtfs = do g <- C.newRandom - st@(NtfStore ns) <- NtfStore <$> TM.emptyIO + st@(NtfStore ns) <- NtfStore <$> SM.newIO now <- systemSeconds <$> getSystemTime let old = now - 100 nId1 = EntityId "notifier 1" @@ -306,7 +306,7 @@ testExpireNtfs = do storeNtf st nId1 =<< mkMsgNtf g old storeNtf st nId2 =<< mkMsgNtf g old storeNtf st nId2 =<< mkMsgNtf g now - atomically $ TM.insertM nId3 (newTVar []) ns + atomically $ newTVar [] >>= \v -> SM.insert v nId3 ns ntfCounts st `shouldReturn` [(nId1, 1), (nId2, 2), (nId3, 0)] deleteExpiredNtfs st (now - 50) `shouldReturn` 2 ntfCounts st `shouldReturn` [(nId2, 1)] @@ -317,14 +317,14 @@ testExpireNtfs = do testDeleteEmptyNtfs :: IO () testDeleteEmptyNtfs = do g <- C.newRandom - st@(NtfStore ns) <- NtfStore <$> TM.emptyIO + st <- NtfStore <$> SM.newIO now <- systemSeconds <$> getSystemTime let nId1 = EntityId "notifier 1" nId2 = EntityId "notifier 2" nId3 = EntityId "notifier 3" nId4 = EntityId "notifier 4" forM_ ([nId1, nId2, nId3, nId4] :: [NotifierId]) $ \nId -> storeNtf st nId =<< mkMsgNtf g now - ntfs <- M.assocs <$> TM.toMapIO ns + ntfs <- getNtfs st let flush nId = forM_ (lookup nId ntfs) $ \v -> atomically $ writeTVar v [] mapM_ flush ([nId1, nId2, nId4] :: [NotifierId]) storeNtf st nId2 =<< mkMsgNtf g now diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 25d733f7ac..45116d4a50 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -35,7 +35,6 @@ import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.SystemTime -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPServiceRole (..)) import Simplex.Messaging.Transport.Credentials (genCredentials) import System.FilePath (()) @@ -192,7 +191,7 @@ testSMPStoreLog testSuite tests = ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted storeState :: STMMsgStore -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (TM.toMapIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec)) + storeState st = M.mapMaybe id <$> (readTVarIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec)) type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) @@ -298,7 +297,7 @@ testXFTPStoreLog testSuite tests = ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile compacted' `shouldBe` compacted storeState :: STMFileStore -> IO (M.Map SenderId FileRecState) - storeState st = TM.toMapIO (files st) >>= mapM fileState + storeState st = readTVarIO (files st) >>= mapM fileState fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus pure (fileInfo, createdAt, expiresAt, status) diff --git a/tests/CoreTests/TSessionSubs.hs b/tests/CoreTests/TSessionSubs.hs index d4261f62e2..96975e9efe 100644 --- a/tests/CoreTests/TSessionSubs.hs +++ b/tests/CoreTests/TSessionSubs.hs @@ -19,7 +19,6 @@ import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client (SMPTransportSession, TransportSessionMode (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SessionId) import Test.Hspec hiding (fit, it) import UnliftIO @@ -32,7 +31,7 @@ instance IsString EntityId where fromString = EntityId . B.pack dumpSessionSubs :: SS.TSessionSubs -> IO (M.Map SMPTransportSession (Maybe SessionId, (M.Map RecipientId RcvQueueSub, M.Map RecipientId RcvQueueSub))) dumpSessionSubs = - TM.toMapIO . SS.sessionSubs + readTVarIO . SS.sessionSubs >=> mapM (\s -> (,) <$> readTVarIO (SS.subsSessId s) <*> SS.mapSubs id s) srv1 :: SMPServer diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 9c4f7b78c8..79dac6dd39 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -303,7 +303,7 @@ getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest getAnyMockNotification APNSMockServer {notifications} = do - atomically $ TM.toMap notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf + atomically $ readTVar notifications >>= mapM readTBQueue . M.elems >>= \case [] -> retry; ntf : _ -> pure ntf closeAPNSMockServer :: APNSMockServer -> IO () closeAPNSMockServer APNSMockServer {action, http2Server} = do From 6e9e51fe7a0d73296b90a69eeb640d010e49fecb Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 25 Oct 2026 19:36:19 +0000 Subject: [PATCH 3/3] smp server: keep client agent unchanged --- src/Simplex/Messaging/Client/Agent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index c110953de7..0d59f00b8f 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -328,7 +328,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s runSubWorker v = withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do subs_ <- atomically $ do - s <- getPending TM.lookup readTVar + s <- getPending TM.lookup readTVar if noPending s then cleanup v $> Nothing else pure $ Just s