deduplicate connections for locking

.github/workflows/build.yml

@@ -75,7 +75,7 @@ jobs:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
 
       - name: Create release
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' && matrix.ghc == '9.6.3'
+        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
         uses: softprops/action-gh-release@v1
         with:
           body: |

CHANGELOG.md

@@ -1,44 +1,3 @@
-# 5.5.2
-
-Extensible handshake for clients and SMP/NTF servers (ignore extra data).
-
-# 5.5.1
-
-SMP servers:
-- do not keep stats file open
-- additional stats about currently stored messages
-
-Agent:
-- support multiple notification servers (only one can be used at a time).
-- expire messages after "quota exceeded" error after 7 days (instead of 21 days previously).
-- stabilize message delivery, remove unnecessary subscription retries and traffic.
-- improve database performance for message delivery.
-- fix sockets/memory leak - a very old bug "activated" by improvements in v5.5.0.
-
-# 5.5.0
-
-Code:
-- compatible with GHC 8.10.7 to support compilation for armv7a.
-- migrate to `crypton` from deprecated `cryptonite` (the seed for DRG is now sha512-hashed).
-- use ChaChaDRG for all random IDs, keys and nonces, only using hashed entropy as seed.
-- more efficient transaction batching in SMP protocol client and server.
-
-Agent:
-- stabilize message reception and delivery, migrate message delivery to database queue.
-- additional event MSGNTF confirming that message received via notification is processed.
-- efficient processing of messages sent to multiple recipients with batched database transactions.
-- new worker abstraction for all queued tasks resilient to race conditions and some database errors.
-- many fixed race conditions.
-- background mode for iOS NSE.
-- additional error reporting to client on critical errors (to be show as alert in the clients).
-- functional api to get worker statistics.
-
-SMP/XFTP servers:
-- fix socket and memory leak on servers with high load (inactive clients without subscriptions are disconnected after set time of inactivity).
-- control port improvements.
-- fix statistics for stored queues, messages and files.
-- make writing to store log atomic (fixes a rare bug in XFTP server).
-
 # 5.4.0
 
 Migrate to GHC 9.6.3

apps/smp-agent/Main.hs

@@ -35,7 +35,6 @@ servers =
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
--- Warning: this SMP agent server is experimental - it does not work correctly with multiple connected TCP clients in some cases.
 main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.5.2.0
+version: 5.4.0.7
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,

protocol/xftp-uri-request.txt

@@ -1,16 +0,0 @@
-Scheme name: xftp
-
-Status: Provisional
-
-Applications/protocols that use this scheme name:
-This scheme is used for URIs of XFTP (SimpleX File Transfer Protocol) servers,
-a client-server protocol for asynchronous file transfer via relays,
-preserving file meta-data (including size and name) and content privacy.
-
-Contact: Evgeny Poberezkin <ep@simplex.chat>
-
-Change controller: Evgeny Poberezkin <ep@simplex.chat>
-
-References:
-The syntax for server URIs in the provisional specification for SimpleX File Transfer Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2022-12-26-simplex-file-transfer.md#server-address-syntax

protocol/xrcp-uri-request.txt

@@ -1,15 +0,0 @@
-Scheme name: xrcp
-
-Status: Provisional
-
-Applications/protocols that use this scheme name:
-This scheme is used for URIs of controller sessions via SimpleX Remote Control protocol (XRCP),
-a protocol for remote access and management of hosts via insecure network.
-
-Contact: Evgeny Poberezkin <ep@simplex.chat>
-
-Change controller: Evgeny Poberezkin <ep@simplex.chat>
-
-References:
-The syntax for server URIs in the provisional specification for SimpleX File Transfer Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2023-10-25-remote-control.md#session-invitation

rfcs/2022-12-26-simplex-file-transfer.md

@@ -149,19 +149,6 @@ parts:
 
 This file description is sent to all recipients via normal messages, split to 15780 byte chunks if needed.
 
-### Server address syntax
-
-The server address is a URI with the following format:
-
-```abnf
-xftpServerURI = %s"xftp://" xftpServer
-xftpServer = serverIdentity "@" srvHost [":" port]
-srvHost = <hostname> ; RFC1123, RFC5891
-port = 1*DIGIT
-serverIdentity = base64url
-base64url = <base64url encoded binary> ; RFC4648, section 5
-```
-
 ### Receiving file
 
 Having received the description, the recipient will:

rfcs/2023-09-12-second-relays.md

@@ -74,8 +74,6 @@ Below considers this design.
 
 5. SMP proxy should implement retry logic and hold messages while they are delivered. They also should return relay replies to the client. To avoid any additional traffic the client should just add "sent to proxy" status and only show "sent" once proxy returns the response from the destination relay - there should be no additional response from the proxy confirming acceptance to delivery.
 
-This would also reduce the difference in how the traffic looks to the observer - sending via proxy may look similar to sending to the usual server (which can be further supported by friendly destination relays that could add latency for direct requests and reply quickly when response came via proxy and be undermined by hostile relays that would introduce some latency pattern to help traffic correlation. The latter problem can be mitigated by having a fixed response latency from proxy that may be "come back later for destination response").
-
 6. Sending messages to groups have to be batched in the client to avoid multiple requests for destination relay sessions - such requests can be batched to proxy, even though it leaks _some_ metadata - which destination relays are used by a given sender's IP address, it also reduces the overhead from proxies – it could be an option based on the privacy slider.
 
 6. SMP proxy may also increase utility and privacy of the platform:
@@ -91,7 +89,7 @@ This would also reduce the difference in how the traffic looks to the observer -
 
 3. We probably should aim to avoid changing agent/client logic and see it instead as transport concern that can be dynamically decided at a point of sending a message, based on the current configuration.
 
-4. Configuration should probably allow to choose between not using proxies (particularly, during testing, when it would be the default), using proxies only for unknown relays, and using proxies for all relays (extra traffic, but more complex transport correlation - although randomizing this choice can be more beneficial to the transport privacy). The clients can aim to use proxy from another provider, to reduce the risks of sharing the information.
+4. Configuration should probably allow to choose between not using proxies (particularly, during testing, when it would be the default), using proxies only for unknown relays, and using proxies for all relays (extra traffic, but more complex transport correlation). The clients can aim to use proxy from another provider, to reduce the risks of sharing the information.
 
 ### SMP-proxy protocol
 
@@ -99,7 +97,7 @@ The flow of the messages will be:
 
 1. Client requests proxy to create session with the relay by sending `server` command with the SMP relay address and optional proxy basic AUTH (below). It should be possible to batch multiple session requests into one block, to reduce traffic.
 
-2. Proxy connects to SMP relay, negotiating a shared secret in the handshake that will be used to encrypt all sender blocks inside TLS (proxy-relay encryption). SMP relay also returns in handshake its temporary DH key to agree e2e encryption with the client (sender-relay encryption, to hide metadata sent to the destination relay from proxy).
+2. Proxy connects to SMP relay, negotiating a shared secret in the handshake that will be used to encrypt all sender blocks inside TLS (proxy-relay encryption). SMP relay also returns in handshake its temporary DH key to agree e2e encryption with the client (sender-relay encryption, to protect metadata from proxy).
 
 3. Proxy replies with `server_id` command including relay session ID to identify it in further requests, relay DH key for e2e encryption with the client - this key is signed with the TLS online private key associated with the certificate (its fingerprint is included in the relay address), and the TLS session ID between proxy and relay (this session ID must be used in transmissions, to mitigate replay attacks as before).
 
@@ -109,10 +107,6 @@ With 32 bits per key there will be ~1/1,000,000 false positives (see https://en.
 
 Given that the client chooses proxy it has some trust to, maybe this replay attack risk can be accepted.
 
-It is important that the same public key from destination relay is returned to all clients, so proxy does not need to repeat this request to know relays while the key did not expire, as using different keys for different clients would allow destination relays to correlate requests to the clients. A proxy that colludes with the destination relay can pass different public keys to the same client, but it is not changing threat model as colluding proxy can share information as well. It is also important that the client uses a new random key for each command, as using the same key would allow the destination relay to identify these commands as comming from the same user, and using a different key for each queue while would protect privacy of the user from the destination relay, would make it visible to the proxy how many different queues the client has on destination relay.
-
-*Unrelated cosideration for SMP protocol privacy improvement*: instead of signing commands to the destination relay, the sender could have a ratchet per queue agreed with the destination relay that would simply use authenticated encryption with per-message symmetric key to encrypt the message on the way to relay, and this encryption would be used as a proof of sender.
-
 4. Now the client sends `forward` to proxy, which it then forwards to SMP relay, applying additional encryption layer.
 
 5. SMP relay sends `response` to proxy applying additional encryption layer, which it then forwards to the client removing the additional encryption layer.
@@ -179,7 +173,7 @@ proxy_command = server / server_id / forward / response / error
 server = "S" address [relay_basic_auth] ; creates transport session between proxy and relay
 server_id = "I" relay_session_id tls_session_id signed_relay_key ;
     ; session_id is the TLS session ID between proxy and relay, it has to be included inside encrypted block to prevent replay attacks
-forward = %s"F" random_dh_pub_key encrypted_block ; it's important that a new key is used for each command, to prevent any correlation by proxy or by destination relay
+forward = %s"F" random_dh_pub_key encrypted_block
 response = %s"R" encrypted_block; response received from the destination SMP relay
 relay_session_id = length *8 OCTET
 error = %s"E" error

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.5.2.0
+version:        5.4.0.7
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -51,7 +51,6 @@ library
       Simplex.FileTransfer.Description
       Simplex.FileTransfer.Protocol
       Simplex.FileTransfer.Server
-      Simplex.FileTransfer.Server.Control
       Simplex.FileTransfer.Server.Env
       Simplex.FileTransfer.Server.Main
       Simplex.FileTransfer.Server.Stats
@@ -99,9 +98,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
+      Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent

src/Simplex/FileTransfer/Agent.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
@@ -30,7 +31,6 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Composition ((.:))
 import Data.Int (Int64)
 import Data.List (foldl', sortOn)
 import qualified Data.List.NonEmpty as L
@@ -58,6 +58,8 @@ import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol (EntityId, XFTPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (liftError, tshow, unlessM, whenM)
 import System.FilePath (takeFileName, (</>))
 import UnliftIO
@@ -67,34 +69,37 @@ startXFTPWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
 startXFTPWorkers c workDir = do
   wd <- asks $ xftpWorkDir . xftpAgent
   atomically $ writeTVar wd workDir
-  cfg <- asks config
-  startRcvFiles cfg
-  startSndFiles cfg
-  startDelFiles cfg
+  startRcvFiles
+  startSndFiles
+  startDelFiles
   where
-    startRcvFiles AgentConfig {rcvFilesTTL} = do
+    startRcvFiles = do
+      rcvFilesTTL <- asks $ rcvFilesTTL . config
       pendingRcvServers <- withStore' c (`getPendingRcvFilesServers` rcvFilesTTL)
-      forM_ pendingRcvServers $ \s -> resumeXFTPRcvWork c (Just s)
+      forM_ pendingRcvServers $ \s -> addXFTPRcvWorker c (Just s)
       -- start local worker for files pending decryption,
       -- no need to make an extra query for the check
       -- as the worker will check the store anyway
-      resumeXFTPRcvWork c Nothing
-    startSndFiles AgentConfig {sndFilesTTL} = do
+      addXFTPRcvWorker c Nothing
+    startSndFiles = do
+      sndFilesTTL <- asks $ sndFilesTTL . config
       -- start worker for files pending encryption/creation
-      resumeXFTPSndWork c Nothing
+      addXFTPSndWorker c Nothing
       pendingSndServers <- withStore' c (`getPendingSndFilesServers` sndFilesTTL)
-      forM_ pendingSndServers $ \s -> resumeXFTPSndWork c (Just s)
-    startDelFiles AgentConfig {rcvFilesTTL} = do
+      forM_ pendingSndServers $ \s -> addXFTPSndWorker c (Just s)
+    startDelFiles = do
+      rcvFilesTTL <- asks $ rcvFilesTTL . config
       pendingDelServers <- withStore' c (`getPendingDelFilesServers` rcvFilesTTL)
-      forM_ pendingDelServers $ resumeXFTPDelWork c
+      forM_ pendingDelServers $ addXFTPDelWorker c
 
 closeXFTPAgent :: MonadUnliftIO m => XFTPAgent -> m ()
-closeXFTPAgent a = do
-  stopWorkers $ xftpRcvWorkers a
-  stopWorkers $ xftpSndWorkers a
-  stopWorkers $ xftpDelWorkers a
+closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
+  stopWorkers xftpRcvWorkers
+  stopWorkers xftpSndWorkers
   where
-    stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
+    stopWorkers wsSel = do
+      ws <- atomically $ stateTVar wsSel (,M.empty)
+      mapM_ (uninterruptibleCancel . snd) ws
 
 xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
 xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfArgs = do
@@ -113,7 +118,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfA
   where
     downloadChunk :: AgentMonad m => FileChunk -> m ()
     downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
-      void $ getXFTPRcvWorker True c (Just server)
+      addXFTPRcvWorker c (Just server)
     downloadChunk _ = throwError $ INTERNAL "no replicas"
 
 getPrefixPath :: AgentMonad m => String -> m FilePath
@@ -129,35 +134,55 @@ toFSFilePath f = (</> f) <$> getXFTPWorkPath
 createEmptyFile :: AgentMonad m => FilePath -> m ()
 createEmptyFile fPath = liftIO $ B.writeFile fPath ""
 
-resumeXFTPRcvWork :: AgentMonad' m => AgentClient -> Maybe XFTPServer -> m ()
-resumeXFTPRcvWork = void .: getXFTPRcvWorker False
+addXFTPRcvWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPRcvWorker c = addWorker c xftpRcvWorkers runXFTPRcvWorker runXFTPRcvLocalWorker
 
-getXFTPRcvWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe XFTPServer -> m Worker
-getXFTPRcvWorker hasWork c server = do
-  ws <- asks $ xftpRcvWorkers . xftpAgent
-  getAgentWorker "xftp_rcv" hasWork c server ws $
-    maybe (runXFTPRcvLocalWorker c) (runXFTPRcvWorker c) server
+addWorker ::
+  AgentMonad m =>
+  AgentClient ->
+  (XFTPAgent -> TMap (Maybe XFTPServer) (TMVar (), Async ())) ->
+  (AgentClient -> XFTPServer -> TMVar () -> m ()) ->
+  (AgentClient -> TMVar () -> m ()) ->
+  Maybe XFTPServer ->
+  m ()
+addWorker c wsSel runWorker runWorkerNoSrv srv_ = do
+  ws <- asks $ wsSel . xftpAgent
+  atomically (TM.lookup srv_ ws) >>= \case
+    Nothing -> do
+      doWork <- newTMVarIO ()
+      let runWorker' = case srv_ of
+            Just srv -> runWorker c srv doWork
+            Nothing -> runWorkerNoSrv c doWork
+      worker <- async $ runWorker' `agentFinally` atomically (TM.delete srv_ ws)
+      atomically $ TM.insert srv_ (doWork, worker) ws
+    Just (doWork, _) ->
+      void . atomically $ tryPutTMVar doWork ()
 
-runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
-runXFTPRcvWorker c srv Worker {doWork} = do
-  cfg <- asks config
+runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPRcvWorker c srv doWork = do
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation cfg
+    runXFTPOperation
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} =
-      withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case
-        RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
-        fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      rcvFilesTTL <- asks (rcvFilesTTL . config)
+      nextChunk <- withStore' c $ \db -> getNextRcvChunkToDownload db srv rcvFilesTTL
+      case nextChunk of
+        Nothing -> noWorkToDo
+        Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
+        Just fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do
+          ri <- asks $ reconnectInterval . config
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
+          withRetryInterval ri' $ \delay' loop ->
             downloadFileChunk fc replica
               `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
+                notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
                 when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e
                 closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
@@ -180,8 +205,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
         liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
         pure (complete, RFPROG rcvd total)
       notify c rcvFileEntityId progress
-      when complete . void $
-        getXFTPRcvWorker True c Nothing
+      when complete $ addXFTPRcvWorker c Nothing
       where
         receivedSize :: [RcvFileChunk] -> Int64
         receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0
@@ -190,12 +214,6 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           | otherwise = 0
         chunkReceived RcvFileChunk {replicas} = any received replicas
 
--- The first call of action has n == 0, maxN is max number of retries
-withRetryIntervalLimit :: forall m. MonadIO m => Int -> RetryInterval -> (Int64 -> m () -> m ()) -> m ()
-withRetryIntervalLimit maxN ri action =
-  withRetryIntervalCount ri $ \n delay loop ->
-    when (n < maxN) $ action delay loop
-
 retryOnError :: AgentMonad m => Text -> m a -> m a -> AgentErrorType -> m a
 retryOnError name loop done e = do
   logError $ name <> " error: " <> tshow e
@@ -209,19 +227,22 @@ rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
   withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
   notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr
 
-runXFTPRcvLocalWorker :: forall m. AgentMonad m => AgentClient -> Worker -> m ()
-runXFTPRcvLocalWorker c Worker {doWork} = do
-  cfg <- asks config
+runXFTPRcvLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+runXFTPRcvLocalWorker c doWork = do
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation cfg
+    runXFTPOperation
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation AgentConfig {rcvFilesTTL} =
-      withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
-        \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      rcvFilesTTL <- asks (rcvFilesTTL . config)
+      nextFile <- withStore' c (`getNextRcvFileToDecrypt` rcvFilesTTL)
+      case nextFile of
+        Nothing -> noWorkToDo
+        Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
           decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveFile, status, chunks} = do
       let CryptoFile savePath cfArgs = saveFile
@@ -265,39 +286,36 @@ xftpSendFile' c userId file numRecipients = do
   prefixPath <- getPrefixPath "snd.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
-  key <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
+  key <- liftIO C.randomSbKey
+  nonce <- liftIO C.randomCbNonce
   -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
   fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce
-  void $ getXFTPSndWorker True c Nothing
+  addXFTPSndWorker c Nothing
   pure fId
 
-resumeXFTPSndWork :: AgentMonad' m => AgentClient -> Maybe XFTPServer -> m ()
-resumeXFTPSndWork = void .: getXFTPSndWorker False
+addXFTPSndWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPSndWorker c = addWorker c xftpSndWorkers runXFTPSndWorker runXFTPSndPrepareWorker
 
-getXFTPSndWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe XFTPServer -> m Worker
-getXFTPSndWorker hasWork c server = do
-  ws <- asks $ xftpSndWorkers . xftpAgent
-  getAgentWorker "xftp_snd" hasWork c server ws $
-    maybe (runXFTPSndPrepareWorker c) (runXFTPSndWorker c) server
-
-runXFTPSndPrepareWorker :: forall m. AgentMonad m => AgentClient -> Worker -> m ()
-runXFTPSndPrepareWorker c Worker {doWork} = do
-  cfg <- asks config
+runXFTPSndPrepareWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+runXFTPSndPrepareWorker c doWork = do
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation cfg
+    runXFTPOperation
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation cfg@AgentConfig {sndFilesTTL} =
-      withWork c doWork (`getNextSndFileToPrepare` sndFilesTTL) $
-        \f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
-          prepareFile cfg f `catchAgentError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
-    prepareFile :: AgentConfig -> SndFile -> m ()
-    prepareFile _ SndFile {prefixPath = Nothing} =
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      nextFile <- withStore' c (`getNextSndFileToPrepare` sndFilesTTL)
+      case nextFile of
+        Nothing -> noWorkToDo
+        Just f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
+          prepareFile f `catchAgentError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    prepareFile :: SndFile -> m ()
+    prepareFile SndFile {prefixPath = Nothing} =
       throwError $ INTERNAL "no prefix path"
-    prepareFile cfg sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do
+    prepareFile sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do
       SndFile {numRecipients, chunks} <-
         if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
           then do
@@ -310,13 +328,12 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
               updateSndFileEncrypted db sndFileId digest chunkSpecsDigests
               getSndFile db sndFileId
           else pure sndFile
+      maxRecipients <- asks (xftpMaxRecipientsPerRequest . config)
       let numRecipients' = min numRecipients maxRecipients
       -- concurrently?
-      -- separate worker to create chunks? record retries and delay on snd_file_chunks?
       forM_ (filter (not . chunkCreated) chunks) $ createChunk numRecipients'
       withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
       where
-        AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients, messageRetryInterval = ri} = cfg
         encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [(XFTPChunkSpec, FileDigest)])
         encryptFileForUpload SndFile {key, nonce, srcFile} fsEncPath = do
           let CryptoFile {filePath} = srcFile
@@ -341,9 +358,10 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
           atomically $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate
           withStore' c $ \db -> createSndFileReplica db ch replica
-          void $ getXFTPSndWorker True c (Just srv)
+          addXFTPSndWorker c $ Just srv
           where
             tryCreate = do
+              ri <- asks $ messageRetryInterval . config
               usedSrvs <- newTVarIO ([] :: [XFTPServer])
               withRetryInterval (riFast ri) $ \_ loop ->
                 createWithNextSrv usedSrvs
@@ -363,34 +381,39 @@ sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = d
   withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr
   notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr
 
-runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
-runXFTPSndWorker c srv Worker {doWork} = do
-  cfg <- asks config
+runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPSndWorker c srv doWork = do
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation cfg
+    runXFTPOperation
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation cfg@AgentConfig {sndFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do
-      withWork c doWork (\db -> getNextSndChunkToUpload db srv sndFilesTTL) $ \case
-        SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
-        fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      nextChunk <- withStore' c $ \db -> getNextSndChunkToUpload db srv sndFilesTTL
+      case nextChunk of
+        Nothing -> noWorkToDo
+        Just SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
+        Just fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
+          ri <- asks $ reconnectInterval . config
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
-            uploadFileChunk cfg fc replica
+          withRetryInterval ri' $ \delay' loop ->
+            uploadFileChunk fc replica
               `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
+                notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
                 when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
                 closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
               atomically $ assertAgentForeground c
               loop
             retryDone e = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (show e)
-    uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> m ()
-    uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
+    uploadFileChunk :: SndFileChunk -> SndFileChunkReplica -> m ()
+    uploadFileChunk sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
       replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica
       fsFilePath <- toFSFilePath filePath
       unlessM (doesFileExist fsFilePath) $ throwError $ INTERNAL "encrypted file doesn't exist on upload"
@@ -416,6 +439,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
           | length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients"
           | length rcvIdsKeys == numRecipients = pure cr
           | otherwise = do
+              maxRecipients <- asks $ xftpMaxRecipientsPerRequest . config
               let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
               rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
               cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
@@ -503,47 +527,55 @@ deleteSndFileRemote c userId sndFileEntityId (ValidFileDescription FileDescripti
     deleteFileChunk :: FileChunk -> m ()
     deleteFileChunk FileChunk {digest, replicas = replica@FileChunkReplica {server} : _} = do
       withStore' c $ \db -> createDeletedSndChunkReplica db userId replica digest
-      void $ getXFTPDelWorker True c server
+      addXFTPDelWorker c server
     deleteFileChunk _ = pure ()
 
-resumeXFTPDelWork :: AgentMonad' m => AgentClient -> XFTPServer -> m ()
-resumeXFTPDelWork = void .: getXFTPDelWorker False
-
-getXFTPDelWorker :: AgentMonad' m => Bool -> AgentClient -> XFTPServer -> m Worker
-getXFTPDelWorker hasWork c server = do
+addXFTPDelWorker :: AgentMonad m => AgentClient -> XFTPServer -> m ()
+addXFTPDelWorker c srv = do
   ws <- asks $ xftpDelWorkers . xftpAgent
-  getAgentWorker "xftp_del" hasWork c server ws $ runXFTPDelWorker c server
+  atomically (TM.lookup srv ws) >>= \case
+    Nothing -> do
+      doWork <- newTMVarIO ()
+      worker <- async $ runXFTPDelWorker c srv doWork `agentFinally` atomically (TM.delete srv ws)
+      atomically $ TM.insert srv (doWork, worker) ws
+    Just (doWork, _) ->
+      void . atomically $ tryPutTMVar doWork ()
 
-runXFTPDelWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
-runXFTPDelWorker c srv Worker {doWork} = do
-  cfg <- asks config
+runXFTPDelWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPDelWorker c srv doWork = do
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation cfg
+    runXFTPOperation
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
       -- no point in deleting files older than rcv ttl, as they will be expired on server
-      withWork c doWork (\db -> getNextDeletedSndChunkReplica db srv rcvFilesTTL) processDeletedReplica
-      where
-        processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do
+      rcvFilesTTL <- asks (rcvFilesTTL . config)
+      nextReplica <- withStore' c $ \db -> getNextDeletedSndChunkReplica db srv rcvFilesTTL
+      case nextReplica of
+        Nothing -> noWorkToDo
+        Just replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} -> do
+          ri <- asks $ reconnectInterval . config
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
-            deleteChunkReplica
+          withRetryInterval ri' $ \delay' loop ->
+            deleteChunkReplica replica
               `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
+                notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
                 when notifyOnRetry $ notify c "" $ SFERR e
                 closeXFTPServerClient c userId server chunkDigest
                 withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
               atomically $ assertAgentForeground c
               loop
             retryDone = delWorkerInternalError c deletedSndChunkReplicaId
-            deleteChunkReplica = do
-              agentXFTPDeleteChunk c userId replica
-              withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
+    deleteChunkReplica :: DeletedSndChunkReplica -> m ()
+    deleteChunkReplica replica@DeletedSndChunkReplica {userId, deletedSndChunkReplicaId} = do
+      agentXFTPDeleteChunk c userId replica
+      withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
 
 delWorkerInternalError :: AgentMonad m => AgentClient -> Int64 -> AgentErrorType -> m ()
 delWorkerInternalError c deletedSndChunkReplicaId e = do

src/Simplex/FileTransfer/Client.hs

@@ -11,7 +11,6 @@ module Simplex.FileTransfer.Client where
 
 import Control.Monad
 import Control.Monad.Except
-import Crypto.Random (ChaChaDRG)
 import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
@@ -132,15 +131,11 @@ xftpClientError = \case
   HCIOError e -> PCEIOError e
 
 sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
-sendXFTPCommand c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
+sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
   t <-
     liftEither . first PCETransportError $
       xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
-  sendXFTPTransmission c t chunkSpec_
-
-sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
-sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} t chunkSpec_ = do
-  let req = H.requestStreaming N.methodPost "/" [] streamBody
+  let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
       reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
   HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
   when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
@@ -152,8 +147,8 @@ sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessio
       _ -> pure (r, body)
     Left e -> throwError $ PCEResponseError e
   where
-    streamBody :: (Builder -> IO ()) -> IO () -> IO ()
-    streamBody send done = do
+    streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
+    streamBody t send done = do
       send $ byteString t
       forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
         withFile filePath ReadMode $ \h -> do
@@ -183,9 +178,9 @@ uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpe
 uploadXFTPChunk c spKey fId chunkSpec =
   sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
-downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
-downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do
-  (rDhKey, rpDhKey) <- atomically $ C.generateKeyPair g
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
+downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do
+  (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
   sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
     (FRFile sDhKey cbNonce, HTTP2Body {bodyHead = _bg, bodySize = _bs, bodyPart}) -> case bodyPart of
       -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
@@ -211,16 +206,6 @@ deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okRes
 ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO ()
 ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse
 
-pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
-pingXFTP c@XFTPClient {http2Client = HTTP2Client {sessionId}} = do
-  t <-
-    liftEither . first PCETransportError $
-      xftpEncodeTransmission sessionId Nothing ("", "", FileCmd SFRecipient PING)
-  (r, _) <- sendXFTPTransmission c t Nothing
-  case r of
-    FRPong -> pure ()
-    _ -> throwError $ PCEUnexpectedResponse $ bshow r
-
 okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO ()
 okResponse = \case
   (FROk, body) -> noFile body ()

src/Simplex/FileTransfer/Client/Main.hs

@@ -15,6 +15,7 @@ module Simplex.FileTransfer.Client.Main
     CLIError (..),
     xftpClientCLI,
     cliSendFile,
+    cliSendFileOpts,
     prepareChunkSizes,
     prepareChunkSpecs,
     maxFileSize,
@@ -27,7 +28,7 @@ where
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
-import Crypto.Random (ChaChaDRG)
+import Crypto.Random (getRandomBytes)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
@@ -263,11 +264,10 @@ cliSendFileOpts :: SendOptions -> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT C
 cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} printInfo notifyProgress = do
   let (_, fileName) = splitFileName filePath
   liftIO $ when printInfo $ printNoNewLine "Encrypting file..."
-  g <- liftIO C.newRandom
-  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload g fileName
+  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName
   liftIO $ when printInfo $ printNoNewLine "Uploading file..."
   uploadedChunks <- newTVarIO []
-  sentChunks <- uploadFile g chunkSpecs uploadedChunks encSize
+  sentChunks <- uploadFile chunkSpecs uploadedChunks encSize
   whenM (doesFileExist encPath) $ removeFile encPath
   -- TODO if only small chunks, use different default size
   liftIO $ do
@@ -280,13 +280,13 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       putStrLn "Pass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
   where
-    encryptFileForUpload :: TVar ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
-    encryptFileForUpload g fileName = do
+    encryptFileForUpload :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
+    encryptFileForUpload fileName = do
       fileSize <- fromInteger <$> getFileSize filePath
       when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
       encPath <- getEncPath tempPath "xftp"
-      key <- atomically $ C.randomSbKey g
-      nonce <- atomically $ C.randomCbNonce g
+      key <- liftIO C.randomSbKey
+      nonce <- liftIO C.randomCbNonce
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
           chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
@@ -301,8 +301,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
           fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
       logInfo $ "encrypted file to " <> tshow encPath
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
-    uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
-    uploadFile g chunks uploadedChunks encSize = do
+    uploadFile :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
+    uploadFile chunks uploadedChunks encSize = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       gen <- newTVarIO =<< liftIO newStdGen
       let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers)
@@ -318,8 +318,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
         uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
           logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
-          (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-          rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519 g)
+          (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+          rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
           digest <- liftIO $ getChunkDigest chunkSpec
           let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
@@ -423,8 +423,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
             [] -> error "empty FileChunk.replicas"
             FileChunkReplica {server} : _ -> server
           srvChunks = groupAllOn srv chunks
-      g <- liftIO C.newRandom
-      chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk g a encPath size downloadedChunks)
+      chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks)
       encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
       when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
@@ -436,13 +435,13 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       liftIO $ do
         printNoNewLine $ "File downloaded: " <> path
         removeFD yes fileDescription
-    downloadFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
-    downloadFileChunk g a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
+    downloadFileChunk :: XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
+    downloadFileChunk a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
       logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
       chunkPath <- uniqueCombine encPath $ show chunkNo
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      withReconnect a server retryCount $ \c -> downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
       logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
       downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
         let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
@@ -450,7 +449,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
         printProgress "Downloaded" downloaded encSize
         when verbose $ putStrLn ""
       pure (chunkNo, chunkPath)
-    downloadFileChunk _ _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
+    downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
     getFilePath :: String -> ExceptT String IO FilePath
     getFilePath name =
       case filePath of
@@ -594,8 +593,7 @@ cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
   putStrLn $ "File created: " <> filePath
   where
     saveRandomFile h sz = do
-      g <- C.newRandom
-      bytes <- atomically $ C.randomBytes (fromIntegral $ min mb' sz) g
+      bytes <- getRandomBytes $ fromIntegral $ min mb' sz
       B.hPut h bytes
       when (sz > mb') $ saveRandomFile h (sz - mb')
     mb' = mb 1

src/Simplex/FileTransfer/Protocol.hs

@@ -48,7 +48,8 @@ import Simplex.Messaging.Protocol
     encodeTransmission,
     messageTagP,
     tDecodeParseValidate,
-    tEncodeBatch1,
+    tEncode,
+    tEncodeBatch,
     tParse,
   )
 import Simplex.Messaging.Transport (SessionId, TransportError (..))
@@ -402,8 +403,10 @@ xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do
     signTransmission t = ((`C.sign` t) <$> pKey, t)
 
 -- this function uses batch syntax but puts only one transmission in the batch
-xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
-xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
+xftpEncodeBatch1 :: (Maybe C.ASignature, ByteString) -> Either TransportError ByteString
+xftpEncodeBatch1 (sig, t) =
+  let t' = tEncodeBatch 1 . smpEncode . Large $ tEncode (sig, t)
+   in first (const TELargeMsg) $ C.pad t' xftpBlockSize
 
 xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
 xftpDecodeTransmission sessionId t = do

src/Simplex/FileTransfer/Server.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +14,9 @@ module Simplex.FileTransfer.Server where
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
+import Crypto.Random (getRandomBytes)
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Builder (byteString)
@@ -32,13 +33,9 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
-import GHC.IO.Handle (hSetNewlineMode)
-import GHC.Stats (getRTSStats)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
-import Network.Socket
 import Simplex.FileTransfer.Protocol
-import Simplex.FileTransfer.Server.Control
 import Simplex.FileTransfer.Server.Env
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
@@ -51,18 +48,17 @@ import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, R
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
-import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runTCPServer)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
 import System.FilePath ((</>))
-import System.IO (hPrint, hPutStrLn, universalNewlineMode)
-import UnliftIO
+import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
+import UnliftIO (IOMode (..), withFile)
 import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Directory (doesFileExist, removeFile, renameFile)
-import qualified UnliftIO.Exception as E
+import UnliftIO.Exception
+import UnliftIO.STM
 
 type M a = ReaderT XFTPEnv IO a
 
@@ -75,16 +71,16 @@ runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
 runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
 
 xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration} started = do
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig} started = do
   restoreServerStats
-  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
+  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer
   where
     runServer :: M ()
     runServer = do
       serverParams <- asks tlsServerParams
       env <- ask
       liftIO $
-        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do
+        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig $ \sessionId r sendResponse -> do
           reqBody <- getHTTP2Body r xftpBlockSize
           processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
 
@@ -108,19 +104,16 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         forM_ sIds $ \sId -> do
           threadDelay 100000
           atomically (expiredFilePath st sId old)
-            >>= mapM_ (maybeRemove $ delete st sId)
+            >>= mapM_ (remove $ delete st sId)
       where
-        maybeRemove del = maybe del (remove del)
         remove del filePath =
           ifM
             (doesFileExist filePath)
-            ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
+            (removeFile filePath >> del `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
             del
         delete st sId = do
           withFileLog (`logDeleteFile` sId)
           void $ atomically $ deleteFile st sId
-          FileServerStats {filesExpired} <- asks serverStats
-          atomically $ modifyTVar' filesExpired (+ 1)
 
     serverStatsThread_ :: XFTPServerConfig -> [M ()]
     serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -132,7 +125,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       liftIO $ threadDelay' $ 1_000_000 * (initialDelay + if initialDelay < 0 then 86_400 else 0)
-      FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} <- asks serverStats
+      FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} <- asks serverStats
       let interval = 1_000_000 * logInterval
       forever $ do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -142,13 +135,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           filesCreated' <- atomically $ swapTVar filesCreated 0
           fileRecipients' <- atomically $ swapTVar fileRecipients 0
           filesUploaded' <- atomically $ swapTVar filesUploaded 0
-          filesExpired' <- atomically $ swapTVar filesExpired 0
           filesDeleted' <- atomically $ swapTVar filesDeleted 0
           files <- atomically $ periodStatCounts filesDownloaded ts
           fileDownloads' <- atomically $ swapTVar fileDownloads 0
           fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0
-          filesCount' <- readTVarIO filesCount
-          filesSize' <- readTVarIO filesSize
+          filesCount' <- atomically $ swapTVar filesCount 0
+          filesSize' <- atomically $ swapTVar filesSize 0
           hPutStrLn h $
             intercalate
               ","
@@ -163,52 +155,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
                 show fileDownloads',
                 show fileDownloadAcks',
                 show filesCount',
-                show filesSize',
-                show filesExpired'
+                show filesSize'
               ]
         liftIO $ threadDelay' interval
 
-    controlPortThread_ :: XFTPServerConfig -> [M ()]
-    controlPortThread_ XFTPServerConfig {controlPort = Just port} = [runCPServer port]
-    controlPortThread_ _ = []
-
-    runCPServer :: ServiceName -> M ()
-    runCPServer port = do
-      cpStarted <- newEmptyTMVarIO
-      u <- askUnliftIO
-      liftIO $ do
-        labelMyThread "control port server"
-        runTCPServer cpStarted port $ runCPClient u
-      where
-        runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
-        runCPClient u sock = do
-          labelMyThread "control port client"
-          h <- socketToHandle sock ReadWriteMode
-          hSetBuffering h LineBuffering
-          hSetNewlineMode h universalNewlineMode
-          hPutStrLn h "XFTP server control port\n'help' for supported commands"
-          cpLoop h
-          where
-            cpLoop h = do
-              s <- B.hGetLine h
-              case strDecode $ trimCR s of
-                Right CPQuit -> hClose h
-                Right cmd -> processCP h cmd >> cpLoop h
-                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h
-            processCP h = \case
-              CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
-              CPDelete fileId -> unliftIO u $ do
-                fs <- asks store
-                r <- runExceptT $ do
-                  let asSender = ExceptT . atomically $ getFile fs SFSender fileId
-                  let asRecipient = ExceptT . atomically $ getFile fs SFRecipient fileId
-                  (fr, _) <- asSender `catchError` const asRecipient
-                  ExceptT $ deleteServerFile_ fr
-                liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r
-              CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit"
-              CPQuit -> pure ()
-              CPSkip -> pure ()
-
 data ServerFile = ServerFile
   { filePath :: FilePath,
     fileSize :: Word32,
@@ -368,10 +318,9 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
       readTVarIO filePath >>= \case
         Just path -> do
-          g <- asks random
-          (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g
+          (sDhKey, spDhKey) <- liftIO C.generateKeyPair'
           let dhSecret = C.dh' rDhKey spDhKey
-          cbNonce <- atomically $ C.randomCbNonce g
+          cbNonce <- liftIO C.randomCbNonce
           case LC.cbInit dhSecret cbNonce of
             Right sbState -> do
               stats <- asks serverStats
@@ -382,7 +331,21 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         _ -> pure (FRErr NO_FILE, Nothing)
 
     deleteServerFile :: FileRec -> M FileResponse
-    deleteServerFile fr = either FRErr (\() -> FROk) <$> deleteServerFile_ fr
+    deleteServerFile FileRec {senderId, fileInfo, filePath} = do
+      withFileLog (`logDeleteFile` senderId)
+      r <- runExceptT $ do
+        path <- readTVarIO filePath
+        stats <- asks serverStats
+        ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
+        st <- asks store
+        void $ atomically $ deleteFile st senderId
+        atomically $ modifyTVar' (filesDeleted stats) (+ 1)
+        pure FROk
+      either (pure . FRErr) pure r
+      where
+        deletedStats stats = do
+          atomically $ modifyTVar' (filesCount stats) (subtract 1)
+          atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
     logFileError :: SomeException -> IO ()
     logFileError e = logError $ "Error deleting file: " <> tshow e
@@ -396,28 +359,13 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1)
       pure FROk
 
-deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ())
-deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
-  withFileLog (`logDeleteFile` senderId)
-  runExceptT $ do
-    path <- readTVarIO filePath
-    stats <- asks serverStats
-    ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
-    st <- asks store
-    void $ atomically $ deleteFile st senderId
-    atomically $ modifyTVar' (filesDeleted stats) (+ 1)
-  where
-    deletedStats stats = do
-      atomically $ modifyTVar' (filesCount stats) (subtract 1)
-      atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
-
 randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
-randomId n = atomically . C.randomBytes n =<< asks random
+randomId n = do
+  gVar <- asks idsDrg
+  atomically (C.pseudoRandomBytes n gVar)
 
 getFileId :: M XFTPFileId
-getFileId = do
-  size <- asks (fileIdSize . config)
-  atomically . C.randomBytes size =<< asks random
+getFileId = liftIO . getRandomBytes =<< asks (fileIdSize . config)
 
 withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
 withFileLog action = liftIO . mapM_ action =<< asks storeLog
@@ -443,17 +391,14 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
     restoreStats f = whenM (doesFileExist f) $ do
       logInfo $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
-        Right d@FileServerStatsData {_filesCount = statsFilesCount, _filesSize = statsFilesSize} -> do
+        Right d -> do
           s <- asks serverStats
-          FileStore {files, usedStorage} <- asks store
-          _filesCount <- M.size <$> readTVarIO files
-          _filesSize <- readTVarIO usedStorage
+          fs <- readTVarIO . files =<< asks store
+          let _filesCount = length $ M.keys fs
+              _filesSize = M.foldl' (\n -> (n +) . fromIntegral . size . fileInfo) 0 fs
           atomically $ setFileServerStats s d {_filesCount, _filesSize}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
-          when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount
-          when (statsFilesSize /= _filesSize) $ logWarn $ "Files size differs: stats: " <> tshow statsFilesSize <> ", store: " <> tshow _filesSize
-          logInfo $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
         Left e -> do
           logInfo $ "error restoring server stats: " <> T.pack e
           liftIO exitFailure

src/Simplex/FileTransfer/Server/Control.hs

@@ -1,31 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.FileTransfer.Server.Control where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString (ByteString)
-import Simplex.Messaging.Encoding.String
-
-data ControlProtocol
-  = CPStatsRTS
-  | CPDelete ByteString
-  | CPHelp
-  | CPQuit
-  | CPSkip
-
-instance StrEncoding ControlProtocol where
-  strEncode = \case
-    CPStatsRTS -> "stats-rts"
-    CPDelete bs -> "delete " <> strEncode bs
-    CPHelp -> "help"
-    CPQuit -> "quit"
-    CPSkip -> ""
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "stats-rts" -> pure CPStatsRTS
-      "delete" -> CPDelete <$> (A.space *> strP)
-      "help" -> pure CPHelp
-      "quit" -> pure CPQuit
-      "" -> pure CPSkip
-      _ -> fail "bad ControlProtocol command"

src/Simplex/FileTransfer/Server/Env.hs

@@ -33,7 +33,6 @@ import UnliftIO.STM
 
 data XFTPServerConfig = XFTPServerConfig
   { xftpPort :: ServiceName,
-    controlPort :: Maybe ServiceName,
     fileIdSize :: Int,
     storeLogFile :: Maybe FilePath,
     filesPath :: FilePath,
@@ -47,8 +46,6 @@ data XFTPServerConfig = XFTPServerConfig
     newFileBasicAuth :: Maybe BasicAuth,
     -- | time after which the files can be removed and check interval, seconds
     fileExpiration :: Maybe ExpirationConfig,
-    -- | time after which inactive clients can be disconnected and check interval, seconds
-    inactiveClientExpiration :: Maybe ExpirationConfig,
     -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -61,18 +58,11 @@ data XFTPServerConfig = XFTPServerConfig
     transportConfig :: TransportServerConfig
   }
 
-defaultInactiveClientExpiration :: ExpirationConfig
-defaultInactiveClientExpiration =
-  ExpirationConfig
-    { ttl = 43200, -- seconds, 12 hours
-      checkInterval = 3600 -- seconds, 1 hours
-    }
-
 data XFTPEnv = XFTPEnv
   { config :: XFTPServerConfig,
     store :: FileStore,
     storeLog :: Maybe (StoreLog 'WriteMode),
-    random :: TVar ChaChaDRG,
+    idsDrg :: TVar ChaChaDRG,
     serverIdentity :: C.KeyHash,
     tlsServerParams :: T.ServerParams,
     serverStats :: FileServerStats
@@ -90,7 +80,7 @@ defaultFileExpiration =
 
 newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv
 newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
-  random <- liftIO C.newRandom
+  idsDrg <- drgNew >>= newTVarIO
   store <- atomically newFileStore
   storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
   used <- readTVarIO (usedStorage store)
@@ -100,7 +90,7 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
   serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
-  pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+  pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 data XFTPRequest
   = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth)

src/Simplex/FileTransfer/Server/Main.hs

@@ -19,7 +19,7 @@ import Options.Applicative
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Description (FileSize (..))
 import Simplex.FileTransfer.Server (runXFTPServer)
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
@@ -33,7 +33,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 xftpServerVersion :: String
-xftpServerVersion = "1.2.2.0"
+xftpServerVersion = "1.1.3"
 
 xftpServerCLI :: FilePath -> FilePath -> IO ()
 xftpServerCLI cfgPath logPath = do
@@ -100,17 +100,10 @@ xftpServerCLI cfgPath logPath = do
             <> ("host: " <> host <> "\n")
             <> ("port: " <> defaultServerPort <> "\n")
             <> "log_tls_errors: off\n\
-               \# control_port: 5226\n\
                \\n\
                \[FILES]\n"
             <> ("path: " <> filesPath <> "\n")
             <> ("storage_quota: " <> B.unpack (strEncode fileSizeQuota) <> "\n")
-            <> "\n\
-               \[INACTIVE_CLIENTS]\n\
-               \# TTL and interval to check inactive clients\n\
-               \disconnect: off\n"
-            <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
-            <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
     runServer ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
@@ -125,16 +118,13 @@ xftpServerCLI cfgPath logPath = do
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
-        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = do
+        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration} = do
           putStrLn $ case storeLogFile of
             Just f -> "Store log: " <> f
             _ -> "Store log disabled."
           putStrLn $ case fileExpiration of
             Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
             _ -> "not expiring files"
-          putStrLn $ case inactiveClientExpiration of
-            Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
-            _ -> "not expiring inactive clients"
           putStrLn $
             "Uploading new files "
               <> if allowNewFiles
@@ -145,7 +135,6 @@ xftpServerCLI cfgPath logPath = do
         serverConfig =
           XFTPServerConfig
             { xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini,
-              controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
               fileIdSize = 16,
               storeLogFile = enableStoreLog $> storeLogFilePath,
               filesPath = T.unpack $ strictIni "FILES" "path" ini,
@@ -158,12 +147,6 @@ xftpServerCLI cfgPath logPath = do
                   defaultFileExpiration
                     { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
                     },
-              inactiveClientExpiration =
-                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
-                  $> ExpirationConfig
-                    { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
-                      checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
-                    },
               caCertificateFile = c caCrtFile,
               privateKeyFile = c serverKeyFile,
               certificateFile = c serverCrtFile,

src/Simplex/FileTransfer/Server/Stats.hs

@@ -4,7 +4,6 @@
 
 module Simplex.FileTransfer.Server.Stats where
 
-import Control.Applicative ((<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
@@ -19,7 +18,6 @@ data FileServerStats = FileServerStats
     filesCreated :: TVar Int,
     fileRecipients :: TVar Int,
     filesUploaded :: TVar Int,
-    filesExpired :: TVar Int,
     filesDeleted :: TVar Int,
     filesDownloaded :: PeriodStats SenderId,
     fileDownloads :: TVar Int,
@@ -33,7 +31,6 @@ data FileServerStatsData = FileServerStatsData
     _filesCreated :: Int,
     _fileRecipients :: Int,
     _filesUploaded :: Int,
-    _filesExpired :: Int,
     _filesDeleted :: Int,
     _filesDownloaded :: PeriodStatsData SenderId,
     _fileDownloads :: Int,
@@ -49,14 +46,13 @@ newFileServerStats ts = do
   filesCreated <- newTVar 0
   fileRecipients <- newTVar 0
   filesUploaded <- newTVar 0
-  filesExpired <- newTVar 0
   filesDeleted <- newTVar 0
   filesDownloaded <- newPeriodStats
   fileDownloads <- newTVar 0
   fileDownloadAcks <- newTVar 0
   filesCount <- newTVar 0
   filesSize <- newTVar 0
-  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
+  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
 
 getFileServerStatsData :: FileServerStats -> STM FileServerStatsData
 getFileServerStatsData s = do
@@ -64,14 +60,13 @@ getFileServerStatsData s = do
   _filesCreated <- readTVar $ filesCreated s
   _fileRecipients <- readTVar $ fileRecipients s
   _filesUploaded <- readTVar $ filesUploaded s
-  _filesExpired <- readTVar $ filesExpired s
   _filesDeleted <- readTVar $ filesDeleted s
   _filesDownloaded <- getPeriodStatsData $ filesDownloaded s
   _fileDownloads <- readTVar $ fileDownloads s
   _fileDownloadAcks <- readTVar $ fileDownloadAcks s
   _filesCount <- readTVar $ filesCount s
   _filesSize <- readTVar $ filesSize s
-  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
+  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
 
 setFileServerStats :: FileServerStats -> FileServerStatsData -> STM ()
 setFileServerStats s d = do
@@ -79,7 +74,6 @@ setFileServerStats s d = do
   writeTVar (filesCreated s) $! _filesCreated d
   writeTVar (fileRecipients s) $! _fileRecipients d
   writeTVar (filesUploaded s) $! _filesUploaded d
-  writeTVar (filesExpired s) $! _filesExpired d
   writeTVar (filesDeleted s) $! _filesDeleted d
   setPeriodStats (filesDownloaded s) $! _filesDownloaded d
   writeTVar (fileDownloads s) $! _fileDownloads d
@@ -88,16 +82,13 @@ setFileServerStats s d = do
   writeTVar (filesSize s) $! _filesSize d
 
 instance StrEncoding FileServerStatsData where
-  strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} =
+  strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "filesCreated=" <> strEncode _filesCreated,
         "fileRecipients=" <> strEncode _fileRecipients,
         "filesUploaded=" <> strEncode _filesUploaded,
-        "filesExpired=" <> strEncode _filesExpired,
         "filesDeleted=" <> strEncode _filesDeleted,
-        "filesCount=" <> strEncode _filesCount,
-        "filesSize=" <> strEncode _filesSize,
         "filesDownloaded:",
         strEncode _filesDownloaded,
         "fileDownloads=" <> strEncode _fileDownloads,
@@ -108,11 +99,8 @@ instance StrEncoding FileServerStatsData where
     _filesCreated <- "filesCreated=" *> strP <* A.endOfLine
     _fileRecipients <- "fileRecipients=" *> strP <* A.endOfLine
     _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine
-    _filesExpired <- "filesExpired=" *> strP <* A.endOfLine <|> pure 0
     _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine
-    _filesCount <- "filesCount=" *> strP <* A.endOfLine <|> pure 0
-    _filesSize <- "filesSize=" *> strP <* A.endOfLine <|> pure 0
     _filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine
     _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine
     _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine
-    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
+    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount = 0, _filesSize = 0}

src/Simplex/FileTransfer/Server/Store.hs

@@ -121,12 +121,12 @@ getFile st party fId = case party of
       Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey)
       _ -> pure $ Left AUTH
 
-expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe FilePath))
+expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe FilePath)
 expiredFilePath FileStore {files} sId old =
   TM.lookup sId files
     $>>= \FileRec {filePath, createdAt} ->
       if systemSeconds createdAt < old
-        then Just <$> readTVar filePath
+        then readTVar filePath
         else pure Nothing
 
 ackFile :: FileStore -> RecipientId -> STM (Either XFTPErrorType ())

src/Simplex/Messaging/Agent.hs

@@ -38,7 +38,6 @@ module Simplex.Messaging.Agent
     AgentErrorMonad,
     SubscriptionsInfo (..),
     getSMPAgentClient,
-    getSMPAgentClient_,
     disconnectAgentClient,
     resumeAgentClient,
     withConnLock,
@@ -66,7 +65,6 @@ module Simplex.Messaging.Agent
     resubscribeConnections,
     sendMessage,
     sendMessages,
-    sendMessagesB,
     ackMessage,
     switchConnection,
     abortConnectionSwitch,
@@ -116,7 +114,7 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
-import Crypto.Random (ChaChaDRG, MonadRandom)
+import Crypto.Random (MonadRandom)
 import qualified Data.Aeson as J
 import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Char8 (ByteString)
@@ -132,6 +130,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
+import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock
@@ -169,28 +168,21 @@ import Simplex.Messaging.Version
 import Simplex.RemoteControl.Client
 import Simplex.RemoteControl.Invitation
 import Simplex.RemoteControl.Types
-import UnliftIO.Async (race_)
+import UnliftIO.Async (async, race_)
 import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
 import UnliftIO.STM
 
 -- import GHC.Conc (unsafeIOToSTM)
 
 -- | Creates an SMP agent client instance
-getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> m AgentClient
-getSMPAgentClient = getSMPAgentClient_ 1
-{-# INLINE getSMPAgentClient #-}
-
-getSMPAgentClient_ :: (MonadRandom m, MonadUnliftIO m) => Int -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> m AgentClient
-getSMPAgentClient_ clientId cfg initServers store backgroundMode =
+getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> SQLiteStore -> m AgentClient
+getSMPAgentClient cfg initServers store =
   liftIO (newSMPAgentEnv cfg store) >>= runReaderT runAgent
   where
     runAgent = do
-      c <- getAgentClient clientId initServers
-      void $ runAgentThreads c `forkFinally` const (disconnectAgentClient c)
+      c <- getAgentClient initServers
+      void $ raceAny_ [subscriber c, runNtfSupervisor c, cleanupManager c] `forkFinally` const (disconnectAgentClient c)
       pure c
-    runAgentThreads c
-      | backgroundMode = subscriber c
-      | otherwise = raceAny_ [subscriber c, runNtfSupervisor c, cleanupManager c]
 
 disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m ()
 disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do
@@ -295,9 +287,6 @@ type MsgReq = (ConnId, MsgFlags, MsgBody)
 sendMessages :: MonadUnliftIO m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
 sendMessages c = withAgentEnv c . sendMessages' c
 
-sendMessagesB :: (MonadUnliftIO m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType AgentMsgId))
-sendMessagesB c = withAgentEnv c . sendMessagesB' c
-
 ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
 ackMessage c = withAgentEnv c .:. ackMessage' c
 
@@ -362,7 +351,7 @@ reconnectAllServers c = liftIO $ do
   closeProtocolServerClients c ntfClients
 
 -- | Register device notifications token
-registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m (NtfTknStatus, Maybe NtfServer)
+registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
 registerNtfToken c = withAgentEnv c .: registerNtfToken' c
 
 -- | Verify device notifications token
@@ -375,7 +364,7 @@ checkNtfToken c = withAgentEnv c . checkNtfToken' c
 deleteNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> m ()
 deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
 
-getNtfToken :: AgentErrorMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
+getNtfToken :: AgentErrorMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode)
 getNtfToken c = withAgentEnv c $ getNtfToken' c
 
 getNtfTokenData :: AgentErrorMonad m => AgentClient -> m NtfToken
@@ -409,8 +398,8 @@ xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFile
 xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c
 
 -- | Create new remote host pairing
-rcNewHostPairing :: AgentErrorMonad m => AgentClient -> m RCHostPairing
-rcNewHostPairing c = withAgentEnv c $ liftIO . newRCHostPairing =<< asks random
+rcNewHostPairing :: MonadIO m => m RCHostPairing
+rcNewHostPairing = liftIO newRCHostPairing
 
 -- | start TLS server for remote host with optional multicast
 rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> m RCHostConnection
@@ -466,9 +455,8 @@ withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
 withAgentEnv c = (`runReaderT` agentEnv c)
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
-getAgentClient :: AgentMonad' m => Int -> InitialAgentServers -> m AgentClient
-getAgentClient clientId initServers = ask >>= atomically . newAgentClient clientId initServers
-{-# INLINE getAgentClient #-}
+getAgentClient :: AgentMonad' m => InitialAgentServers -> m AgentClient
+getAgentClient initServers = ask >>= atomically . newAgentClient initServers
 
 logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
 logConnection c connected =
@@ -636,10 +624,10 @@ newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SCon
 newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do
   AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
   (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwError e
-  rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
+  void . withStore c $ \db -> updateNewConnRcv db connId rq
   case subMode of
     SMOnlyCreate -> pure ()
-    SMSubscribe -> addSubscription c rq'
+    SMSubscribe -> addSubscription c rq
   when enableNtfs $ do
     ns <- asks ntfSupervisor
     atomically $ sendNtfSubCommand ns (connId, NSCCreate)
@@ -647,8 +635,7 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do
   case cMode of
     SCMContact -> pure (connId, CRContactUri crData)
     SCMInvitation -> do
-      g <- asks random
-      (pk1, pk2, e2eRcvParams) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange
+      (pk1, pk2, e2eRcvParams) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange
       withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2
       pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
 
@@ -660,7 +647,7 @@ joinConn c userId connId enableNtfs cReq cInfo subMode = do
     _ -> getSMPServer c userId
   joinConnSrv c userId connId enableNtfs cReq cInfo subMode srv
 
-startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> m (Compatible Version, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.E2ERatchetParams 'C.X448)
+startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> m (Compatible Version, ConnData, SndQueue, CR.Ratchet 'C.X448, CR.E2ERatchetParams 'C.X448)
 startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) = do
   AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
   case ( qUri `compatibleVersion` smpClientVRange,
@@ -668,9 +655,8 @@ startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {cr
          crAgentVRange `compatibleVersion` smpAgentVRange
        ) of
     (Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just aVersion@(Compatible connAgentVersion)) -> do
-      g <- asks random
-      (pk1, pk2, e2eSndParams) <- atomically . CR.generateE2EParams g $ version e2eRcvParams
-      (_, rcDHRs) <- atomically $ C.generateKeyPair g
+      (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams
+      (_, rcDHRs) <- liftIO C.generateKeyPair'
       let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
       q <- newSndQueue userId "" qInfo
       let duplexHS = connAgentVersion /= 1
@@ -683,11 +669,12 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv
   withInvLock c (strEncode inv) "joinConnSrv" $ do
     (aVersion, cData@ConnData {connAgentVersion}, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv
     g <- asks random
-    (connId', sq) <- withStore c $ \db -> runExceptT $ do
-      r@(connId', _) <- ExceptT $ createSndConn db g cData q
+    connId' <- withStore c $ \db -> runExceptT $ do
+      connId' <- ExceptT $ createSndConn db g cData q
       liftIO $ createRatchet db connId' rc
-      pure r
-    let cData' = (cData :: ConnData) {connId = connId'}
+      pure connId'
+    let sq = (q :: SndQueue) {connId = connId'}
+        cData' = (cData :: ConnData) {connId = connId'}
         duplexHS = connAgentVersion /= 1
     tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
       Right _ -> do
@@ -712,9 +699,10 @@ joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRan
 joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> SMPServerWithAuth -> m ()
 joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv = do
   (aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv
-  q' <- withStore c $ \db -> runExceptT $ do
+  dbQueueId <- withStore c $ \db -> runExceptT $ do
     liftIO $ createRatchet db connId rc
     ExceptT $ updateNewConnSnd db connId q
+  let q' = (q :: SndQueue) {dbQueueId}
   confirmQueueAsync aVersion c cData q' srv cInfo (Just e2eSndParams) subMode
 joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _srv = do
   throwError $ CMD PROHIBITED
@@ -723,10 +711,10 @@ createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Subsc
 createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
   (rq, qUri) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode
   let qInfo = toVersionT qUri smpClientVersion
-  rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq
   case subMode of
     SMOnlyCreate -> pure ()
-    SMSubscribe -> addSubscription c rq'
+    SMSubscribe -> addSubscription c rq
+  void . withStore c $ \db -> upgradeSndConnToDuplex db connId rq
   when enableNtfs $ do
     ns <- asks ntfSupervisor
     atomically $ sendNtfSubCommand ns (connId, NSCCreate)
@@ -889,64 +877,87 @@ getNotificationMessage' c nonce encNtfInfo = do
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
-sendMessage' c connId msgFlags msg = liftEither . runIdentity =<< sendMessagesB' c (Identity (Right (connId, msgFlags, msg)))
+sendMessage' c connId msgFlags msg = liftEither . runIdentity =<< sendMessagesB c (Identity (Right (connId, msgFlags, msg)))
 
 -- | Send multiple messages to different connections (SEND command) in Reader monad
 sendMessages' :: forall m. AgentMonad' m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
-sendMessages' c = sendMessagesB' c . map Right
+sendMessages' c = sendMessagesB c . map Right
 
-sendMessagesB' :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType AgentMsgId))
-sendMessagesB' c reqs = withConnLocks c connIds "sendMessages" $ do
-  reqs' <- withStoreBatch c (\db -> fmap (bindRight $ \req@(connId, _, _) -> bimap storeError (req,) <$> getConn db connId) reqs)
+sendMessagesB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType AgentMsgId))
+sendMessagesB c reqs = withConnLocks c connIds "sendMessages" $ do
+  reqs' <- withStoreBatch c (\db -> fmap (mapE $ \req@(connId, _, _) -> bimap storeError (req,) <$> getConn db connId) reqs)
   let reqs'' = fmap (>>= prepareConn) reqs'
   enqueueMessagesB c reqs''
   where
     prepareConn :: (MsgReq, SomeConn) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
     prepareConn ((_, msgFlags, msg), SomeConn _ conn) = case conn of
-      DuplexConnection cData _ sqs -> prepareMsg cData sqs
-      SndConnection cData sq -> prepareMsg cData [sq]
+      DuplexConnection cData _ sqs -> prepareMsgs cData sqs
+      SndConnection cData sq -> prepareMsgs cData [sq]
       _ -> Left $ CONN SIMPLEX
       where
-        prepareMsg :: ConnData -> NonEmpty SndQueue -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
-        prepareMsg cData sqs
+        prepareMsgs :: ConnData -> NonEmpty SndQueue -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
+        prepareMsgs cData sqs
           | ratchetSyncSendProhibited cData = Left $ CMD PROHIBITED
           | otherwise = Right (cData, sqs, msgFlags, A_MSG msg)
-    connIds = map (\(connId, _, _) -> connId) $ rights $ toList reqs
+    connIds = foldl' (\cs -> either (\_ -> cs) (\(connId, _, _) -> S.insert connId cs)) S.empty reqs
 
 -- / async command processing v v v
 
 enqueueCommand :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> m ()
 enqueueCommand c corrId connId server aCommand = do
-  withStore c $ \db -> createCommand db corrId connId server aCommand
-  void $ getAsyncCmdWorker True c server
+  resumeSrvCmds c server
+  commandId <- withStore c $ \db -> createCommand db corrId connId server aCommand
+  queuePendingCommands c server [commandId]
 
-resumeSrvCmds :: forall m. AgentMonad' m => AgentClient -> Maybe SMPServer -> m ()
-resumeSrvCmds = void .: getAsyncCmdWorker False
+resumeSrvCmds :: forall m. AgentMonad m => AgentClient -> Maybe SMPServer -> m ()
+resumeSrvCmds c server =
+  unlessM (cmdProcessExists c server) $
+    async (runCommandProcessing c server)
+      >>= \a -> atomically (TM.insert server a $ asyncCmdProcesses c)
 
 resumeConnCmds :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
 resumeConnCmds c connId =
   unlessM connQueued $
-    withStore' c (`getPendingCommandServers` connId)
-      >>= mapM_ (resumeSrvCmds c)
+    withStore' c (`getPendingCommands` connId)
+      >>= mapM_ (uncurry enqueueConnCmds)
   where
+    enqueueConnCmds srv cmdIds = do
+      resumeSrvCmds c srv
+      queuePendingCommands c srv cmdIds
     connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
 
-getAsyncCmdWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe SMPServer -> m Worker
-getAsyncCmdWorker hasWork c server =
-  getAgentWorker "async_cmd" hasWork c server (asyncCmdWorkers c) (runCommandProcessing c server)
+cmdProcessExists :: AgentMonad' m => AgentClient -> Maybe SMPServer -> m Bool
+cmdProcessExists c srv = atomically $ TM.member srv (asyncCmdProcesses c)
 
-runCommandProcessing :: forall m. AgentMonad m => AgentClient -> Maybe SMPServer -> Worker -> m ()
-runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
+queuePendingCommands :: AgentMonad' m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m ()
+queuePendingCommands c server cmdIds = atomically $ do
+  q <- getPendingCommandQ c server
+  mapM_ (writeTQueue q) cmdIds
+
+getPendingCommandQ :: AgentClient -> Maybe SMPServer -> STM (TQueue AsyncCmdId)
+getPendingCommandQ c server = do
+  maybe newMsgQueue pure =<< TM.lookup server (asyncCmdQueues c)
+  where
+    newMsgQueue = do
+      cq <- newTQueue
+      TM.insert server cq $ asyncCmdQueues c
+      pure cq
+
+runCommandProcessing :: forall m. AgentMonad m => AgentClient -> Maybe SMPServer -> m ()
+runCommandProcessing c@AgentClient {subQ} server_ = do
+  cq <- atomically $ getPendingCommandQ c server_
   ri <- asks $ messageRetryInterval . config -- different retry interval?
   forever $ do
     atomically $ endAgentOperation c AOSndNetwork
-    waitForWork doWork
     atomically $ throwWhenInactive c
+    cmdId <- atomically $ readTQueue cq
     atomically $ beginAgentOperation c AOSndNetwork
-    withWork c doWork (`getPendingServerCommand` server_) $ processCmd (riFast ri)
+    tryAgentError (withStore c $ \db -> getPendingCommand db cmdId) >>= \case
+      Left e -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR e)
+      Right cmd -> processCmd (riFast ri) cmdId cmd
   where
-    processCmd :: RetryInterval -> PendingCommand -> m ()
-    processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} = case command of
+    processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m ()
+    processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of
       AClientCommand (APC _ cmd) -> case cmd of
         NEW enableNtfs (ACM cMode) subMode -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
@@ -1086,10 +1097,13 @@ enqueueMessage c cData sq msgFlags aMessage =
 -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries
 enqueueMessageB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType (AgentMsgId, Maybe (ConnData, [SndQueue], AgentMsgId))))
 enqueueMessageB c reqs = do
+  void . forME reqs $ \(cData, sq :| _, _, _) ->
+    runExceptT $ resumeMsgDelivery c cData sq
   aVRange <- asks $ maxVersion . smpAgentVRange . config
-  reqMids <- withStoreBatch c $ \db -> fmap (bindRight $ storeSentMsg db aVRange) reqs
-  forME reqMids $ \((cData, sq :| sqs, _, _), InternalId msgId) -> do
-    submitPendingMsg c cData sq
+  reqMids <- withStoreBatch c $ \db -> fmap (mapE $ storeSentMsg db aVRange) reqs
+  forME reqMids $ \((cData, sq :| sqs, _, _), mId) -> do
+    let InternalId msgId = mId
+    queuePendingMsgs c sq [mId]
     let sqs' = filter isActiveSndQ sqs
     pure $ Right (msgId, if null sqs' then Nothing else Just (cData, sqs', msgId))
   where
@@ -1114,46 +1128,69 @@ enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData,
 
 enqueueSavedMessageB :: (AgentMonad' m, Foldable t) => AgentClient -> t (ConnData, [SndQueue], AgentMsgId) -> m ()
 enqueueSavedMessageB c reqs = do
-  -- saving to the database is in the start to avoid race conditions when delivery is read from queue before it is saved
+  -- saving to the database has to be before enqueue to avoid race condition when delivery is read from queue before it is saved
   void $ withStoreBatch' c $ \db -> concatMap (storeDeliveries db) reqs
-  forM_ reqs $ \(cData, sqs, _) ->
-    forM sqs $ submitPendingMsg c cData
+  forM_ reqs $ \(cData, sqs, msgId) ->
+    forM sqs $ \sq -> do
+      void . runExceptT $ resumeMsgDelivery c cData sq
+      let mId = InternalId msgId
+      queuePendingMsgs c sq [mId]
   where
     storeDeliveries :: DB.Connection -> (ConnData, [SndQueue], AgentMsgId) -> [IO ()]
     storeDeliveries db (ConnData {connId}, sqs, msgId) = do
       let mId = InternalId msgId
        in map (\sq -> createSndMsgDelivery db connId sq mId) sqs
 
-resumeMsgDelivery :: forall m. AgentMonad' m => AgentClient -> ConnData -> SndQueue -> m ()
-resumeMsgDelivery = void .:. getDeliveryWorker False
-
-getDeliveryWorker :: AgentMonad' m => Bool -> AgentClient -> ConnData -> SndQueue -> m (Worker, TMVar ())
-getDeliveryWorker hasWork c cData sq =
-  getAgentWorker' fst mkLock "msg_delivery" hasWork c (qAddress sq) (smpDeliveryWorkers c) (runSmpQueueMsgDelivery c cData sq)
+resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
+resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
+  let qKey = (server, sndId)
+  unlessM (queueDelivering qKey) $
+    async (runSmpQueueMsgDelivery c cData sq)
+      >>= \a -> atomically (TM.insert qKey a $ smpQueueMsgDeliveries c)
+  unlessM msgsQueued $
+    withStore' c (\db -> getPendingMsgs db connId sq)
+      >>= queuePendingMsgs' c False sq
   where
-    mkLock w = do
-      retryLock <- newEmptyTMVar
-      pure (w, retryLock)
+    queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
+    msgsQueued = atomically $ isJust <$> TM.lookupInsert (server, sndId) True (pendingMsgsQueued c)
 
-submitPendingMsg :: AgentMonad' m => AgentClient -> ConnData -> SndQueue -> m ()
-submitPendingMsg c cData sq = do
-  atomically $ modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + 1}
-  void $ getDeliveryWorker True c cData sq
+queuePendingMsgs :: AgentMonad' m => AgentClient -> SndQueue -> [InternalId] -> m ()
+queuePendingMsgs c = queuePendingMsgs' c True
 
-runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> (Worker, TMVar ()) -> m ()
-runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, duplexHandshake} sq (Worker {doWork}, qLock) = do
-  AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config
+queuePendingMsgs' :: AgentMonad' m => AgentClient -> Bool -> SndQueue -> [InternalId] -> m ()
+queuePendingMsgs' c setDeliveryOps sq msgIds = atomically $ do
+  when setDeliveryOps $ modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds}
+  -- s <- readTVar (msgDeliveryOp c)
+  -- unsafeIOToSTM $ putStrLn $ "msgDeliveryOp: " <> show (opsInProgress s)
+  (mq, _) <- getPendingMsgQ c sq
+  mapM_ (writeTQueue mq . (,setDeliveryOps)) msgIds
+
+getPendingMsgQ :: AgentClient -> SndQueue -> STM (TQueue (InternalId, Bool), TMVar ())
+getPendingMsgQ c SndQueue {server, sndId} = do
+  let qKey = (server, sndId)
+  maybe (newMsgQueue qKey) pure =<< TM.lookup qKey (smpQueueMsgQueues c)
+  where
+    newMsgQueue qKey = do
+      q <- (,) <$> newTQueue <*> newEmptyTMVar
+      TM.insert qKey q $ smpQueueMsgQueues c
+      pure q
+
+runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
+runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, duplexHandshake} sq = do
+  (mq, qLock) <- atomically $ getPendingMsgQ c sq
+  ri <- asks $ messageRetryInterval . config
   forever $ do
     atomically $ endAgentOperation c AOSndNetwork
-    waitForWork doWork
     atomically $ throwWhenInactive c
     atomically $ throwWhenNoDelivery c sq
+    (msgId, deliveryOp) <- atomically $ readTQueue mq
     atomically $ beginAgentOperation c AOSndNetwork
-    withWork c doWork (\db -> getPendingQueueMsg db connId sq) $
-      \(rq_, PendingMsgData {msgId, msgType, msgBody, msgFlags, msgRetryState, internalTs}) -> do
-        atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in submitPendingMsg
-        let mId = unId msgId
-            ri' = maybe id updateRetryInterval2 msgRetryState ri
+    when deliveryOp $ atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in queuePendingMsgs
+    let mId = unId msgId
+    tryAgentError (withStore c $ \db -> getPendingMsgData db connId msgId) >>= \case
+      Left e -> notify $ MERR mId e
+      Right (rq_, PendingMsgData {msgType, msgBody, msgFlags, msgRetryState, internalTs}) -> do
+        let ri' = maybe id updateRetryInterval2 msgRetryState ri
         withRetryLock2 ri' qLock $ \riState loop -> do
           resp <- tryError $ case msgType of
             AM_CONN_INFO -> sendConfirmation c sq msgBody
@@ -1166,9 +1203,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 SMP SMP.QUOTA -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
-                  _ -> do
-                    expireTs <- addUTCTime (-quotaExceededTimeout) <$> liftIO getCurrentTime
-                    if internalTs < expireTs then notifyDelMsgs msgId e expireTs else retrySndMsg RISlow
+                  _ -> retrySndMsg RISlow
                 SMP SMP.AUTH -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -1177,11 +1212,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                     -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying,
                     -- because the queue must be secured by the time the confirmation or the first HELLO is received
                     | duplexHandshake == Just True -> connErr
-                    -- otherwise branch is not used in clients with v2+ of agent protocol (since June 2022)
-                    -- TODO remove in v6
-                    | otherwise -> do
-                        expireTs <- addUTCTime (-helloTimeout) <$> liftIO getCurrentTime
-                        if internalTs < expireTs then connErr else retrySndMsg RIFast
+                    | otherwise ->
+                        ifM (msgExpired helloTimeout) connErr (retrySndMsg RIFast)
                     where
                       connErr = case rq_ of
                         -- party initiating connection
@@ -1201,11 +1233,14 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                   -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
                   -- the message sending would be retried
                   | temporaryOrHostError e -> do
-                      let msgTimeout = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
-                      expireTs <- addUTCTime (-msgTimeout) <$> liftIO getCurrentTime
-                      if internalTs < expireTs then notifyDelMsgs msgId e expireTs else retrySndMsg RIFast
+                      let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
+                      ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg RIFast)
                   | otherwise -> notifyDel msgId err
               where
+                msgExpired timeoutSel = do
+                  msgTimeout <- asks $ timeoutSel . config
+                  currentTime <- liftIO getCurrentTime
+                  pure $ diffUTCTime currentTime internalTs > msgTimeout
                 retrySndMsg riMode = do
                   withStore' c $ \db -> updatePendingMsgRIState db connId msgId riState
                   retrySndOp c $ loop riMode
@@ -1261,7 +1296,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                             Just (sq', sq'' : sqs') -> do
                               checkSQSwchStatus sq' SSSendingQTEST
                               -- remove the delivery from the map to stop the thread when the delivery loop is complete
-                              atomically $ TM.delete (qAddress sq') $ smpDeliveryWorkers c
+                              atomically $ TM.delete (qAddress sq') $ smpQueueMsgQueues c
                               withStore' c $ \db -> do
                                 when primary $ setSndQueuePrimary db connId sq
                                 deletePendingMsgs db connId sq'
@@ -1281,13 +1316,6 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                     when (isJust rq_) $ removeConfirmations db connId
                   unless (duplexHandshake == Just True) . void $ enqueueMessage c cData sq SMP.noMsgFlags HELLO
   where
-    notifyDelMsgs :: InternalId -> AgentErrorType -> UTCTime -> m ()
-    notifyDelMsgs msgId err expireTs = do
-      notifyDel msgId $ MERR (unId msgId) err
-      msgIds_ <- withStore' c $ \db -> getExpiredSndMessages db connId sq expireTs
-      forM_ (L.nonEmpty msgIds_) $ \msgIds -> do
-        notify $ MERRS (L.map unId msgIds) err
-        withStore' c $ \db -> forM_ msgIds $ \msgId' -> deleteSndMsgDelivery db connId sq msgId' False `catchAll_` pure ()
     delMsg :: InternalId -> m ()
     delMsg = delMsgKeep False
     delMsgKeep :: Bool -> InternalId -> m ()
@@ -1354,19 +1382,19 @@ switchConnection' c connId =
       _ -> throwError $ CMD PROHIBITED
 
 switchDuplexConnection :: AgentMonad m => AgentClient -> Connection 'CDuplex -> RcvQueue -> m ConnectionStats
-switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId dbQueueId, sndId} = do
+switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId, sndId} = do
   checkRQSwchStatus rq RSSwitchStarted
   clientVRange <- asks $ smpClientVRange . config
   -- try to get the server that is different from all queues, or at least from the primary rcv queue
   srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
   srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth
   (q, qUri) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe
-  let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-  rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
-  addSubscription c rq''
+  let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
+  void . withStore c $ \db -> addConnRcvQueue db connId rq'
+  addSubscription c rq'
   void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))]
   rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSendingQADD
-  let rqs' = updatedQs rq1 rqs <> [rq'']
+  let rqs' = updatedQs rq1 rqs <> [rq']
   pure . connectionStats $ DuplexConnection cData rqs' sqs
 
 abortConnectionSwitch' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
@@ -1400,9 +1428,8 @@ synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet"
       | ratchetSyncAllowed cData || force -> do
           -- check queues are not switching?
           AgentConfig {e2eEncryptVRange} <- asks config
-          g <- asks random
-          (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange
-          enqueueRatchetKeyMsgs c cData sqs e2eParams
+          (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange
+          void $ enqueueRatchetKeyMsgs c cData sqs e2eParams
           withStore' c $ \db -> do
             setConnRatchetSync db connId RSStarted
             setRatchetX3dhKeys db connId pk1 pk2 k1 k2
@@ -1573,23 +1600,22 @@ connectionStats = \case
 setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
 setProtocolServers' c userId srvs = atomically $ TM.insert userId srvs (userServers c)
 
-registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m (NtfTknStatus, Maybe NtfServer)
+registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
 registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
   withStore' c getSavedNtfToken >>= \case
-    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode, ntfServer} -> do
-      (status, srv) <- case (ntfTokenId, ntfTknAction) of
+    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do
+      status <- case (ntfTokenId, ntfTknAction) of
         (Nothing, Just NTARegister) -> do
           when (savedDeviceToken /= suppliedDeviceToken) $ withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken
-          registerToken tkn $> (NTRegistered, Just ntfServer)
+          registerToken tkn $> NTRegistered
         -- possible improvement: add minimal time before repeat registration
         (Just tknId, Nothing)
           | savedDeviceToken == suppliedDeviceToken ->
-              when (ntfTknStatus == NTRegistered) (registerToken tkn) $> (NTRegistered, Just ntfServer)
+              when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
           | otherwise -> replaceToken tknId
         (Just tknId, Just (NTAVerify code))
-          | savedDeviceToken == suppliedDeviceToken -> do
-              status' <- t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
-              pure (status', Just ntfServer)
+          | savedDeviceToken == suppliedDeviceToken ->
+              t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
           | otherwise -> replaceToken tknId
         (Just tknId, Just NTACheck)
           | savedDeviceToken == suppliedDeviceToken -> do
@@ -1601,19 +1627,19 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
                 when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
                 when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete
               -- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
-              pure (ntfTknStatus, Just ntfServer)
+              pure ntfTknStatus
           | otherwise -> replaceToken tknId
         (Just tknId, Just NTADelete) -> do
           agentNtfDeleteToken c tknId tkn
           withStore' c (`removeNtfToken` tkn)
           ns <- asks ntfSupervisor
           atomically $ nsRemoveNtfToken ns
-          pure (NTExpired, Nothing)
-        _ -> pure (ntfTknStatus, Just ntfServer)
+          pure NTExpired
+        _ -> pure ntfTknStatus
       withStore' c $ \db -> updateNtfMode db tkn suppliedNtfMode
-      pure (status, srv)
+      pure status
       where
-        replaceToken :: NtfTokenId -> m (NtfTknStatus, Maybe NtfServer)
+        replaceToken :: NtfTokenId -> m NtfTknStatus
         replaceToken tknId = do
           ns <- asks ntfSupervisor
           tryReplace ns `catchAgentError` \e ->
@@ -1628,23 +1654,22 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
               agentNtfReplaceToken c tknId tkn suppliedDeviceToken
               withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken
               atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
-              pure (NTRegistered, Just ntfServer)
+              pure NTRegistered
     _ -> createToken
   where
     t tkn = withToken c tkn Nothing
-    createToken :: m (NtfTknStatus, Maybe NtfServer)
+    createToken :: m NtfTknStatus
     createToken =
       getNtfServer c >>= \case
         Just ntfServer ->
           asks (cmdSignAlg . config) >>= \case
             C.SignAlg a -> do
-              g <- asks random
-              tknKeys <- atomically $ C.generateSignatureKeyPair a g
-              dhKeys <- atomically $ C.generateKeyPair g
+              tknKeys <- liftIO $ C.generateSignatureKeyPair a
+              dhKeys <- liftIO C.generateKeyPair'
               let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode
               withStore' c (`createNtfToken` tkn)
               registerToken tkn
-              pure (NTRegistered, Just ntfServer)
+              pure NTRegistered
         _ -> throwError $ CMD PROHIBITED
     registerToken :: NtfToken -> m ()
     registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
@@ -1686,10 +1711,10 @@ deleteNtfToken' c deviceToken =
       deleteNtfSubs c NSCSmpDelete
     _ -> throwError $ CMD PROHIBITED
 
-getNtfToken' :: AgentMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
+getNtfToken' :: AgentMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode)
 getNtfToken' c =
   withStore' c getSavedNtfToken >>= \case
-    Just NtfToken {deviceToken, ntfTknStatus, ntfMode, ntfServer} -> pure (deviceToken, ntfTknStatus, ntfMode, ntfServer)
+    Just NtfToken {deviceToken, ntfTknStatus, ntfMode} -> pure (deviceToken, ntfTknStatus, ntfMode)
     _ -> throwError $ CMD PROHIBITED
 
 getNtfTokenData' :: AgentMonad m => AgentClient -> m NtfToken
@@ -1808,11 +1833,12 @@ getAgentMigrations' :: AgentMonad m => AgentClient -> m [UpMigration]
 getAgentMigrations' c = map upMigration <$> withStore' c (Migrations.getCurrent . DB.conn)
 
 debugAgentLocks' :: AgentMonad' m => AgentClient -> m AgentLocks
-debugAgentLocks' AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do
+debugAgentLocks' AgentClient {connLocks = cs, invLocks = is, reconnectLocks = rs, deleteLock = d} = do
   connLocks <- getLocks cs
   invLocks <- getLocks is
+  srvLocks <- getLocks rs
   delLock <- atomically $ tryReadTMVar d
-  pure AgentLocks {connLocks, invLocks, delLock}
+  pure AgentLocks {connLocks, invLocks, srvLocks, delLock}
   where
     getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
 
@@ -1929,9 +1955,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                     let e2eDh = C.dh' e2ePubKey e2ePrivKey
                     decryptClientMessage e2eDh clientMsg >>= \case
                       (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) ->
-                        smpConfirmation srvMsgId conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
+                        smpConfirmation conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
                       (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
-                        smpInvitation srvMsgId conn connReq connInfo >> ack
+                        smpInvitation conn connReq connInfo >> ack
                       _ -> prohibited >> ack
                   (Just e2eDh, Nothing) -> do
                     decryptClientMessage e2eDh clientMsg >>= \case
@@ -1955,25 +1981,24 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                               _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
                           _ -> pure ()
                         let encryptedMsgHash = C.sha256Hash encAgentMessage
-                        g <- asks random
-                        tryError (agentClientMsg g encryptedMsgHash) >>= \case
+                        tryError (agentClientMsg encryptedMsgHash) >>= \case
                           Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do
                             conn'' <- resetRatchetSync
                             case aMessage of
-                              HELLO -> helloMsg srvMsgId conn'' >> ackDel msgId
-                              REPLY cReq -> replyMsg srvMsgId conn'' cReq >> ackDel msgId
+                              HELLO -> helloMsg conn'' >> ackDel msgId
+                              REPLY cReq -> replyMsg conn'' cReq >> ackDel msgId
                               -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
                               A_MSG body -> do
-                                logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
+                                logServer "<--" c srv rId "MSG <MSG>"
                                 notify $ MSG msgMeta msgFlags body
                               A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta
-                              QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending srvMsgId addr
-                              QADD qs -> qDuplexAckDel conn'' "QADD" $ qAddMsg srvMsgId qs
-                              QKEY qs -> qDuplexAckDel conn'' "QKEY" $ qKeyMsg srvMsgId qs
-                              QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs
+                              QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending addr
+                              QADD qs -> qDuplexAckDel conn'' "QADD" $ qAddMsg qs
+                              QKEY qs -> qDuplexAckDel conn'' "QKEY" $ qKeyMsg qs
+                              QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg qs
                               -- no action needed for QTEST
                               -- any message in the new queue will mark it active and trigger deletion of the old queue
-                              QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret srvMsgId) >> ackDel msgId
+                              QTEST _ -> logServer "<--" c srv rId "MSG <QTEST>" >> ackDel msgId
                               EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev
                             where
                               qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> m ()) -> m ()
@@ -1995,7 +2020,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                                 | otherwise -> do
                                     liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
                                       AgentMessage _ (A_MSG body) -> do
-                                        logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
+                                        logServer "<--" c srv rId "MSG <MSG>"
                                         notify $ MSG msgMeta msgFlags body
                                       _ -> pure ()
                               _ -> checkDuplicateHash e encryptedMsgHash >> ack
@@ -2018,10 +2043,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                           checkDuplicateHash e encryptedMsgHash =
                             unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $
                               throwError e
-                          agentClientMsg :: TVar ChaChaDRG -> ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
-                          agentClientMsg g encryptedMsgHash = withStore c $ \db -> runExceptT $ do
+                          agentClientMsg :: ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
+                          agentClientMsg encryptedMsgHash = withStore c $ \db -> runExceptT $ do
                             rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY
-                            agentMsgBody <- agentRatchetDecrypt' g db connId rc encAgentMessage
+                            agentMsgBody <- agentRatchetDecrypt' db connId rc encAgentMessage
                             liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
                               agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
                                 let msgType = agentMessageType agentMsg
@@ -2057,7 +2082,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               handleNotifyAck :: m () -> m ()
               handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack
           SMP.END ->
-            atomically (TM.lookup tSess smpClients $>>= (tryReadTMVar . sessionVar) >>= processEND)
+            atomically (TM.lookup tSess smpClients $>>= tryReadTMVar >>= processEND)
               >>= logServer "<--" c srv rId
             where
               processEND = \case
@@ -2101,9 +2126,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           parseMessage :: Encoding a => ByteString -> m a
           parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
 
-          smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
-          smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
-            logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret srvMsgId
+          smpConfirmation :: Connection c -> C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
+          smpConfirmation conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
+            logServer "<--" c srv rId "MSG <CONF>"
             AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
             unless
               (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
@@ -2115,8 +2140,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
                   (pk1, rcDHRs) <- withStore c (`getRatchetX3dhKeys` connId)
                   let rc = CR.initRcvRatchet e2eEncryptVRange rcDHRs $ CR.x3dhRcv pk1 rcDHRs e2eSndParams
-                  g <- asks random
-                  (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt g rc M.empty encConnInfo
+                  (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt rc M.empty encConnInfo
                   case (agentMsgBody_, skipped) of
                     (Right agentMsgBody, CR.SMDNoChange) ->
                       parseMessage agentMsgBody >>= \case
@@ -2128,6 +2152,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                       where
                         processConf connInfo senderConf duplexHS = do
                           let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
+                          g <- asks random
                           confId <- withStore c $ \db -> do
                             setHandshakeVersion db connId agentVersion duplexHS
                             createConfirmation db g newConfirmation
@@ -2136,8 +2161,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                     _ -> prohibited
                 -- party accepting connection
                 (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
-                  g <- asks random
-                  withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage >>= \case
+                  withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case
                     AgentConnInfo connInfo -> do
                       notify $ INFO connInfo
                       let dhSecret = C.dh' e2ePubKey e2ePrivKey
@@ -2147,9 +2171,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 _ -> prohibited
               _ -> prohibited
 
-          helloMsg :: SMP.MsgId -> Connection c -> m ()
-          helloMsg srvMsgId conn' = do
-            logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret srvMsgId
+          helloMsg :: Connection c -> m ()
+          helloMsg conn' = do
+            logServer "<--" c srv rId "MSG <HELLO>"
             case status of
               Active -> prohibited
               _ ->
@@ -2169,9 +2193,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 let cData' = toConnData conn'
                 void $ enqueueMessage c cData' sq SMP.MsgFlags {notification = True} HELLO
 
-          replyMsg :: SMP.MsgId -> Connection c -> NonEmpty SMPQueueInfo -> m ()
-          replyMsg srvMsgId conn' smpQueues = do
-            logServer "<--" c srv rId $ "MSG <REPLY>:" <> logSecret srvMsgId
+          replyMsg :: Connection c -> NonEmpty SMPQueueInfo -> m ()
+          replyMsg conn' smpQueues = do
+            logServer "<--" c srv rId "MSG <REPLY>"
             case duplexHandshake of
               Just True -> prohibited
               _ -> case conn' of
@@ -2181,19 +2205,19 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   connectReplyQueues c cData' ownConnInfo smpQueues `catchAgentError` (notify . ERR)
                 _ -> prohibited
 
-          continueSending :: SMP.MsgId -> (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
-          continueSending srvMsgId addr (DuplexConnection _ _ sqs) =
+          continueSending :: (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
+          continueSending addr (DuplexConnection _ _ sqs) =
             case findQ addr sqs of
               Just sq -> do
-                logServer "<--" c srv rId $ "MSG <QCONT>:" <> logSecret srvMsgId
-                atomically $
-                  TM.lookup (qAddress sq) (smpDeliveryWorkers c)
-                    >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ())
+                logServer "<--" c srv rId "MSG <QCONT>"
+                atomically $ do
+                  (_, qLock) <- getPendingMsgQ c sq
+                  void $ tryPutTMVar qLock ()
               Nothing -> qError "QCONT: queue address not found"
 
           messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> m ()
           messagesRcvd rcpts msgMeta@MsgMeta {broker = (srvMsgId, _)} _ = do
-            logServer "<--" c srv rId $ "MSG <RCPT>:" <> logSecret srvMsgId
+            logServer "<--" c srv rId "MSG <RCPT>"
             rs <- forM rcpts $ \rcpt -> clientReceipt rcpt `catchAgentError` \e -> notify (ERR e) $> Nothing
             case L.nonEmpty . catMaybes $ L.toList rs of
               Just rs' -> notify $ RCVD msgMeta rs' -- client must ACK once processed
@@ -2214,27 +2238,28 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                       pure $ Just rcpt
 
           -- processed by queue sender
-          qAddMsg :: SMP.MsgId -> NonEmpty (SMPQueueUri, Maybe SndQAddr) -> Connection 'CDuplex -> m ()
-          qAddMsg _ ((_, Nothing) :| _) _ = qError "adding queue without switching is not supported"
-          qAddMsg srvMsgId ((qUri, Just addr) :| _) (DuplexConnection cData' rqs sqs) = do
+          qAddMsg :: NonEmpty (SMPQueueUri, Maybe SndQAddr) -> Connection 'CDuplex -> m ()
+          qAddMsg ((_, Nothing) :| _) _ = qError "adding queue without switching is not supported"
+          qAddMsg ((qUri, Just addr) :| _) (DuplexConnection cData' rqs sqs) = do
             when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized")
             clientVRange <- asks $ smpClientVRange . config
             case qUri `compatibleVersion` clientVRange of
               Just qInfo@(Compatible sqInfo@SMPQueueInfo {queueAddress}) ->
                 case (findQ (qAddress sqInfo) sqs, findQ addr sqs) of
                   (Just _, _) -> qError "QADD: queue address is already used in connection"
-                  (_, Just sq@SndQueue {dbQueueId = DBQueueId dbQueueId}) -> do
-                    let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs
+                  (_, Just sq@SndQueue {dbQueueId}) -> do
+                    let (delSqs, keepSqs) = L.partition ((Just dbQueueId == ) . dbReplaceQId) sqs
                     case L.nonEmpty keepSqs of
                       Just sqs' -> do
                         -- move inside case?
                         withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs
                         sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue userId connId qInfo
-                        let sq'' = (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-                        sq2 <- withStore c $ \db -> addConnSndQueue db connId sq''
+                        let sq'' = (sq_ :: SndQueue) {primary = True, dbQueueId, dbReplaceQueueId = Just dbQueueId}
+                        dbId <- withStore c $ \db -> addConnSndQueue db connId sq''
+                        let sq2 = (sq'' :: SndQueue) {dbQueueId = dbId}
                         case (sndPublicKey, e2ePubKey) of
                           (Just sndPubKey, Just dhPublicKey) -> do
-                            logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress)
+                            logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
                             let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
                             void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
                             sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
@@ -2247,8 +2272,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               _ -> throwError $ AGENT A_VERSION
 
           -- processed by queue recipient
-          qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
-          qKeyMsg srvMsgId ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do
+          qKeyMsg :: NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
+          qKeyMsg ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do
             when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized")
             clientVRange <- asks $ smpClientVRange . config
             unless (qInfo `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
@@ -2256,7 +2281,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'}
                 | status' == New || status' == Confirmed -> do
                     checkRQSwchStatus rq RSSendingQADD
-                    logServer "<--" c srv rId $ "MSG <QKEY>:" <> logSecret srvMsgId <> " " <> logSecret senderId
+                    logServer "<--" c srv rId $ "MSG <QKEY> " <> logSecret senderId
                     let dhSecret = C.dh' dhPublicKey dhPrivKey
                     withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
                     enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey
@@ -2268,16 +2293,16 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
 
           -- processed by queue sender
           -- mark queue as Secured and to start sending messages to it
-          qUseMsg :: SMP.MsgId -> NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> m ()
+          qUseMsg :: NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> m ()
           -- NOTE: does not yet support the change of the primary status during the rotation
-          qUseMsg srvMsgId ((addr, _primary) :| _) (DuplexConnection cData' rqs sqs) = do
+          qUseMsg ((addr, _primary) :| _) (DuplexConnection cData' rqs sqs) = do
             when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized")
             case findQ addr sqs of
               Just sq'@SndQueue {dbReplaceQueueId = Just replaceQId} -> do
                 case find ((replaceQId ==) . dbQId) sqs of
                   Just sq1 -> do
                     checkSQSwchStatus sq1 SSSendingQKEY
-                    logServer "<--" c srv rId $ "MSG <QUSE>:" <> logSecret srvMsgId <> " " <> logSecret (snd addr)
+                    logServer "<--" c srv rId $ "MSG <QUSE> " <> logSecret (snd addr)
                     withStore' c $ \db -> setSndQueueStatus db sq' Secured
                     let sq'' = (sq' :: SndQueue) {status = Secured}
                     -- sending QTEST to the new queue only, the old one will be removed if sent successfully
@@ -2299,9 +2324,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
             when (isNothing rcSnd) . void $
               enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} (EREADY lastExternalSndId)
 
-          smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-          smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
-            logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret srvMsgId
+          smpInvitation :: Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+          smpInvitation conn' connReq@(CRInvitationUri crData _) cInfo = do
+            logServer "<--" c srv rId "MSG <KEY>"
             case conn' of
               ContactConnection {} -> do
                 g <- asks random
@@ -2347,9 +2372,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   throwError $ AGENT (A_CRYPTO RATCHET_SYNC)
                 where
                   sendReplyKey = do
-                    g <- asks random
-                    (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- atomically . CR.generateE2EParams g $ version e2eOtherPartyParams
-                    enqueueRatchetKeyMsgs c cData' sqs e2eParams
+                    (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ version e2eOtherPartyParams
+                    void $ enqueueRatchetKeyMsgs c cData' sqs e2eParams
                     pure (pk1, pk2, k1, k2)
                   notifyRatchetSyncError = do
                     let cData'' = cData' {ratchetSyncState = RSRequired} :: ConnData
@@ -2372,7 +2396,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 | rkHash k1 k2 <= rkHashRcv = do
                     recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 $ CR.x3dhRcv pk1 pk2 e2eOtherPartyParams
                 | otherwise = do
-                    (_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random
+                    (_, rcDHRs) <- liftIO C.generateKeyPair'
                     recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams
                     void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
 
@@ -2407,13 +2431,14 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) =
     Nothing -> throwError $ AGENT A_VERSION
     Just qInfo' -> do
       sq <- newSndQueue userId connId qInfo'
-      sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
-      enqueueConfirmation c cData sq' ownConnInfo Nothing
+      dbQueueId <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
+      enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing
 
 confirmQueueAsync :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> SubscriptionMode -> m ()
 confirmQueueAsync v c cData sq srv connInfo e2eEncryption_ subMode = do
-  storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation v c cData sq srv connInfo subMode
-  submitPendingMsg c cData sq
+  resumeMsgDelivery c cData sq
+  msgId <- storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation v c cData sq srv connInfo subMode
+  queuePendingMsgs c sq [msgId]
 
 confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> SubscriptionMode -> m ()
 confirmQueue v@(Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption_ subMode = do
@@ -2436,10 +2461,11 @@ mkAgentConfirmation (Compatible agentVersion) c cData sq srv connInfo subMode
 
 enqueueConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
 enqueueConfirmation c cData sq connInfo e2eEncryption_ = do
-  storeConfirmation c cData sq e2eEncryption_ $ AgentConnInfo connInfo
-  submitPendingMsg c cData sq
+  resumeMsgDelivery c cData sq
+  msgId <- storeConfirmation c cData sq e2eEncryption_ $ AgentConnInfo connInfo
+  queuePendingMsgs c sq [msgId]
 
-storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.E2ERatchetParams 'C.X448) -> AgentMessage -> m ()
+storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.E2ERatchetParams 'C.X448) -> AgentMessage -> m InternalId
 storeConfirmation c ConnData {connId, connAgentVersion} sq e2eEncryption_ agentMsg = withStore c $ \db -> runExceptT $ do
   internalTs <- liftIO getCurrentTime
   (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
@@ -2451,17 +2477,20 @@ storeConfirmation c ConnData {connId, connAgentVersion} sq e2eEncryption_ agentM
       msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
   liftIO $ createSndMsg db connId msgData
   liftIO $ createSndMsgDelivery db connId sq internalId
+  pure internalId
 
-enqueueRatchetKeyMsgs :: forall m. AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> CR.E2ERatchetParams 'C.X448 -> m ()
+enqueueRatchetKeyMsgs :: forall m. AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> CR.E2ERatchetParams 'C.X448 -> m AgentMsgId
 enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do
   msgId <- enqueueRatchetKey c cData sq e2eEncryption
   mapM_ (enqueueSavedMessage c cData msgId) $ filter isActiveSndQ sqs
+  pure msgId
 
 enqueueRatchetKey :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> CR.E2ERatchetParams 'C.X448 -> m AgentMsgId
 enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
+  resumeMsgDelivery c cData sq
   aVRange <- asks $ smpAgentVRange . config
   msgId <- storeRatchetKey $ maxVersion aVRange
-  submitPendingMsg c cData sq
+  queuePendingMsgs c sq [msgId]
   pure $ unId msgId
   where
     storeRatchetKey :: Version -> m InternalId
@@ -2487,24 +2516,23 @@ agentRatchetEncrypt db connId msg paddedLen = do
   pure encMsg
 
 -- encoded EncAgentMessage -> encoded AgentMessage
-agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
-agentRatchetDecrypt g db connId encAgentMsg = do
+agentRatchetDecrypt :: DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
+agentRatchetDecrypt db connId encAgentMsg = do
   rc <- ExceptT $ getRatchet db connId
-  agentRatchetDecrypt' g db connId rc encAgentMsg
+  agentRatchetDecrypt' db connId rc encAgentMsg
 
-agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString
-agentRatchetDecrypt' g db connId rc encAgentMsg = do
+agentRatchetDecrypt' :: DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString
+agentRatchetDecrypt' db connId rc encAgentMsg = do
   skipped <- liftIO $ getSkippedMsgKeys db connId
-  (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt g rc skipped encAgentMsg
+  (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg
   liftIO $ updateRatchet db connId rc' skippedDiff
   liftEither $ first (SEAgentError . cryptoError) agentMsgBody_
 
-newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m NewSndQueue
+newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m SndQueue
 newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do
   C.SignAlg a <- asks $ cmdSignAlg . config
-  g <- asks random
-  (sndPublicKey, sndPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
-  (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
+  (sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
+  (e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   pure
     SndQueue
       { userId,
@@ -2516,7 +2544,7 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd
         e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
         e2ePubKey = Just e2ePubKey,
         status = New,
-        dbQueueId = DBNewQueue,
+        dbQueueId = 0,
         primary = True,
         dbReplaceQueueId = Nothing,
         sndSwchStatus = Nothing,

src/Simplex/Messaging/Agent/Client.hs

@@ -77,8 +77,6 @@ module Simplex.Messaging.Agent.Client
     agentClientStore,
     agentDRG,
     getAgentSubscriptions,
-    Worker (..),
-    SessionVar (..),
     SubscriptionsInfo (..),
     SubInfo (..),
     AgentOperation (..),
@@ -86,13 +84,6 @@ module Simplex.Messaging.Agent.Client
     AgentState (..),
     AgentLocks (..),
     AgentStatsKey (..),
-    getAgentWorker,
-    getAgentWorker',
-    cancelWorker,
-    waitForWork,
-    hasWorkToDo,
-    hasWorkToDo',
-    withWork,
     agentOperations,
     agentOperationBracket,
     waitUntilActive,
@@ -117,10 +108,6 @@ module Simplex.Messaging.Agent.Client
     getNextServer,
     withUserServers,
     withNextSrv,
-    AgentWorkersDetails (..),
-    getAgentWorkersDetails,
-    AgentWorkersSummary (..),
-    getAgentWorkersSummary,
   )
 where
 
@@ -134,7 +121,7 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Crypto.Random (ChaChaDRG)
+import Crypto.Random (ChaChaDRG, getRandomBytes)
 import qualified Data.Aeson.TH as J
 import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Base64
@@ -147,16 +134,13 @@ import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (isNothing, listToMaybe)
+import Data.Maybe (isJust, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
-import Data.Time.Clock.System (getSystemTime)
 import Data.Word (Word16)
-
--- import GHC.Conc (unsafeIOToSTM)
 import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
@@ -172,6 +156,7 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import Simplex.Messaging.Agent.TAsyncs
 import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues))
 import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import Simplex.Messaging.Client
@@ -216,25 +201,19 @@ import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Random (randomR)
-import UnliftIO (mapConcurrently, timeout)
-import UnliftIO.Async (async)
+import System.Timeout (timeout)
+import UnliftIO (mapConcurrently)
 import UnliftIO.Directory (getTemporaryDirectory)
-import UnliftIO.Exception (bracket)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-data SessionVar a = SessionVar
-  { sessionVar :: TMVar a,
-    sessionVarId :: Int
-  }
-
-type ClientVar msg = SessionVar (Either AgentErrorType (Client msg))
+type ClientVar msg = TMVar (Either AgentErrorType (Client msg))
 
 type SMPClientVar = ClientVar SMP.BrokerMsg
 
 type NtfClientVar = ClientVar NtfResponse
 
-type XFTPClientVar = ClientVar FileResponse
+type XFTPClientVar = TMVar (Either AgentErrorType XFTPClient)
 
 type SMPTransportSession = TransportSession SMP.BrokerMsg
 
@@ -258,10 +237,12 @@ data AgentClient = AgentClient
     activeSubs :: TRcvQueues,
     pendingSubs :: TRcvQueues,
     removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
-    workerSeq :: TVar Int,
-    smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
-    asyncCmdWorkers :: TMap (Maybe SMPServer) Worker,
+    pendingMsgsQueued :: TMap SndQAddr Bool,
+    smpQueueMsgQueues :: TMap SndQAddr (TQueue (InternalId, Bool), TMVar ()),
+    smpQueueMsgDeliveries :: TMap SndQAddr (Async ()),
     connCmdsQueued :: TMap ConnId Bool,
+    asyncCmdQueues :: TMap (Maybe SMPServer) (TQueue AsyncCmdId),
+    asyncCmdProcesses :: TMap (Maybe SMPServer) (Async ()),
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -275,79 +256,15 @@ data AgentClient = AgentClient
     invLocks :: TMap ByteString Lock,
     -- lock to prevent concurrency between periodic and async connection deletions
     deleteLock :: Lock,
-    -- smpSubWorkers for SMP servers sessions
-    smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
+    -- locks to prevent concurrent reconnections to SMP servers
+    reconnectLocks :: TMap SMPTransportSession Lock,
+    reconnections :: TAsyncs,
+    asyncClients :: TAsyncs,
     agentStats :: TMap AgentStatsKey (TVar Int),
     clientId :: Int,
     agentEnv :: Env
   }
 
-getAgentWorker :: (AgentMonad' m, Ord k, Show k) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT AgentErrorType m ()) -> m Worker
-getAgentWorker = getAgentWorker' id pure
-
-getAgentWorker' :: forall a k m. (AgentMonad' m, Ord k, Show k) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT AgentErrorType m ()) -> m a
-getAgentWorker' toW fromW name hasWork c key ws work = do
-  atomically (getWorker >>= maybe createWorker whenExists) >>= \w -> runWorker w $> w
-  where
-    getWorker = TM.lookup key ws
-    createWorker = do
-      w <- fromW =<< newWorker c
-      TM.insert key w ws
-      pure w
-    whenExists w
-      | hasWork = hasWorkToDo (toW w) $> w
-      | otherwise = pure w
-    runWorker w = runWorkerAsync (toW w) runWork
-      where
-        runWork :: m ()
-        runWork = tryAgentError' (work w) >>= restartOrDelete
-        restartOrDelete :: Either AgentErrorType () -> m ()
-        restartOrDelete e_ = do
-          t <- liftIO getSystemTime
-          maxRestarts <- asks $ maxWorkerRestartsPerMin . config
-          -- worker may terminate because it was deleted from the map (getWorker returns Nothing), then it won't restart
-          restart <- atomically $ getWorker >>= maybe (pure False) (shouldRestart e_ (toW w) t maxRestarts)
-          when restart runWork
-        shouldRestart e_ Worker {workerId = wId, doWork, action, restarts} t maxRestarts w'
-          | wId == workerId (toW w') =
-              checkRestarts . updateRestartCount t =<< readTVar restarts
-          | otherwise =
-              pure False -- there is a new worker in the map, no action
-          where
-            checkRestarts rc
-              | restartCount rc < maxRestarts = do
-                  writeTVar restarts rc
-                  hasWorkToDo' doWork
-                  void $ tryPutTMVar action Nothing
-                  notifyErr INTERNAL
-                  pure True
-              | otherwise = do
-                  TM.delete key ws
-                  notifyErr $ CRITICAL True
-                  pure False
-              where
-                notifyErr err = do
-                  let e = either ((", error: " <>) . show) (\_ -> ", no error") e_
-                      msg = "Worker " <> name <> " for " <> show key <> " terminated " <> show (restartCount rc) <> " times" <> e
-                  writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err msg)
-
-newWorker :: AgentClient -> STM Worker
-newWorker c = do
-  workerId <- stateTVar (workerSeq c) $ \next -> (next, next + 1)
-  doWork <- newTMVar ()
-  action <- newTMVar Nothing
-  restarts <- newTVar $ RestartCount 0 0
-  pure Worker {workerId, doWork, action, restarts}
-
-runWorkerAsync :: AgentMonad' m => Worker -> m () -> m ()
-runWorkerAsync Worker {action} work =
-  bracket
-    (atomically $ takeTMVar action) -- get current action, locking to avoid race conditions
-    (atomically . tryPutTMVar action) -- if it was running (or if start crashes), put it back and unlock (don't lock if it was just started)
-    (\a -> when (isNothing a) start) -- start worker if it's not running
-  where
-    start = atomically . putTMVar action . Just =<< async work
-
 data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
   deriving (Eq, Show)
 
@@ -370,6 +287,7 @@ data AgentState = ASForeground | ASSuspending | ASSuspended
 data AgentLocks = AgentLocks
   { connLocks :: Map String String,
     invLocks :: Map String String,
+    srvLocks :: Map String String,
     delLock :: Maybe String
   }
   deriving (Show)
@@ -383,8 +301,8 @@ data AgentStatsKey = AgentStatsKey
   }
   deriving (Eq, Ord, Show)
 
-newAgentClient :: Int -> InitialAgentServers -> Env -> STM AgentClient
-newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
+newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
+newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
   active <- newTVar True
   rcvQ <- newTBQueue qSize
@@ -401,10 +319,12 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
   activeSubs <- RQ.empty
   pendingSubs <- RQ.empty
   removedSubs <- TM.empty
-  workerSeq <- newTVar 0
-  smpDeliveryWorkers <- TM.empty
-  asyncCmdWorkers <- TM.empty
+  pendingMsgsQueued <- TM.empty
+  smpQueueMsgQueues <- TM.empty
+  smpQueueMsgDeliveries <- TM.empty
   connCmdsQueued <- TM.empty
+  asyncCmdQueues <- TM.empty
+  asyncCmdProcesses <- TM.empty
   ntfNetworkOp <- newTVar $ AgentOpState False 0
   rcvNetworkOp <- newTVar $ AgentOpState False 0
   msgDeliveryOp <- newTVar $ AgentOpState False 0
@@ -415,8 +335,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
   connLocks <- TM.empty
   invLocks <- TM.empty
   deleteLock <- createLock
-  smpSubWorkers <- TM.empty
+  reconnectLocks <- TM.empty
+  reconnections <- newTAsyncs
+  asyncClients <- newTAsyncs
   agentStats <- TM.empty
+  clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
   return
     AgentClient
       { active,
@@ -434,10 +357,12 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
         activeSubs,
         pendingSubs,
         removedSubs,
-        workerSeq,
-        smpDeliveryWorkers,
-        asyncCmdWorkers,
+        pendingMsgsQueued,
+        smpQueueMsgQueues,
+        smpQueueMsgDeliveries,
         connCmdsQueued,
+        asyncCmdQueues,
+        asyncCmdProcesses,
         ntfNetworkOp,
         rcvNetworkOp,
         msgDeliveryOp,
@@ -448,7 +373,9 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
         connLocks,
         invLocks,
         deleteLock,
-        smpSubWorkers,
+        reconnectLocks,
+        reconnections,
+        asyncClients,
         agentStats,
         clientId,
         agentEnv
@@ -499,25 +426,25 @@ instance ProtocolServerClient XFTPErrorType FileResponse where
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
 getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) . throwError $ INACTIVE
-  v <- atomically (getTSessVar c tSess smpClients)
-  either newClient (waitForProtocolClient c tSess) v
-    `catchAgentError` \e -> resubscribeSMPSession c tSess >> throwError e
+  atomically (getClientVar tSess smpClients)
+    >>= either
+      (newProtocolClient c tSess smpClients connectClient reconnectSMPClient)
+      (waitForProtocolClient c tSess)
   where
-    newClient = newProtocolClient c tSess smpClients connectClient
-    connectClient :: SMPClientVar -> m SMPClient
-    connectClient v = do
+    connectClient :: m SMPClient
+    connectClient = do
       cfg <- getClientConfig c smpCfg
       u <- askUnliftIO
-      liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg (Just msgQ) $ clientDisconnected u v)
+      liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg (Just msgQ) $ clientDisconnected u)
 
-    clientDisconnected :: UnliftIO m -> SMPClientVar -> SMPClient -> IO ()
-    clientDisconnected u v client = do
+    clientDisconnected :: UnliftIO m -> SMPClient -> IO ()
+    clientDisconnected u client = do
       removeClientAndSubs >>= serverDown
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
       where
         removeClientAndSubs :: IO ([RcvQueue], [ConnId])
         removeClientAndSubs = atomically $ do
-          removeTSessVar v tSess smpClients
+          TM.delete tSess smpClients
           qs <- RQ.getDelSessQueues tSess $ activeSubs c
           mapM_ (`RQ.addQueue` pendingSubs c) qs
           let cs = S.fromList $ map qConnId qs
@@ -531,55 +458,27 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv,
           unless (null conns) $ notifySub "" $ DOWN srv conns
           unless (null qs) $ do
             atomically $ mapM_ (releaseGetLock c) qs
-            unliftIO u $ resubscribeSMPSession c tSess
+            unliftIO u $ reconnectServer c tSess
 
         notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
         notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
 
-resubscribeSMPSession :: AgentMonad' m => AgentClient -> SMPTransportSession -> m ()
-resubscribeSMPSession c@AgentClient {smpSubWorkers} tSess =
-  atomically getWorkerVar >>= mapM_ (either newSubWorker (\_ -> pure ()))
+reconnectServer :: AgentMonad m => AgentClient -> SMPTransportSession -> m ()
+reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c
   where
-    getWorkerVar =
-      ifM
-        (null <$> getPending)
-        (pure Nothing) -- prevent race with cleanup and adding pending queues in another call
-        (Just <$> getTSessVar c tSess smpSubWorkers)
-    newSubWorker v = do
-      a <- async $ void (E.tryAny runSubWorker) >> atomically (cleanup v)
-      atomically $ putTMVar (sessionVar v) a
-    runSubWorker = do
+    tryReconnectSMPClient aId = do
       ri <- asks $ reconnectInterval . config
-      timeoutCounts <- newTVarIO 0
-      withRetryInterval ri $ \_ loop -> do
-        pending <- atomically getPending
-        forM_ (L.nonEmpty pending) $ \qs -> do
-          void . tryAgentError' $ reconnectSMPClient timeoutCounts c tSess qs
-          loop
-    getPending = RQ.getSessQueues tSess $ pendingSubs c
-    cleanup :: SessionVar (Async ()) -> STM ()
-    cleanup v = do
-      -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
-      -- Not waiting may result in terminated worker remaining in the map.
-      whenM (isEmptyTMVar $ sessionVar v) retry
-      removeTSessVar v tSess smpSubWorkers
+      withRetryInterval ri $ \_ loop ->
+        reconnectSMPClient c tSess `catchAgentError` const loop
+      atomically . removeAsyncAction aId $ reconnections c
 
-reconnectSMPClient :: forall m. AgentMonad m => TVar Int -> AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> m ()
-reconnectSMPClient tc c tSess@(_, srv, _) qs = do
-  NetworkConfig {tcpTimeout} <- readTVarIO $ useNetworkConfig c
-  -- this allows 3x of timeout per batch of subscription (90 queues per batch empirically)
-  let t = (length qs `div` 90 + 1) * tcpTimeout * 3
-  t `timeout` resubscribe >>= \case
-    Just _ -> atomically $ writeTVar tc 0
-    Nothing -> do
-      tc' <- atomically $ stateTVar tc $ \i -> (i + 1, i + 1)
-      maxTC <- asks $ maxSubscriptionTimeouts . config
-      let err = if tc' >= maxTC then CRITICAL True else INTERNAL
-          msg = show tc' <> " consecutive subscription timeouts: " <> show (length qs) <> " queues, transport session: " <> show tSess
-      atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err msg)
+reconnectSMPClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m ()
+reconnectSMPClient c tSess@(_, srv, _) =
+  withLockMap_ (reconnectLocks c) tSess "reconnect" $
+    atomically (RQ.getSessQueues tSess $ pendingSubs c) >>= mapM_ resubscribe . L.nonEmpty
   where
-    resubscribe :: m ()
-    resubscribe = do
+    resubscribe :: NonEmpty RcvQueue -> m ()
+    resubscribe qs = do
       cs <- atomically . RQ.getConns $ activeSubs c
       rs <- subscribeQueues c $ L.toList qs
       let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
@@ -588,29 +487,26 @@ reconnectSMPClient tc c tSess@(_, srv, _) qs = do
         unless (null conns) $ notifySub "" $ UP srv conns
       let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
       liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
-      forM_ (listToMaybe tempErrs) $ \(_, err) -> do
-        when (null okConns && S.null cs && null finalErrs) . liftIO $
-          closeClient c smpClients tSess
-        throwError err
+      mapM_ (throwError . snd) $ listToMaybe tempErrs
     notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
     notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
 
 getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
 getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) . throwError $ INACTIVE
-  atomically (getTSessVar c tSess ntfClients)
+  atomically (getClientVar tSess ntfClients)
     >>= either
-      (newProtocolClient c tSess ntfClients connectClient)
+      (newProtocolClient c tSess ntfClients connectClient $ \_ _ -> pure ())
       (waitForProtocolClient c tSess)
   where
-    connectClient :: NtfClientVar -> m NtfClient
-    connectClient v = do
+    connectClient :: m NtfClient
+    connectClient = do
       cfg <- getClientConfig c ntfCfg
-      liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing $ clientDisconnected v)
+      liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing clientDisconnected)
 
-    clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
-    clientDisconnected v client = do
-      atomically $ removeTSessVar v tSess ntfClients
+    clientDisconnected :: NtfClient -> IO ()
+    clientDisconnected client = do
+      atomically $ TM.delete tSess ntfClients
       incClientStat c userId client "DISCONNECT" ""
       atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
@@ -618,73 +514,78 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
 getXFTPServerClient :: forall m. AgentMonad m => AgentClient -> XFTPTransportSession -> m XFTPClient
 getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) . throwError $ INACTIVE
-  atomically (getTSessVar c tSess xftpClients)
+  atomically (getClientVar tSess xftpClients)
     >>= either
-      (newProtocolClient c tSess xftpClients connectClient)
+      (newProtocolClient c tSess xftpClients connectClient $ \_ _ -> pure ())
       (waitForProtocolClient c tSess)
   where
-    connectClient :: XFTPClientVar -> m XFTPClient
-    connectClient v = do
+    connectClient :: m XFTPClient
+    connectClient = do
       cfg <- asks $ xftpCfg . config
       xftpNetworkConfig <- readTVarIO useNetworkConfig
-      liftEitherError (protocolClientError XFTP $ B.unpack $ strEncode srv) (X.getXFTPClient tSess cfg {xftpNetworkConfig} $ clientDisconnected v)
+      liftEitherError (protocolClientError XFTP $ B.unpack $ strEncode srv) (X.getXFTPClient tSess cfg {xftpNetworkConfig} clientDisconnected)
 
-    clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
-    clientDisconnected v client = do
-      atomically $ removeTSessVar v tSess xftpClients
+    clientDisconnected :: XFTPClient -> IO ()
+    clientDisconnected client = do
+      atomically $ TM.delete tSess xftpClients
       incClientStat c userId client "DISCONNECT" ""
       atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-getTSessVar :: forall a s. AgentClient -> TransportSession s -> TMap (TransportSession s) (SessionVar a) -> STM (Either (SessionVar a) (SessionVar a))
-getTSessVar c tSess vs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup tSess vs
+getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
+getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup tSess clients
   where
-    newSessionVar :: STM (SessionVar a)
-    newSessionVar = do
-      sessionVar <- newEmptyTMVar
-      sessionVarId <- stateTVar (workerSeq c) $ \next -> (next, next + 1)
-      let v = SessionVar {sessionVar, sessionVarId}
-      TM.insert tSess v vs
-      pure v
-
-removeTSessVar :: SessionVar a -> TransportSession msg -> TMap (TransportSession msg) (SessionVar a) -> STM ()
-removeTSessVar v tSess vs =
-  TM.lookup tSess vs
-    >>= mapM_ (\v' -> when (sessionVarId v == sessionVarId v') $ TM.delete tSess vs)
+    newClientVar :: STM (TMVar a)
+    newClientVar = do
+      var <- newEmptyTMVar
+      TM.insert tSess var clients
+      pure var
 
 waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar msg -> m (Client msg)
-waitForProtocolClient c (_, srv, _) v = do
+waitForProtocolClient c (_, srv, _) clientVar = do
   NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
-  client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
+  client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
   liftEither $ case client_ of
     Just (Right smpClient) -> Right smpClient
     Just (Left e) -> Left e
     Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
 
--- clientConnected arg is only passed for SMP server
 newProtocolClient ::
   forall err msg m.
   (AgentMonad m, ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) =>
   AgentClient ->
   TransportSession msg ->
   TMap (TransportSession msg) (ClientVar msg) ->
-  (ClientVar msg -> m (Client msg)) ->
+  m (Client msg) ->
+  (AgentClient -> TransportSession msg -> m ()) ->
   ClientVar msg ->
   m (Client msg)
-newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
-  tryAgentError (connectClient v) >>= \case
-    Right client -> do
-      logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
-      atomically $ putTMVar (sessionVar v) (Right client)
-      liftIO $ incClientStat c userId client "CLIENT" "OK"
-      atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
-      pure client
-    Left e -> do
-      liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
-      atomically $ do
-        removeTSessVar v tSess clients
-        putTMVar (sessionVar v) (Left e)
-      throwError e -- signal error to caller
+newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
+  where
+    tryConnectClient :: (Client msg -> m a) -> m () -> m a
+    tryConnectClient successAction retryAction =
+      tryError connectClient >>= \r -> case r of
+        Right client -> do
+          logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
+          atomically $ putTMVar clientVar r
+          liftIO $ incClientStat c userId client "CLIENT" "OK"
+          atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
+          successAction client
+        Left e -> do
+          liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
+          if temporaryAgentError e
+            then retryAction
+            else atomically $ do
+              putTMVar clientVar (Left e)
+              TM.delete tSess clients
+          throwError e
+    tryConnectAsync :: m ()
+    tryConnectAsync = newAsyncAction connectAsync $ asyncClients c
+    connectAsync :: Int -> m ()
+    connectAsync aId = do
+      ri <- asks $ reconnectInterval . config
+      withRetryInterval ri $ \_ loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop
+      atomically . removeAsyncAction aId $ asyncClients c
 
 hostEvent :: forall err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
 hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
@@ -701,26 +602,21 @@ closeAgentClient c = liftIO $ do
   closeProtocolServerClients c smpClients
   closeProtocolServerClients c ntfClients
   closeProtocolServerClients c xftpClients
-  atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect
-  clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst)
-  clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker
-  clear connCmdsQueued
+  cancelActions . actions $ reconnections c
+  cancelActions . actions $ asyncClients c
+  cancelActions $ smpQueueMsgDeliveries c
+  cancelActions $ asyncCmdProcesses c
   atomically . RQ.clear $ activeSubs c
   atomically . RQ.clear $ pendingSubs c
   clear subscrConns
+  clear pendingMsgsQueued
+  clear smpQueueMsgQueues
+  clear connCmdsQueued
+  clear asyncCmdQueues
   clear getMsgLocks
   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
-    cancelReconnect :: SessionVar (Async ()) -> IO ()
-    cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel
-
-cancelWorker :: Worker -> IO ()
-cancelWorker Worker {doWork, action} = do
-  noWorkToDo doWork
-  atomically (tryTakeTMVar action) >>= mapM_ (mapM_ uninterruptibleCancel)
 
 waitUntilActive :: AgentClient -> STM ()
 waitUntilActive c = unlessM (readTVar $ active c) retry
@@ -728,11 +624,13 @@ waitUntilActive c = unlessM (readTVar $ active c) retry
 throwWhenInactive :: AgentClient -> STM ()
 throwWhenInactive c = unlessM (readTVar $ active c) $ throwSTM ThreadKilled
 
--- this function is used to remove workers once delivery is complete, not when it is removed from the map
 throwWhenNoDelivery :: AgentClient -> SndQueue -> STM ()
-throwWhenNoDelivery c sq =
-  unlessM (TM.member (qAddress sq) $ smpDeliveryWorkers c) $
+throwWhenNoDelivery c SndQueue {server, sndId} =
+  unlessM (isJust <$> TM.lookup k (smpQueueMsgQueues c)) $ do
+    TM.delete k $ smpQueueMsgDeliveries c
     throwSTM ThreadKilled
+  where
+    k = (server, sndId)
 
 closeProtocolServerClients :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
@@ -743,9 +641,9 @@ closeClient c clientSel tSess =
   atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
 
 closeClient_ :: ProtocolServerClient err msg => AgentClient -> ClientVar msg -> IO ()
-closeClient_ c v = do
+closeClient_ c cVar = do
   NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
-  tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
+  tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
     Just (Right client) -> closeProtocolServerClient client `catchAll_` pure ()
     _ -> pure ()
 
@@ -753,6 +651,9 @@ closeXFTPServerClient :: AgentMonad' m => AgentClient -> UserId -> XFTPServer ->
 closeXFTPServerClient c userId server (FileDigest chunkDigest) =
   mkTransportSession c userId server chunkDigest >>= liftIO . closeClient c xftpClients
 
+cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
+cancelActions as = atomically (swapTVar as mempty) >>= mapM_ (forkIO . uninterruptibleCancel)
+
 withConnLock :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m a -> m a
 withConnLock _ "" _ = id
 withConnLock AgentClient {connLocks} connId name = withLockMap_ connLocks connId name
@@ -760,13 +661,13 @@ withConnLock AgentClient {connLocks} connId name = withLockMap_ connLocks connId
 withInvLock :: MonadUnliftIO m => AgentClient -> ByteString -> String -> m a -> m a
 withInvLock AgentClient {invLocks} = withLockMap_ invLocks
 
-withConnLocks :: MonadUnliftIO m => AgentClient -> [ConnId] -> String -> m a -> m a
-withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . filter (not . B.null)
+withConnLocks :: MonadUnliftIO m => AgentClient -> Set ConnId -> String -> m a -> m a
+withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . S.filter (not . B.null)
 
 withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
 withLockMap_ = withGetLock . getMapLock
 
-withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> [k] -> String -> m a -> m a
+withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> String -> m a -> m a
 withLocksMap_ = withGetLocks . getMapLock
 
 getMapLock :: Ord k => TMap k Lock -> k -> STM Lock
@@ -861,14 +762,13 @@ runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -
 runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
   cfg <- getClientConfig c smpCfg
   C.SignAlg a <- asks $ cmdSignAlg . config
-  g <- asks random
   liftIO $ do
     let tSess = (userId, srv, Nothing)
     getProtocolClient tSess cfg Nothing (\_ -> pure ()) >>= \case
       Right smp -> do
-        (rKey, rpKey) <- atomically $ C.generateSignatureKeyPair a g
-        (sKey, _) <- atomically $ C.generateSignatureKeyPair a g
-        (dhKey, _) <- atomically $ C.generateKeyPair g
+        (rKey, rpKey) <- C.generateSignatureKeyPair a
+        (sKey, _) <- C.generateSignatureKeyPair a
+        (dhKey, _) <- C.generateKeyPair'
         r <- runExceptT $ do
           SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe
           liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
@@ -885,7 +785,6 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
 runXFTPServerTest :: forall m. AgentMonad m => AgentClient -> UserId -> XFTPServerWithAuth -> m (Maybe ProtocolTestFailure)
 runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
   cfg <- asks $ xftpCfg . config
-  g <- asks random
   xftpNetworkConfig <- readTVarIO $ useNetworkConfig c
   workDir <- getXFTPWorkPath
   filePath <- getTempFilePath workDir
@@ -894,8 +793,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
     let tSess = (userId, srv, Nothing)
     X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
       Right xftp -> do
-        (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-        (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+        (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+        (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
         createTestChunk filePath
         digest <- liftIO $ C.sha256Hash <$> B.readFile filePath
         let file = FileInfo {sndKey, size = chSize, digest}
@@ -903,7 +802,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
         r <- runExceptT $ do
           (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
           liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
-          liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
+          liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
           rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
           unless (digest == rcvDigest) $ throwError $ ProtocolTestFailure TSCompareFile $ XFTP DIGEST
           liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
@@ -922,9 +821,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
       ts <- liftIO getCurrentTime
       let isoTime = formatTime defaultTimeLocale "%Y-%m-%dT%H%M%S.%6q" ts
       uniqueCombine workPath isoTime
-    -- this creates a new DRG on purpose to avoid blocking the one used in the agent
     createTestChunk :: FilePath -> IO ()
-    createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom
+    createTestChunk fp = B.writeFile fp =<< getRandomBytes chSize
 
 getXFTPWorkPath :: AgentMonad m => m FilePath
 getXFTPWorkPath = do
@@ -946,13 +844,12 @@ mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode
 getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig
 
-newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (NewRcvQueue, SMPQueueUri)
+newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (RcvQueue, SMPQueueUri)
 newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
   C.SignAlg a <- asks (cmdSignAlg . config)
-  g <- asks random
-  (recipientKey, rcvPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
-  (dhKey, privDhKey) <- atomically $ C.generateKeyPair g
-  (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
+  (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
+  (dhKey, privDhKey) <- liftIO C.generateKeyPair'
+  (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   logServer "-->" c srv "" "NEW"
   tSess <- mkTransportSession c userId srv connId
   QIK {rcvId, sndId, rcvPublicDhKey} <-
@@ -970,7 +867,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
             e2eDhSecret = Nothing,
             sndId,
             status = New,
-            dbQueueId = DBNewQueue,
+            dbQueueId = 0,
             primary = True,
             dbReplaceQueueId = Nothing,
             rcvSwchStatus = Nothing,
@@ -1003,7 +900,7 @@ temporaryOrHostError = \case
   e -> temporaryAgentError e
 
 -- | Subscribe to queues. The list of results can have a different order.
-subscribeQueues :: forall m. AgentMonad' m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+subscribeQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
 subscribeQueues c qs = do
   (errs, qs') <- partitionEithers <$> mapM checkQueue qs
   forM_ qs' $ \rq@RcvQueue {connId} -> atomically $ do
@@ -1021,13 +918,13 @@ subscribeQueues c qs = do
       rs <- sendBatch subscribeSMPQueues smp qs'
       mapM_ (uncurry $ processSubResult c) rs
       when (any temporaryClientError . lefts . map snd $ L.toList rs) . unliftIO u $
-        resubscribeSMPSession c (transportSession' smp)
+        reconnectServer c (transportSession' smp)
       pure rs
 
 type BatchResponses e r = (NonEmpty (RcvQueue, Either e r))
 
 -- statBatchSize is not used to batch the commands, only for traffic statistics
-sendTSessionBatches :: forall m q r. AgentMonad' m => ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> m [(RcvQueue, Either AgentErrorType r)]
+sendTSessionBatches :: forall m q r. AgentMonad m => ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> m [(RcvQueue, Either AgentErrorType r)]
 sendTSessionBatches statCmd statBatchSize toRQ action c qs =
   concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
   where
@@ -1041,7 +938,7 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs =
            in M.alter (Just . maybe [q] (q <|)) tSess m
     sendClientBatch :: (SMPTransportSession, NonEmpty q) -> m (BatchResponses AgentErrorType r)
     sendClientBatch (tSess@(userId, srv, _), qs') =
-      tryAgentError' (getSMPServerClient c tSess) >>= \case
+      tryError (getSMPServerClient c tSess) >>= \case
         Left e -> pure $ L.map ((,Left e) . toRQ) qs'
         Right smp -> liftIO $ do
           logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
@@ -1142,7 +1039,7 @@ enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtf
   withSMPClient c rq "NKEY <nkey>" $ \smp ->
     enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
 
-enableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
+enableQueuesNtfs :: forall m. AgentMonad m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
 enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_
   where
     fst3 (x, _, _) = x
@@ -1156,12 +1053,12 @@ disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
   withSMPClient c rq "NDEL" $ \smp ->
     disableSMPQueueNotifications smp rcvPrivateKey rcvId
 
-disableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+disableQueuesNtfs :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
 disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueuesNtfs
 
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
 sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
-  withSMPClient c rq ("ACK:" <> logSecret msgId) $ \smp ->
+  withSMPClient c rq "ACK" $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId msgId
   atomically $ releaseGetLock c rq
 
@@ -1183,7 +1080,7 @@ deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
   withSMPClient c rq "DEL" $ \smp ->
     deleteSMPQueue smp rcvPrivateKey rcvId
 
-deleteQueues :: forall m. AgentMonad' m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+deleteQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
 deleteQueues = sendTSessionBatches "DEL" 90 id $ sendBatch deleteSMPQueues
 
 sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
@@ -1230,14 +1127,13 @@ agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
 
 agentXFTPDownloadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> m ()
-agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = do
-  g <- asks random
-  withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec
+agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
+  withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk xftp replicaKey fId chunkSpec
 
 agentXFTPNewChunk :: AgentMonad m => AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> m NewSndChunkReplica
 agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
   rKeys <- xftpRcvKeys n
-  (sndKey, replicaKey) <- atomically . C.generateSignatureKeyPair C.SEd25519 =<< asks random
+  (sndKey, replicaKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest}
   logServer "-->" c srv "" "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
@@ -1261,7 +1157,7 @@ agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkR
 
 xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair)
 xftpRcvKeys n = do
-  rKeys <- atomically . replicateM n . C.generateSignatureKeyPair C.SEd25519 =<< asks random
+  rKeys <- liftIO $ replicateM n $ C.generateSignatureKeyPair C.SEd25519
   case L.nonEmpty rKeys of
     Just rKeys' -> pure rKeys'
     _ -> throwError $ INTERNAL "non-positive number of recipients"
@@ -1271,7 +1167,7 @@ xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
 
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
-  cmNonce <- atomically . C.randomCbNonce =<< asks random
+  cmNonce <- liftIO C.randomCbNonce
   let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey
   cmEncBody <-
     liftEither . first cryptoError $
@@ -1282,10 +1178,9 @@ agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
 -- add encoding as AgentInvitation'?
 agentCbEncryptOnce :: AgentMonad m => Version -> C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
-  g <- asks random
-  (dhSndPubKey, dhSndPrivKey) <- atomically $ C.generateKeyPair g
+  (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
   let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
-  cmNonce <- atomically $ C.randomCbNonce g
+  cmNonce <- liftIO C.randomCbNonce
   cmEncBody <-
     liftEither . first cryptoError $
       C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength
@@ -1313,29 +1208,6 @@ cryptoError = \case
   where
     c = AGENT . A_CRYPTO
 
-waitForWork :: AgentMonad' m => TMVar () -> m ()
-waitForWork = void . atomically . readTMVar
-
-withWork :: AgentMonad m => AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError (Maybe a))) -> (a -> m ()) -> m ()
-withWork c doWork getWork action =
-  withStore' c getWork >>= \case
-    Right (Just r) -> action r
-    Right Nothing -> noWork
-    Left e@SEWorkItemError {} -> noWork >> notifyErr (CRITICAL False) e
-    Left e -> notifyErr INTERNAL e
-  where
-    noWork = liftIO $ noWorkToDo doWork
-    notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err $ show e)
-
-noWorkToDo :: TMVar () -> IO ()
-noWorkToDo = void . atomically . tryTakeTMVar
-
-hasWorkToDo :: Worker -> STM ()
-hasWorkToDo = hasWorkToDo' . doWork
-
-hasWorkToDo' :: TMVar () -> STM ()
-hasWorkToDo' = void . (`tryPutTMVar` ())
-
 endAgentOperation :: AgentClient -> AgentOperation -> STM ()
 endAgentOperation c op = endOperation c op $ case op of
   AONtfNetwork -> pure ()
@@ -1434,15 +1306,14 @@ withStoreCtx_ ctx_ c action = do
 withStoreBatch :: (AgentMonad' m, Traversable t) => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> m (t (Either AgentErrorType a))
 withStoreBatch c actions = do
   st <- asks store
-  liftIO . agentOperationBracket c AODatabase (\_ -> pure ()) $
-    withTransaction st $
-      mapM (`E.catch` handleInternal) . actions
+  liftIO $ agentOperationBracket c AODatabase (\_ -> pure ()) $
+      withTransaction st $ mapM (`E.catch` handleInternal) . actions
   where
     handleInternal :: E.SomeException -> IO (Either AgentErrorType a)
     handleInternal = pure . Left . INTERNAL . show
 
 withStoreBatch' :: (AgentMonad' m, Traversable t) => AgentClient -> (DB.Connection -> t (IO a)) -> m (t (Either AgentErrorType a))
-withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions)
+withStoreBatch' c actions = withStoreBatch c $ \db -> fmap Right <$> actions db
 
 storeError :: StoreError -> AgentErrorType
 storeError = \case
@@ -1539,117 +1410,6 @@ getAgentSubscriptions c = do
     enc :: StrEncoding a => a -> Text
     enc = decodeLatin1 . strEncode
 
-data AgentWorkersDetails = AgentWorkersDetails
-  { smpClients_ :: [Text],
-    ntfClients_ :: [Text],
-    xftpClients_ :: [Text],
-    smpDeliveryWorkers_ :: Map Text WorkersDetails,
-    asyncCmdWorkers_ :: Map Text WorkersDetails,
-    smpSubWorkers_ :: [Text],
-    ntfWorkers_ :: Map Text WorkersDetails,
-    ntfSMPWorkers_ :: Map Text WorkersDetails,
-    xftpRcvWorkers_ :: Map Text WorkersDetails,
-    xftpSndWorkers_ :: Map Text WorkersDetails,
-    xftpDelWorkers_ :: Map Text WorkersDetails
-  }
-  deriving (Show)
-
-data WorkersDetails = WorkersDetails
-  { restarts :: Int,
-    hasWork :: Bool,
-    hasAction :: Bool
-  }
-  deriving (Show)
-
-getAgentWorkersDetails :: MonadIO m => AgentClient -> m 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
-  pure
-    AgentWorkersDetails
-      { smpClients_,
-        ntfClients_,
-        xftpClients_,
-        smpDeliveryWorkers_,
-        asyncCmdWorkers_,
-        smpSubWorkers_,
-        ntfWorkers_,
-        ntfSMPWorkers_,
-        xftpRcvWorkers_,
-        xftpSndWorkers_,
-        xftpDelWorkers_
-      }
-  where
-    textKeys :: StrEncoding k => Map k v -> [Text]
-    textKeys = map textKey . M.keys
-    textKey :: StrEncoding k => k -> Text
-    textKey = decodeASCII . strEncode
-    workerStats :: (StrEncoding k, MonadIO m) => Map k Worker -> m (Map Text WorkersDetails)
-    workerStats ws = fmap M.fromList . forM (M.toList ws) $ \(qa, Worker {restarts, doWork, action}) -> do
-      RestartCount {restartCount} <- readTVarIO restarts
-      hasWork <- atomically $ not <$> isEmptyTMVar doWork
-      hasAction <- atomically $ not <$> isEmptyTMVar action
-      pure (textKey qa, WorkersDetails {restarts = restartCount, hasWork, hasAction})
-    Env {ntfSupervisor, xftpAgent} = agentEnv
-    NtfSupervisor {ntfWorkers, ntfSMPWorkers} = ntfSupervisor
-    XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers} = xftpAgent
-
-data AgentWorkersSummary = AgentWorkersSummary
-  { smpClientsCount :: Int,
-    ntfClientsCount :: Int,
-    xftpClientsCount :: Int,
-    smpDeliveryWorkersCount :: Int,
-    asyncCmdWorkersCount :: Int,
-    smpSubWorkersCount :: Int,
-    ntfWorkersCount :: Int,
-    ntfSMPWorkersCount :: Int,
-    xftpRcvWorkersCount :: Int,
-    xftpSndWorkersCount :: Int,
-    xftpDelWorkersCount :: Int
-  }
-  deriving (Show)
-
-getAgentWorkersSummary :: MonadIO m => AgentClient -> m 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 <- M.size <$> readTVarIO smpDeliveryWorkers
-  asyncCmdWorkersCount <- M.size <$> readTVarIO asyncCmdWorkers
-  smpSubWorkersCount <- M.size <$> readTVarIO smpSubWorkers
-  ntfWorkersCount <- M.size <$> readTVarIO ntfWorkers
-  ntfSMPWorkersCount <- M.size <$> readTVarIO ntfSMPWorkers
-  xftpRcvWorkersCount <- M.size <$> readTVarIO xftpRcvWorkers
-  xftpSndWorkersCount <- M.size <$> readTVarIO xftpSndWorkers
-  xftpDelWorkersCount <- M.size <$> readTVarIO xftpDelWorkers
-  pure
-    AgentWorkersSummary
-      { smpClientsCount,
-        ntfClientsCount,
-        xftpClientsCount,
-        smpDeliveryWorkersCount,
-        asyncCmdWorkersCount,
-        smpSubWorkersCount,
-        ntfWorkersCount,
-        ntfSMPWorkersCount,
-        xftpRcvWorkersCount,
-        xftpSndWorkersCount,
-        xftpDelWorkersCount
-      }
-  where
-    Env {ntfSupervisor, xftpAgent} = agentEnv
-    NtfSupervisor {ntfWorkers, ntfSMPWorkers} = ntfSupervisor
-    XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers} = xftpAgent
-
 $(J.deriveJSON defaultJSON ''AgentLocks)
 
 $(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep)
@@ -1659,8 +1419,3 @@ $(J.deriveJSON defaultJSON ''ProtocolTestFailure)
 $(J.deriveJSON defaultJSON ''SubInfo)
 
 $(J.deriveJSON defaultJSON ''SubscriptionsInfo)
-
-$(J.deriveJSON defaultJSON ''WorkersDetails)
-$(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWorkersDetails)
-
-$(J.deriveJSON defaultJSON ''AgentWorkersSummary)

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -19,7 +19,6 @@ module Simplex.Messaging.Agent.Env.SQLite
     defaultAgentConfig,
     defaultReconnectInterval,
     tryAgentError,
-    tryAgentError',
     catchAgentError,
     agentFinally,
     Env (..),
@@ -28,13 +27,9 @@ module Simplex.Messaging.Agent.Env.SQLite
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
     XFTPAgent (..),
-    Worker (..),
-    RestartCount (..),
-    updateRestartCount,
   )
 where
 
-import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -44,7 +39,6 @@ import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
-import Data.Time.Clock.System (SystemTime (..))
 import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
@@ -92,17 +86,13 @@ data AgentConfig = AgentConfig
     messageRetryInterval :: RetryInterval2,
     messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
-    quotaExceededTimeout :: NominalDiffTime,
     initialCleanupDelay :: Int64,
     cleanupInterval :: Int64,
     cleanupStepInterval :: Int,
-    maxWorkerRestartsPerMin :: Int,
-    maxSubscriptionTimeouts :: Int,
     storedMsgDataTTL :: NominalDiffTime,
     rcvFilesTTL :: NominalDiffTime,
     sndFilesTTL :: NominalDiffTime,
     xftpNotifyErrsOnRetry :: Bool,
-    xftpConsecutiveRetries :: Int,
     xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
     ntfCron :: Word16,
@@ -115,7 +105,8 @@ data AgentConfig = AgentConfig
     certificateFile :: FilePath,
     e2eEncryptVRange :: VersionRange,
     smpAgentVRange :: VersionRange,
-    smpClientVRange :: VersionRange
+    smpClientVRange :: VersionRange,
+    initialClientId :: Int
   }
 
 defaultReconnectInterval :: RetryInterval
@@ -136,10 +127,13 @@ defaultMessageRetryInterval =
             maxInterval = 60_000000
           },
       riSlow =
+        -- TODO: these timeouts can be increased in v5.0 once most clients are updated
+        -- to resume sending on QCONT messages.
+        -- After that local message expiration period should be also increased.
         RetryInterval
-          { initialInterval = 180_000000, -- 3 minutes
+          { initialInterval = 60_000000,
             increaseAfter = 60_000000,
-            maxInterval = 3 * 3600_000000 -- 3 hours
+            maxInterval = 3600_000000 -- 1 hour
           }
     }
 
@@ -157,19 +151,13 @@ defaultAgentConfig =
       messageRetryInterval = defaultMessageRetryInterval,
       messageTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
-      quotaExceededTimeout = 7 * nominalDay,
       initialCleanupDelay = 30 * 1000000, -- 30 seconds
       cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
       cleanupStepInterval = 200000, -- 200ms
-      maxWorkerRestartsPerMin = 5,
-      -- 3 consecutive subscription timeouts will result in alert to the user
-      -- this is a fallback, as the timeout set to 3x of expected timeout, to avoid potential locking.
-      maxSubscriptionTimeouts = 3,
       storedMsgDataTTL = 21 * nominalDay,
       rcvFilesTTL = 2 * nominalDay,
       sndFilesTTL = nominalDay,
       xftpNotifyErrsOnRetry = True,
-      xftpConsecutiveRetries = 3,
       xftpMaxRecipientsPerRequest = 200,
       deleteErrorCount = 10,
       ntfCron = 20, -- minutes
@@ -184,13 +172,15 @@ defaultAgentConfig =
       certificateFile = "/etc/opt/simplex-agent/agent.crt",
       e2eEncryptVRange = supportedE2EEncryptVRange,
       smpAgentVRange = supportedSMPAgentVRange,
-      smpClientVRange = supportedSMPClientVRange
+      smpClientVRange = supportedSMPClientVRange,
+      initialClientId = 0
     }
 
 data Env = Env
   { config :: AgentConfig,
     store :: SQLiteStore,
     random :: TVar ChaChaDRG,
+    clientCounter :: TVar Int,
     randomServer :: TVar StdGen,
     ntfSupervisor :: NtfSupervisor,
     xftpAgent :: XFTPAgent,
@@ -198,13 +188,14 @@ data Env = Env
   }
 
 newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env
-newSMPAgentEnv config store = do
-  random <- C.newRandom
+newSMPAgentEnv config@AgentConfig {initialClientId} store = do
+  random <- newTVarIO =<< drgNew
+  clientCounter <- newTVarIO initialClientId
   randomServer <- newTVarIO =<< liftIO newStdGen
   ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
   xftpAgent <- atomically newXFTPAgent
   multicastSubscribers <- newTMVarIO 0
-  pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
+  pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
 createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
 createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey keepKey Migrations.app
@@ -212,8 +203,8 @@ createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey k
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
     ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
-    ntfWorkers :: TMap NtfServer Worker,
-    ntfSMPWorkers :: TMap SMPServer Worker
+    ntfWorkers :: TMap NtfServer (TMVar (), Async ()),
+    ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
   }
 
 data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
@@ -230,9 +221,9 @@ newNtfSubSupervisor qSize = do
 data XFTPAgent = XFTPAgent
   { -- if set, XFTP file paths will be considered as relative to this directory
     xftpWorkDir :: TVar (Maybe FilePath),
-    xftpRcvWorkers :: TMap (Maybe XFTPServer) Worker,
-    xftpSndWorkers :: TMap (Maybe XFTPServer) Worker,
-    xftpDelWorkers :: TMap XFTPServer Worker
+    xftpRcvWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
+    xftpSndWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
+    xftpDelWorkers :: TMap XFTPServer (TMVar (), Async ())
   }
 
 newXFTPAgent :: STM XFTPAgent
@@ -247,11 +238,6 @@ tryAgentError :: AgentMonad m => m a -> m (Either AgentErrorType a)
 tryAgentError = tryAllErrors mkInternal
 {-# INLINE tryAgentError #-}
 
--- unlike runExceptT, this ensures we catch IO exceptions as well
-tryAgentError' :: AgentMonad' m => ExceptT AgentErrorType m a -> m (Either AgentErrorType a)
-tryAgentError' = fmap join . runExceptT . tryAgentError
-{-# INLINE tryAgentError' #-}
-
 catchAgentError :: AgentMonad m => m a -> (AgentErrorType -> m a) -> m a
 catchAgentError = catchAllErrors mkInternal
 {-# INLINE catchAgentError #-}
@@ -263,20 +249,3 @@ agentFinally = allFinally mkInternal
 mkInternal :: SomeException -> AgentErrorType
 mkInternal = INTERNAL . show
 {-# INLINE mkInternal #-}
-
-data Worker = Worker
-  { workerId :: Int,
-    doWork :: TMVar (),
-    action :: TMVar (Maybe (Async ())),
-    restarts :: TVar RestartCount
-  }
-
-data RestartCount = RestartCount
-  { restartMinute :: Int64,
-    restartCount :: Int
-  }
-
-updateRestartCount :: SystemTime -> RestartCount -> RestartCount
-updateRestartCount t (RestartCount minute count) = do
-  let min' = systemSeconds t `div` 60
-   in RestartCount min' $ if minute == min' then count + 1 else 1

src/Simplex/Messaging/Agent/Lock.hs

@@ -12,6 +12,8 @@ where
 import Control.Monad (void)
 import Control.Monad.IO.Unlift
 import Data.Functor (($>))
+import Data.Set (Set)
+import qualified Data.Set as S
 import UnliftIO.Async (forConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -35,10 +37,10 @@ withGetLock getLock key name a =
     (atomically . takeTMVar)
     (const a)
 
-withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> [k] -> String -> m a -> m a
+withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> String -> m a -> m a
 withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
   where
-    holdLocks = forConcurrently keys $ \key -> atomically $ getPutLock getLock key name
+    holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
     -- only this withGetLocks would be holding the locks,
     -- so it's safe to combine all lock releases into one transaction
     releaseLocks = atomically . mapM_ takeTMVar

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -37,7 +37,9 @@ import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, SMPServer, sameSrvAddr)
+import Simplex.Messaging.Protocol (NtfServer, ProtocolServer, SMPServer, sameSrvAddr)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
 import System.Random (randomR)
 import UnliftIO
@@ -72,16 +74,16 @@ processNtfSub c (connId, cmd) = do
       logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
       case a of
         Nothing -> do
-          withTokenServer $ \ntfServer -> do
+          withNtfServer c $ \ntfServer -> do
             case clientNtfCreds of
               Just ClientNtfCreds {notifierId} -> do
                 let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
                 withStore c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
-                void $ getNtfNTFWorker True c ntfServer
+                addNtfNTFWorker ntfServer
               Nothing -> do
                 let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
                 withStore c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
-                void $ getNtfSMPWorker True c smpServer
+                addNtfSMPWorker smpServer
         (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
           case (clientNtfCreds, ntfQueueId) of
             (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
@@ -99,72 +101,82 @@ processNtfSub c (connId, cmd) = do
                 | isDeleteNtfSubAction action -> do
                     if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
                       then resetSubscription
-                      else withTokenServer $ \ntfServer -> do
+                      else withNtfServer c $ \ntfServer -> do
                         withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
-                        void $ getNtfNTFWorker True c ntfServer
+                        addNtfNTFWorker ntfServer
                 | otherwise -> case action of
-                    NtfSubNTFAction _ -> void $ getNtfNTFWorker True c subNtfServer
-                    NtfSubSMPAction _ -> void $ getNtfSMPWorker True c smpServer
+                    NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
+                    NtfSubSMPAction _ -> addNtfSMPWorker smpServer
             rotate :: m ()
             rotate = do
               withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
-              void $ getNtfNTFWorker True c subNtfServer
+              addNtfNTFWorker subNtfServer
             resetSubscription :: m ()
             resetSubscription =
-              withTokenServer $ \ntfServer -> do
+              withNtfServer c $ \ntfServer -> do
                 let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
                 withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
-                void $ getNtfSMPWorker True c smpServer
+                addNtfSMPWorker smpServer
     NSCDelete -> do
       sub_ <- withStore' c $ \db -> do
         supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
         getNtfSubscription db connId
       logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
       case sub_ of
-        (Just (NtfSubscription {ntfServer}, _)) -> void $ getNtfNTFWorker True c ntfServer
+        (Just (NtfSubscription {ntfServer}, _)) -> addNtfNTFWorker ntfServer
         _ -> pure () -- err "NSCDelete - no subscription"
     NSCSmpDelete -> do
       withStore' c (`getPrimaryRcvQueue` connId) >>= \case
         Right rq@RcvQueue {server = smpServer} -> do
           logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
           withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
-          void $ getNtfSMPWorker True c smpServer
+          addNtfSMPWorker smpServer
         _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    NSCNtfWorker ntfServer -> void $ getNtfNTFWorker True c ntfServer
-    NSCNtfSMPWorker smpServer -> void $ getNtfSMPWorker True c smpServer
+    NSCNtfWorker ntfServer -> addNtfNTFWorker ntfServer
+    NSCNtfSMPWorker smpServer -> addNtfSMPWorker smpServer
+  where
+    addNtfNTFWorker = addWorker ntfWorkers runNtfWorker
+    addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
+    addWorker ::
+      (NtfSupervisor -> TMap (ProtocolServer s) (TMVar (), Async ())) ->
+      (AgentClient -> ProtocolServer s -> TMVar () -> m ()) ->
+      ProtocolServer s ->
+      m ()
+    addWorker wsSel runWorker srv = do
+      ws <- asks $ wsSel . ntfSupervisor
+      atomically (TM.lookup srv ws) >>= \case
+        Nothing -> do
+          doWork <- newTMVarIO ()
+          worker <- async $ runWorker c srv doWork `agentFinally` atomically (TM.delete srv ws)
+          atomically $ TM.insert srv (doWork, worker) ws
+        Just (doWork, _) ->
+          void . atomically $ tryPutTMVar doWork ()
 
-getNtfNTFWorker :: AgentMonad' m => Bool -> AgentClient -> NtfServer -> m Worker
-getNtfNTFWorker hasWork c server = do
-  ws <- asks $ ntfWorkers . ntfSupervisor
-  getAgentWorker "ntf_ntf" hasWork c server ws $ runNtfWorker c server
+withNtfServer :: AgentMonad' m => AgentClient -> (NtfServer -> m ()) -> m ()
+withNtfServer c action = getNtfServer c >>= mapM_ action
 
-getNtfSMPWorker :: AgentMonad' m => Bool -> AgentClient -> SMPServer -> m Worker
-getNtfSMPWorker hasWork c server = do
-  ws <- asks $ ntfSMPWorkers . ntfSupervisor
-  getAgentWorker "ntf_smp" hasWork c server ws $ runNtfSMPWorker c server
-
-withTokenServer :: AgentMonad' m => (NtfServer -> m ()) -> m ()
-withTokenServer action = getNtfToken >>= mapM_ (\NtfToken {ntfServer} -> action ntfServer)
-
-runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> Worker -> m ()
-runNtfWorker c srv Worker {doWork} = do
+runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
+runNtfWorker c srv doWork = do
   delay <- asks $ ntfWorkerDelay . config
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
     threadDelay delay
   where
     runNtfOperation :: m ()
-    runNtfOperation =
-      withWork c doWork (`getNextNtfSubNTFAction` srv) $
-        \nextSub@(NtfSubscription {connId}, _, _) -> do
-          logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
+    runNtfOperation = do
+      nextSub_ <- withStore' c (`getNextNtfSubNTFAction` srv)
+      logInfo $ "runNtfWorker, nextSub_ " <> tshow nextSub_
+      case nextSub_ of
+        Nothing -> noWorkToDo
+        Just a@(NtfSubscription {connId}, _, _) -> do
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop ->
-            processSub nextSub
+            processAction a
               `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
-    processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
-    processSub (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
+    processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
       ts <- liftIO getCurrentTime
       unlessM (rescheduleAction doWork ts actionTs) $
         case action of
@@ -228,24 +240,27 @@ runNtfWorker c srv Worker {doWork} = do
           withStore' c $ \db ->
             updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
 
-runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> Worker -> m ()
-runNtfSMPWorker c srv Worker {doWork} = do
+runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
+runNtfSMPWorker c srv doWork = do
   delay <- asks $ ntfSMPWorkerDelay . config
   forever $ do
-    waitForWork doWork
+    void . atomically $ readTMVar doWork
     agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
     threadDelay delay
   where
-    runNtfSMPOperation =
-      withWork c doWork (`getNextNtfSubSMPAction` srv) $
-        \nextSub@(NtfSubscription {connId}, _, _) -> do
-          logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
+    runNtfSMPOperation = do
+      nextSub_ <- withStore' c (`getNextNtfSubSMPAction` srv)
+      logInfo $ "runNtfSMPWorker, nextSub_ " <> tshow nextSub_
+      case nextSub_ of
+        Nothing -> noWorkToDo
+        Just a@(NtfSubscription {connId}, _, _) -> do
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop ->
-            processSub nextSub
+            processAction a
               `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
-    processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
-    processSub (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
+    processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
       ts <- liftIO getCurrentTime
       unlessM (rescheduleAction doWork ts actionTs) $
         case smpAction of
@@ -254,9 +269,8 @@ runNtfSMPWorker c srv Worker {doWork} = do
               Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
                 rq <- withStore c (`getPrimaryRcvQueue` connId)
                 C.SignAlg a <- asks (cmdSignAlg . config)
-                g <- asks random
-                (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
-                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
+                (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
+                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
                 (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
                 let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
                 withStore' c $ \db -> do
@@ -279,7 +293,7 @@ rescheduleAction doWork ts actionTs
       void . atomically $ tryTakeTMVar doWork
       void . forkIO $ do
         liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
-        atomically $ hasWorkToDo' doWork
+        void . atomically $ tryPutTMVar doWork ()
       pure True
 
 retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
@@ -328,10 +342,13 @@ instantNotifications = \case
 
 closeNtfSupervisor :: MonadUnliftIO m => NtfSupervisor -> m ()
 closeNtfSupervisor ns = do
-  stopWorkers $ ntfWorkers ns
-  stopWorkers $ ntfSMPWorkers ns
-  where
-    stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
+  cancelNtfWorkers_ $ ntfWorkers ns
+  cancelNtfWorkers_ $ ntfSMPWorkers ns
+
+cancelNtfWorkers_ :: MonadUnliftIO m => TMap (ProtocolServer s) (TMVar (), Async ()) -> m ()
+cancelNtfWorkers_ wsVar = do
+  ws <- atomically $ stateTVar wsVar (,M.empty)
+  mapM_ (uninterruptibleCancel . snd) ws
 
 getNtfServer :: AgentMonad' m => AgentClient -> m (Maybe NtfServer)
 getNtfServer c = do

src/Simplex/Messaging/Agent/Protocol.hs

@@ -337,7 +337,6 @@ data ACommand (p :: AParty) (e :: AEntity) where
   MID :: AgentMsgId -> ACommand Agent AEConn
   SENT :: AgentMsgId -> ACommand Agent AEConn
   MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
-  MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
   MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn
   MSGNTF :: SMPMsgMeta -> ACommand Agent AEConn
   ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn
@@ -399,7 +398,6 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   MID_ :: ACommandTag Agent AEConn
   SENT_ :: ACommandTag Agent AEConn
   MERR_ :: ACommandTag Agent AEConn
-  MERRS_ :: ACommandTag Agent AEConn
   MSG_ :: ACommandTag Agent AEConn
   MSGNTF_ :: ACommandTag Agent AEConn
   ACK_ :: ACommandTag Client AEConn
@@ -454,7 +452,6 @@ aCommandTag = \case
   MID _ -> MID_
   SENT _ -> SENT_
   MERR {} -> MERR_
-  MERRS {} -> MERRS_
   MSG {} -> MSG_
   MSGNTF {} -> MSGNTF_
   ACK {} -> ACK_
@@ -1435,8 +1432,6 @@ data AgentErrorType
     AGENT {agentErr :: SMPAgentError}
   | -- | agent implementation or dependency errors
     INTERNAL {internalErr :: String}
-  | -- | critical agent errors that should be shown to the user, optionally with restart button
-    CRITICAL {offerRestart :: Bool, criticalErr :: String}
   | -- | agent inactive
     INACTIVE
   deriving (Eq, Show, Exception)
@@ -1548,7 +1543,6 @@ instance StrEncoding AgentErrorType where
       <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
       <|> "AGENT " *> (AGENT <$> parseRead1)
       <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
-      <|> "CRITICAL " *> (CRITICAL <$> parseRead1 <* A.space <*> parseRead A.takeByteString)
       <|> "INACTIVE" $> INACTIVE
     where
       textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
@@ -1566,7 +1560,6 @@ instance StrEncoding AgentErrorType where
     AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
     AGENT e -> "AGENT " <> bshow e
     INTERNAL e -> "INTERNAL " <> bshow e
-    CRITICAL restart e -> "CRITICAL " <> bshow restart <> " " <> bshow e
     INACTIVE -> "INACTIVE"
     where
       text = encodeUtf8 . T.pack
@@ -1614,7 +1607,6 @@ instance StrEncoding ACmdTag where
       "MID" -> ct MID_
       "SENT" -> ct SENT_
       "MERR" -> ct MERR_
-      "MERRS" -> ct MERRS_
       "MSG" -> ct MSG_
       "MSGNTF" -> ct MSGNTF_
       "ACK" -> t ACK_
@@ -1671,7 +1663,6 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     MID_ -> "MID"
     SENT_ -> "SENT"
     MERR_ -> "MERR"
-    MERRS_ -> "MERRS"
     MSG_ -> "MSG"
     MSGNTF_ -> "MSGNTF"
     ACK_ -> "ACK"
@@ -1712,8 +1703,8 @@ commandP binaryP =
     >>= \case
       ACmdTag SClient e cmd ->
         ACmd SClient e <$> case cmd of
-          NEW_ -> s (NEW <$> strP_ <*> strP_ <*> (strP <|> pure SMP.SMSubscribe))
-          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
+          NEW_ -> s (NEW <$> strP_ <*> strP_ <*> strP)
+          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> strP_ <*> binaryP)
           LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
           ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> binaryP)
           RJCT_ -> s (RJCT <$> A.takeByteString)
@@ -1741,7 +1732,6 @@ commandP binaryP =
           MID_ -> s (MID <$> A.decimal)
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
-          MERRS_ -> s (MERRS <$> strP_ <*> strP)
           MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP)
           MSGNTF_ -> s (MSGNTF <$> strP)
           RCVD_ -> s (RCVD <$> strP <* A.space <*> strP)
@@ -1794,13 +1784,12 @@ serializeCommand = \case
   SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
   RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
   SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
-  MID mId -> s (MID_, mId)
-  SENT mId -> s (SENT_, mId)
-  MERR mId e -> s (MERR_, mId, e)
-  MERRS mIds e -> s (MERRS_, mIds, e)
+  MID mId -> s (MID_, Str $ bshow mId)
+  SENT mId -> s (SENT_, Str $ bshow mId)
+  MERR mId e -> s (MERR_, Str $ bshow mId, e)
   MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, s msgMeta, smpEncode msgFlags, serializeBinary msgBody]
   MSGNTF smpMsgMeta -> s (MSGNTF_, smpMsgMeta)
-  ACK mId rcptInfo_ -> s (ACK_, mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_
+  ACK mId rcptInfo_ -> s (ACK_, Str $ bshow mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_
   RCVD msgMeta rcpts -> s (RCVD_, msgMeta, rcpts)
   SWCH -> s SWCH_
   OFF -> s OFF_

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -8,7 +8,6 @@ module Simplex.Messaging.Agent.RetryInterval
     RetryIntervalMode (..),
     RI2State (..),
     withRetryInterval,
-    withRetryIntervalCount,
     withRetryLock2,
     updateRetryInterval2,
   )
@@ -49,18 +48,15 @@ data RetryIntervalMode = RISlow | RIFast
   deriving (Eq, Show)
 
 withRetryInterval :: forall m a. MonadIO m => RetryInterval -> (Int64 -> m a -> m a) -> m a
-withRetryInterval ri = withRetryIntervalCount ri . const
-
-withRetryIntervalCount :: forall m a. MonadIO m => RetryInterval -> (Int -> Int64 -> m a -> m a) -> m a
-withRetryIntervalCount ri action = callAction 0 0 $ initialInterval ri
+withRetryInterval ri action = callAction 0 $ initialInterval ri
   where
-    callAction :: Int -> Int64 -> Int64 -> m a
-    callAction n elapsed delay = action n delay loop
+    callAction :: Int64 -> Int64 -> m a
+    callAction elapsed delay = action delay loop
       where
         loop = do
           liftIO $ threadDelay' delay
           let elapsed' = elapsed + delay
-          callAction (n + 1) elapsed' $ nextDelay elapsed' delay ri
+          callAction elapsed' $ nextDelay elapsed' delay ri
 
 -- This function allows action to toggle between slow and fast retry intervals.
 withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()

src/Simplex/Messaging/Agent/Server.hs

@@ -34,25 +34,23 @@ import UnliftIO.STM
 -- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
 runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> m ()
 runSMPAgent t cfg initServers store =
-  runSMPAgentBlocking t cfg initServers store 0 =<< newEmptyTMVarIO
+  runSMPAgentBlocking t cfg initServers store =<< newEmptyTMVarIO
 
 -- | Runs an SMP agent as a TCP service using passed configuration with signalling.
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Int -> TMVar Bool -> m ()
-runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store initClientId started = do
+runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> TMVar Bool -> m ()
+runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store started = do
   liftIO (newSMPAgentEnv cfg store) >>= runReaderT (smpAgent t)
   where
     smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
     smpAgent _ = do
       -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
       tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-      clientId <- newTVarIO initClientId
       runTransportServer started tcpPort tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
         liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
-        cId <- atomically $ stateTVar clientId $ \i -> (i + 1, i + 1)
-        c <- getAgentClient cId initServers
+        c <- getAgentClient initServers
         logConnection c True
         race_ (connectClient h c) (runAgentClient c)
           `E.finally` disconnectAgentClient c

src/Simplex/Messaging/Agent/Store.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
@@ -50,26 +49,8 @@ import Simplex.Messaging.Version
 
 -- * Queue types
 
-data QueueStored = QSStored | QSNew
-
-data SQueueStored (q :: QueueStored) where
-  SQSStored :: SQueueStored 'QSStored
-  SQSNew :: SQueueStored 'QSNew
-
-data DBQueueId (q :: QueueStored) where
-  DBQueueId :: Int64 -> DBQueueId 'QSStored
-  DBNewQueue :: DBQueueId 'QSNew
-
-deriving instance Eq (DBQueueId q)
-
-deriving instance Show (DBQueueId q)
-
-type RcvQueue = StoredRcvQueue 'QSStored
-
-type NewRcvQueue = StoredRcvQueue 'QSNew
-
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
-data StoredRcvQueue (q :: QueueStored) = RcvQueue
+data RcvQueue = RcvQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -88,7 +69,7 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: DBQueueId q,
+    dbQueueId :: Int64,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
     primary :: Bool,
     -- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
@@ -129,12 +110,8 @@ data ClientNtfCreds = ClientNtfCreds
   }
   deriving (Eq, Show)
 
-type SndQueue = StoredSndQueue 'QSStored
-
-type NewSndQueue = StoredSndQueue 'QSNew
-
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
-data StoredSndQueue (q :: QueueStored) = SndQueue
+data SndQueue = SndQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -150,7 +127,7 @@ data StoredSndQueue (q :: QueueStored) = SndQueue
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: DBQueueId q,
+    dbQueueId :: Int64,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
     primary :: Bool,
     -- | ID of the queue this one is replacing
@@ -217,7 +194,7 @@ instance SMPQueueRec RcvQueue where
   {-# INLINE qUserId #-}
   qConnId RcvQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId RcvQueue {dbQueueId = DBQueueId qId} = qId
+  dbQId RcvQueue {dbQueueId} = dbQueueId
   {-# INLINE dbQId #-}
   dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
@@ -227,7 +204,7 @@ instance SMPQueueRec SndQueue where
   {-# INLINE qUserId #-}
   qConnId SndQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId SndQueue {dbQueueId = DBQueueId qId} = qId
+  dbQId SndQueue {dbQueueId} = dbQueueId
   {-# INLINE dbQId #-}
   dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
@@ -339,8 +316,7 @@ ratchetSyncSendProhibited ConnData {ratchetSyncState} =
   ratchetSyncState `elem` ([RSRequired, RSStarted, RSAgreed] :: [RatchetSyncState])
 
 data PendingCommand = PendingCommand
-  { cmdId :: AsyncCmdId,
-    corrId :: ACorrId,
+  { corrId :: ACorrId,
     userId :: UserId,
     connId :: ConnId,
     command :: AgentCommand
@@ -645,6 +621,4 @@ data StoreError
     SEFileNotFound
   | -- | XFTP Deleted snd chunk replica not found.
     SEDeletedSndChunkReplicaNotFound
-  | -- | Error when reading work item that suspends worker - do not use!
-    SEWorkItemError ByteString
   deriving (Eq, Show, Exception)

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -50,7 +50,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     createNewConn,
     updateNewConnRcv,
     updateNewConnSnd,
-    createRcvConn, -- no longer used
+    createRcvConn,
     createSndConn,
     getConn,
     getDeletedConn,
@@ -107,10 +107,10 @@ module Simplex.Messaging.Agent.Store.SQLite
     createSndMsgDelivery,
     getSndMsgViaRcpt,
     updateSndMsgRcpt,
-    getPendingQueueMsg,
+    getPendingMsgData,
     updatePendingMsgRIState,
+    getPendingMsgs,
     deletePendingMsgs,
-    getExpiredSndMessages,
     setMsgUserAck,
     getRcvMsg,
     getLastMsg,
@@ -133,8 +133,8 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateRatchet,
     -- Async commands
     createCommand,
-    getPendingCommandServers,
-    getPendingServerCommand,
+    getPendingCommands,
+    getPendingCommand,
     deleteCommand,
     -- Notification device token persistence
     createNtfToken,
@@ -153,9 +153,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     setNullNtfSubscriptionAction,
     deleteNtfSubscription,
     getNextNtfSubNTFAction,
-    markNtfSubActionNtfFailed_, -- exported for tests
     getNextNtfSubSMPAction,
-    markNtfSubActionSMPFailed_, -- exported for tests
     getActiveNtfToken,
     getNtfRcvQueue,
     setConnectionNtfs,
@@ -194,7 +192,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     deleteSndFile',
     getSndFileDeleted,
     createSndFileReplica,
-    createSndFileReplica_, -- exported for tests
     getNextSndChunkToUpload,
     updateSndChunkReplicaDelay,
     addSndChunkReplicaRecipients,
@@ -226,7 +223,7 @@ import Control.Monad.IO.Class
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (first, second)
+import Data.Bifunctor (second)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
@@ -275,7 +272,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, from
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ifM, safeDecodeUtf8, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
@@ -533,56 +530,54 @@ deleteUsersWithoutConns db = do
 createConn_ ::
   TVar ChaChaDRG ->
   ConnData ->
-  (ConnId -> IO a) ->
-  IO (Either StoreError (ConnId, a))
+  (ByteString -> IO ()) ->
+  IO (Either StoreError ByteString)
 createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of
-  ConnData {connId = ""} -> createWithRandomId' gVar create
-  ConnData {connId} -> Right . (connId,) <$> create connId
+  ConnData {connId = ""} -> createWithRandomId gVar create
+  ConnData {connId} -> create connId $> Right connId
 
 createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId)
-createNewConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} cMode = do
-  fst <$$> createConn_ gVar cData create
-  where
-    create connId =
-      DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+createNewConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} cMode =
+  createConn_ gVar cData $ \connId -> do
+    DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
 
-updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
+updateNewConnRcv :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
 updateNewConnRcv db connId rq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
     (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
     (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
   where
-    updateConn :: IO (Either StoreError RcvQueue)
+    updateConn :: IO (Either StoreError Int64)
     updateConn = Right <$> addConnRcvQueue_ db connId rq
 
-updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
+updateNewConnSnd :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
 updateNewConnSnd db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
     (SomeConn _ SndConnection {}) -> updateConn -- to allow retries
     (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
   where
-    updateConn :: IO (Either StoreError SndQueue)
+    updateConn :: IO (Either StoreError Int64)
     updateConn = Right <$> addConnSndQueue_ db connId sq
 
-createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue))
+createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId)
 createRcvConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode =
   createConn_ gVar cData $ \connId -> do
     serverKeyHash_ <- createServer_ db server
     DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
-    insertRcvQueue_ db connId q serverKeyHash_
+    void $ insertRcvQueue_ db connId q serverKeyHash_
 
-createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue))
+createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId)
 createSndConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} =
   -- check confirmed snd queue doesn't already exist, to prevent it being deleted by REPLACE in insertSndQueue_
   ifM (liftIO $ checkConfirmedSndQueueExists_ db q) (pure $ Left SESndQueueExists) $
     createConn_ gVar cData $ \connId -> do
       serverKeyHash_ <- createServer_ db server
       DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
-      insertSndQueue_ db connId q serverKeyHash_
+      void $ insertSndQueue_ db connId q serverKeyHash_
 
-checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
+checkConfirmedSndQueueExists_ :: DB.Connection -> SndQueue -> IO Bool
 checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
   fromMaybe False
     <$> maybeFirstRow
@@ -607,39 +602,39 @@ deleteConn db connId =
     "DELETE FROM connections WHERE conn_id = :conn_id;"
     [":conn_id" := connId]
 
-upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
+upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
 upgradeRcvConnToDuplex db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
     (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
 
-upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
+upgradeSndConnToDuplex :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
 upgradeSndConnToDuplex db connId rq =
   getConn db connId >>= \case
     Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
     Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
-addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
+addConnRcvQueue :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
 addConnRcvQueue db connId rq =
   getConn db connId >>= \case
     Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
     Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
-addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
+addConnRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO Int64
 addConnRcvQueue_ db connId rq@RcvQueue {server} = do
   serverKeyHash_ <- createServer_ db server
   insertRcvQueue_ db connId rq serverKeyHash_
 
-addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
+addConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
 addConnSndQueue db connId sq =
   getConn db connId >>= \case
     Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
     Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
-addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
+addConnSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO Int64
 addConnSndQueue_ db connId sq@SndQueue {server} = do
   serverKeyHash_ <- createServer_ db server
   insertSndQueue_ db connId sq serverKeyHash_
@@ -979,96 +974,40 @@ updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} =
     "UPDATE snd_messages SET rcpt_internal_id = ?, rcpt_status = ? WHERE conn_id = ? AND internal_snd_id = ?"
     (agentMsgId, msgRcptStatus, connId, sndMsgId)
 
-getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
-getPendingQueueMsg db connId SndQueue {dbQueueId} =
-  getWorkItem "message" getMsgId getMsgData markMsgFailed
+getPendingMsgData :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData))
+getPendingMsgData db connId msgId = do
+  rq_ <- L.head <$$> getRcvQueuesByConnId_ db connId
+  (rq_,) <$$> firstRow pendingMsgData SEMsgNotFound getMsgData_
   where
-    getMsgId :: IO (Maybe InternalId)
-    getMsgId =
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT internal_id
-            FROM snd_message_deliveries d
-            WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0
-            ORDER BY internal_id ASC
-            LIMIT 1
-          |]
-          (connId, dbQueueId)
-    getMsgData :: InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData))
-    getMsgData msgId = runExceptT $ do
-      msg <- ExceptT $ firstRow pendingMsgData err getMsgData_
-      rq_ <- liftIO $ L.head <$$> getRcvQueuesByConnId_ db connId
-      pure (rq_, msg)
-      where
-        getMsgData_ =
-          DB.query
-            db
-            [sql|
-              SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts, s.retry_int_slow, s.retry_int_fast
-              FROM messages m
-              JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
-              WHERE m.conn_id = ? AND m.internal_id = ?
-            |]
-            (connId, msgId)
-        err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []"
-        pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
-        pendingMsgData (msgType, msgFlags_, msgBody, internalTs, riSlow_, riFast_) =
-          let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
-              msgRetryState = RI2State <$> riSlow_ <*> riFast_
-           in PendingMsgData {msgId, msgType, msgFlags, msgBody, msgRetryState, internalTs}
-    markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
-
-getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
-getWorkItem itemName getId getItem markFailed =
-  runExceptT $ handleErr "getId" getId >>= mapM tryGetItem
-  where
-    tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwError e
-    mark itemId = handleErr ("markFailed ID " <> bshow itemId) $ markFailed itemId
-    catchStoreErrors = catchAllErrors (SEInternal . bshow)
-    -- Errors caught by this function will suspend worker as if there is no more work,
-    handleErr :: ByteString -> IO a -> ExceptT StoreError IO a
-    handleErr opName action = ExceptT $ first mkError <$> E.try action
-      where
-        mkError :: E.SomeException -> StoreError
-        mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
+    getMsgData_ =
+      DB.query
+        db
+        [sql|
+          SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts, s.retry_int_slow, s.retry_int_fast
+          FROM messages m
+          JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
+          WHERE m.conn_id = ? AND m.internal_id = ?
+        |]
+        (connId, msgId)
+    pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
+    pendingMsgData (msgType, msgFlags_, msgBody, internalTs, riSlow_, riFast_) =
+      let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
+          msgRetryState = RI2State <$> riSlow_ <*> riFast_
+       in PendingMsgData {msgId, msgType, msgFlags, msgBody, msgRetryState, internalTs}
 
 updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO ()
 updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} =
   DB.execute db "UPDATE snd_messages SET retry_int_slow = ?, retry_int_fast = ? WHERE conn_id = ? AND internal_id = ?" (slowInterval, fastInterval, connId, msgId)
 
+getPendingMsgs :: DB.Connection -> ConnId -> SndQueue -> IO [InternalId]
+getPendingMsgs db connId SndQueue {dbQueueId} =
+  map fromOnly
+    <$> DB.query db "SELECT internal_id FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? ORDER BY internal_id ASC" (connId, dbQueueId)
+
 deletePendingMsgs :: DB.Connection -> ConnId -> SndQueue -> IO ()
 deletePendingMsgs db connId SndQueue {dbQueueId} =
   DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId)
 
-getExpiredSndMessages :: DB.Connection -> ConnId -> SndQueue -> UTCTime -> IO [InternalId]
-getExpiredSndMessages db connId SndQueue {dbQueueId} expireTs = do
-  -- type is Maybe InternalId because MAX always returns one row, possibly with NULL value
-  maxId :: [Maybe InternalId] <-
-    map fromOnly
-      <$> DB.query
-        db
-        [sql|
-          SELECT MAX(internal_id)
-          FROM messages
-          WHERE conn_id = ? AND internal_snd_id IS NOT NULL AND internal_ts < ?
-        |]
-        (connId, expireTs)
-  case maxId of
-    Just msgId : _ ->
-      map fromOnly
-        <$> DB.query
-          db
-          [sql|
-            SELECT internal_id
-            FROM snd_message_deliveries
-            WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0 AND internal_id <= ?
-            ORDER BY internal_id ASC
-          |]
-          (connId, dbQueueId, msgId)
-    _ -> pure []
-
 setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId))
 setMsgUserAck db connId agentMsgId = runExceptT $ do
   (dbRcvId, srvMsgId) <-
@@ -1157,7 +1096,7 @@ deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do
 
 countPendingSndDeliveries_ :: DB.Connection -> ConnId -> InternalId -> IO Int
 countPendingSndDeliveries_ db connId msgId = do
-  (Only cnt : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ? AND failed = 0" (connId, msgId)
+  (Only cnt : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
   pure cnt
 
 deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
@@ -1263,15 +1202,15 @@ updateRatchet db connId rc skipped = do
         forM_ (M.assocs mks) $ \(msgN, mk) ->
           DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
 
-createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO (Either StoreError ())
+createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO (Either StoreError AsyncCmdId)
 createCommand db corrId connId srv_ cmd = runExceptT $ do
   (host_, port_, serverKeyHash_) <- serverFields
-  createdAt <- liftIO getCurrentTime
-  liftIO $
+  liftIO $ do
     DB.execute
       db
-      "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash, created_at) VALUES (?,?,?,?,?,?,?,?)"
-      (host_, port_, corrId, connId, agentCommandTag cmd, cmd, serverKeyHash_, createdAt)
+      "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash) VALUES (?,?,?,?,?,?,?)"
+      (host_, port_, corrId, connId, agentCommandTag cmd, cmd, serverKeyHash_)
+    insertedRowId db
   where
     serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash)
     serverFields = case srv_ of
@@ -1282,63 +1221,38 @@ createCommand db corrId connId srv_ cmd = runExceptT $ do
 insertedRowId :: DB.Connection -> IO Int64
 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
 
-getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer]
-getPendingCommandServers db connId = do
+getPendingCommands :: DB.Connection -> ConnId -> IO [(Maybe SMPServer, [AsyncCmdId])]
+getPendingCommands db connId = do
+  -- `groupOn` is used instead of `groupAllOn` to avoid extra sorting by `server + cmdId`, as the query already sorts by them.
   -- TODO review whether this can break if, e.g., the server has another key hash.
-  map smpServer
+  map (\ids -> (fst $ head ids, map snd ids)) . groupOn fst . map srvCmdId
     <$> DB.query
       db
       [sql|
-        SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
+        SELECT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash), c.command_id
         FROM commands c
         LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
         WHERE conn_id = ?
+        ORDER BY c.host, c.port, c.command_id ASC
       |]
       (Only connId)
   where
-    smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
+    srvCmdId (host, port, keyHash, cmdId) = (SMPServer <$> host <*> port <*> keyHash, cmdId)
 
-getPendingServerCommand :: DB.Connection -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
-getPendingServerCommand db srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
+getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError PendingCommand)
+getPendingCommand db msgId = do
+  firstRow pendingCommand SECmdNotFound $
+    DB.query
+      db
+      [sql|
+        SELECT c.corr_id, cs.user_id, c.conn_id, c.command
+        FROM commands c
+        JOIN connections cs USING (conn_id)
+        WHERE c.command_id = ?
+      |]
+      (Only msgId)
   where
-    getCmdId :: IO (Maybe Int64)
-    getCmdId =
-      maybeFirstRow fromOnly $ case srv_ of
-        Nothing ->
-          DB.query_
-            db
-            [sql|
-              SELECT command_id FROM commands
-              WHERE host IS NULL AND port IS NULL AND failed = 0
-              ORDER BY created_at ASC, command_id ASC
-              LIMIT 1
-            |]
-        Just (SMPServer host port _) ->
-          DB.query
-            db
-            [sql|
-              SELECT command_id FROM commands
-              WHERE host = ? AND port = ? AND failed = 0
-              ORDER BY created_at ASC, command_id ASC
-              LIMIT 1
-            |]
-            (host, port)
-    getCommand :: Int64 -> IO (Either StoreError PendingCommand)
-    getCommand cmdId =
-      firstRow pendingCommand err $
-        DB.query
-          db
-          [sql|
-            SELECT c.corr_id, cs.user_id, c.conn_id, c.command
-            FROM commands c
-            JOIN connections cs USING (conn_id)
-            WHERE c.command_id = ?
-          |]
-          (Only cmdId)
-      where
-        err = SEInternal $ "command  " <> bshow cmdId <> " returned []"
-        pendingCommand (corrId, userId, connId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
-    markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId)
+    pendingCommand (corrId, userId, connId, command) = PendingCommand {corrId, userId, connId, command}
 
 deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
 deleteCommand db cmdId =
@@ -1563,95 +1477,53 @@ deleteNtfSubscription db connId = do
           (Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId)
       else DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
 
-getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs)))
-getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
-  getWorkItem "ntf NTF" getNtfConnId getNtfSubAction (markNtfSubActionNtfFailed_ db)
+getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs))
+getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) = do
+  maybeFirstRow ntfSubAction getNtfSubAction_ $>>= \a@(NtfSubscription {connId}, _, _) -> do
+    DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = ? WHERE conn_id = ?" (False, connId)
+    pure $ Just a
   where
-    getNtfConnId :: IO (Maybe ConnId)
-    getNtfConnId =
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT conn_id
-            FROM ntf_subscriptions
-            WHERE ntf_host = ? AND ntf_port = ? AND ntf_sub_action IS NOT NULL
-              AND (ntf_failed = 0 OR updated_by_supervisor = 1)
-            ORDER BY ntf_sub_action_ts ASC
-            LIMIT 1
-          |]
-          (ntfHost, ntfPort)
-    getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubNTFAction, NtfActionTs))
-    getNtfSubAction connId = do
-      markUpdatedByWorker db connId
-      firstRow ntfSubAction err $
-        DB.query
-          db
-          [sql|
-            SELECT s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash),
-              ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action
-            FROM ntf_subscriptions ns
-            JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port
-            WHERE ns.conn_id = ?
-          |]
-          (Only connId)
-      where
-        err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
-        ntfSubAction (smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
-          let smpServer = SMPServer smpHost smpPort smpKeyHash
-              ntfSubscription = NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
-           in (ntfSubscription, action, actionTs)
+    getNtfSubAction_ =
+      DB.query
+        db
+        [sql|
+          SELECT ns.conn_id, s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash),
+            ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action
+          FROM ntf_subscriptions ns
+          JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port
+          WHERE ns.ntf_host = ? AND ns.ntf_port = ? AND ns.ntf_sub_action IS NOT NULL
+          ORDER BY ns.ntf_sub_action_ts ASC
+          LIMIT 1
+        |]
+        (ntfHost, ntfPort)
+    ntfSubAction (connId, smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
+      let smpServer = SMPServer smpHost smpPort smpKeyHash
+          ntfSubscription = NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
+       in (ntfSubscription, action, actionTs)
 
-markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO ()
-markNtfSubActionNtfFailed_ db connId =
-  DB.execute db "UPDATE ntf_subscriptions SET ntf_failed = 1 where conn_id = ?" (Only connId)
-
-getNextNtfSubSMPAction :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubSMPAction, NtfActionTs)))
-getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
-  getWorkItem "ntf SMP" getNtfConnId getNtfSubAction (markNtfSubActionSMPFailed_ db)
+getNextNtfSubSMPAction :: DB.Connection -> SMPServer -> IO (Maybe (NtfSubscription, NtfSubSMPAction, NtfActionTs))
+getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) = do
+  maybeFirstRow ntfSubAction getNtfSubAction_ $>>= \a@(NtfSubscription {connId}, _, _) -> do
+    DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = ? WHERE conn_id = ?" (False, connId)
+    pure $ Just a
   where
-    getNtfConnId :: IO (Maybe ConnId)
-    getNtfConnId =
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT conn_id
-            FROM ntf_subscriptions ns
-            WHERE smp_host = ? AND smp_port = ? AND ntf_sub_smp_action IS NOT NULL AND ntf_sub_action_ts IS NOT NULL
-              AND (smp_failed = 0 OR updated_by_supervisor = 1)
-            ORDER BY ntf_sub_action_ts ASC
-            LIMIT 1
-          |]
-          (smpHost, smpPort)
-    getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubSMPAction, NtfActionTs))
-    getNtfSubAction connId = do
-      markUpdatedByWorker db connId
-      firstRow ntfSubAction err $
-        DB.query
-          db
-          [sql|
-            SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
-              ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
-            FROM ntf_subscriptions ns
-            JOIN ntf_servers s USING (ntf_host, ntf_port)
-            WHERE ns.conn_id = ?
-          |]
-          (Only connId)
-      where
-        err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
-        ntfSubAction (ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
-          let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
-              ntfSubscription = NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
-           in (ntfSubscription, action, actionTs)
-
-markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO ()
-markNtfSubActionSMPFailed_ db connId =
-  DB.execute db "UPDATE ntf_subscriptions SET smp_failed = 1 where conn_id = ?" (Only connId)
-
-markUpdatedByWorker :: DB.Connection -> ConnId -> IO ()
-markUpdatedByWorker db connId =
-  DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = 0 WHERE conn_id = ?" (Only connId)
+    getNtfSubAction_ =
+      DB.query
+        db
+        [sql|
+          SELECT ns.conn_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
+            ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
+          FROM ntf_subscriptions ns
+          JOIN ntf_servers s USING (ntf_host, ntf_port)
+          WHERE ns.smp_host = ? AND ns.smp_port = ? AND ns.ntf_sub_smp_action IS NOT NULL AND ns.ntf_sub_action_ts IS NOT NULL
+          ORDER BY ns.ntf_sub_action_ts ASC
+          LIMIT 1
+        |]
+        (smpHost, smpPort)
+    ntfSubAction (connId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
+      let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
+          ntfSubscription = NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
+       in (ntfSubscription, action, actionTs)
 
 getActiveNtfToken :: DB.Connection -> IO (Maybe NtfToken)
 getActiveNtfToken db =
@@ -1699,10 +1571,6 @@ instance ToField QueueStatus where toField = toField . serializeQueueStatus
 
 instance FromField QueueStatus where fromField = fromTextField_ queueStatusT
 
-instance ToField (DBQueueId 'QSStored) where toField (DBQueueId qId) = toField qId
-
-instance FromField (DBQueueId 'QSStored) where fromField x = DBQueueId <$> fromField x
-
 instance ToField InternalRcvId where toField (InternalRcvId x) = toField x
 
 instance FromField InternalRcvId where fromField x = InternalRcvId <$> fromField x
@@ -1843,8 +1711,8 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue
-insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> Maybe C.KeyHash -> IO Int64
+insertRcvQueue_ db connId' RcvQueue {..} serverKeyHash_ = do
   qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')
   DB.execute
     db
@@ -1853,12 +1721,12 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
         (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
     ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
-  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
+  pure qId
 
 -- * createSndConn helpers
 
-insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue
-insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
+insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> Maybe C.KeyHash -> IO Int64
+insertSndQueue_ db connId' SndQueue {..} serverKeyHash_ = do
   qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')
   DB.execute
     db
@@ -1867,11 +1735,11 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
         (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
     ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
-  pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
+  pure qId
 
-newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored
-newQueueId_ [] = DBQueueId 1
-newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
+newQueueId_ :: [Only Int64] -> Int64
+newQueueId_ [] = 1
+newQueueId_ (Only maxId : _) = maxId + 1
 
 -- * getConn helpers
 
@@ -1985,7 +1853,7 @@ rcvQueueQuery =
 
 toRcvQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
-    :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
+    :. (Int64, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
     :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
   RcvQueue
 toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
@@ -2026,7 +1894,7 @@ sndQueueQuery =
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId)
     :. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
-    :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
+    :. (Int64, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
   SndQueue
 toSndQueue
   ( (userId, keyHash, connId, host, port, sndId)
@@ -2225,23 +2093,20 @@ updateHashSnd_ dbConn connId SndMsgData {..} =
 
 -- create record with a random ID
 createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString)
-createWithRandomId gVar create = fst <$$> createWithRandomId' gVar create
-
-createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError (ByteString, a))
-createWithRandomId' gVar create = tryCreate 3
+createWithRandomId gVar create = tryCreate 3
   where
-    tryCreate :: Int -> IO (Either StoreError (ByteString, a))
+    tryCreate :: Int -> IO (Either StoreError ByteString)
     tryCreate 0 = pure $ Left SEUniqueID
     tryCreate n = do
       id' <- randomId gVar 12
       E.try (create id') >>= \case
-        Right r -> pure $ Right (id', r)
+        Right _ -> pure $ Right id'
         Left e
           | SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1)
           | otherwise -> pure . Left . SEInternal $ bshow e
 
 randomId :: TVar ChaChaDRG -> Int -> IO ByteString
-randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar
+randomId gVar n = atomically $ U.encode <$> C.pseudoRandomBytes n gVar
 
 ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction)
 ntfSubAndSMPAction (NtfSubNTFAction action) = (Just action, Nothing)
@@ -2408,84 +2273,60 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO ()
 deleteRcvFile' db rcvFileId =
   DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId)
 
-getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFileChunk))
+getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe RcvFileChunk)
 getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
-  getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
+  cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
+  maybeFirstRow toChunk $
+    DB.query
+      db
+      [sql|
+        SELECT
+          f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
+          r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries
+        FROM rcv_file_chunk_replicas r
+        JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+        JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
+        JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id
+        WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
+          AND r.received = 0 AND r.replica_number = 1
+          AND f.status = ? AND f.deleted = 0 AND f.created_at >= ?
+        ORDER BY r.created_at ASC
+        LIMIT 1
+      |]
+      (host, port, keyHash, RFSReceiving, cutoffTs)
   where
-    getReplicaId :: IO (Maybe (Int64, DBRcvFileId))
-    getReplicaId = do
-      cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
-      maybeFirstRow id $
-        DB.query
-          db
-          [sql|
-            SELECT r.rcv_file_chunk_replica_id, f.rcv_file_id
-            FROM rcv_file_chunk_replicas r
-            JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
-            JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
-            JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id
-            WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
-              AND r.received = 0 AND r.replica_number = 1
-              AND f.status = ? AND f.deleted = 0 AND f.created_at >= ?
-              AND f.failed = 0
-            ORDER BY r.retries ASC, r.created_at ASC
-            LIMIT 1
-          |]
-          (host, port, keyHash, RFSReceiving, cutoffTs)
-    getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError RcvFileChunk)
-    getChunkData (rcvFileChunkReplicaId, _fileId) =
-      firstRow toChunk SEFileNotFound $
-        DB.query
-          db
-          [sql|
-            SELECT
-              f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
-              r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries
-            FROM rcv_file_chunk_replicas r
-            JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
-            JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
-            JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id
-            WHERE r.rcv_file_chunk_replica_id = ?
-          |]
-          (Only rcvFileChunkReplicaId)
-      where
-        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int)) -> RcvFileChunk
-        toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) =
-          RcvFileChunk
-            { rcvFileId,
-              rcvFileEntityId,
-              userId,
-              rcvChunkId,
-              chunkNo,
-              chunkSize,
-              digest,
-              fileTmpPath,
-              chunkTmpPath,
-              replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
-            }
+    toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int)) -> RcvFileChunk
+    toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) =
+      RcvFileChunk
+        { rcvFileId,
+          rcvFileEntityId,
+          userId,
+          rcvChunkId,
+          chunkNo,
+          chunkSize,
+          digest,
+          fileTmpPath,
+          chunkTmpPath,
+          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
+        }
 
-getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile))
-getNextRcvFileToDecrypt db ttl =
-  getWorkItem "rcv_file_decrypt" getFileId (getRcvFile db) (markRcvFileFailed db)
-  where
-    getFileId :: IO (Maybe DBRcvFileId)
-    getFileId = do
-      cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT rcv_file_id
-            FROM rcv_files
-            WHERE status IN (?,?) AND deleted = 0 AND created_at >= ?
-              AND failed = 0
-            ORDER BY created_at ASC LIMIT 1
-          |]
-          (RFSReceived, RFSDecrypting, cutoffTs)
-
-markRcvFileFailed :: DB.Connection -> DBRcvFileId -> IO ()
-markRcvFileFailed db fileId = do
-  DB.execute db "UPDATE rcv_files SET failed = 1 WHERE rcv_file_id = ?" (Only fileId)
+getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Maybe RcvFile)
+getNextRcvFileToDecrypt db ttl = do
+  cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
+  fileId_ :: Maybe DBRcvFileId <-
+    maybeFirstRow fromOnly $
+      DB.query
+        db
+        [sql|
+          SELECT rcv_file_id
+          FROM rcv_files
+          WHERE status IN (?,?) AND deleted = 0 AND created_at >= ?
+          ORDER BY created_at ASC LIMIT 1
+        |]
+        (RFSReceived, RFSDecrypting, cutoffTs)
+  case fileId_ of
+    Nothing -> pure Nothing
+    Just fileId -> eitherToMaybe <$> getRcvFile db fileId
 
 getPendingRcvFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer]
 getPendingRcvFilesServers db ttl = do
@@ -2637,28 +2478,23 @@ getChunkReplicaRecipients_ db replicaId =
     |]
     (Only replicaId)
 
-getNextSndFileToPrepare :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe SndFile))
-getNextSndFileToPrepare db ttl =
-  getWorkItem "snd_file_prepare" getFileId (getSndFile db) (markSndFileFailed db)
-  where
-    getFileId :: IO (Maybe DBSndFileId)
-    getFileId = do
-      cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT snd_file_id
-            FROM snd_files
-            WHERE status IN (?,?,?) AND deleted = 0 AND created_at >= ?
-              AND failed = 0
-            ORDER BY created_at ASC LIMIT 1
-          |]
-          (SFSNew, SFSEncrypting, SFSEncrypted, cutoffTs)
-
-markSndFileFailed :: DB.Connection -> DBSndFileId -> IO ()
-markSndFileFailed db fileId =
-  DB.execute db "UPDATE snd_files SET failed = 1 WHERE snd_file_id = ?" (Only fileId)
+getNextSndFileToPrepare :: DB.Connection -> NominalDiffTime -> IO (Maybe SndFile)
+getNextSndFileToPrepare db ttl = do
+  cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
+  fileId_ :: Maybe DBSndFileId <-
+    maybeFirstRow fromOnly $
+      DB.query
+        db
+        [sql|
+          SELECT snd_file_id
+          FROM snd_files
+          WHERE status IN (?,?,?) AND deleted = 0 AND created_at >= ?
+          ORDER BY created_at ASC LIMIT 1
+        |]
+        (SFSNew, SFSEncrypting, SFSEncrypted, cutoffTs)
+  case fileId_ of
+    Nothing -> pure Nothing
+    Just fileId -> eitherToMaybe <$> getSndFile db fileId
 
 updateSndFileError :: DB.Connection -> DBSndFileId -> String -> IO ()
 updateSndFileError db sndFileId errStr = do
@@ -2702,10 +2538,7 @@ getSndFileDeleted db sndFileId =
     <$> maybeFirstRow fromOnly (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId))
 
 createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO ()
-createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId
-
-createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO ()
-createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
+createSndFileReplica db SndFileChunk {sndChunkId} NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
   srvId <- createXFTPServer_ db server
   DB.execute
     db
@@ -2726,69 +2559,50 @@ createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, repli
       |]
       (rId, rcvId, rcvKey)
 
-getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe SndFileChunk))
+getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe SndFileChunk)
 getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
-  getWorkItem "snd_file_upload" getReplicaId getChunkData (markSndFileFailed db . snd)
+  cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
+  chunk_ <-
+    maybeFirstRow toChunk $
+      DB.query
+        db
+        [sql|
+          SELECT
+            f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path,
+            c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest,
+            r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries
+          FROM snd_file_chunk_replicas r
+          JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+          JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
+          JOIN snd_files f ON f.snd_file_id = c.snd_file_id
+          WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
+            AND r.replica_status = ? AND r.replica_number = 1
+            AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ?
+          ORDER BY r.created_at ASC
+          LIMIT 1
+        |]
+        (host, port, keyHash, SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs)
+  forM chunk_ $ \chunk@SndFileChunk {replicas} -> do
+    replicas' <- forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do
+      rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
+      pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
+    pure (chunk {replicas = replicas'} :: SndFileChunk)
   where
-    getReplicaId :: IO (Maybe (Int64, DBSndFileId))
-    getReplicaId = do
-      cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
-      maybeFirstRow id $
-        DB.query
-          db
-          [sql|
-            SELECT r.snd_file_chunk_replica_id, f.snd_file_id
-            FROM snd_file_chunk_replicas r
-            JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
-            JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
-            JOIN snd_files f ON f.snd_file_id = c.snd_file_id
-            WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
-              AND r.replica_status = ? AND r.replica_number = 1
-              AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ?
-              AND f.failed = 0
-            ORDER BY r.retries ASC, r.created_at ASC
-            LIMIT 1
-          |]
-          (host, port, keyHash, SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs)
-    getChunkData :: (Int64, DBSndFileId) -> IO (Either StoreError SndFileChunk)
-    getChunkData (sndFileChunkReplicaId, _fileId) = do
-      chunk_ <-
-        firstRow toChunk SEFileNotFound $
-          DB.query
-            db
-            [sql|
-              SELECT
-                f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path,
-                c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest,
-                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries
-              FROM snd_file_chunk_replicas r
-              JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
-              JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
-              JOIN snd_files f ON f.snd_file_id = c.snd_file_id
-              WHERE r.snd_file_chunk_replica_id = ?
-            |]
-            (Only sndFileChunkReplicaId)
-      forM chunk_ $ \chunk@SndFileChunk {replicas} -> do
-        replicas' <- forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do
-          rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
-          pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
-        pure (chunk {replicas = replicas'} :: SndFileChunk)
-      where
-        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
-        toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) =
-          let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize}
-           in SndFileChunk
-                { sndFileId,
-                  sndFileEntityId,
-                  userId,
-                  numRecipients,
-                  sndChunkId,
-                  chunkNo,
-                  chunkSpec,
-                  digest,
-                  filePrefixPath,
-                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}]
-                }
+    toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
+    toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) =
+      let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize}
+       in SndFileChunk
+            { sndFileId,
+              sndFileEntityId,
+              userId,
+              numRecipients,
+              sndChunkId,
+              chunkNo,
+              chunkSpec,
+              digest,
+              filePrefixPath,
+              replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}]
+            }
 
 updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()
 updateSndChunkReplicaDelay db replicaId delay = do
@@ -2893,30 +2707,25 @@ getDeletedSndChunkReplica db deletedSndChunkReplicaId =
       let server = XFTPServer host port keyHash
        in DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, replicaId, replicaKey, chunkDigest, delay, retries}
 
-getNextDeletedSndChunkReplica :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe DeletedSndChunkReplica))
-getNextDeletedSndChunkReplica db ProtocolServer {host, port, keyHash} ttl =
-  getWorkItem "deleted replica" getReplicaId (getDeletedSndChunkReplica db) markReplicaFailed
-  where
-    getReplicaId :: IO (Maybe Int64)
-    getReplicaId = do
-      cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT r.deleted_snd_chunk_replica_id
-            FROM deleted_snd_chunk_replicas r
-            JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
-            WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
-              AND r.created_at >= ?
-              AND failed = 0
-            ORDER BY r.retries ASC, r.created_at ASC
-            LIMIT 1
-          |]
-          (host, port, keyHash, cutoffTs)
-    markReplicaFailed :: Int64 -> IO ()
-    markReplicaFailed replicaId = do
-      DB.execute db "UPDATE deleted_snd_chunk_replicas SET failed = 1 WHERE deleted_snd_chunk_replica_id = ?" (Only replicaId)
+getNextDeletedSndChunkReplica :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe DeletedSndChunkReplica)
+getNextDeletedSndChunkReplica db ProtocolServer {host, port, keyHash} ttl = do
+  cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
+  replicaId_ :: Maybe Int64 <-
+    maybeFirstRow fromOnly $
+      DB.query
+        db
+        [sql|
+          SELECT r.deleted_snd_chunk_replica_id
+          FROM deleted_snd_chunk_replicas r
+          JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+          WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
+            AND r.created_at >= ?
+          ORDER BY r.created_at ASC LIMIT 1
+        |]
+        (host, port, keyHash, cutoffTs)
+  case replicaId_ of
+    Nothing -> pure Nothing
+    Just replicaId -> eitherToMaybe <$> getDeletedSndChunkReplica db replicaId
 
 updateDeletedSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()
 updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId delay = do

src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs

@@ -65,9 +65,6 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -101,10 +98,7 @@ schemaMigrations =
     ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
     ("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
     ("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
-    ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files),
-    ("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
-    ("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
-    ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes)
+    ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -130,12 +124,9 @@ run st = \case
   where
     runUp Migration {name, up, down} = withTransaction' st $ \db -> do
       when (name == "m20220811_onion_hosts") $ updateServers db
-      insert db >> execSQL db up'
+      insert db >> execSQL db up
       where
         insert db = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
-        up'
-          | dbNew st && name == "m20230110_users" = fromQuery new_m20230110_users
-          | otherwise = up
         updateServers db = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
           let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
            in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs

@@ -27,24 +27,3 @@ UPDATE connections SET user_id = 1;
 
 PRAGMA ignore_check_constraints=OFF;
 |]
-
--- This is executed in the new database
--- It does not create new user record
-new_m20230110_users :: Query
-new_m20230110_users =
-  [sql|
-PRAGMA ignore_check_constraints=ON;
-
-CREATE TABLE users (
-  user_id INTEGER PRIMARY KEY AUTOINCREMENT
-);
-
-ALTER TABLE connections ADD COLUMN user_id INTEGER CHECK (user_id NOT NULL)
-REFERENCES users ON DELETE CASCADE;
-
-CREATE INDEX idx_connections_user ON connections(user_id);
-
-CREATE INDEX idx_commands_conn_id ON commands(conn_id);
-
-PRAGMA ignore_check_constraints=OFF;
-|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20231222_command_created_at.hs

@@ -1,20 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20231222_command_created_at :: Query
-m20231222_command_created_at =
-  [sql|
-ALTER TABLE commands ADD COLUMN created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00');
-CREATE INDEX idx_commands_server_commands ON commands(host, port, created_at, command_id);
-|]
-
-down_m20231222_command_created_at :: Query
-down_m20231222_command_created_at =
-  [sql|
-DROP INDEX idx_commands_server_commands;
-ALTER TABLE commands DROP COLUMN created_at;
-|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20231225_failed_work_items.hs

@@ -1,38 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20231225_failed_work_items :: Query
-m20231225_failed_work_items =
-    [sql|
-ALTER TABLE snd_message_deliveries ADD COLUMN failed INTEGER DEFAULT 0;
-ALTER TABLE commands ADD COLUMN failed INTEGER DEFAULT 0;
-ALTER TABLE ntf_subscriptions ADD COLUMN ntf_failed INTEGER DEFAULT 0;
-ALTER TABLE ntf_subscriptions ADD COLUMN smp_failed INTEGER DEFAULT 0;
-ALTER TABLE rcv_files ADD COLUMN failed INTEGER DEFAULT 0;
-ALTER TABLE snd_files ADD COLUMN failed INTEGER DEFAULT 0;
-ALTER TABLE deleted_snd_chunk_replicas ADD COLUMN failed INTEGER DEFAULT 0;
-
-CREATE INDEX idx_rcv_files_status_created_at ON rcv_files(status, created_at);
-CREATE INDEX idx_snd_files_status_created_at ON snd_files(status, created_at);
-CREATE INDEX idx_snd_files_snd_file_entity_id ON snd_files(snd_file_entity_id);
-|]
-
-down_m20231225_failed_work_items :: Query
-down_m20231225_failed_work_items =
-    [sql|
-DROP INDEX idx_rcv_files_status_created_at;
-DROP INDEX idx_snd_files_status_created_at;
-DROP INDEX idx_snd_files_snd_file_entity_id;
-
-ALTER TABLE snd_message_deliveries DROP COLUMN failed;
-ALTER TABLE commands DROP COLUMN failed;
-ALTER TABLE ntf_subscriptions DROP COLUMN ntf_failed;
-ALTER TABLE ntf_subscriptions DROP COLUMN smp_failed;
-ALTER TABLE rcv_files DROP COLUMN failed;
-ALTER TABLE snd_files DROP COLUMN failed;
-ALTER TABLE deleted_snd_chunk_replicas DROP COLUMN failed;
-|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240121_message_delivery_indexes.hs

@@ -1,20 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20240121_message_delivery_indexes :: Query
-m20240121_message_delivery_indexes =
-    [sql|
-CREATE INDEX idx_messages_snd_expired ON messages(conn_id, internal_snd_id, internal_ts);
-CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries(conn_id, snd_queue_id, failed, internal_id);
-|]
-
-down_m20240121_message_delivery_indexes :: Query
-down_m20240121_message_delivery_indexes =
-    [sql|
-DROP INDEX idx_messages_snd_expired;
-DROP INDEX idx_snd_message_deliveries_expired;
-|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql

@@ -213,8 +213,6 @@ CREATE TABLE ntf_subscriptions(
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
   smp_server_key_hash BLOB,
-  ntf_failed INTEGER DEFAULT 0,
-  smp_failed INTEGER DEFAULT 0,
   PRIMARY KEY(conn_id),
   FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
   ON DELETE SET NULL ON UPDATE CASCADE,
@@ -231,8 +229,6 @@ CREATE TABLE commands(
   command BLOB NOT NULL,
   agent_version INTEGER NOT NULL DEFAULT 1,
   server_key_hash BLOB,
-  created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'),
-  failed INTEGER DEFAULT 0,
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 );
@@ -241,7 +237,6 @@ CREATE TABLE snd_message_deliveries(
   conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
   snd_queue_id INTEGER NOT NULL,
   internal_id INTEGER NOT NULL,
-  failed INTEGER DEFAULT 0,
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
 );
 CREATE TABLE sqlite_sequence(name,seq);
@@ -278,7 +273,6 @@ CREATE TABLE rcv_files(
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
   save_file_key BLOB,
   save_file_nonce BLOB,
-  failed INTEGER DEFAULT 0,
   UNIQUE(rcv_file_entity_id)
 );
 CREATE TABLE rcv_file_chunks(
@@ -321,8 +315,7 @@ CREATE TABLE snd_files(
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
   ,
   src_file_key BLOB,
-  src_file_nonce BLOB,
-  failed INTEGER DEFAULT 0
+  src_file_nonce BLOB
 );
 CREATE TABLE snd_file_chunks(
   snd_file_chunk_id INTEGER PRIMARY KEY,
@@ -366,8 +359,6 @@ CREATE TABLE deleted_snd_chunk_replicas(
   retries INTEGER NOT NULL DEFAULT 0,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
-  ,
-  failed INTEGER DEFAULT 0
 );
 CREATE TABLE encrypted_rcv_message_hashes(
   encrypted_rcv_message_hash_id INTEGER PRIMARY KEY,
@@ -488,23 +479,3 @@ CREATE INDEX idx_encrypted_rcv_message_hashes_created_at ON encrypted_rcv_messag
   created_at
 );
 CREATE INDEX idx_messages_internal_ts ON messages(internal_ts);
-CREATE INDEX idx_commands_server_commands ON commands(
-  host,
-  port,
-  created_at,
-  command_id
-);
-CREATE INDEX idx_rcv_files_status_created_at ON rcv_files(status, created_at);
-CREATE INDEX idx_snd_files_status_created_at ON snd_files(status, created_at);
-CREATE INDEX idx_snd_files_snd_file_entity_id ON snd_files(snd_file_entity_id);
-CREATE INDEX idx_messages_snd_expired ON messages(
-  conn_id,
-  internal_snd_id,
-  internal_ts
-);
-CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries(
-  conn_id,
-  snd_queue_id,
-  failed,
-  internal_id
-);

src/Simplex/Messaging/Agent/TAsyncs.hs

@@ -0,0 +1,24 @@
+module Simplex.Messaging.Agent.TAsyncs where
+
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import UnliftIO.Async (Async, async)
+import UnliftIO.STM
+
+data TAsyncs = TAsyncs
+  { actionId :: TVar Int,
+    actions :: TMap Int (Async ())
+  }
+
+newTAsyncs :: STM TAsyncs
+newTAsyncs = TAsyncs <$> newTVar 0 <*> TM.empty
+
+newAsyncAction :: MonadUnliftIO m => (Int -> m ()) -> TAsyncs -> m ()
+newAsyncAction action as = do
+  aId <- atomically $ stateTVar (actionId as) $ \i -> (i + 1, i + 1)
+  a <- async $ action aId
+  atomically $ TM.insert aId a $ actions as
+
+removeAsyncAction :: Int -> TAsyncs -> STM ()
+removeAsyncAction aId = TM.delete aId . actions

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -18,7 +18,7 @@ import qualified Data.Map.Strict as M
 import Data.Set (Set)
 import qualified Data.Set as S
 import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
-import Simplex.Messaging.Agent.Store (RcvQueue, StoredRcvQueue (..))
+import Simplex.Messaging.Agent.Store (RcvQueue (..))
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM

src/Simplex/Messaging/Client.hs

@@ -72,7 +72,9 @@ module Simplex.Messaging.Client
     ClientCommand,
 
     -- * For testing
+    ClientBatch (..),
     PCTransmission,
+    batchClientTransmissions,
     mkTransmission,
     clientStub,
   )
@@ -97,9 +99,10 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
-import Simplex.Messaging.Protocol
+import Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
@@ -170,7 +173,7 @@ clientStub sessionId = do
             }
       }
 
-type SMPClient = ProtocolClient ErrorType BrokerMsg
+type SMPClient = ProtocolClient ErrorType SMP.BrokerMsg
 
 -- | Type for client command data
 type ClientCommand msg = (Maybe C.APrivateSignKey, EntityId, ProtoCommand msg)
@@ -346,12 +349,12 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
       action <-
         async $
           runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
-            `finally` atomically (tryPutTMVar cVar $ Left PCENetworkError)
+            `finally` atomically (putTMVar cVar $ Left PCENetworkError)
       c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
-      case c_ of
-        Just (Right c') -> pure $ Right c' {action = Just action}
-        Just (Left e) -> pure $ Left e
-        Nothing -> cancel action $> Left PCENetworkError
+      pure $ case c_ of
+        Just (Right c') -> Right c' {action = Just action}
+        Just (Left e) -> Left e
+        Nothing -> Left PCENetworkError
 
     useTransport :: (ServiceName, ATransport)
     useTransport = case port srv of
@@ -631,7 +634,7 @@ type PCTransmission err msg = (SentRawTransmission, Request err msg)
 -- | Send multiple commands with batching and collect responses
 sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
 sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
-  bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+  bs <- batchClientTransmissions batch blockSize <$> mapM (mkTransmission c) cs
   validate . concat =<< mapM (sendBatch c) bs
   where
     validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
@@ -648,24 +651,58 @@ sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
 
 streamProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
 streamProtocolCommands c@ProtocolClient {batch, blockSize} cs cb = do
-  bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+  bs <- batchClientTransmissions batch blockSize <$> mapM (mkTransmission c) cs
   mapM_ (cb <=< sendBatch c) bs
 
-sendBatch :: ProtocolClient err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
+sendBatch :: ProtocolClient err msg -> ClientBatch err msg -> IO [Response err msg]
 sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
   case b of
-    TBLargeTransmission Request {entityId} -> do
+    CBLargeTransmission Request {entityId} -> do
       putStrLn "send error: large message"
       pure [Response entityId $ Left $ PCETransportError TELargeMsg]
-    TBTransmissions s n rs
-      | n > 0 -> do
-          atomically $ writeTBQueue sndQ s
-          mapConcurrently (getResponse c) rs
-      | otherwise -> pure []
-    TBTransmission s r -> do
+    CBTransmissions s n rs -> do
+      when (n > 0) $ atomically $ writeTBQueue sndQ $ tEncodeBatch n s
+      mapConcurrently (getResponse c) rs
+    CBTransmission s r -> do
       atomically $ writeTBQueue sndQ s
       (: []) <$> getResponse c r
 
+data ClientBatch err msg
+  = -- ByteString in CBTransmissions does not include count byte, it is added by tEncodeBatch
+    CBTransmissions ByteString Int [Request err msg]
+  | CBTransmission ByteString (Request err msg)
+  | CBLargeTransmission (Request err msg)
+
+-- | encodes and batches transmissions into blocks
+batchClientTransmissions :: forall err msg. Bool -> Int -> NonEmpty (PCTransmission err msg) -> [ClientBatch err msg]
+batchClientTransmissions batch blkSize
+  | batch = reverse . mkBatch []
+  | otherwise = map mkBatch1 . L.toList
+  where
+    mkBatch :: [ClientBatch err msg] -> NonEmpty (PCTransmission err msg) -> [ClientBatch err msg]
+    mkBatch bs ts =
+      let (b, ts_) = encodeBatch "" 0 [] ts
+          bs' = b : bs
+       in maybe bs' (mkBatch bs') ts_
+    mkBatch1 :: PCTransmission err msg -> ClientBatch err msg
+    mkBatch1 (t, r)
+      | B.length s <= blkSize - 2 = CBTransmission s r
+      | otherwise = CBLargeTransmission r
+      where
+        s = tEncode t
+    encodeBatch :: ByteString -> Int -> [Request err msg] -> NonEmpty (PCTransmission err msg) -> (ClientBatch err msg, Maybe (NonEmpty (PCTransmission err msg)))
+    encodeBatch s n rs ts@((t, r) :| ts_)
+      | B.length s' <= blkSize - 3 && n < 255 =
+          case L.nonEmpty ts_ of
+            Just ts' -> encodeBatch s' n' rs' ts'
+            Nothing -> (CBTransmissions s' n' (reverse rs'), Nothing)
+      | n == 0 = (CBLargeTransmission r, L.nonEmpty ts_)
+      | otherwise = (CBTransmissions s n (reverse rs), Just ts)
+      where
+        s' = s <> smpEncode (Large $ tEncode t)
+        n' = n + 1
+        rs' = r : rs
+
 -- | Send Protocol command
 sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
 sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, batch, blockSize} pKey entId cmd =
@@ -678,7 +715,7 @@ sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, batch, blockSize
       | otherwise = atomically (writeTBQueue sndQ s) >> response <$> getResponse c r
       where
         s
-          | batch = tEncodeBatch1 t
+          | batch = tEncodeBatch 1 . smpEncode . Large $ tEncode t
           | otherwise = tEncode t
 
 -- TODO switch to timeout or TimeManager that supports Int64

src/Simplex/Messaging/Crypto.hs

@@ -61,9 +61,8 @@ module Simplex.Messaging.Crypto
     DhSecretX25519,
     ADhSecret (..),
     KeyHash (..),
-    newRandom,
-    generateAKeyPair,
     generateKeyPair,
+    generateKeyPair',
     generateSignatureKeyPair,
     generateDhKeyPair,
     privateToX509,
@@ -106,6 +105,7 @@ module Simplex.Messaging.Crypto
     decryptAESNoPad,
     authTagSize,
     randomAesKey,
+    randomIV,
     randomGCMIV,
     ivSize,
     gcmIVSize,
@@ -121,6 +121,7 @@ module Simplex.Messaging.Crypto
     sbEncrypt_,
     cbNonce,
     randomCbNonce,
+    pseudoRandomCbNonce,
 
     -- * NaCl crypto_secretbox
     SbKey (unSbKey),
@@ -132,7 +133,7 @@ module Simplex.Messaging.Crypto
     randomSbKey,
 
     -- * pseudo-random bytes
-    randomBytes,
+    pseudoRandomBytes,
 
     -- * digests
     sha256Hash,
@@ -179,7 +180,7 @@ import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
 import qualified Crypto.PubKey.Ed25519 as Ed25519
 import qualified Crypto.PubKey.Ed448 as Ed448
-import Crypto.Random (ChaChaDRG, MonadPseudoRandom, drgNew, randomBytesGenerate, withDRG)
+import Crypto.Random (ChaChaDRG, getRandomBytes, randomBytesGenerate)
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.Encoding
 import Data.ASN1.Types
@@ -594,23 +595,17 @@ type ASignatureKeyPair = KeyPairType APrivateSignKey
 
 type ADhKeyPair = KeyPairType APrivateDhKey
 
-newRandom :: IO (TVar ChaChaDRG)
-newRandom = newTVarIO =<< drgNew
+generateKeyPair :: AlgorithmI a => SAlgorithm a -> IO AKeyPair
+generateKeyPair a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair'
 
-generateAKeyPair :: AlgorithmI a => SAlgorithm a -> TVar ChaChaDRG -> STM AKeyPair
-generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair g
+generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> IO ASignatureKeyPair
+generateSignatureKeyPair a = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair'
 
-generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair
-generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair g
+generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> IO ADhKeyPair
+generateDhKeyPair a = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair'
 
-generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair
-generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g
-
-generateKeyPair :: forall a. AlgorithmI a => TVar ChaChaDRG -> STM (KeyPair a)
-generateKeyPair g = stateTVar g (`withDRG` generateKeyPair_)
-
-generateKeyPair_ :: forall a. AlgorithmI a => MonadPseudoRandom ChaChaDRG (KeyPair a)
-generateKeyPair_ = case sAlgorithm @a of
+generateKeyPair' :: forall a. AlgorithmI a => IO (KeyPair a)
+generateKeyPair' = case sAlgorithm @a of
   SEd25519 ->
     Ed25519.generateSecretKey >>= \pk ->
       let k = Ed25519.toPublic pk
@@ -979,11 +974,15 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
   AES.aeadInit AES.AEAD_GCM cipher ivBytes
 
 -- | Random AES256 key.
-randomAesKey :: TVar ChaChaDRG -> STM Key
-randomAesKey = fmap Key . randomBytes aesKeySize
+randomAesKey :: IO Key
+randomAesKey = Key <$> getRandomBytes aesKeySize
 
-randomGCMIV :: TVar ChaChaDRG -> STM GCMIV
-randomGCMIV = fmap GCMIV . randomBytes gcmIVSize
+-- | Random IV bytes for AES256 encryption.
+randomIV :: IO IV
+randomIV = IV <$> getRandomBytes (ivSize @AES256)
+
+randomGCMIV :: IO GCMIV
+randomGCMIV = GCMIV <$> getRandomBytes gcmIVSize
 
 ivSize :: forall c. AES.BlockCipher c => Int
 ivSize = AES.blockSize (undefined :: c)
@@ -1144,11 +1143,14 @@ cbNonce s
   where
     len = B.length s
 
-randomCbNonce :: TVar ChaChaDRG -> STM CbNonce
-randomCbNonce = fmap CryptoBoxNonce . randomBytes 24
+randomCbNonce :: IO CbNonce
+randomCbNonce = CryptoBoxNonce <$> getRandomBytes 24
 
-randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
-randomBytes n gVar = stateTVar gVar $ randomBytesGenerate n
+pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
+pseudoRandomCbNonce gVar = CryptoBoxNonce <$> pseudoRandomBytes 24 gVar
+
+pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
+pseudoRandomBytes n gVar = stateTVar gVar $ randomBytesGenerate n
 
 instance Encoding CbNonce where
   smpEncode = unCbNonce
@@ -1185,8 +1187,8 @@ sbKey s
 unsafeSbKey :: ByteString -> SbKey
 unsafeSbKey s = either error id $ sbKey s
 
-randomSbKey :: TVar ChaChaDRG -> STM SbKey
-randomSbKey gVar = SecretBoxKey <$> randomBytes 32 gVar
+randomSbKey :: IO SbKey
+randomSbKey = SecretBoxKey <$> getRandomBytes 32
 
 xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
 xSalsa20 secret nonce msg = (rs, msg')

src/Simplex/Messaging/Crypto/File.hs

@@ -23,7 +23,6 @@ where
 import Control.Exception
 import Control.Monad
 import Control.Monad.Except
-import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import qualified Data.ByteArray as BA
 import Data.ByteString.Char8 (ByteString)
@@ -110,8 +109,8 @@ data FTCryptoError
 plain :: FilePath -> CryptoFile
 plain = (`CryptoFile` Nothing)
 
-randomArgs :: TVar ChaChaDRG -> STM CryptoFileArgs
-randomArgs g = CFArgs <$> C.randomSbKey g <*> C.randomCbNonce g
+randomArgs :: IO CryptoFileArgs
+randomArgs = CFArgs <$> C.randomSbKey <*> C.randomCbNonce
 
 getFileContentsSize :: CryptoFile -> IO Integer
 getFileContentsSize (CryptoFile path cfArgs) = do

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -41,6 +41,7 @@ import qualified Crypto.MAC.Poly1305 as Poly1305
 import Data.Bifunctor (first)
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
+import qualified Data.ByteString as S
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -174,7 +175,7 @@ secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
 
 -- passes lazy bytestring via initialized secret box returning the reversed list of chunks
 secretBoxLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> ([ByteString], SbState)
-secretBoxLazy_ sbProcess state = LB.foldlChunks update ([], state)
+secretBoxLazy_ sbProcess state = foldlChunks update ([], state)
   where
     update (cs, st) chunk = let (!c, !st') = sbProcess st chunk in (c : cs, st')
 
@@ -230,3 +231,10 @@ cryptoPassed :: CE.CryptoFailable b -> Either CryptoError b
 cryptoPassed = \case
   CE.CryptoPassed a -> Right a
   CE.CryptoFailed e -> Left $ CryptoPoly1305Error e
+
+foldlChunks :: (a -> S.ByteString -> a) -> a -> LazyByteString -> a
+foldlChunks f = go
+  where
+    go !a LB.Empty = a
+    go !a (LB.Chunk c cs) = go (f a c) cs
+{-# INLINE foldlChunks #-}

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -15,11 +15,11 @@
 module Simplex.Messaging.Crypto.Ratchet where
 
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Crypto.Cipher.AES (AES256)
 import Crypto.Hash (SHA512)
 import qualified Crypto.KDF.HKDF as H
-import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as JQ
@@ -40,7 +40,6 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE')
 import Simplex.Messaging.Version
-import UnliftIO.STM
 
 currentE2EEncryptVersion :: Version
 currentE2EEncryptVersion = 2
@@ -82,10 +81,10 @@ instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where
       [key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2
       _ -> fail "bad e2e params"
 
-generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> Version -> STM (PrivateKey a, PrivateKey a, E2ERatchetParams a)
-generateE2EParams g v = do
-  (k1, pk1) <- generateKeyPair g
-  (k2, pk2) <- generateKeyPair g
+generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => Version -> IO (PrivateKey a, PrivateKey a, E2ERatchetParams a)
+generateE2EParams v = do
+  (k1, pk1) <- generateKeyPair'
+  (k2, pk2) <- generateKeyPair'
   pure (pk1, pk2, E2ERatchetParams v k1 k2)
 
 data RatchetInitParams = RatchetInitParams
@@ -346,12 +345,11 @@ maxSkip = 512
 rcDecrypt ::
   forall a.
   (AlgorithmI a, DhAlgorithm a) =>
-  TVar ChaChaDRG ->
   Ratchet a ->
   SkippedMsgKeys ->
   ByteString ->
   ExceptT CryptoError IO (DecryptResult a)
-rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
+rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
   encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError smpP msg'
   encHdr <- parseE CryptoHeaderError smpP emHeader
   -- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD)
@@ -391,7 +389,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
             Left e -> throwE e
             Right (rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr}, hmks) -> do
               -- DHRatchetHE(state, header)
-              (_, rcDHRs') <- atomically $ generateKeyPair @a g
+              (_, rcDHRs') <- liftIO $ generateKeyPair' @a
               -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
               let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs
                   -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))

src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs

@@ -18,7 +18,7 @@ withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr
 createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc)
 createRNGFunc drg =
   mkRNGFunc $ \_ctx sz buf -> do
-    bs <- atomically $ C.randomBytes (fromIntegral sz) drg
+    bs <- atomically $ C.pseudoRandomBytes (fromIntegral sz) drg
     copyByteArrayToPtr bs buf
 
 type RNGContext = ()

src/Simplex/Messaging/Encoding.hs

@@ -174,37 +174,37 @@ instance (Encoding a, Encoding b) => Encoding (a, b) where
   {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
-  smpEncode (a, b, c) = B.concat [smpEncode a, smpEncode b, smpEncode c]
+  smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c
   {-# INLINE smpEncode #-}
   smpP = (,,) <$> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where
-  smpEncode (a, b, c, d) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d]
+  smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d
   {-# INLINE smpEncode #-}
   smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
-  smpEncode (a, b, c, d, e) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e]
+  smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
   {-# INLINE smpEncode #-}
   smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
-  smpEncode (a, b, c, d, e, f) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e, smpEncode f]
+  smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
   {-# INLINE smpEncode #-}
   smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g) => Encoding (a, b, c, d, e, f, g) where
-  smpEncode (a, b, c, d, e, f, g) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e, smpEncode f, smpEncode g]
+  smpEncode (a, b, c, d, e, f, g) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g
   {-# INLINE smpEncode #-}
   smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
-  smpEncode (a, b, c, d, e, f, g, h) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e, smpEncode f, smpEncode g, smpEncode h]
+  smpEncode (a, b, c, d, e, f, g, h) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g <> smpEncode h
   {-# INLINE smpEncode #-}
   smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
   {-# INLINE smpP #-}

src/Simplex/Messaging/Notifications/Server.hs

@@ -109,9 +109,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
       NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
       let interval = 1000000 * logInterval
-      forever $ do
-        withFile statsFilePath AppendMode $ \h -> liftIO $ do
-          hSetBuffering h LineBuffering
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
           ts <- getCurrentTime
           fromTime' <- atomically $ swapTVar fromTime ts
           tknCreated' <- atomically $ swapTVar tknCreated 0
@@ -141,7 +141,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
                 weekCount sub,
                 monthCount sub
               ]
-        liftIO $ threadDelay' interval
+          threadDelay' interval
 
 resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
 resubscribe NtfSubscriber {newSubQ} subs = do
@@ -345,17 +345,17 @@ runNtfClientTransport th@THandle {sessionId} = do
   raceAny_ ([liftIO $ send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
     `finally` liftIO (clientDisconnected c)
   where
-    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (pure True)]
+    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th c activeAt expCfg]
     disconnectThread_ _ _ = []
 
 clientDisconnected :: NtfServerClient -> IO ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
 receive :: Transport c => THandle c -> NtfServerClient -> M ()
-receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
+receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
   ts <- liftIO $ tGet th
   forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
-    atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
+    atomically . writeTVar activeAt =<< liftIO getSystemTime
     logDebug "received transmission"
     case cmdOrError of
       Left e -> write sndQ (corrId, entId, NRErr e)
@@ -367,10 +367,10 @@ receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
     write q t = atomically $ writeTBQueue q t
 
 send :: Transport c => THandle c -> NtfServerClient -> IO ()
-send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do
+send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
-  atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
+  void . liftIO $ tPut h Nothing [(Nothing, encodeTransmission v sessionId t)]
+  atomically . writeTVar activeAt =<< liftIO getSystemTime
 
 -- instance Show a => Show (TVar a) where
 --   show x = unsafePerformIO $ show <$> readTVarIO x
@@ -440,7 +440,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
       NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
         logDebug "TNEW - new token"
         st <- asks store
-        ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random
+        ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair'
         let dhSecret = C.dh' dhPubKey srvDhPrivKey
         tknId <- getId
         regCode <- getRegCode
@@ -565,11 +565,13 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
           PING -> pure NRPong
       NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
     getId :: M NtfEntityId
-    getId = randomBytes =<< asks (subIdBytes . config)
+    getId = getRandomBytes =<< asks (subIdBytes . config)
     getRegCode :: M NtfRegCode
-    getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config))
-    randomBytes :: Int -> M ByteString
-    randomBytes n = atomically . C.randomBytes n =<< asks random
+    getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
+    getRandomBytes :: Int -> M ByteString
+    getRandomBytes n = do
+      gVar <- asks idsDrg
+      atomically (C.pseudoRandomBytes n gVar)
     cancelInvervalNotifications :: NtfTokenId -> M ()
     cancelInvervalNotifications tknId =
       atomically (TM.lookupDelete tknId intervalNotifiers)

src/Simplex/Messaging/Notifications/Server/Env.hs

@@ -66,8 +66,8 @@ data NtfServerConfig = NtfServerConfig
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
-    { ttl = 43200, -- seconds, 12 hours
-      checkInterval = 3600 -- seconds, 1 hours
+    { ttl = 7200, -- 2 hours
+      checkInterval = 3600 -- seconds, 1 hour
     }
 
 data NtfEnv = NtfEnv
@@ -76,7 +76,7 @@ data NtfEnv = NtfEnv
     pushServer :: NtfPushServer,
     store :: NtfStore,
     storeLog :: Maybe (StoreLog 'WriteMode),
-    random :: TVar ChaChaDRG,
+    idsDrg :: TVar ChaChaDRG,
     tlsServerParams :: T.ServerParams,
     serverIdentity :: C.KeyHash,
     serverStats :: NtfServerStats
@@ -84,7 +84,7 @@ data NtfEnv = NtfEnv
 
 newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
 newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
-  random <- liftIO C.newRandom
+  idsDrg <- newTVarIO =<< drgNew
   store <- atomically newNtfStore
   logInfo "restoring subscriptions..."
   storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
@@ -94,7 +94,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
   serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
-  pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+  pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriber,
@@ -160,8 +160,7 @@ data NtfServerClient = NtfServerClient
     sndQ :: TBQueue (Transmission NtfResponse),
     sessionId :: ByteString,
     connected :: TVar Bool,
-    rcvActiveAt :: TVar SystemTime,
-    sndActiveAt :: TVar SystemTime
+    activeAt :: TVar SystemTime
   }
 
 newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
@@ -169,6 +168,5 @@ newNtfServerClient qSize sessionId ts = do
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
-  rcvActiveAt <- newTVar ts
-  sndActiveAt <- newTVar ts
-  return NtfServerClient {rcvQ, sndQ, sessionId, connected, rcvActiveAt, sndActiveAt}
+  activeAt <- newTVar ts
+  return NtfServerClient {rcvQ, sndQ, sessionId, connected, activeAt}

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -17,11 +17,10 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..))
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Server (runNtfServer)
-import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
 import Simplex.Messaging.Server.CLI
-import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
@@ -30,7 +29,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.7.2.0"
+ntfServerVersion = "1.6.4"
 
 defaultSMPBatchDelay :: Int
 defaultSMPBatchDelay = 10000
@@ -87,12 +86,7 @@ ntfServerCLI cfgPath logPath =
             <> "log_tls_errors: off\n\
                \# delay between command batches sent to SMP relays (microseconds), 0 to disable\n"
             <> ("smp_batch_delay: " <> show defaultSMPBatchDelay <> "\n")
-            <> "websockets: off\n\n\
-               \[INACTIVE_CLIENTS]\n\
-               \# TTL and interval to check inactive clients\n\
-               \disconnect: off\n"
-            <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
-            <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
+            <> "websockets: off\n"
     runServer ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
@@ -121,12 +115,7 @@ ntfServerCLI cfgPath logPath =
               smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
               apnsConfig = defaultAPNSPushClientConfig,
               subsBatchSize = 900,
-              inactiveClientExpiration =
-                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
-                  $> ExpirationConfig
-                    { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
-                      checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
-                    },
+              inactiveClientExpiration = Nothing,
               storeLogFile = enableStoreLog $> storeLogFilePath,
               caCertificateFile = c caCrtFile,
               privateKeyFile = c serverKeyFile,

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -18,7 +18,7 @@ import Control.Monad.IO.Class
 import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
 import qualified Crypto.PubKey.ECC.Types as ECT
-import Crypto.Random (ChaChaDRG)
+import Crypto.Random (ChaChaDRG, drgNew)
 import qualified Crypto.Store.PKCS8 as PK
 import Data.ASN1.BinaryEncoding (DER (..))
 import Data.ASN1.Encoding
@@ -232,7 +232,7 @@ createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, auth
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
   let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
-  nonceDrg <- C.newRandom
+  nonceDrg <- drgNew >>= newTVarIO
   pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
 
 getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken
@@ -337,7 +337,7 @@ $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
 apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
-  nonce <- atomically $ C.randomCbNonce nonceDrg
+  nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
   req <- liftIO $ apnsRequest c tknStr apnsNtf
   -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect

src/Simplex/Messaging/Protocol.hs

@@ -144,9 +144,8 @@ module Simplex.Messaging.Protocol
     tParse,
     tDecodeParseValidate,
     tEncode,
-    tEncodeBatch1,
+    tEncodeBatch,
     batchTransmissions,
-    batchTransmissions',
 
     -- * exports for tests
     CommandTag (..),
@@ -155,6 +154,7 @@ module Simplex.Messaging.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Concurrent (threadDelay)
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
@@ -1283,14 +1283,14 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
-tPut th = fmap concat . mapM tPutBatch . batchTransmissions (batch th) (blockSize th)
+tPut :: Transport c => THandle c -> Maybe Int -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
+tPut th delay_ = fmap concat . mapM tPutBatch . batchTransmissions (batch th) (blockSize th)
   where
-    tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
+    tPutBatch :: TransportBatch -> IO [Either TransportError ()]
     tPutBatch = \case
-      TBLargeTransmission _ -> [Left TELargeMsg] <$ putStrLn "tPut error: large message"
-      TBTransmissions s n _ -> replicate n <$> (tPutLog th s)
-      TBTransmission s _ -> (: []) <$> tPutLog th s
+      TBLargeTransmission -> [Left TELargeMsg] <$ putStrLn "tPut error: large message"
+      TBTransmissions n s -> replicate n <$> (tPutLog th (tEncodeBatch n s) <* mapM_ threadDelay delay_)
+      TBTransmission s -> (: []) <$> tPutLog th s
 
 tPutLog :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
 tPutLog th s = do
@@ -1300,52 +1300,44 @@ tPutLog th s = do
     _ -> pure ()
   pure r
 
--- ByteString in TBTransmissions includes byte with transmissions count
-data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBLargeTransmission r
-
-batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch ()]
-batchTransmissions batch bSize = batchTransmissions' batch bSize . L.map (,())
+-- ByteString does not include length byte, it is added by tEncodeBatch
+data TransportBatch = TBTransmissions Int ByteString | TBTransmission ByteString | TBLargeTransmission
 
 -- | encodes and batches transmissions into blocks,
-batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (SentRawTransmission, r) -> [TransportBatch r]
-batchTransmissions' batch bSize
-  | batch = addBatch . foldr addTransmission ([], 0, 0, [], [])
-  | otherwise = map mkBatch1 . L.toList
+batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch]
+batchTransmissions batch bSize
+  | batch = reverse . mkBatch [] . L.map tEncode
+  | otherwise = map (mkBatch1 . tEncode) . L.toList
   where
-    mkBatch1 :: (SentRawTransmission, r) -> TransportBatch r
-    mkBatch1 (t, r)
-      -- 2 bytes are reserved for pad size
-      | B.length s <= bSize - 2 = TBTransmission s r
-      | otherwise = TBLargeTransmission r
-      where
-        s = tEncode t
-    -- 3 = 2 bytes reserved for pad size + 1 for transmission count
-    bSize' = bSize - 3
-    addTransmission :: (SentRawTransmission, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
-    addTransmission (t, r) acc@(bs, len, n, ss, rs)
-      | len' <= bSize' && n < 255 = (bs, len', 1 + n, s : ss, r : rs)
-      | sLen <= bSize' = (addBatch acc, sLen, 1, [s], [r])
-      | otherwise = (TBLargeTransmission r : addBatch acc, 0, 0, [], [])
-      where
-        s = tEncodeForBatch t
-        sLen = B.length s
-        len' = len + sLen
-    addBatch :: ([TransportBatch r], Int, Int, [ByteString], [r]) -> [TransportBatch r]
-    addBatch (bs, _len, n, ss, rs) = if n == 0 then bs else TBTransmissions b n rs : bs
-      where
-        b = B.concat $ B.singleton (lenEncode n) : ss
+    mkBatch :: [TransportBatch] -> NonEmpty ByteString -> [TransportBatch]
+    mkBatch rs ts =
+      let (n, s, ts_) = encodeBatch 0 "" ts
+          r = if n == 0 then TBLargeTransmission else TBTransmissions n s
+          rs' = r : rs
+       in case ts_ of
+            Just ts' -> mkBatch rs' ts'
+            _ -> rs'
+    mkBatch1 :: ByteString -> TransportBatch
+    mkBatch1 s = if B.length s > bSize - 2 then TBLargeTransmission else TBTransmission s
+    encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
+    encodeBatch n s ts@(t :| ts_)
+      | n == 255 = (n, s, Just ts)
+      | otherwise =
+          let s' = s <> smpEncode (Large t)
+              n' = n + 1
+           in if B.length s' > bSize - 3 -- one byte is reserved for the number of messages in the batch
+                then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
+                else case L.nonEmpty ts_ of
+                  Just ts' -> encodeBatch n' s' ts'
+                  _ -> (n', s', Nothing)
 
 tEncode :: SentRawTransmission -> ByteString
 tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t
 {-# INLINE tEncode #-}
 
-tEncodeForBatch :: SentRawTransmission -> ByteString
-tEncodeForBatch = smpEncode . Large . tEncode
-{-# INLINE tEncodeForBatch #-}
-
-tEncodeBatch1 :: SentRawTransmission -> ByteString
-tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
-{-# INLINE tEncodeBatch1 #-}
+tEncodeBatch :: Int -> ByteString -> ByteString
+tEncodeBatch n s = lenEncode n `B.cons` s
+{-# INLINE tEncodeBatch #-}
 
 encodeTransmission :: ProtocolEncoding e c => Version -> ByteString -> Transmission c -> ByteString
 encodeTransmission v sessionId (CorrId corrId, queueId, command) =

src/Simplex/Messaging/Server.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -84,9 +83,8 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
-import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode)
+import System.IO (hPutStrLn, hSetNewlineMode, universalNewlineMode)
 import System.Mem.Weak (deRefWeak)
-import UnliftIO (timeout)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
@@ -119,8 +117,8 @@ type M a = ReaderT Env IO a
 smpServer :: TMVar Bool -> ServerConfig -> M ()
 smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
   s <- asks server
-  expired <- restoreServerMessages
-  restoreServerStats expired
+  restoreServerMessages
+  restoreServerStats
   raceAny_
     ( serverThread s "server subscribedQ" subscribedQ subscribers subscriptions cancelSub
         : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ())
@@ -131,8 +129,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
     runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      ss <- asks sockets
-      runTransportServerState ss started tcpPort serverParams tCfg (runClient t)
+      runTransportServer started tcpPort serverParams tCfg (runClient t)
 
     saveServer :: Bool -> M ()
     saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
@@ -146,12 +143,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       (Client -> TMap QueueId s) ->
       (s -> IO ()) ->
       M ()
-    serverThread s label subQ subs clientSubs unsub = do
+    serverThread s label subQ subs clientSubs unsub = forever $ do
       labelMyThread label
-      forever $
-        atomically updateSubscribers
-          $>>= endPreviousSubscriptions
-          >>= liftIO . mapM_ unsub
+      atomically updateSubscribers
+        $>>= endPreviousSubscriptions
+        >>= liftIO . mapM_ unsub
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
         updateSubscribers = do
@@ -165,9 +161,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
           TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
         endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
         endPreviousSubscriptions (qId, c) = do
-          void . forkIO $ do
-            labelMyThread $ label <> ".endPreviousSubscriptions"
-            atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)]
+          labelMyThread $ label <> ".endPreviousSubscriptions"
+          void . forkIO . atomically $
+            writeTBQueue (sndQ c) [(CorrId "", qId, END)]
           atomically $ TM.lookupDelete qId (clientSubs c)
 
     expireMessagesThread_ :: ServerConfig -> [M ()]
@@ -179,16 +175,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
       let interval = checkInterval expCfg * 1000000
-      stats <- asks serverStats
       labelMyThread "expireMessages"
       forever $ do
         liftIO $ threadDelay' interval
         old <- liftIO $ expireBeforeEpoch expCfg
         rIds <- M.keysSet <$> readTVarIO ms
-        forM_ rIds $ \rId -> do
-          q <- atomically (getMsgQueue ms rId quota)
-          deleted <- atomically $ deleteExpiredMsgs q old
-          atomically $ modifyTVar' (msgExpired stats) (+ deleted)
+        forM_ rIds $ \rId ->
+          atomically (getMsgQueue ms rId quota)
+            >>= atomically . (`deleteExpiredMsgs` old)
 
     serverStatsThread_ :: ServerConfig -> [M ()]
     serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -201,11 +195,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
       let interval = 1000000 * logInterval
-      forever $ do
-        withFile statsFilePath AppendMode $ \h -> liftIO $ do
-          hSetBuffering h LineBuffering
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
           ts <- getCurrentTime
           fromTime' <- atomically $ swapTVar fromTime ts
           qCreated' <- atomically $ swapTVar qCreated 0
@@ -213,7 +207,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
           qDeleted' <- atomically $ swapTVar qDeleted 0
           msgSent' <- atomically $ swapTVar msgSent 0
           msgRecv' <- atomically $ swapTVar msgRecv 0
-          msgExpired' <- atomically $ swapTVar msgExpired 0
           ps <- atomically $ periodStatCounts activeQueues ts
           msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
           msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
@@ -238,19 +231,18 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                 weekCount psNtf,
                 monthCount psNtf,
                 show qCount',
-                show msgCount',
-                show msgExpired'
+                show msgCount'
               ]
-        liftIO $ threadDelay' interval
+          threadDelay' interval
 
     runClient :: Transport c => TProxy c -> c -> M ()
     runClient tp h = do
       kh <- asks serverIdentity
-      ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
+      smpVRange <- asks $ smpServerVRange . config
       labelMyThread $ "smp handshake for " <> transportName tp
-      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h kh smpServerVRange) >>= \case
-        Just (Right th) -> runClientTransport th
-        _ -> pure ()
+      liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
+        Right th -> runClientTransport th
+        Left _ -> pure ()
 
     controlPortThread_ :: ServerConfig -> [M ()]
     controlPortThread_ ServerConfig {controlPort = Just port} = [runCPServer port]
@@ -284,16 +276,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
               CPSuspend -> hPutStrLn h "suspend not implemented"
               CPResume -> hPutStrLn h "resume not implemented"
               CPClients -> do
-                active <- unliftIO u (asks clients) >>= readTVarIO
-                hPutStrLn h $ "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions"
-                forM_ (M.toList active) $ \(cid, Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do
-                  connected' <- bshow <$> readTVarIO connected
-                  rcvActiveAt' <- strEncode <$> readTVarIO rcvActiveAt
-                  sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt
-                  now <- liftIO getSystemTime
-                  let age = systemSeconds now - systemSeconds createdAt
-                  subscriptions' <- bshow . M.size <$> readTVarIO subscriptions
-                  hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
+                Server {subscribers} <- unliftIO u $ asks server
+                clients <- readTVarIO subscribers
+                hPutStrLn h $ "Clients: " <> show (length clients)
+                forM_ (M.toList clients) $ \(cid, Client {sessionId, connected, activeAt, subscriptions}) -> do
+                  hPutStrLn h . B.unpack $ "Client " <> encode cid <> " $" <> encode sessionId
+                  readTVarIO connected >>= hPutStrLn h . ("  connected: " <>) . show
+                  readTVarIO activeAt >>= hPutStrLn h . ("  activeAt: " <>) . B.unpack . strEncode
+                  readTVarIO subscriptions >>= hPutStrLn h . ("  subscriptions: " <>) . show . M.size
               CPStats -> do
                 ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
                 putStat "fromTime" fromTime
@@ -309,7 +299,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                 where
                   putStat :: Show a => String -> TVar a -> IO ()
                   putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v
-              CPStatsRTS -> getRTSStats >>= hPrint h
+              CPStatsRTS -> getRTSStats >>= hPutStrLn h . show
               CPThreads -> do
 #if MIN_VERSION_base(4,18,0)
                 threads <- liftIO listThreads
@@ -321,50 +311,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
 #else
                 hPutStrLn h "Not available on GHC 8.10"
 #endif
-              CPSockets -> do
-                (accepted', closed', active') <- unliftIO u $ asks sockets
-                (accepted, closed, active) <- atomically $ (,,) <$> readTVar accepted' <*> readTVar closed' <*> readTVar active'
-                hPutStrLn h "Sockets: "
-                hPutStrLn h $ "accepted: " <> show accepted
-                hPutStrLn h $ "closed: " <> show closed
-                hPutStrLn h $ "active: " <> show (M.size active)
-                hPutStrLn h $ "leaked: " <> show (accepted - closed - M.size active)
-              CPSocketThreads -> do
-#if MIN_VERSION_base(4,18,0)
-                (_, _, active') <- unliftIO u $ asks sockets
-                active <- readTVarIO active'
-                forM_ (M.toList active) $ \(sid, tid') ->
-                  deRefWeak tid' >>= \case
-                    Nothing -> hPutStrLn h $ intercalate "," [show sid, "", "gone", ""]
-                    Just tid -> do
-                      label <- threadLabel tid
-                      status <- threadStatus tid
-                      hPutStrLn h $ intercalate "," [show sid, show tid, show status, fromMaybe "" label]
-#else
-                hPutStrLn h "Not available on GHC 8.10"
-#endif
-              CPDelete queueId' -> unliftIO u $ do
-                st <- asks queueStore
-                ms <- asks msgStore
-                stats <- asks serverStats
-                queueId <- atomically (getQueue st SSender queueId') >>= \case
-                  Left _ -> pure queueId' -- fallback to using as recipientId directly
-                  Right QueueRec {recipientId} -> pure recipientId
-                r <- atomically $
-                  deleteQueue st queueId $>>= \() ->
-                    Right <$> delMsgQueueSize ms queueId
-                case r of
-                  Left e -> liftIO . hPutStrLn h $ "error: " <> show e
-                  Right numDeleted -> do
-                    withLog (`logDeleteQueue` queueId)
-                    atomically $ modifyTVar' (qDeleted stats) (+ 1)
-                    atomically $ modifyTVar' (qCount stats) (subtract 1)
-                    liftIO . hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted"
               CPSave -> withLock (savingLock srv) "control" $ do
                 hPutStrLn h "saving server state..."
                 unliftIO u $ saveServer True
                 hPutStrLn h "server state saved!"
-              CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, delete, save, help, quit"
+              CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, threads, save, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
 
@@ -372,32 +323,24 @@ runClientTransport :: Transport c => THandle c -> M ()
 runClientTransport th@THandle {thVersion, sessionId} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
-  active <- asks clients
-  nextClientId <- asks clientSeq
-  c <- atomically $ do
-    new@Client {clientId} <- newClient nextClientId q thVersion sessionId ts
-    TM.insert clientId new active
-    pure new
+  c <- atomically $ newClient q thVersion sessionId ts
   s <- asks server
   expCfg <- asks $ inactiveClientExpiration . config
   labelMyThread . B.unpack $ "client $" <> encode sessionId
   raceAny_ ([liftIO $ send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
     `finally` clientDisconnected c
   where
-    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)]
+    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th c activeAt expCfg]
     disconnectThread_ _ _ = []
-    noSubscriptions c = atomically $ (&&) <$> TM.null (subscriptions c) <*> TM.null (ntfSubscriptions c)
 
 clientDisconnected :: Client -> M ()
-clientDisconnected c@Client {clientId, subscriptions, connected, sessionId} = do
-  labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc"
+clientDisconnected c@Client {subscriptions, connected} = do
   atomically $ writeTVar connected False
   subs <- readTVarIO subscriptions
   liftIO $ mapM_ cancelSub subs
   atomically $ writeTVar subscriptions M.empty
   cs <- asks $ subscribers . server
   atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
-  asks clients >>= atomically . TM.delete clientId
   where
     deleteCurrentClient :: Client -> Maybe Client
     deleteCurrentClient c'
@@ -414,11 +357,11 @@ cancelSub sub =
     _ -> return ()
 
 receive :: Transport c => THandle c -> Client -> M ()
-receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
+receive th Client {rcvQ, sndQ, activeAt, sessionId} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
   forever $ do
     ts <- L.toList <$> liftIO (tGet th)
-    atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
+    atomically . writeTVar activeAt =<< liftIO getSystemTime
     as <- partitionEithers <$> mapM cmdAction ts
     write sndQ $ fst as
     write rcvQ $ snd as
@@ -435,12 +378,12 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
     write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
 send :: Transport c => THandle c -> Client -> IO ()
-send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
+send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
   forever $ do
     ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-    void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
-    atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
+    void . liftIO . tPut h Nothing $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
+    atomically . writeTVar activeAt =<< liftIO getSystemTime
   where
     tOrder :: Transmission BrokerMsg -> Int
     tOrder (_, _, cmd) = case cmd of
@@ -448,18 +391,15 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
       NMSG {} -> 0
       _ -> 1
 
-disconnectTransport :: Transport c => THandle c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
-disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
+disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()
+disconnectTransport THandle {connection, sessionId} c activeAt expCfg = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport"
-  loop
-  where
-    loop = do
-      threadDelay' $ checkInterval expCfg * 1000000
-      ifM noSubscriptions checkExpired loop
-    checkExpired = do
-      old <- expireBeforeEpoch expCfg
-      ts <- max <$> readTVarIO rcvActiveAt <*> readTVarIO sndActiveAt
-      if systemSeconds ts < old then closeConnection connection else loop
+  let interval = checkInterval expCfg * 1000000
+  forever . liftIO $ do
+    threadDelay' interval
+    old <- expireBeforeEpoch expCfg
+    ts <- readTVarIO $ activeAt c
+    when (systemSeconds ts < old) $ closeConnection connection
 
 data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 
@@ -547,7 +487,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
       where
         createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg)
         createQueue st recipientKey dhKey subMode = time "NEW" $ do
-          (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
+          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
           let rcvDhSecret = C.dh' dhKey privDhKey
               qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
               qRec (recipientId, senderId) =
@@ -602,7 +542,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
 
         addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
         addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do
-          (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
+          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
           let rcvNtfDhSecret = C.dh' dhKey privDhKey
           (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
           where
@@ -748,7 +688,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
                       Just msg -> time "SEND ok" $ do
                         stats <- asks serverStats
                         when (notification msgFlags) $ do
-                          atomically . trySendNotification msg =<< asks random
+                          atomically . trySendNotification msg =<< asks idsDrg
                           atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
                           atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
                         atomically $ modifyTVar' (msgSent stats) (+ 1)
@@ -766,9 +706,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
             expireMessages q = do
               msgExp <- asks $ messageExpiration . config
               old <- liftIO $ mapM expireBeforeEpoch msgExp
-              stats <- asks serverStats
-              deleted <- atomically $ sum <$> mapM (deleteExpiredMsgs q) old
-              atomically $ modifyTVar' (msgExpired stats) (+ deleted)
+              atomically $ mapM_ (deleteExpiredMsgs q) old
 
             trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
             trySendNotification msg ntfNonceDrg =
@@ -785,7 +723,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
 
             mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
             mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do
-              cbNonce <- C.randomCbNonce ntfNonceDrg
+              cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
               let msgMeta = NMsgMeta {msgId, msgTs}
                   encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
               pure . (cbNonce,) $ fromRight "" encNMsgMeta
@@ -810,7 +748,6 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
                 s -> s
               where
                 subscriber = do
-                  labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " subscriber/" <> T.unpack name
                   msg <- atomically $ peekMsg q
                   time "subscriber" . atomically $ do
                     let encMsg = encryptMsg qr msg
@@ -885,7 +822,9 @@ timed name qId a = do
     sec = 1000_000000
 
 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
-randomId n = atomically . C.randomBytes n =<< asks random
+randomId n = do
+  gVar <- asks idsDrg
+  atomically (C.pseudoRandomBytes n gVar)
 
 saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => Bool -> m ()
 saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages
@@ -902,27 +841,24 @@ saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessag
           atomically (getMessages ms rId)
             >>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
 
-restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m Int
-restoreServerMessages = asks (storeMsgsFile . config) >>= \case
-  Just f -> ifM (doesFileExist f) (restoreMessages f) (pure 0)
-  Nothing -> pure 0
+restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
+restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
   where
-    restoreMessages f = do
+    restoreMessages f = whenM (doesFileExist f) $ do
       logInfo $ "restoring messages from file " <> T.pack f
       st <- asks queueStore
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
       old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch)
-      runExceptT (liftIO (B.readFile f) >>= foldM (\expired -> restoreMsg expired st ms quota old_) 0 . B.lines) >>= \case
+      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota old_) . B.lines) >>= \case
         Left e -> do
           logError . T.pack $ "error restoring messages: " <> e
           liftIO exitFailure
-        Right expired -> do
+        _ -> do
           renameFile f $ f <> ".bak"
           logInfo "messages restored"
-          pure expired
       where
-        restoreMsg !expired st ms quota old_ s = do
+        restoreMsg st ms quota old_ s = do
           r <- liftEither . first (msgErr "parsing") $ strDecode s
           case r of
             MLRv3 rId msg -> addToMsgQueue rId msg
@@ -932,15 +868,14 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case
               addToMsgQueue rId msg'
           where
             addToMsgQueue rId msg = do
-              (isExpired, logFull) <- atomically $ do
+              logFull <- atomically $ do
                 q <- getMsgQueue ms rId quota
                 case msg of
                   Message {msgTs}
-                    | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q msg
-                    | otherwise -> pure (True, False)
-                  MessageQuota {} -> writeMsg q msg $> (False, False)
+                    | maybe True (systemSeconds msgTs >=) old_ -> isNothing <$> writeMsg q msg
+                    | otherwise -> pure False
+                  MessageQuota {} -> writeMsg q msg $> False
               when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg)
-              pure $ if isExpired then expired + 1 else expired
             updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
               let nonce = C.cbNonce msgId
               msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
@@ -958,21 +893,19 @@ saveServerStats =
       B.writeFile f $ strEncode stats
       logInfo "server stats saved"
 
-restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ()
-restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
+restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
       logInfo $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
-        Right d@ServerStatsData {_qCount = statsQCount} -> do
+        Right d -> do
           s <- asks serverStats
-          _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore
-          _msgCount <- foldM (\(!n) q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore
-          atomically $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring}
+          _qCount <- fmap (length . M.keys) . readTVarIO . queues =<< asks queueStore
+          _msgCount <- foldM (\n q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore
+          atomically $ setServerStats s d {_qCount, _msgCount}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
-          when (_qCount /= statsQCount) $ logWarn $ "Queue count differs: stats: " <> tshow statsQCount <> ", store: " <> tshow _qCount
-          logInfo $ "Restored " <> tshow _msgCount <> " messages in " <> tshow _qCount <> " queues"
         Left e -> do
           logInfo $ "error restoring server stats: " <> T.pack e
           liftIO exitFailure

src/Simplex/Messaging/Server/Control.hs

@@ -4,7 +4,6 @@
 module Simplex.Messaging.Server.Control where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString (ByteString)
 import Simplex.Messaging.Encoding.String
 
 data ControlProtocol
@@ -14,9 +13,6 @@ data ControlProtocol
   | CPStats
   | CPStatsRTS
   | CPThreads
-  | CPSockets
-  | CPSocketThreads
-  | CPDelete ByteString
   | CPSave
   | CPHelp
   | CPQuit
@@ -30,9 +26,6 @@ instance StrEncoding ControlProtocol where
     CPStats -> "stats"
     CPStatsRTS -> "stats-rts"
     CPThreads -> "threads"
-    CPSockets -> "sockets"
-    CPSocketThreads -> "socket-threads"
-    CPDelete bs -> "delete " <> strEncode bs
     CPSave -> "save"
     CPHelp -> "help"
     CPQuit -> "quit"
@@ -45,9 +38,6 @@ instance StrEncoding ControlProtocol where
       "stats" -> pure CPStats
       "stats-rts" -> pure CPStatsRTS
       "threads" -> pure CPThreads
-      "sockets" -> pure CPSockets
-      "socket-threads" -> pure CPSocketThreads
-      "delete" -> CPDelete <$> (A.space *> strP)
       "save" -> pure CPSave
       "help" -> pure CPHelp
       "quit" -> pure CPQuit

src/Simplex/Messaging/Server/Env/STM.hs

@@ -21,7 +21,6 @@ import qualified Network.TLS as T
 import Numeric.Natural
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Crypto (KeyHash (..))
-import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.STM
@@ -32,7 +31,7 @@ import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport)
-import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState)
+import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
 import Simplex.Messaging.Version
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
@@ -40,7 +39,6 @@ import UnliftIO.STM
 
 data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport)],
-    smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
     -- serverTbqSize :: Natural,
     msgQueueQuota :: Int,
@@ -91,8 +89,8 @@ defaultMessageExpiration =
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
-    { ttl = 43200, -- seconds, 12 hours
-      checkInterval = 3600 -- seconds, 1 hours
+    { ttl = 86400, -- seconds, 24 hours
+      checkInterval = 43200 -- seconds, 12 hours
     }
 
 data Env = Env
@@ -101,13 +99,10 @@ data Env = Env
     serverIdentity :: KeyHash,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
-    random :: TVar ChaChaDRG,
+    idsDrg :: TVar ChaChaDRG,
     storeLog :: Maybe (StoreLog 'WriteMode),
     tlsServerParams :: T.ServerParams,
-    serverStats :: ServerStats,
-    sockets :: SocketState,
-    clientSeq :: TVar Int,
-    clients :: TMap Int Client
+    serverStats :: ServerStats
   }
 
 data Server = Server
@@ -119,17 +114,14 @@ data Server = Server
   }
 
 data Client = Client
-  { clientId :: Int,
-    subscriptions :: TMap RecipientId (TVar Sub),
+  { subscriptions :: TMap RecipientId (TVar Sub),
     ntfSubscriptions :: TMap NotifierId (),
     rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
     sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     thVersion :: Version,
     sessionId :: ByteString,
     connected :: TVar Bool,
-    createdAt :: SystemTime,
-    rcvActiveAt :: TVar SystemTime,
-    sndActiveAt :: TVar SystemTime
+    activeAt :: TVar SystemTime
   }
 
 data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
@@ -148,17 +140,15 @@ newServer = do
   savingLock <- createLock
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
 
-newClient :: TVar Int -> Natural -> Version -> ByteString -> SystemTime -> STM Client
-newClient nextClientId qSize thVersion sessionId createdAt = do
-  clientId <- stateTVar nextClientId $ \next -> (next, next + 1)
+newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
+newClient qSize thVersion sessionId ts = do
   subscriptions <- TM.empty
   ntfSubscriptions <- TM.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
-  rcvActiveAt <- newTVar createdAt
-  sndActiveAt <- newTVar createdAt
-  return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
+  activeAt <- newTVar ts
+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, activeAt}
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription subThread = do
@@ -170,16 +160,13 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
   server <- atomically newServer
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
-  random <- liftIO C.newRandom
+  idsDrg <- drgNew >>= newTVarIO
   storeLog <- restoreQueues queueStore `mapM` storeLogFile
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
   let serverIdentity = KeyHash fp
   serverStats <- atomically . newServerStats =<< liftIO getCurrentTime
-  sockets <- atomically newSocketState
-  clientSeq <- newTVarIO 0
-  clients <- atomically TM.empty
-  return Env {config, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients}
+  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog, tlsServerParams, serverStats}
   where
     restoreQueues :: QueueStore -> FilePath -> m (StoreLog 'WriteMode)
     restoreQueues QueueStore {queues, senders, notifiers} f = do

src/Simplex/Messaging/Server/Main.hs

@@ -8,8 +8,8 @@
 
 module Simplex.Messaging.Server.Main where
 
-import Control.Concurrent.STM
 import Control.Monad (void)
+import Crypto.Random (getRandomBytes)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
@@ -95,7 +95,7 @@ smpServerCLI cfgPath logPath =
           where
             createServerPassword = \case
               ServerPassword s -> pure s
-              SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom)
+              SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString)
             iniFileContent host basicAuth =
               "[STORE_LOG]\n\
               \# The server uses STM memory for persistence,\n\
@@ -165,7 +165,6 @@ smpServerCLI cfgPath logPath =
         serverConfig =
           ServerConfig
             { transports = iniTransports ini,
-              smpHandshakeTimeout = 120000000,
               tbqSize = 64,
               -- serverTbqSize = 1024,
               msgQueueQuota = 128,

src/Simplex/Messaging/Server/MsgStore/STM.hs

@@ -12,7 +12,6 @@ module Simplex.Messaging.Server.MsgStore.STM
     newMsgStore,
     getMsgQueue,
     delMsgQueue,
-    delMsgQueueSize,
     flushMsgQueue,
     snapshotMsgQueue,
     writeMsg,
@@ -25,6 +24,7 @@ module Simplex.Messaging.Server.MsgStore.STM
 where
 
 import Control.Concurrent.STM.TQueue (flushTQueue)
+import Control.Monad (when)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -60,9 +60,6 @@ getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
 delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
 delMsgQueue st rId = TM.delete rId st
 
-delMsgQueueSize :: STMMsgStore -> RecipientId -> STM Int
-delMsgQueueSize st rId = TM.lookupDelete rId st >>= maybe (pure 0) (\MsgQueue {size} -> readTVar size)
-
 flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
 flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
 
@@ -115,15 +112,15 @@ tryDelPeekMsg mq msgId' =
       | otherwise -> pure (Nothing, msg_)
     _ -> pure (Nothing, Nothing)
 
-deleteExpiredMsgs :: MsgQueue -> Int64 -> STM Int
-deleteExpiredMsgs mq old = loop 0
+deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
+deleteExpiredMsgs mq old = loop
   where
-    loop dc =
-      tryPeekMsg mq >>= \case
-        Just Message {msgTs}
-          | systemSeconds msgTs < old ->
-              tryDeleteMsg mq >> loop (dc + 1)
-        _ -> pure dc
+    loop = tryPeekMsg mq >>= mapM_ delOldMsg
+    delOldMsg = \case
+      Message {msgTs} ->
+        when (systemSeconds msgTs < old) $
+          tryDeleteMsg mq >> loop
+      _ -> pure ()
 
 tryDeleteMsg :: MsgQueue -> STM ()
 tryDeleteMsg MsgQueue {msgQueue = q, size} =

src/Simplex/Messaging/Server/Stats.hs

@@ -25,7 +25,6 @@ data ServerStats = ServerStats
     qDeleted :: TVar Int,
     msgSent :: TVar Int,
     msgRecv :: TVar Int,
-    msgExpired :: TVar Int,
     activeQueues :: PeriodStats RecipientId,
     msgSentNtf :: TVar Int,
     msgRecvNtf :: TVar Int,
@@ -41,7 +40,6 @@ data ServerStatsData = ServerStatsData
     _qDeleted :: Int,
     _msgSent :: Int,
     _msgRecv :: Int,
-    _msgExpired :: Int,
     _activeQueues :: PeriodStatsData RecipientId,
     _msgSentNtf :: Int,
     _msgRecvNtf :: Int,
@@ -59,14 +57,13 @@ newServerStats ts = do
   qDeleted <- newTVar 0
   msgSent <- newTVar 0
   msgRecv <- newTVar 0
-  msgExpired <- newTVar 0
   activeQueues <- newPeriodStats
   msgSentNtf <- newTVar 0
   msgRecvNtf <- newTVar 0
   activeQueuesNtf <- newPeriodStats
   qCount <- newTVar 0
   msgCount <- newTVar 0
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
+  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
@@ -76,14 +73,13 @@ getServerStatsData s = do
   _qDeleted <- readTVar $ qDeleted s
   _msgSent <- readTVar $ msgSent s
   _msgRecv <- readTVar $ msgRecv s
-  _msgExpired <- readTVar $ msgExpired s
   _activeQueues <- getPeriodStatsData $ activeQueues s
   _msgSentNtf <- readTVar $ msgSentNtf s
   _msgRecvNtf <- readTVar $ msgRecvNtf s
   _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
   _qCount <- readTVar $ qCount s
   _msgCount <- readTVar $ msgCount s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
 
 setServerStats :: ServerStats -> ServerStatsData -> STM ()
 setServerStats s d = do
@@ -93,7 +89,6 @@ setServerStats s d = do
   writeTVar (qDeleted s) $! _qDeleted d
   writeTVar (msgSent s) $! _msgSent d
   writeTVar (msgRecv s) $! _msgRecv d
-  writeTVar (msgExpired s) $! _msgExpired d
   setPeriodStats (activeQueues s) (_activeQueues d)
   writeTVar (msgSentNtf s) $! _msgSentNtf d
   writeTVar (msgRecvNtf s) $! _msgRecvNtf d
@@ -102,16 +97,14 @@ setServerStats s d = do
   writeTVar (msgCount s) $! _msgCount d
 
 instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount} =
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "qCreated=" <> strEncode _qCreated,
         "qSecured=" <> strEncode _qSecured,
         "qDeleted=" <> strEncode _qDeleted,
-        "qCount=" <> strEncode _qCount,
         "msgSent=" <> strEncode _msgSent,
         "msgRecv=" <> strEncode _msgRecv,
-        "msgExpired=" <> strEncode _msgExpired,
         "msgSentNtf=" <> strEncode _msgSentNtf,
         "msgRecvNtf=" <> strEncode _msgRecvNtf,
         "activeQueues:",
@@ -124,10 +117,8 @@ instance StrEncoding ServerStatsData where
     _qCreated <- "qCreated=" *> strP <* A.endOfLine
     _qSecured <- "qSecured=" *> strP <* A.endOfLine
     _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
-    _qCount <- "qCount=" *> strP <* A.endOfLine <|> pure 0
     _msgSent <- "msgSent=" *> strP <* A.endOfLine
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    _msgExpired <- "msgExpired=" *> strP <* A.endOfLine <|> pure 0
     _msgSentNtf <- "msgSentNtf=" *> strP <* A.endOfLine <|> pure 0
     _msgRecvNtf <- "msgRecvNtf=" *> strP <* A.endOfLine <|> pure 0
     _activeQueues <-
@@ -142,7 +133,7 @@ instance StrEncoding ServerStatsData where
       optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
         Just _ -> strP <* optional A.endOfLine
         _ -> pure newPeriodStatsData
-    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount = 0}
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount = 0, _msgCount = 0}
 
 data PeriodStats a = PeriodStats
   { day :: TVar (Set a),

src/Simplex/Messaging/Server/StoreLog.hs

@@ -114,7 +114,7 @@ closeStoreLog = \case
 
 writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
 writeStoreLogRecord (WriteStoreLog _ h) r = do
-  B.hPut h $ strEncode r `B.snoc` '\n' -- hPutStrLn makes write non-atomic for length > 1024
+  B.hPutStrLn h $ strEncode r
   hFlush h
 
 logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO ()

src/Simplex/Messaging/Transport.hs

@@ -65,12 +65,11 @@ import Control.Monad.Except
 import Control.Monad.Trans.Except (throwE)
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.Bitraversable (bimapM)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.ByteString.Lazy as BL
 import Data.Default (def)
 import Data.Functor (($>))
 import Data.Version (showVersion)
@@ -81,7 +80,7 @@ import qualified Network.TLS.Extra as TE
 import qualified Paths_simplexmq as SMQ
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
+import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
 import Simplex.Messaging.Transport.Buffer
 import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
 import Simplex.Messaging.Version
@@ -218,8 +217,8 @@ instance Transport TLS where
     getBuffered tlsBuffer n t_ (T.recvData tlsContext)
 
   cPut :: TLS -> ByteString -> IO ()
-  cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} =
-    withTimedErr t_ . T.sendData tlsContext . LB.fromStrict
+  cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} s =
+    withTimedErr t_ . T.sendData tlsContext $ BL.fromStrict s
 
   getLn :: TLS -> IO ByteString
   getLn TLS {tlsContext, tlsBuffer} = do
@@ -359,9 +358,8 @@ smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
 sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
 sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
--- ignores tail bytes to allow future extensions
 getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
-getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
+getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
 
 smpTHandle :: Transport c => c -> THandle c
 smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}

src/Simplex/Messaging/Transport/Client.hs

@@ -21,7 +21,6 @@ module Simplex.Messaging.Transport.Client
 where
 
 import Control.Applicative (optional)
-import Control.Logger.Simple (logError)
 import Control.Monad.IO.Unlift
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -49,7 +48,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Util (bshow, (<$?>), catchAll, tshow)
+import Simplex.Messaging.Util (bshow, (<$?>))
 import System.IO.Error
 import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
@@ -136,7 +135,7 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
         _ -> connectTCPClient hostName
   c <- liftIO $ do
     sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
+    mapM_ (setSocketKeepAlive sock) tcpKeepAlive
     let tCfg = clientTransportConfig cfg
     connectTLS (Just hostName) tCfg clientParams sock >>= getClientConnection tCfg
   client c `E.finally` liftIO (closeConnection c)

src/Simplex/Messaging/Transport/Credentials.hs

@@ -9,8 +9,6 @@ module Simplex.Messaging.Transport.Credentials
   )
 where
 
-import Control.Concurrent.STM
-import Crypto.Random (ChaChaDRG)
 import Data.ASN1.Types (getObjectID)
 import Data.ASN1.Types.String (ASN1StringEncoding (UTF8))
 import Data.Hourglass (Hours (..), timeAdd)
@@ -47,9 +45,9 @@ privateToTls (C.APrivateSignKey _ k) = case k of
 
 type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate)
 
-genCredentials :: TVar ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
-genCredentials g parent (before, after) subjectName = do
-  subjectKeys <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+genCredentials :: Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
+genCredentials parent (before, after) subjectName = do
+  subjectKeys <- C.generateSignatureKeyPair C.SEd25519
   let (issuerKeys, issuer) = case parent of
         Nothing -> (subjectKeys, subject) -- self-signed
         Just (keys, cert) -> (keys, X509.certSubjectDN . X509.signedObject $ X509.getSigned cert)

src/Simplex/Messaging/Transport/HTTP2/Server.hs

@@ -5,20 +5,15 @@ module Simplex.Messaging.Transport.HTTP2.Server where
 import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
 import Control.Concurrent.STM
 import Control.Monad
-import Data.Time.Clock.System (getSystemTime, systemSeconds)
 import Network.HPACK (BufferSize)
 import Network.HTTP2.Server (Request, Response)
 import qualified Network.HTTP2.Server as H
 import Network.Socket
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
-import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (SessionId, TLS, closeConnection)
+import Simplex.Messaging.Transport (SessionId, TLS)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer)
-import Simplex.Messaging.Util (threadDelay')
-import UnliftIO (finally)
-import UnliftIO.Concurrent (forkIO, killThread)
 
 type HTTP2ServerFunc = SessionId -> Request -> (Response -> IO ()) -> IO ()
 
@@ -54,7 +49,7 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing $ \sessionId r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig $ \sessionId r sendResponse -> do
       reqBody <- getHTTP2Body r bodyHeadSize
       atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
@@ -63,29 +58,12 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ = runHTTP2ServerWith_ expCfg_ bufferSize setup
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port bufferSize serverParams transportConfig = runHTTP2ServerWith bufferSize setup
   where
     setup = runTransportServer started port serverParams transportConfig
 
-runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
-runHTTP2ServerWith = runHTTP2ServerWith_ Nothing
-
-runHTTP2ServerWith_ :: Maybe ExpirationConfig -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
-runHTTP2ServerWith_ expCfg_ bufferSize setup http2Server = setup $ \tls -> do
-  activeAt <- newTVarIO =<< getSystemTime
-  tid_ <- mapM (forkIO . expireInactiveClient tls activeAt) expCfg_
-  withHTTP2 bufferSize (run activeAt) tls `finally` mapM_ killThread tid_
+runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> (SessionId -> Request -> (Response -> IO ()) -> IO ()) -> a
+runHTTP2ServerWith bufferSize setup http2Server = setup $ withHTTP2 bufferSize run
   where
-    run activeAt cfg sessId = H.run cfg $ \req _aux sendResp -> do
-      getSystemTime >>= atomically . writeTVar activeAt
-      http2Server sessId req (`sendResp` [])
-    expireInactiveClient tls activeAt expCfg = loop
-      where
-        loop = do
-          threadDelay' $ checkInterval expCfg * 1000000
-          old <- expireBeforeEpoch expCfg
-          ts <- readTVarIO activeAt
-          if systemSeconds ts < old
-            then closeConnection tls
-            else loop
+    run cfg sessId = H.run cfg $ \req _aux sendResp -> http2Server sessId req (`sendResp` [])

src/Simplex/Messaging/Transport/Server.hs

@@ -7,9 +7,6 @@
 module Simplex.Messaging.Transport.Server
   ( TransportServerConfig (..),
     defaultTransportServerConfig,
-    runTransportServerState,
-    SocketState,
-    newSocketState,
     runTransportServer,
     runTransportServerSocket,
     runTCPServer,
@@ -41,14 +38,12 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow)
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak, deRefWeak)
-import UnliftIO (timeout)
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
 data TransportServerConfig = TransportServerConfig
   { logTLSErrors :: Bool,
-    tlsSetupTimeout :: Int,
     transportTimeout :: Int
   }
   deriving (Eq, Show)
@@ -57,7 +52,6 @@ defaultTransportServerConfig :: TransportServerConfig
 defaultTransportServerConfig =
   TransportServerConfig
     { logTLSErrors = True,
-      tlsSetupTimeout = 60000000,
       transportTimeout = 40000000
     }
 
@@ -70,57 +64,39 @@ serverTransportConfig TransportServerConfig {logTLSErrors} =
 --
 -- All accepted connections are passed to the passed function.
 runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> m ()) -> m ()
-runTransportServer started port params cfg server = do
-  ss <- atomically newSocketState
-  runTransportServerState ss started port params cfg server
-
-runTransportServerState :: forall c m. (Transport c, MonadUnliftIO m) => SocketState -> TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> m ()) -> m ()
-runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c))
+runTransportServer started port = runTransportServerSocket started (startTCPServer started port) (transportName (TProxy :: TProxy c))
 
 -- | Run a transport server with provided connection setup and handler.
 runTransportServerSocket :: (MonadUnliftIO m, T.TLSParams p, Transport a) => TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m ()
 runTransportServerSocket started getSocket threadLabel serverParams cfg server = do
-  ss <- atomically newSocketState
-  runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server
-
--- | Run a transport server with provided connection setup and handler.
-runTransportServerSocketState :: (MonadUnliftIO m, T.TLSParams p, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m ()
-runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server = do
   u <- askUnliftIO
+  let tCfg = serverTransportConfig cfg
   labelMyThread $ "transport server for " <> threadLabel
-  liftIO . runTCPServerSocket ss started getSocket $ \conn ->
-    E.bracket (setup conn >>= maybe (fail "tls setup timeout") pure) closeConnection (unliftIO u . server)
-  where
-    tCfg = serverTransportConfig cfg
-    setup conn = timeout (tlsSetupTimeout cfg) $ do
-      labelMyThread $ threadLabel <> "/setup"
-      tls <- connectTLS Nothing tCfg serverParams conn
-      getServerConnection tCfg tls
+  liftIO . runTCPServerSocket started getSocket $ \conn ->
+    E.bracket
+      (connectTLS Nothing tCfg serverParams conn >>= getServerConnection tCfg)
+      closeConnection
+      (unliftIO u . server)
 
 -- | Run TCP server without TLS
 runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
-runTCPServer started port server = do
-  ss <- atomically newSocketState
-  runTCPServerSocket ss started (startTCPServer started port) server
+runTCPServer started port = runTCPServerSocket started $ startTCPServer started port
 
 -- | Wrap socket provider in a TCP server bracket.
-runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO ()
-runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket server =
-  E.bracket getSocket (closeServer started clients) $ \sock ->
-    forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
-      cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId `seq` (cId', cId')
-      let closeConn _ = do
-            atomically $ TM.delete cId clients
-            gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
-            atomically $ modifyTVar' gracefullyClosed (+1)
+runTCPServerSocket :: TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO ()
+runTCPServerSocket started getSocket server = do
+  clients <- atomically TM.empty
+  clientId <- newTVarIO 0
+  E.bracket
+    getSocket
+    (closeServer started clients)
+    $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
+      -- catchAll_ is needed here in case the connection was closed earlier
+      cId <- atomically $ stateTVar clientId $ \cId -> let cId' = cId + 1 in (cId', cId')
+      let closeConn _ = atomically (TM.delete cId clients) >> gracefulClose conn 5000 `catchAll_` pure ()
       tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
       atomically $ TM.insert cId tId clients
 
-type SocketState = (TVar Int, TVar Int, TMap Int (Weak ThreadId))
-
-newSocketState :: STM SocketState
-newSocketState = (,,) <$> newTVar 0 <*> newTVar 0 <*> newTVar mempty
-
 closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO ()
 closeServer started clients sock = do
   readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -7,7 +7,7 @@ module Simplex.Messaging.Transport.WebSockets (WS (..)) where
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString.Lazy as BL
 import qualified Network.TLS as T
 import Network.WebSockets
 import Network.WebSockets.Stream (Stream)
@@ -101,5 +101,5 @@ makeTLSContextStream cxt =
       (Just <$> T.recvData cxt) `E.catch` \case
         T.Error_EOF -> pure Nothing
         e -> E.throwIO e
-    writeStream :: Maybe LB.ByteString -> IO ()
+    writeStream :: Maybe BL.ByteString -> IO ()
     writeStream = maybe (closeTLS cxt) (T.sendData cxt)

src/Simplex/Messaging/Util.hs

@@ -86,17 +86,25 @@ unlessM b = ifM b $ pure ()
 f $>>= g = f >>= fmap join . mapM g
 
 mapME :: (Monad m, Traversable t) => (a -> m (Either e b)) -> t (Either e a) -> m (t (Either e b))
-mapME f = mapM (bindRight f)
+mapME f = mapM (mapE f)
 {-# INLINE mapME #-}
 
-bindRight :: Monad m => (a -> m (Either e b)) -> Either e a -> m (Either e b)
-bindRight = either (pure . Left)
-{-# INLINE bindRight #-}
+mapME_ :: (Monad m, Traversable t) => (a -> m (Either e b)) -> t (Either e a) -> m ()
+mapME_ f = mapM_ (mapE f)
+{-# INLINE mapME_ #-}
+
+mapE :: Monad m => (a -> m (Either e b)) -> Either e a -> m (Either e b)
+mapE = either (pure . Left)
+{-# INLINE mapE #-}
 
 forME :: (Monad m, Traversable t) => t (Either e a) -> (a -> m (Either e b)) -> m (t (Either e b))
 forME = flip mapME
 {-# INLINE forME #-}
 
+forME_ :: (Monad m, Traversable t) => t (Either e a) -> (a -> m (Either e b)) -> m ()
+forME_ f = void . forME f
+{-# INLINE forME_ #-}
+
 catchAll :: IO a -> (E.SomeException -> IO a) -> IO a
 catchAll = E.catch
 {-# INLINE catchAll #-}

src/Simplex/RemoteControl/Client.hs

@@ -83,10 +83,10 @@ helloBlockSize = 12288
 encInvitationSize :: Int
 encInvitationSize = 900
 
-newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
-newRCHostPairing drg = do
-  ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca"
-  (_, idPrivKey) <- atomically $ C.generateKeyPair drg
+newRCHostPairing :: IO RCHostPairing
+newRCHostPairing = do
+  ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca"
+  (_, idPrivKey) <- C.generateKeyPair'
   pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing}
 
 data RCHostClient = RCHostClient
@@ -108,7 +108,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
   r <- newEmptyTMVarIO
   found@(RCCtrlAddress {address} :| _) <- findCtrlAddress
   c@RCHClient_ {startedPort, announcer} <- liftIO mkClient
-  hostKeys <- atomically genHostKeys
+  hostKeys <- liftIO genHostKeys
   action <- runClient c r hostKeys `putRCError` r
   -- wait for the port to make invitation
   portNum <- atomically $ readTMVar startedPort
@@ -133,7 +133,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
       pure RCHClient_ {startedPort, announcer, hostCAHash, endSession}
     runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ())
     runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do
-      tlsCreds <- liftIO $ genTLSCredentials drg caKey caCert
+      tlsCreds <- liftIO $ genTLSCredentials caKey caCert
       startTLSServer port_ startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls ->
         void . runExceptT $ do
           r' <- newEmptyTMVarIO
@@ -168,10 +168,10 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
               _ ->
                 pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA
         }
-    genHostKeys :: STM RCHostKeys
+    genHostKeys :: IO RCHostKeys
     genHostKeys = do
-      sessKeys <- C.generateKeyPair drg
-      dhKeys <- C.generateKeyPair drg
+      sessKeys <- C.generateKeyPair'
+      dhKeys <- C.generateKeyPair'
       pure RCHostKeys {sessKeys, dhKeys}
     mkInvitation :: RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation
     mkInvitation RCHostKeys {sessKeys, dhKeys} host portNum = do
@@ -190,10 +190,10 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
               }
       pure $ signInvitation (snd sessKeys) idPrivKey inv
 
-genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
-genTLSCredentials drg caKey caCert = do
+genTLSCredentials :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
+genTLSCredentials caKey caCert = do
   let caCreds = (C.signatureKeyPair caKey, caCert)
-  leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
+  leaf <- genCredentials (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
   pure . snd $ tlsCredentials (leaf :| [caCreds])
 
 certFingerprint :: X509.SignedCertificate -> C.KeyHash
@@ -225,7 +225,7 @@ prepareHostSession
     knownHost' <- updateKnownHost ca dhPubKey
     let ctrlHello = RCCtrlHello {}
     -- TODO send error response if something fails
-    nonce' <- liftIO . atomically $ C.randomCbNonce drg
+    nonce' <- liftIO . atomically $ C.pseudoRandomCbNonce drg
     encBody' <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt hybridKey nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
     let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, nonce = nonce', encBody = encBody'}
     pure (ctrlEncHello, keys, hostHello, pairing {knownHost = Just knownHost'})
@@ -258,13 +258,13 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h
   where
     newCtrlPairing :: IO RCCtrlPairing
     newCtrlPairing = do
-      ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca"
-      (_, dhPrivKey) <- atomically $ C.generateKeyPair drg
+      ((_, caKey), caCert) <- genCredentials Nothing (0, 24 * 999999) "ca"
+      (_, dhPrivKey) <- C.generateKeyPair'
       pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing}
     updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
     updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, dhPrivKey = currDhPrivKey} = do
       unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity
-      (_, dhPrivKey) <- atomically $ C.generateKeyPair drg
+      (_, dhPrivKey) <- liftIO C.generateKeyPair'
       pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey}
 
 connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
@@ -282,7 +282,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
     runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
     runClient RCCClient_ {confirmSession, endSession} r = do
       clientCredentials <-
-        liftIO (genTLSCredentials drg caKey caCert) >>= \case
+        liftIO (genTLSCredentials caKey caCert) >>= \case
           TLS.Credentials (creds : _) -> pure $ Just creds
           _ -> throwError $ RCEInternal "genTLSCredentials must generate credentials"
       let clientConfig = defaultTransportClientConfig {clientCredentials}
@@ -337,7 +337,7 @@ prepareHostHello
     case compatibleVersion v supportedRCVRange of
       Nothing -> throwError RCEVersion
       Just (Compatible v') -> do
-        nonce <- liftIO . atomically $ C.randomCbNonce drg
+        nonce <- liftIO . atomically $ C.pseudoRandomCbNonce drg
         (kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg
         let helloBody = RCHostHello {v = v', ca = certFingerprint caCert, app = hostAppInfo, kem = kemPubKey}
             sharedKey = C.dh' dhPubKey dhPrivKey
@@ -369,7 +369,7 @@ announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519
 announceRC drg maxCount idPrivKey knownDhPub RCHostKeys {sessKeys, dhKeys} inv = withSender $ \sender -> do
   replicateM_ maxCount $ do
     logDebug "Announcing..."
-    nonce <- atomically $ C.randomCbNonce drg
+    nonce <- atomically $ C.pseudoRandomCbNonce drg
     encInvitation <- liftEitherWith undefined $ C.cbEncrypt sharedKey nonce sigInvitation encInvitationSize
     liftIO . UDP.send sender $ smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation}
     threadDelay 1000000
@@ -434,7 +434,7 @@ cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do
 
 rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString)
 rcEncryptBody drg hybridKey s = do
-  nonce <- atomically $ C.randomCbNonce drg
+  nonce <- atomically $ C.pseudoRandomCbNonce drg
   let len = LB.length s
   ct <- liftEitherWith (const RCEEncrypt) $ LC.kcbEncryptTailTag hybridKey nonce s len (len + 8)
   pure (nonce, ct)

tests/AgentTests.hs

@@ -20,7 +20,6 @@ import Control.Concurrent
 import Control.Monad (forM_)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Maybe (fromJust)
 import Data.Type.Equality
 import GHC.Stack (withFrozenCallStack)
 import Network.HTTP.Types (urlEncode)
@@ -45,11 +44,10 @@ agentTests (ATransport t) = do
   describe "SQLite store" storeTests
   describe "Migration tests" migrationTests
   describe "SMP agent protocol syntax" $ syntaxTests t
-  describe "Establishing duplex connection (via agent protocol)" $ do
-    -- These tests are disabled because the agent does not work correctly with multiple connected TCP clients
-    xit "should connect via one server and one agent" $ do
+  describe "Establishing duplex connection" $ do
+    it "should connect via one server and one agent" $ do
       smpAgentTest2_1_1 $ testDuplexConnection t
-    xit "should connect via one server and one agent (random IDs)" $ do
+    it "should connect via one server and one agent (random IDs)" $ do
       smpAgentTest2_1_1 $ testDuplexConnRandomIds t
     it "should connect via one server and 2 agents" $ do
       smpAgentTest2_2_1 $ testDuplexConnection t
@@ -139,18 +137,18 @@ correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
   Left e -> error $ show e
 
 -- | receive message to handle `h` and validate that it is the expected one
-(<#) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
-h <# (corrId, connId, cmd) = timeout 5000000 (h <#:) `shouldReturn` Just (corrId, connId, Right cmd)
+(<#) :: Transport c => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
+h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd)
 
-(<#.) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AENone -> Expectation
-h <#. (corrId, connId, cmd) = timeout 5000000 (h <#:.) `shouldReturn` Just (corrId, connId, Right cmd)
+(<#.) :: Transport c => c -> AEntityTransmission 'Agent 'AENone -> Expectation
+h <#. (corrId, connId, cmd) = (h <#:.) `shouldReturn` (corrId, connId, Right cmd)
 
 -- | receive message to handle `h` and validate it using predicate `p`
-(<#=) :: (HasCallStack, Transport c) => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
-h <#= p = timeout 5000000 (h <#:) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
+(<#=) :: Transport c => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
+h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
 
-(<#=?) :: (HasCallStack, Transport c) => c -> (ATransmission 'Agent -> Bool) -> Expectation
-h <#=? p = timeout 5000000 (h <#:?) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
+(<#=?) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
+h <#=? p = (h <#:?) >>= (`shouldSatisfy` p . correctTransmission)
 
 -- | test that nothing is delivered to handle `h` during 10ms
 (#:#) :: Transport c => c -> String -> Expectation
@@ -164,10 +162,7 @@ h #:# err = tryGet `shouldReturn` ()
 pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
-pattern Msg' :: AgentMsgId -> MsgBody -> ACommand 'Agent e
-pattern Msg' aMsgId msgBody <- MSG MsgMeta {integrity = MsgOk, recipient = (aMsgId, _)} _ msgBody
-
-testDuplexConnection :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
+testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnection _ alice bob = do
   ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV subscribe")
   let cReq' = strEncode cReq
@@ -180,19 +175,19 @@ testDuplexConnection _ alice bob = do
   -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
   alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", MID 4)
   alice <# ("", "bob", SENT 4)
-  bob <#= \case ("", "alice", Msg' 4 "hello") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
   bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
   alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 5)
   alice <# ("", "bob", SENT 5)
-  bob <#= \case ("", "alice", Msg' 5 "how are you?") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
   bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
   bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
   bob <# ("", "alice", SENT 6)
-  alice <#= \case ("", "bob", Msg' 6 "hello too") -> True; _ -> False
+  alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
   alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
   bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 7)
   bob <# ("", "alice", SENT 7)
-  alice <#= \case ("", "bob", Msg' 7 "message 1") -> True; _ -> False
+  alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
   alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
   bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", MID 8)
@@ -359,6 +354,7 @@ testServerConnectionAfterError t _ = do
     withAgent2 $ \alice -> do
       withServer $ do
         connect (bob, "bob") (alice, "alice")
+
       bob <#. ("", "", DOWN server ["alice"])
       alice <#. ("", "", DOWN server ["bob"])
       alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
@@ -385,10 +381,10 @@ testServerConnectionAfterError t _ = do
   where
     server = SMPServer "localhost" testPort2 testKeyHash
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
-    withAgent1 = withAgent agentTestPort testDB 0 
-    withAgent2 = withAgent agentTestPort2 testDB2 10
-    withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a
-    withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort
+    withAgent1 = withAgent agentTestPort testDB
+    withAgent2 = withAgent agentTestPort2 testDB2
+    withAgent :: String -> FilePath -> (c -> IO a) -> IO a
+    withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
 
 testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
 testMsgDeliveryAgentRestart t bob = do
@@ -423,7 +419,7 @@ testMsgDeliveryAgentRestart t bob = do
   removeFile testDB
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
-    withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) 0 (pure ()) . const . testSMPAgentClientOn agentTestPort
+    withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (pure ()) . const . testSMPAgentClientOn agentTestPort
 
 testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
 testConcurrentMsgDelivery _ alice bob = do

tests/AgentTests/DoubleRatchetTests.hs

@@ -11,7 +11,6 @@ module AgentTests.DoubleRatchetTests where
 
 import Control.Concurrent.STM
 import Control.Monad.Except
-import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
@@ -59,14 +58,14 @@ fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen
 
 testMessageHeader :: Expectation
 testMessageHeader = do
-  (k, _) <- atomically . C.generateKeyPair @X25519 =<< C.newRandom
+  (k, _) <- C.generateKeyPair' @X25519
   let hdr = MsgHeader {msgMaxVersion = currentE2EEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}
   parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr
 
 pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString)
 pattern Decrypted msg <- Right (Right msg)
 
-type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()
+type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()
 
 testEncryptDecrypt :: TestRatchets a
 testEncryptDecrypt alice bob = do
@@ -154,7 +153,7 @@ testSkippedAfterRatchetAdvance alice bob = do
 
 testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO ()
 testKeyJSON _ = do
-  (k, pk) <- atomically . C.generateKeyPair @a =<< C.newRandom
+  (k, pk) <- C.generateKeyPair' @a
   testEncodeDecode k
   testEncodeDecode pk
 
@@ -172,51 +171,46 @@ testEncodeDecode x = do
 
 testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dh _ = do
-  g <- C.newRandom
-  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a currentE2EEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a currentE2EEncryptVersion
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   paramsAlice `shouldBe` paramsBob
 
 testX3dhV1 :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dhV1 _ = do
-  g <- C.newRandom
-  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g 1
-  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g 1
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a 1
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a 1
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   paramsAlice `shouldBe` paramsBob
 
-(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Expectation
+(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys), ByteString) -> TVar (Ratchet a, SkippedMsgKeys) -> Expectation
 (alice, msg) #> bob = do
   Right msg' <- encrypt alice msg
   Decrypted msg'' <- decrypt bob msg'
   msg'' `shouldBe` msg
 
-withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation
+withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation
 withRatchets test = do
-  ga <- C.newRandom
-  gb <- C.newRandom
   (a, b) <- initRatchets @a
-  alice <- newTVarIO (ga, a, M.empty)
-  bob <- newTVarIO (gb, b, M.empty)
+  alice <- newTVarIO (a, M.empty)
+  bob <- newTVarIO (b, M.empty)
   test alice bob `shouldReturn` ()
 
 initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)
 initRatchets = do
-  g <- C.newRandom
-  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams g currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams g currentE2EEncryptVersion
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams currentE2EEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams currentE2EEncryptVersion
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
-  (_, pkBob3) <- atomically $ C.generateKeyPair g
+  (_, pkBob3) <- C.generateKeyPair'
   let bob = initSndRatchet supportedE2EEncryptVRange (C.publicKey pkAlice2) pkBob3 paramsBob
       alice = initRcvRatchet supportedE2EEncryptVRange pkAlice2 paramsAlice
   pure (alice, bob)
 
-encrypt_ :: AlgorithmI a => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
-encrypt_ (_, rc, _) msg =
+encrypt_ :: AlgorithmI a => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
+encrypt_ (rc, _) msg =
   runExceptT (rcEncrypt rc paddedMsgLen msg)
     >>= either (pure . Left) checkLength
   where
@@ -224,26 +218,26 @@ encrypt_ (_, rc, _) msg =
       B.length msg' `shouldBe` fullMsgLen
       pure $ Right (msg', rc', SMDNoChange)
 
-decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff))
-decrypt_ (g, rc, smks) msg = runExceptT $ rcDecrypt g rc smks msg
+decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff))
+decrypt_ (rc, smks) msg = runExceptT $ rcDecrypt rc smks msg
 
-encrypt :: AlgorithmI a => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)
+encrypt :: AlgorithmI a => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)
 encrypt = withTVar encrypt_
 
-decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))
+decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))
 decrypt = withTVar decrypt_
 
 withTVar ::
   AlgorithmI a =>
-  ((TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) ->
-  TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) ->
+  ((Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) ->
+  TVar (Ratchet a, SkippedMsgKeys) ->
   ByteString ->
   IO (Either e r)
-withTVar op rcVar msg = do
-  (g, rc, smks) <- readTVarIO rcVar
-  applyDiff smks <$$> (testEncodeDecode rc >> op (g, rc, smks) msg)
+withTVar op rcVar msg =
+  readTVarIO rcVar
+    >>= (\(rc, smks) -> applyDiff smks <$$> (testEncodeDecode rc >> op (rc, smks) msg))
     >>= \case
-      Right (res, rc', smks') -> atomically (writeTVar rcVar (g, rc', smks')) >> pure (Right res)
+      Right (res, rc', smks') -> atomically (writeTVar rcVar (rc', smks')) >> pure (Right res)
       Left e -> pure $ Left e
   where
     applyDiff smks (res, rc', smDiff) = (res, rc', applySMDiff smks smDiff)

tests/AgentTests/FunctionalAPITests.hs

@@ -36,7 +36,6 @@ import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchet
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad
 import Control.Monad.Except
-import Control.Monad.Reader
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (isRight)
@@ -47,15 +46,13 @@ import qualified Data.Set as S
 import Data.Time.Clock (diffUTCTime, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Type.Equality
-import qualified Database.SQLite.Simple as SQL
 import SMPAgentClient
 import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
 import Simplex.Messaging.Agent.Protocol as Agent
-import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
-import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
 import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -76,12 +73,9 @@ type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e)
 a ##> t = withTimeout a (`shouldBe` t)
 
 (=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (a -> Bool) -> m ()
-a =##> p =
-  withTimeout a $ \r -> do
-    unless (p r) $ liftIO $ putStrLn $ "value failed predicate: " <> show r
-    r `shouldSatisfy` p
+a =##> p = withTimeout a (`shouldSatisfy` p)
 
-withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (a -> Expectation) -> m ()
+withTimeout :: MonadUnliftIO m => m a -> (a -> Expectation) -> m ()
 withTimeout a test =
   timeout 10_000000 a >>= \case
     Nothing -> error "operation timed out"
@@ -117,48 +111,35 @@ pGet c = do
 pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
-pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> ACommand 'Agent e
-pattern MsgErr msgId err msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err} _ msgBody
-
 pattern Rcvd :: AgentMsgId -> ACommand 'Agent e
 pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
 
 smpCfgVPrev :: ProtocolClientConfig
-smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
-
-smpCfgV1 :: ProtocolClientConfig
-smpCfgV1 = (smpCfg agentCfg) {serverVRange = v1Range}
+smpCfgVPrev = (smpCfg agentCfg) {serverVRange = serverVRangePrev}
+  where
+    serverVRangePrev = prevRange $ serverVRange $ smpCfg agentCfg
 
 agentCfgVPrev :: AgentConfig
 agentCfgVPrev =
   agentCfg
-    { smpAgentVRange = prevRange $ smpAgentVRange agentCfg,
-      smpClientVRange = prevRange $ smpClientVRange agentCfg,
-      e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg,
+    { smpAgentVRange = smpAgentVRangePrev,
+      smpClientVRange = smpClientVRangePrev,
+      e2eEncryptVRange = e2eEncryptVRangePrev,
       smpCfg = smpCfgVPrev
     }
-
-agentCfgV1 :: AgentConfig
-agentCfgV1 =
-  agentCfg
-    { smpAgentVRange = v1Range,
-      smpClientVRange = v1Range,
-      e2eEncryptVRange = v1Range,
-      smpCfg = smpCfgV1
-    }
+  where
+    smpAgentVRangePrev = prevRange $ smpAgentVRange agentCfg
+    smpClientVRangePrev = prevRange $ smpClientVRange agentCfg
+    e2eEncryptVRangePrev = prevRange $ e2eEncryptVRange agentCfg
 
 agentCfgRatchetVPrev :: AgentConfig
-agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg}
-
-agentCfgRatchetV1 :: AgentConfig
-agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = v1Range}
+agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = e2eEncryptVRangePrev}
+  where
+    e2eEncryptVRangePrev = prevRange $ e2eEncryptVRange agentCfg
 
 prevRange :: VersionRange -> VersionRange
 prevRange vr = vr {maxVersion = maxVersion vr - 1}
 
-v1Range :: VersionRange
-v1Range = mkVersionRange 1 1
-
 runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation
 runRight_ action = runExceptT action `shouldReturn` Right ()
 
@@ -169,18 +150,15 @@ runRight action =
     Left e -> error $ "Unexpected error: " <> show e
 
 getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation
-getInAnyOrder c = inAnyOrder (pGet c)
-
-inAnyOrder :: (Show a, MonadIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
-inAnyOrder _ [] = pure ()
-inAnyOrder g rs = do
-  r <- g
+getInAnyOrder _ [] = pure ()
+getInAnyOrder c rs = do
+  r <- pGet c
   let rest = filter (not . expected r) rs
   if length rest < length rs
-    then inAnyOrder g rest
+    then getInAnyOrder c rest
     else error $ "unexpected event: " <> show r
   where
-    expected :: a -> (a -> Bool) -> Bool
+    expected :: ATransmission 'Agent -> (ATransmission 'Agent -> Bool) -> Bool
     expected r rp = rp r
 
 functionalAPITests :: ATransport -> Spec
@@ -189,8 +167,6 @@ functionalAPITests t = do
     testMatrix2 t runAgentClientTest
     it "should connect when server with multiple identities is stored" $
       withSmpServer t testServerMultipleIdentities
-    it "should connect with two peers" $
-      withSmpServer t testAgentClient3
   describe "Establishing duplex connection v2, different Ratchet versions" $
     testRatchetMatrix2 t runAgentClientTest
   describe "Establish duplex connection via contact address" $
@@ -224,11 +200,6 @@ functionalAPITests t = do
       testDuplicateMessage t
     it "should report error via msg integrity on skipped messages" $
       testSkippedMessages t
-    describe "message expiration" $ do
-      it "should expire one message" $ testExpireMessage t
-      it "should expire multiple messages" $ testExpireManyMessages t
-      it "should expire one message if quota is exceeded" $ testExpireMessageQuota t
-      it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota t
     describe "Ratchet synchronization" $ do
       it "should report ratchet de-synchronization, synchronize ratchets" $
         testRatchetSync t
@@ -244,10 +215,8 @@ functionalAPITests t = do
       it "messages delivered only when polled" $
         withSmpServer t testOnlyCreatePull
   describe "Inactive client disconnection" $ do
-    it "should disconnect clients without subs if they were inactive longer than TTL" $
-      testInactiveNoSubs t
-    it "should NOT disconnect inactive clients when they have subscriptions" $
-      testInactiveWithSubs t
+    it "should disconnect clients if it was inactive longer than TTL" $
+      testInactiveClientDisconnected t
     it "should NOT disconnect active clients" $
       testActiveClientNotDisconnected t
   describe "Suspending agent" $ do
@@ -367,9 +336,6 @@ testMatrix2 t runTest = do
   it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 runTest
   it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 runTest
   it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 runTest
-  it "v1" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfgV1 4 runTest
-  it "v1 to current" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfg 4 runTest
-  it "current to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgV1 4 runTest
 
 testRatchetMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testRatchetMatrix2 t runTest = do
@@ -377,9 +343,6 @@ testRatchetMatrix2 t runTest = do
   it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 runTest
   it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 runTest
   it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 runTest
-  it "ratchet v1" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfgRatchetV1 3 runTest
-  it "ratchets v1 to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfg 3 runTest
-  it "ratchets current to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetV1 3 runTest
 
 testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
 testServerMatrix2 t runTest = do
@@ -392,8 +355,8 @@ runTestCfg2 aCfg bCfg baseMsgId runTest =
 
 withAgentClientsCfg2 :: AgentConfig -> AgentConfig -> (AgentClient -> AgentClient -> IO ()) -> IO ()
 withAgentClientsCfg2 aCfg bCfg runTest = do
-  a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 bCfg initAgentServers testDB2
+  a <- getSMPAgentClient' aCfg initAgentServers testDB
+  b <- getSMPAgentClient' bCfg initAgentServers testDB2
   runTest a b
   disconnectAgentClient a
   disconnectAgentClient b
@@ -402,7 +365,7 @@ withAgentClients2 :: (AgentClient -> AgentClient -> IO ()) -> IO ()
 withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg
 
 runAgentClientTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
-runAgentClientTest alice bob baseId =
+runAgentClientTest alice bob baseId = do
   runRight_ $ do
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
@@ -436,34 +399,8 @@ runAgentClientTest alice bob baseId =
   where
     msgId = subtract baseId
 
-testAgentClient3 :: HasCallStack => IO ()
-testAgentClient3 = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
-  runRight_ $ do
-    (aIdForB, bId) <- makeConnection a b
-    (aIdForC, cId) <- makeConnection a c
-
-    4 <- sendMessage a bId SMP.noMsgFlags "b4"
-    4 <- sendMessage a cId SMP.noMsgFlags "c4"
-    5 <- sendMessage a bId SMP.noMsgFlags "b5"
-    5 <- sendMessage a cId SMP.noMsgFlags "c5"
-    get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False
-    get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False
-    get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False
-    get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False
-    get b =##> \case ("", connId, Msg "b4") -> connId == aIdForB; _ -> False
-    ackMessage b aIdForB 4 Nothing
-    get b =##> \case ("", connId, Msg "b5") -> connId == aIdForB; _ -> False
-    ackMessage b aIdForB 5 Nothing
-    get c =##> \case ("", connId, Msg "c4") -> connId == aIdForC; _ -> False
-    ackMessage c aIdForC 4 Nothing
-    get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False
-    ackMessage c aIdForC 5 Nothing
-
 runAgentClientContactTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
-runAgentClientContactTest alice bob baseId =
+runAgentClientContactTest alice bob baseId = do
   runRight_ $ do
     (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe
     aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
@@ -513,7 +450,7 @@ testAsyncInitiatingOffline =
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     disconnectAgentClient alice
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
-    alice' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB
+    alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB
     subscribeConnection alice' bobId
     ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
@@ -530,7 +467,7 @@ testAsyncJoiningOfflineBeforeActivation =
     disconnectAgentClient bob
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+    bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2
     subscribeConnection bob' aliceId
     get alice ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -544,11 +481,11 @@ testAsyncBothOffline =
     disconnectAgentClient alice
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     disconnectAgentClient bob
-    alice' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB
+    alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB
     subscribeConnection alice' bobId
     ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient' 4 agentCfg initAgentServers testDB2
+    bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2
     subscribeConnection bob' aliceId
     get alice' ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -582,6 +519,9 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do
 testAsyncHelloTimeout :: HasCallStack => IO ()
 testAsyncHelloTimeout = do
   -- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
+  let vr11 = mkVersionRange 1 1
+      smpCfgV1 = (smpCfg agentCfg) {serverVRange = vr11}
+      agentCfgV1 = agentCfg {smpAgentVRange = vr11, smpClientVRange = vr11, e2eEncryptVRange = vr11, smpCfg = smpCfgV1}
   withAgentClientsCfg2 agentCfgV1 agentCfg {helloTimeout = 1} $ \alice bob -> runRight_ $ do
     (_, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     disconnectAgentClient alice
@@ -591,8 +531,8 @@ testAsyncHelloTimeout = do
 testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO ()
 testAllowConnectionClientRestart t = do
   let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]}
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServersSrv2 testDB2
   withSmpServerStoreLogOn t testPort $ \_ -> do
     (aliceId, bobId, confId) <-
       withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
@@ -606,13 +546,13 @@ testAllowConnectionClientRestart t = do
 
     runRight_ $ do
       allowConnectionAsync alice "1" bobId confId "alice's connInfo"
-      get alice =##> \case ("1", _, OK) -> True; _ -> False
+      ("1", _, OK) <- get alice
       pure ()
 
     threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation)
     disconnectAgentClient alice
 
-    alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+    alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
 
     withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
       runRight $ do
@@ -630,8 +570,8 @@ testAllowConnectionClientRestart t = do
 
 testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO ()
 testIncreaseConnAgentVersion t = do
-  alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ do
       (aliceId, bobId) <- makeConnection alice bob
@@ -643,7 +583,7 @@ testIncreaseConnAgentVersion t = do
     -- version doesn't increase if incompatible
 
     disconnectAgentClient alice
-    alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+    alice2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
 
     runRight_ $ do
       subscribeConnection alice2 bobId
@@ -654,7 +594,7 @@ testIncreaseConnAgentVersion t = do
     -- version increases if compatible
 
     disconnectAgentClient bob
-    bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
+    bob2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
 
     runRight_ $ do
       subscribeConnection bob2 aliceId
@@ -665,7 +605,7 @@ testIncreaseConnAgentVersion t = do
     -- version doesn't decrease, even if incompatible
 
     disconnectAgentClient alice2
-    alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB
+    alice3 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB
 
     runRight_ $ do
       subscribeConnection alice3 bobId
@@ -674,7 +614,7 @@ testIncreaseConnAgentVersion t = do
       checkVersion bob2 aliceId 3
 
     disconnectAgentClient bob2
-    bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2
+    bob3 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2
 
     runRight_ $ do
       subscribeConnection bob3 aliceId
@@ -691,8 +631,8 @@ checkVersion c connId v = do
 
 testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO ()
 testIncreaseConnAgentVersionMaxCompatible t = do
-  alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ do
       (aliceId, bobId) <- makeConnection alice bob
@@ -704,9 +644,9 @@ testIncreaseConnAgentVersionMaxCompatible t = do
     -- version increases to max compatible
 
     disconnectAgentClient alice
-    alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+    alice2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
     disconnectAgentClient bob
-    bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB2
+    bob2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB2
 
     runRight_ $ do
       subscribeConnection alice2 bobId
@@ -719,8 +659,8 @@ testIncreaseConnAgentVersionMaxCompatible t = do
 
 testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO ()
 testIncreaseConnAgentVersionStartDifferentVersion t = do
-  alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ do
       (aliceId, bobId) <- makeConnection alice bob
@@ -732,7 +672,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do
     -- version increases to max compatible
 
     disconnectAgentClient alice
-    alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+    alice2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
 
     runRight_ $ do
       subscribeConnection alice2 bobId
@@ -744,8 +684,8 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do
 
 testDeliverClientRestart :: HasCallStack => ATransport -> IO ()
 testDeliverClientRestart t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
 
   (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight $ do
@@ -760,7 +700,7 @@ testDeliverClientRestart t = do
 
   disconnectAgentClient bob
 
-  bob2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
 
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight_ $ do
@@ -775,8 +715,8 @@ testDeliverClientRestart t = do
 
 testDuplicateMessage :: HasCallStack => ATransport -> IO ()
 testDuplicateMessage t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ makeConnection alice bob
     runRight_ $ do
@@ -786,7 +726,7 @@ testDuplicateMessage t = do
     disconnectAgentClient bob
 
     -- if the agent user did not send ACK, the message will be delivered again
-    bob1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+    bob1 <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ $ do
       subscribeConnection bob1 aliceId
       get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
@@ -802,13 +742,13 @@ testDuplicateMessage t = do
   -- commenting two lines below and uncommenting further two lines would also runRight_,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
-  Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 5 Nothing
+  Left (BROKER _ TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5 Nothing
 
   disconnectAgentClient alice
   disconnectAgentClient bob1
 
-  alice2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB
-  bob2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB2
+  alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
 
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight_ $ do
@@ -825,8 +765,8 @@ testDuplicateMessage t = do
 
 testSkippedMessages :: HasCallStack => ATransport -> IO ()
 testSkippedMessages t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ makeConnection alice bob
     runRight_ $ do
@@ -852,8 +792,8 @@ testSkippedMessages t = do
 
   disconnectAgentClient alice
 
-  alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
-  bob2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
+  alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
 
   withSmpServerStoreLogOn t testPort $ \_ -> do
     runRight_ $ do
@@ -872,102 +812,6 @@ testSkippedMessages t = do
   disconnectAgentClient alice2
   disconnectAgentClient bob2
 
-testExpireMessage :: HasCallStack => ATransport -> IO ()
-testExpireMessage t = do
-  a <- getSMPAgentClient' 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b
-  nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
-  nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
-  4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1"
-  threadDelay 1000000
-  5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire
-  get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False
-    withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False
-    ackMessage b aId 4 Nothing
-
-testExpireManyMessages :: HasCallStack => ATransport -> IO ()
-testExpireManyMessages t = do
-  a <- getSMPAgentClient' 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b
-  runRight_ $ do
-    nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
-    nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
-    4 <- sendMessage a bId SMP.noMsgFlags "1"
-    5 <- sendMessage a bId SMP.noMsgFlags "2"
-    6 <- sendMessage a bId SMP.noMsgFlags "3"
-    liftIO $ threadDelay 1000000
-    7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire
-    get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False
-    get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False
-    withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False
-    ackMessage b aId 4 Nothing
-
-withUP :: AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO ()
-withUP a bId p =
-  liftIO $
-    getInAnyOrder
-      a
-      [ \case ("", "", APC SAENone (UP _ [c])) -> c == bId; _ -> False,
-        \case (corrId, c, APC SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
-      ]
-
-testExpireMessageQuota :: HasCallStack => ATransport -> IO ()
-testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do
-  a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aId, bId) <- runRight $ do
-    (aId, bId) <- makeConnection a b
-    liftIO $ threadDelay 500000
-    disconnectAgentClient b
-    4 <- sendMessage a bId SMP.noMsgFlags "1"
-    get a ##> ("", bId, SENT 4)
-    5 <- sendMessage a bId SMP.noMsgFlags "2"
-    liftIO $ threadDelay 1000000
-    6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire
-    get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False
-    pure (aId, bId)
-  b' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
-  runRight_ $ do
-    subscribeConnection b' aId
-    get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
-    ackMessage b' aId 4 Nothing
-    get a ##> ("", bId, SENT 6)
-    get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False
-    ackMessage b' aId 6 Nothing
-
-testExpireManyMessagesQuota :: HasCallStack => ATransport -> IO ()
-testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do
-  a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aId, bId) <- runRight $ do
-    (aId, bId) <- makeConnection a b
-    liftIO $ threadDelay 500000
-    disconnectAgentClient b
-    4 <- sendMessage a bId SMP.noMsgFlags "1"
-    get a ##> ("", bId, SENT 4)
-    5 <- sendMessage a bId SMP.noMsgFlags "2"
-    6 <- sendMessage a bId SMP.noMsgFlags "3"
-    7 <- sendMessage a bId SMP.noMsgFlags "4"
-    liftIO $ threadDelay 1000000
-    8 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire
-    get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False
-    get a =##> \case ("", c, MERRS [6, 7] (SMP QUOTA)) -> bId == c; _ -> False
-    pure (aId, bId)
-  b' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
-  runRight_ $ do
-    subscribeConnection b' aId
-    get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
-    ackMessage b' aId 4 Nothing
-    get a ##> ("", bId, SENT 8)
-    get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False
-    ackMessage b' aId 6 Nothing
-
 testRatchetSync :: HasCallStack => ATransport -> IO ()
 testRatchetSync t = withAgentClients2 $ \alice bob ->
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
@@ -1012,7 +856,7 @@ setupDesynchronizedRatchet alice bob = do
   -- importing database backup after progressing ratchet de-synchronizes ratchet
   liftIO $ renameFile (testDB2 <> ".bak") testDB2
 
-  bob2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
 
   runRight_ $ do
     subscribeConnection bob2 aliceId
@@ -1072,8 +916,8 @@ serverUpP = \case
 
 testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO ()
 testRatchetSyncClientRestart t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
     setupDesynchronizedRatchet alice bob
   ("", "", DOWN _ _) <- nGet alice
@@ -1081,7 +925,7 @@ testRatchetSyncClientRestart t = do
   ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId False
   liftIO $ ratchetSyncState `shouldBe` RSStarted
   disconnectAgentClient bob2
-  bob3 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+  bob3 <- getSMPAgentClient' agentCfg initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight_ $ do
       ("", "", UP _ _) <- nGet alice
@@ -1097,8 +941,8 @@ testRatchetSyncClientRestart t = do
 
 testRatchetSyncSuspendForeground :: HasCallStack => ATransport -> IO ()
 testRatchetSyncSuspendForeground t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
     setupDesynchronizedRatchet alice bob
 
@@ -1131,8 +975,8 @@ testRatchetSyncSuspendForeground t = do
 
 testRatchetSyncSimultaneous :: HasCallStack => ATransport -> IO ()
 testRatchetSyncSimultaneous t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
     setupDesynchronizedRatchet alice bob
 
@@ -1210,33 +1054,21 @@ makeConnectionForUsers alice aliceUserId bob bobUserId = do
   get bob ##> ("", aliceId, CON)
   pure (aliceId, bobId)
 
-testInactiveNoSubs :: ATransport -> IO ()
-testInactiveNoSubs t = do
+testInactiveClientDisconnected :: ATransport -> IO ()
+testInactiveClientDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
-    alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check
-    Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice)
-    Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
-    disconnectAgentClient alice
-
-testInactiveWithSubs :: ATransport -> IO ()
-testInactiveWithSubs t = do
-  let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
-  withSmpServerConfigOn t cfg' testPort $ \_ -> do
-    alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    Nothing <- 800000 `timeout` get alice
-    liftIO $ threadDelay 1200000
-    -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
-    liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
+    alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ do
+      (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
+      nGet alice ##> ("", "", DOWN testSMPServer [connId])
     disconnectAgentClient alice
 
 testActiveClientNotDisconnected :: ATransport -> IO ()
 testActiveClientNotDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
-    alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    alice <- getSMPAgentClient' agentCfg initAgentServers testDB
     ts <- getSystemTime
     runRight_ $ do
       (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -1256,8 +1088,8 @@ testActiveClientNotDisconnected t = do
           -- check that nothing is sent from agent
           Nothing <- 800000 `timeout` get alice
           liftIO $ threadDelay 1200000
-          -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
-          liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
+          -- and after 2 sec of inactivity DOWN is sent
+          nGet alice ##> ("", "", DOWN testSMPServer [connId])
     milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
 
 testSuspendingAgent :: IO ()
@@ -1327,8 +1159,8 @@ testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do
 
 testBatchedSubscriptions :: Int -> Int -> ATransport -> IO ()
 testBatchedSubscriptions nCreate nDel t = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2
+  a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
   conns <- runServers $ do
     conns <- replicateM (nCreate :: Int) $ makeConnection a b
     forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
@@ -1402,7 +1234,7 @@ testAsyncCommands =
     liftIO $ aliceId' `shouldBe` aliceId
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnectionAsync alice "3" bobId confId "alice's connInfo"
-    get alice =##> \case ("3", _, OK) -> True; _ -> False
+    ("3", _, OK) <- get alice
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
@@ -1413,26 +1245,20 @@ testAsyncCommands =
     get alice ##> ("", bobId, SENT $ baseId + 2)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
     ackMessageAsync bob "4" aliceId (baseId + 1) Nothing
-    inAnyOrder
-      (get bob)
-      [ \case ("4", _, OK) -> True; _ -> False,
-        \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-      ]
+    ("4", _, OK) <- get bob
+    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
     ackMessageAsync bob "5" aliceId (baseId + 2) Nothing
-    get bob =##> \case ("5", _, OK) -> True; _ -> False
+    ("5", _, OK) <- get bob
     3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
     4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
     get bob ##> ("", aliceId, SENT $ baseId + 4)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
     ackMessageAsync alice "6" bobId (baseId + 3) Nothing
-    inAnyOrder
-      (get alice)
-      [ \case ("6", _, OK) -> True; _ -> False,
-        \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-      ]
+    ("6", _, OK) <- get alice
+    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
     ackMessageAsync alice "7" bobId (baseId + 4) Nothing
-    get alice =##> \case ("7", _, OK) -> True; _ -> False
+    ("7", _, OK) <- get alice
     deleteConnectionAsync alice bobId
     get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False
     get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False
@@ -1443,15 +1269,15 @@ testAsyncCommands =
 
 testAsyncCommandsRestore :: ATransport -> IO ()
 testAsyncCommandsRestore t = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
   bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation SMSubscribe
   liftIO $ noMessages alice "alice doesn't receive INV because server is down"
   disconnectAgentClient alice
-  alice' <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB
+  alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB
   withSmpServerStoreLogOn t testPort $ \_ -> do
     runRight_ $ do
       subscribeConnection alice' bobId
-      get alice' =##> \case ("1", _, INV _) -> True; _ -> False
+      ("1", _, INV _) <- get alice'
       pure ()
   disconnectAgentClient alice'
 
@@ -1462,7 +1288,8 @@ testAcceptContactAsync =
     aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     ("", _, REQ invId _ "bob's connInfo") <- get alice
     bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" SMSubscribe
-    get alice =##> \case ("1", c, OK) -> c == bobId; _ -> False
+    ("1", bobId', OK) <- get alice
+    liftIO $ bobId' `shouldBe` bobId
     ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
     get alice ##> ("", bobId, INFO "bob's connInfo")
@@ -1496,7 +1323,7 @@ testAcceptContactAsync =
 
 testDeleteConnectionAsync :: ATransport -> IO ()
 testDeleteConnectionAsync t = do
-  a <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
+  a <- getSMPAgentClient' agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
   connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe
     (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe
@@ -1516,8 +1343,8 @@ testDeleteConnectionAsync t = do
 testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO ()
 testJoinConnectionAsyncReplyError t = do
   let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]}
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServersSrv2 testDB2
   (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     bId <- createConnectionAsync a 1 "1" True SCMInvitation SMSubscribe
     ("1", bId', INV (ACR _ qInfo)) <- get a
@@ -1528,7 +1355,8 @@ testJoinConnectionAsyncReplyError t = do
     pure (aId, bId)
   nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
   withSmpServerOn t testPort2 $ do
-    get b =##> \case ("2", c, OK) -> c == aId; _ -> False
+    ("2", aId', OK) <- get b
+    liftIO $ aId' `shouldBe` aId
     confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
       pGet a >>= \case
         ("", "", APC _ (UP _ [_])) -> do
@@ -1608,8 +1436,8 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
 
 testSwitchConnection :: InitialAgentServers -> IO ()
 testSwitchConnection servers = do
-  a <- getSMPAgentClient' 1 agentCfg servers testDB
-  b <- getSMPAgentClient' 2 agentCfg servers testDB2
+  a <- getSMPAgentClient' agentCfg servers testDB
+  b <- getSMPAgentClient' agentCfg {initialClientId = 1} servers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -1692,12 +1520,12 @@ testSwitchAsync servers = do
     testFullSwitch a bId b aId 16
   where
     withA :: (AgentClient -> IO a) -> IO a
-    withA = withAgent 1 agentCfg servers testDB
+    withA = withAgent agentCfg servers testDB
     withB :: (AgentClient -> IO a) -> IO a
-    withB = withAgent 2 agentCfg servers testDB2
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
-withAgent :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> (AgentClient -> IO a) -> IO a
-withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) disconnectAgentClient
+withAgent :: AgentConfig -> InitialAgentServers -> FilePath -> (AgentClient -> IO a) -> IO a
+withAgent cfg' servers dbPath = bracket (getSMPAgentClient' cfg' servers dbPath) disconnectAgentClient
 
 sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
 sessionSubscribe withC connIds a =
@@ -1710,8 +1538,8 @@ sessionSubscribe withC connIds a =
 
 testSwitchDelete :: InitialAgentServers -> IO ()
 testSwitchDelete servers = do
-  a <- getSMPAgentClient' 1 agentCfg servers testDB
-  b <- getSMPAgentClient' 2 agentCfg servers testDB2
+  a <- getSMPAgentClient' agentCfg servers testDB
+  b <- getSMPAgentClient' agentCfg {initialClientId = 1} servers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -1773,9 +1601,9 @@ testAbortSwitchStarted servers = do
     testFullSwitch a bId b aId 18
   where
     withA :: (AgentClient -> IO a) -> IO a
-    withA = withAgent 1 agentCfg servers testDB
+    withA = withAgent agentCfg servers testDB
     withB :: (AgentClient -> IO a) -> IO a
-    withB = withAgent 2 agentCfg servers testDB2
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
 testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO ()
 testAbortSwitchStartedReinitiate servers = do
@@ -1824,9 +1652,9 @@ testAbortSwitchStartedReinitiate servers = do
     testFullSwitch a bId b aId 18
   where
     withA :: (AgentClient -> IO a) -> IO a
-    withA = withAgent 1 agentCfg servers testDB
+    withA = withAgent agentCfg servers testDB
     withB :: (AgentClient -> IO a) -> IO a
-    withB = withAgent 2 agentCfg servers testDB2
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
 switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission 'Agent -> Bool
 switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
@@ -1878,9 +1706,9 @@ testCannotAbortSwitchSecured servers = do
     testFullSwitch a bId b aId 16
   where
     withA :: (AgentClient -> IO a) -> IO a
-    withA = withAgent 1 agentCfg servers testDB
+    withA = withAgent agentCfg servers testDB
     withB :: (AgentClient -> IO a) -> IO a
-    withB = withAgent 2 agentCfg servers testDB2
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
 testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO ()
 testSwitch2Connections servers = do
@@ -1936,9 +1764,9 @@ testSwitch2Connections servers = do
     testFullSwitch a bId2 b aId2 16
   where
     withA :: (AgentClient -> IO a) -> IO a
-    withA = withAgent 1 agentCfg servers testDB
+    withA = withAgent agentCfg servers testDB
     withB :: (AgentClient -> IO a) -> IO a
-    withB = withAgent 2 agentCfg servers testDB2
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
 testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO ()
 testSwitch2ConnectionsAbort1 servers = do
@@ -1989,14 +1817,14 @@ testSwitch2ConnectionsAbort1 servers = do
     testFullSwitch a bId2 b aId2 14
   where
     withA :: (AgentClient -> IO a) -> IO a
-    withA = withAgent 1 agentCfg servers testDB
+    withA = withAgent agentCfg servers testDB
     withB :: (AgentClient -> IO a) -> IO a
-    withB = withAgent 2 agentCfg servers testDB2
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
 testCreateQueueAuth :: HasCallStack => (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
 testCreateQueueAuth clnt1 clnt2 = do
-  a <- getClient 1 clnt1 testDB
-  b <- getClient 2 clnt2 testDB2
+  a <- getClient clnt1
+  b <- getClient clnt2
   r <- runRight $ do
     tryError (createConnection a 1 True SCMInvitation Nothing SMSubscribe) >>= \case
       Left (SMP AUTH) -> pure 0
@@ -2017,15 +1845,15 @@ testCreateQueueAuth clnt1 clnt2 = do
   disconnectAgentClient b
   pure r
   where
-    getClient clientId (clntAuth, clntVersion) db =
+    getClient (clntAuth, clntVersion) =
       let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]}
           smpCfg = (defaultClientConfig :: ProtocolClientConfig) {serverVRange = mkVersionRange 4 clntVersion}
-       in getSMPAgentClient' clientId agentCfg {smpCfg} servers db
+       in getSMPAgentClient' agentCfg {smpCfg} servers testDB
 
 testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testSMPServerConnectionTest t newQueueBasicAuth srv =
   withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do
-    a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running
+    a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
     runRight $ testProtocolServer a 1 srv
 
 testRatchetAdHash :: HasCallStack => IO ()
@@ -2058,8 +1886,8 @@ testDeliveryReceipts =
 
 testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO ()
 testDeliveryReceiptsVersion t = do
-  a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
+  a <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aId, bId) <- runRight $ do
       (aId, bId) <- makeConnection a b
@@ -2079,8 +1907,8 @@ testDeliveryReceiptsVersion t = do
 
     disconnectAgentClient a
     disconnectAgentClient b
-    a' <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB
-    b' <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB2
+    a' <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB
+    b' <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB2
 
     runRight_ $ do
       subscribeConnection a' bId
@@ -2220,12 +2048,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
     hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
 
-getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient
-getSMPAgentClient' clientId cfg' initServers dbPath = do
+getSMPAgentClient' :: AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient
+getSMPAgentClient' cfg' initServers dbPath = do
   Right st <- liftIO $ createAgentStore dbPath "" False MCError
-  c <- getSMPAgentClient_ clientId cfg' initServers st False
-  when (dbNew st) $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)")
-  pure c
+  getSMPAgentClient cfg' initServers st
 
 testServerMultipleIdentities :: HasCallStack => IO ()
 testServerMultipleIdentities =
@@ -2241,7 +2067,7 @@ testServerMultipleIdentities =
     -- this saves queue with second server identity
     Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe
     disconnectAgentClient bob
-    bob' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+    bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2
     subscribeConnection bob' aliceId
     exchangeGreetingsMsgId 6 alice bobId bob' aliceId
   where

tests/AgentTests/NotificationTests.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -11,10 +10,9 @@ module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
 import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, getSMPAgentClient', makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
-import Control.Concurrent (ThreadId, killThread, threadDelay)
+import Control.Concurrent (killThread, threadDelay)
 import Control.Monad
 import Control.Monad.Except
-import Control.Monad.Reader (runReaderT)
 import Control.Monad.Trans.Except
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
@@ -23,19 +21,17 @@ import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
-import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer2)
+import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2)
 import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit')
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Client (withStore')
-import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers)
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Types (NtfToken (..))
-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
+import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..), SubscriptionMode (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Transport (ATransport)
@@ -64,12 +60,6 @@ notificationTests t =
       it "should re-register token when notification server is restarted" $ \_ ->
         withAPNSMockServer $ \apns ->
           testNtfTokenServerRestart t apns
-      it "should work with multiple configured servers" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenMultipleServers t apns
-      it "should keep working with active token until replaced" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenChangeServers t apns
     describe "Managing notification subscriptions" $ do
       -- fails on Ubuntu CI?
       xit' "should create notification subscription for existing connection" $ \_ -> do
@@ -105,23 +95,13 @@ notificationTests t =
       testServerMatrix2 t $ \servers ->
         withAPNSMockServer $ \apns ->
           withNtfServer t $ testSwitchNotifications servers apns
-    it "should keep sending notifications for old token" $
-      withSmpServer t $
-        withAPNSMockServer $ \apns ->
-          withNtfServerOn t ntfTestPort $
-            testNotificationsOldToken apns
-    it "should update server from new token" $
-      withSmpServer t $
-        withAPNSMockServer $ \apns ->
-          withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf ->
-            testNotificationsNewToken apns ntf
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
-    (NTRegistered, _) <- registerNtfToken a tkn NMPeriodic
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
@@ -146,16 +126,16 @@ testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
-    (NTRegistered, _) <- registerNtfToken a tkn NMPeriodic
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     liftIO $ sendApnsResponse APNSRespOk
-    (NTRegistered, _) <- registerNtfToken a tkn NMPeriodic
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     _ <- ntfData' .-> "verification"
@@ -170,11 +150,11 @@ testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  a' <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
-    (NTRegistered, _) <- registerNtfToken a tkn NMPeriodic
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
@@ -182,7 +162,7 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
     liftIO $ sendApnsResponse APNSRespOk
     verifyNtfToken a tkn nonce verification
 
-    (NTRegistered, _) <- registerNtfToken a' tkn NMPeriodic
+    NTRegistered <- registerNtfToken a' tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
       atomically $ readTBQueue apnsQ
     verification' <- ntfData' .-> "verification"
@@ -205,10 +185,10 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
   let tkn = DeviceToken PPApnsTest "abcd"
   ntfData <- withNtfServer t . runRight $ do
-    (NTRegistered, _) <- registerNtfToken a tkn NMPeriodic
+    NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     liftIO $ sendApnsResponse APNSRespOk
@@ -216,7 +196,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
   threadDelay 1000000
   disconnectAgentClient a
-  a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
+  a' <- getSMPAgentClient' agentCfg initAgentServers testDB
   -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
   -- so that repeat verification happens without restarting the clients, when notification arrives
   withNtfServer t . runRight_ $ do
@@ -232,72 +212,10 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
     NTActive <- checkNtfToken a' tkn
     disconnectAgentClient a'
 
-getTestNtfTokenPort :: (MonadUnliftIO m, MonadError AgentErrorType m) => AgentClient -> m String
-getTestNtfTokenPort a =
-  runReaderT (withStore' a getSavedNtfToken) (agentEnv a) >>= \case
-    Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port
-    Nothing -> error "no active NtfToken"
-
-testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do
-  let tkn = DeviceToken PPApnsTest "abcd"
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
-  withNtfServerThreadOn t ntfTestPort $ \ntf ->
-    withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
-      -- register a new token, the agent picks a server and stores its choice
-      (NTRegistered, _) <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      verification <- ntfData .-> "verification"
-      nonce <- C.cbNonce <$> ntfData .-> "nonce"
-      liftIO $ sendApnsResponse APNSRespOk
-      verifyNtfToken a tkn nonce verification
-      NTActive <- checkNtfToken a tkn
-      -- shut down the "other" server
-      port <- getTestNtfTokenPort a
-      liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf
-      -- still works
-      NTActive <- checkNtfToken a tkn
-      liftIO . killThread $ if port == ntfTestPort then ntf else ntf2
-      -- negative test, the correct server is now gone
-      Left _ <- tryError (checkNtfToken a tkn)
-      pure ()
-
-testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
-testNtfTokenChangeServers t APNSMockServer {apnsQ} =
-  withNtfServerThreadOn t ntfTestPort $ \ntf -> do
-    tkn1 <- runRight $ do
-      a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
-      tkn <- registerTestToken a "abcd" NMInstant apnsQ
-      NTActive <- checkNtfToken a tkn
-      setNtfServers a [testNtfServer2]
-      NTActive <- checkNtfToken a tkn -- still works on old server
-      disconnectAgentClient a
-      pure tkn
-
-    threadDelay 1000000
-
-    a <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB
-    runRight_ $ do
-      getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
-      NTActive <- checkNtfToken a tkn1
-      setNtfServers a [testNtfServer2] -- just change configured server list
-      getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
-      -- trigger token replace
-      tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
-      getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
-      deleteNtfToken a tkn2 -- force server switch
-      Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
-      getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
-    killThread ntf
-    withNtfServerOn t ntfTestPort2 $ runRight_ $ do
-      tkn <- registerTestToken a "qwer" NMInstant apnsQ
-      checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
-
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (bobId, aliceId, nonce, message) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -309,7 +227,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, CON)
     -- register notification token
     let tkn = DeviceToken PPApnsTest "abcd"
-    (NTRegistered, _) <- registerNtfToken alice tkn NMInstant
+    NTRegistered <- registerNtfToken alice tkn NMInstant
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
     verification <- ntfData .-> "verification"
@@ -329,7 +247,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
-  aliceNtf <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+  aliceNtf <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
     pure ()
@@ -354,8 +272,8 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
 
 testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     -- alice registers notification token
     DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -400,9 +318,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
 registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
 registerTestToken a token mode apnsQ = do
   let tkn = DeviceToken PPApnsTest token
-  (NTRegistered, _) <- registerNtfToken a tkn mode
-  Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-    timeout 1000000 . atomically $ readTBQueue apnsQ
+  NTRegistered <- registerNtfToken a tkn mode
+  APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
+    atomically $ readTBQueue apnsQ
   verification' <- ntfData' .-> "verification"
   nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
   liftIO $ sendApnsResponse' APNSRespOk
@@ -412,8 +330,8 @@ registerTestToken a token mode apnsQ = do
 
 testChangeNotificationsMode :: APNSMockServer -> IO ()
 testChangeNotificationsMode APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -433,7 +351,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     -- set mode to NMPeriodic
-    (NTActive, _) <- registerNtfToken alice tkn NMPeriodic
+    NTActive <- registerNtfToken alice tkn NMPeriodic
     -- send message, no notification
     liftIO $ threadDelay 750000
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
@@ -442,7 +360,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 2) Nothing
     -- set mode to NMInstant
-    (NTActive, _) <- registerNtfToken alice tkn NMInstant
+    NTActive <- registerNtfToken alice tkn NMInstant
     -- send message, receive notification
     liftIO $ threadDelay 500000
     3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
@@ -478,8 +396,8 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
 
 testChangeToken :: APNSMockServer -> IO ()
 testChangeToken APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -501,7 +419,7 @@ testChangeToken APNSMockServer {apnsQ} = do
     pure (aliceId, bobId)
   disconnectAgentClient alice
 
-  alice1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+  alice1 <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     subscribeConnection alice1 bobId
     -- change notification token
@@ -523,8 +441,8 @@ testChangeToken APNSMockServer {apnsQ} = do
 
 testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
 testNotificationsStoreLog t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -551,8 +469,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
 
 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -583,13 +501,12 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
 
 testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2
-  threadDelay 1000000
+  a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
   conns <- runServers $ do
     conns <- replicateM (n :: Int) $ makeConnection a b
     _ <- registerTestToken a "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 5000000
+    liftIO $ threadDelay 1500000
     forM_ conns $ \(aliceId, bobId) -> do
       msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
       get b ##> ("", aliceId, SENT msgId)
@@ -632,8 +549,8 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
 
 testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
 testSwitchNotifications servers APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg servers testDB
-  b <- getSMPAgentClient' 2 agentCfg servers testDB2
+  a <- getSMPAgentClient' agentCfg servers testDB
+  b <- getSMPAgentClient' agentCfg {initialClientId = 1} servers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -653,70 +570,9 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
   disconnectAgentClient a
   disconnectAgentClient b
 
-testNotificationsOldToken :: APNSMockServer -> IO ()
-testNotificationsOldToken APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
-  runRight_ $ do
-    (abId, baId) <- makeConnection a b
-    let testMessageAB = testMessage_ apnsQ a abId b baId
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 250000
-    testMessageAB "hello"
-    -- change server
-    setNtfServers a [testNtfServer2] -- server 2 isn't running now, don't use
-    -- replacing token keeps server
-    _ <- registerTestToken a "xyzw" NMInstant apnsQ
-    getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
-    testMessageAB "still there"
-    -- new connections keep server
-    (acId, caId) <- makeConnection a c
-    let testMessageAC = testMessage_ apnsQ a acId c caId
-    testMessageAC "greetings"
-  disconnectAgentClient a
-  disconnectAgentClient b
-  disconnectAgentClient c
-
-testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
-testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
-  runRight_ $ do
-    (abId, baId) <- makeConnection a b
-    let testMessageAB = testMessage_ apnsQ a abId b baId
-    tkn <- registerTestToken a "abcd" NMInstant apnsQ
-    getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
-    liftIO $ threadDelay 250000
-    testMessageAB "hello"
-    -- switch
-    setNtfServers a [testNtfServer2]
-    deleteNtfToken a tkn
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
-    getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort2
-    liftIO $ threadDelay 250000
-    liftIO $ killThread oldNtf
-    -- -- back to work
-    testMessageAB "hello again"
-    (acId, caId) <- makeConnection a c
-    let testMessageAC = testMessage_ apnsQ a acId c caId
-    testMessageAC "greetings"
-  disconnectAgentClient a
-  disconnectAgentClient b
-  disconnectAgentClient c
-
-testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
-testMessage_ apnsQ a aId b bId msg = do
-  msgId <- sendMessage b aId (SMP.MsgFlags True) msg
-  get b ##> ("", aId, SENT msgId)
-  void $ messageNotification apnsQ
-  get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
-  ackMessage a bId msgId Nothing
-
-messageNotification :: HasCallStack => TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
+messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apnsQ = do
-  1000000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+  750000 `timeout` atomically (readTBQueue apnsQ) >>= \case
     Nothing -> error "no notification"
     Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
       nonce <- C.cbNonce <$> ntfData .-> "nonce"

tests/AgentTests/SQLiteTests.hs

@@ -15,6 +15,7 @@ import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Exception (SomeException)
 import Control.Monad (replicateM_)
+import Crypto.Random (drgNew)
 import Data.ByteArray (ScrubbedBytes)
 import Data.ByteString.Char8 (ByteString)
 import Data.List (isInfixOf)
@@ -22,25 +23,16 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time
 import Data.Word (Word32)
-import Database.SQLite.Simple (Only (..))
 import qualified Database.SQLite.Simple as SQL
 import Database.SQLite.Simple.QQ (sql)
 import SMPClient (testKeyHash)
-import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
-import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol
-import Simplex.FileTransfer.Types
 import Simplex.Messaging.Agent.Client ()
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
-import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.File (CryptoFile (..))
-import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Protocol (SubscriptionMode (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import System.Random
 import Test.Hspec
@@ -70,7 +62,6 @@ createEncryptedStore key keepKey = do
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
   Right st <- createSQLiteStore (testDB <> show r) key keepKey Migrations.app MCError
-  withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);")
   pure st
 
 removeStore :: SQLiteStore -> IO ()
@@ -119,16 +110,6 @@ storeTests = do
           testCreateRcvMsg
           testCreateSndMsg
           testCreateRcvAndSndMsgs
-      describe "Work items" $ do
-        it "should getPendingQueueMsg" testGetPendingQueueMsg
-        it "should getPendingServerCommand" testGetPendingServerCommand
-        it "should getNextRcvChunkToDownload" testGetNextRcvChunkToDownload
-        it "should getNextRcvFileToDecrypt" testGetNextRcvFileToDecrypt
-        it "should getNextSndFileToPrepare" testGetNextSndFileToPrepare
-        it "should getNextSndChunkToUpload" testGetNextSndChunkToUpload
-        it "should getNextDeletedSndChunkReplica" testGetNextDeletedSndChunkReplica
-        it "should markNtfSubActionNtfFailed_" testMarkNtfSubActionNtfFailed
-        it "should markNtfSubActionSMPFailed_" testMarkNtfSubActionSMPFailed
   describe "open/close store" $ do
     it "should close and re-open" testCloseReopenStore
     it "should close and re-open encrypted store" testCloseReopenEncryptedStore
@@ -137,17 +118,17 @@ storeTests = do
 testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
 testConcurrentWrites =
   it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do
-    g <- C.newRandom
-    Right (_, rq) <- withTransaction s1 $ \db ->
+    g <- newTVarIO =<< drgNew
+    _ <- withTransaction s1 $ \db ->
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let ConnData {connId} = cData1
-    concurrently_ (runTest s1 connId rq) (runTest s2 connId rq)
+    concurrently_ (runTest s1 connId) (runTest s2 connId)
   where
-    runTest :: SQLiteStore -> ConnId -> RcvQueue -> IO ()
-    runTest st connId rq = replicateM_ 100 . withTransaction st $ \db -> do
+    runTest :: SQLiteStore -> ConnId -> IO ()
+    runTest st connId = replicateM_ 100 . withTransaction st $ \db -> do
       (internalId, internalRcvId, _, _) <- updateRcvIds db connId
       let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
-      createRcvMsg db connId rq rcvMsgData
+      createRcvMsg db connId rcvQueue1 rcvMsgData
 
 testCompiledThreadsafe :: SpecWith SQLiteStore
 testCompiledThreadsafe =
@@ -183,15 +164,12 @@ testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOp
 testDhSecret :: C.DhSecretX25519
 testDhSecret = "01234567890123456789012345678901"
 
-smpServer1 :: SMPServer
-smpServer1 = SMPServer "smp.simplex.im" "5223" testKeyHash
-
-rcvQueue1 :: NewRcvQueue
+rcvQueue1 :: RcvQueue
 rcvQueue1 =
   RcvQueue
     { userId = 1,
       connId = "conn1",
-      server = smpServer1,
+      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       rcvId = "1234",
       rcvPrivateKey = testPrivateSignKey,
       rcvDhSecret = testDhSecret,
@@ -199,7 +177,7 @@ rcvQueue1 =
       e2eDhSecret = Nothing,
       sndId = "2345",
       status = New,
-      dbQueueId = DBNewQueue,
+      dbQueueId = 1,
       primary = True,
       dbReplaceQueueId = Nothing,
       rcvSwchStatus = Nothing,
@@ -208,19 +186,19 @@ rcvQueue1 =
       deleteErrors = 0
     }
 
-sndQueue1 :: NewSndQueue
+sndQueue1 :: SndQueue
 sndQueue1 =
   SndQueue
     { userId = 1,
       connId = "conn1",
-      server = smpServer1,
+      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       sndId = "3456",
       sndPublicKey = Nothing,
       sndPrivateKey = testPrivateSignKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
       status = New,
-      dbQueueId = DBNewQueue,
+      dbQueueId = 1,
       primary = True,
       dbReplaceQueueId = Nothing,
       sndSwchStatus = Nothing,
@@ -230,33 +208,34 @@ sndQueue1 =
 testCreateRcvConn :: SpecWith SQLiteStore
 testCreateRcvConn =
   it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (connId, rq@RcvQueue {dbQueueId}) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    connId `shouldBe` "conn1"
-    dbQueueId `shouldBe` DBQueueId 1
+    g <- newTVarIO =<< drgNew
+    createRcvConn db g cData1 rcvQueue1 SCMInvitation
+      `shouldReturn` Right "conn1"
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
-    Right sq@SndQueue {dbQueueId = dbQueueId'} <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+    upgradeRcvConnToDuplex db "conn1" sndQueue1
+      `shouldReturn` Right 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
 
 testCreateRcvConnRandomId :: SpecWith SQLiteStore
 testCreateRcvConnRandomId =
   it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (connId, rq) <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
+    g <- newTVarIO =<< drgNew
+    Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
+    let rq' = (rcvQueue1 :: RcvQueue) {connId}
+        sq' = (sndQueue1 :: SndQueue) {connId}
     getConn db connId
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq))
-    Right sq@SndQueue {dbQueueId = dbQueueId'} <- upgradeRcvConnToDuplex db connId sndQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq'))
+    upgradeRcvConnToDuplex db connId sndQueue1
+      `shouldReturn` Right 1
     getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq'] [sq']))
 
 testCreateRcvConnDuplicate :: SpecWith SQLiteStore
 testCreateRcvConnDuplicate =
   it "should throw error on attempt to create duplicate RcvConnection" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
+    g <- newTVarIO =<< drgNew
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     createRcvConn db g cData1 rcvQueue1 SCMInvitation
       `shouldReturn` Left SEConnDuplicate
@@ -264,33 +243,34 @@ testCreateRcvConnDuplicate =
 testCreateSndConn :: SpecWith SQLiteStore
 testCreateSndConn =
   it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (connId, sq@SndQueue {dbQueueId}) <- createSndConn db g cData1 sndQueue1
-    connId `shouldBe` "conn1"
-    dbQueueId `shouldBe` DBQueueId 1
+    g <- newTVarIO =<< drgNew
+    createSndConn db g cData1 sndQueue1
+      `shouldReturn` Right "conn1"
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
-    Right rq@RcvQueue {dbQueueId = dbQueueId'} <- upgradeSndConnToDuplex db "conn1" rcvQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
+    upgradeSndConnToDuplex db "conn1" rcvQueue1
+      `shouldReturn` Right 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
 
 testCreateSndConnRandomID :: SpecWith SQLiteStore
 testCreateSndConnRandomID =
   it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (connId, sq) <- createSndConn db g cData1 {connId = ""} sndQueue1
+    g <- newTVarIO =<< drgNew
+    Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1
+    let rq' = (rcvQueue1 :: RcvQueue) {connId}
+        sq' = (sndQueue1 :: SndQueue) {connId}
     getConn db connId
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq))
-    Right (rq@RcvQueue {dbQueueId = dbQueueId'}) <- upgradeSndConnToDuplex db connId rcvQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq'))
+    upgradeSndConnToDuplex db connId rcvQueue1
+      `shouldReturn` Right 1
     getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq'] [sq']))
 
 testCreateSndConnDuplicate :: SpecWith SQLiteStore
 testCreateSndConnDuplicate =
   it "should throw error on attempt to create duplicate SndConnection" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
+    g <- newTVarIO =<< drgNew
     _ <- createSndConn db g cData1 sndQueue1
     createSndConn db g cData1 sndQueue1
       `shouldReturn` Left SEConnDuplicate
@@ -300,18 +280,18 @@ testGetRcvConn =
   it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do
     let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash
     let recipientId = "1234"
-    g <- C.newRandom
-    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    g <- newTVarIO =<< drgNew
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getRcvConn db smpServer recipientId
-      `shouldReturn` Right (rq, SomeConn SCRcv (RcvConnection cData1 rq))
+      `shouldReturn` Right (rcvQueue1, SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
 
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
   it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    g <- newTVarIO =<< drgNew
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
     deleteConn db "conn1"
       `shouldReturn` ()
     getConn db "conn1"
@@ -320,10 +300,10 @@ testDeleteRcvConn =
 testDeleteSndConn :: SpecWith SQLiteStore
 testDeleteSndConn =
   it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (_, sq) <- createSndConn db g cData1 sndQueue1
+    g <- newTVarIO =<< drgNew
+    _ <- createSndConn db g cData1 sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
     deleteConn db "conn1"
       `shouldReturn` ()
     getConn db "conn1"
@@ -332,11 +312,11 @@ testDeleteSndConn =
 testDeleteDuplexConn :: SpecWith SQLiteStore
 testDeleteDuplexConn =
   it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    g <- newTVarIO =<< drgNew
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
     deleteConn db "conn1"
       `shouldReturn` ()
     getConn db "conn1"
@@ -345,7 +325,7 @@ testDeleteDuplexConn =
 testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
 testUpgradeRcvConnToDuplex =
   it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
+    g <- newTVarIO =<< drgNew
     _ <- createSndConn db g cData1 sndQueue1
     let anotherSndQueue =
           SndQueue
@@ -358,7 +338,7 @@ testUpgradeRcvConnToDuplex =
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
               status = New,
-              dbQueueId = DBNewQueue,
+              dbQueueId = 1,
               sndSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -373,7 +353,7 @@ testUpgradeRcvConnToDuplex =
 testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
 testUpgradeSndConnToDuplex =
   it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
+    g <- newTVarIO =<< drgNew
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let anotherRcvQueue =
           RcvQueue
@@ -387,7 +367,7 @@ testUpgradeSndConnToDuplex =
               e2eDhSecret = Nothing,
               sndId = "4567",
               status = New,
-              dbQueueId = DBNewQueue,
+              dbQueueId = 1,
               rcvSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -404,43 +384,43 @@ testUpgradeSndConnToDuplex =
 testSetRcvQueueStatus :: SpecWith SQLiteStore
 testSetRcvQueueStatus =
   it "should update status of RcvQueue" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    g <- newTVarIO =<< drgNew
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
-    setRcvQueueStatus db rq Confirmed
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+    setRcvQueueStatus db rcvQueue1 Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed}))
 
 testSetSndQueueStatus :: SpecWith SQLiteStore
 testSetSndQueueStatus =
   it "should update status of SndQueue" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (_, sq) <- createSndConn db g cData1 sndQueue1
+    g <- newTVarIO =<< drgNew
+    _ <- createSndConn db g cData1 sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
-    setSndQueueStatus db sq Confirmed
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
+    setSndQueueStatus db sndQueue1 Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed}))
 
 testSetQueueStatusDuplex :: SpecWith SQLiteStore
 testSetQueueStatusDuplex =
   it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do
-    g <- C.newRandom
-    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    g <- newTVarIO =<< drgNew
+    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
-    setRcvQueueStatus db rq Secured
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
+    setRcvQueueStatus db rcvQueue1 Secured
       `shouldReturn` ()
-    let rq' = (rq :: RcvQueue) {status = Secured}
+    let rq' = (rcvQueue1 :: RcvQueue) {status = Secured}
+        sq' = (sndQueue1 :: SndQueue) {status = Confirmed}
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sq]))
-    setSndQueueStatus db sq Confirmed
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sndQueue1]))
+    setSndQueueStatus db sndQueue1 Confirmed
       `shouldReturn` ()
-    let sq' = (sq :: SndQueue) {status = Confirmed}
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sq']))
 
@@ -480,13 +460,13 @@ testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rq rcvMsgData@Rcv
 testCreateRcvMsg :: SpecWith SQLiteStore
 testCreateRcvMsg =
   it "should reserve internal ids and create a RcvMsg" $ \st -> do
-    g <- C.newRandom
+    g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    Right (_, rq) <- withTransaction st $ \db -> do
+    _ <- withTransaction st $ \db -> do
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     withTransaction st $ \db -> do
-      testCreateRcvMsg_ db 0 "" connId rq $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
-      testCreateRcvMsg_ db 1 "hash_dummy" connId rq $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
+      testCreateRcvMsg_ db 0 "" connId rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
+      testCreateRcvMsg_ db 1 "hash_dummy" connId rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
 
 mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
 mkSndMsgData internalId internalSndId internalHash =
@@ -501,41 +481,39 @@ mkSndMsgData internalId internalSndId internalHash =
       prevMsgHash = internalHash
     }
 
-testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndQueue -> SndMsgData -> Expectation
-testCreateSndMsg_ db expectedPrevHash connId sq sndMsgData@SndMsgData {..} = do
+testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
+testCreateSndMsg_ db expectedPrevHash connId sndMsgData@SndMsgData {..} = do
   updateSndIds db connId
     `shouldReturn` (internalId, internalSndId, expectedPrevHash)
   createSndMsg db connId sndMsgData
     `shouldReturn` ()
-  createSndMsgDelivery db connId sq internalId
-    `shouldReturn` ()
 
 testCreateSndMsg :: SpecWith SQLiteStore
 testCreateSndMsg =
   it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \st -> do
-    g <- C.newRandom
+    g <- newTVarIO =<< drgNew
     let ConnData {connId} = cData1
-    Right (_, sq) <- withTransaction st $ \db -> do
+    _ <- withTransaction st $ \db -> do
       createSndConn db g cData1 sndQueue1
     withTransaction st $ \db -> do
-      testCreateSndMsg_ db "" connId sq $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
-      testCreateSndMsg_ db "hash_dummy" connId sq $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
+      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
+      testCreateSndMsg_ db "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
 
 testCreateRcvAndSndMsgs :: SpecWith SQLiteStore
 testCreateRcvAndSndMsgs =
   it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \st -> do
     let ConnData {connId} = cData1
-    Right (_, rq) <- withTransaction st $ \db -> do
-      g <- C.newRandom
+    _ <- withTransaction st $ \db -> do
+      g <- newTVarIO =<< drgNew
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     withTransaction st $ \db -> do
-      Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-      testCreateRcvMsg_ db 0 "" connId rq $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
-      testCreateRcvMsg_ db 1 "rcv_hash_1" connId rq $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
-      testCreateSndMsg_ db "" connId sq $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
-      testCreateRcvMsg_ db 2 "rcv_hash_2" connId rq $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
-      testCreateSndMsg_ db "snd_hash_1" connId sq $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
-      testCreateSndMsg_ db "snd_hash_2" connId sq $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
+      _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+      testCreateRcvMsg_ db 0 "" connId rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
+      testCreateRcvMsg_ db 1 "rcv_hash_1" connId rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
+      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
+      testCreateRcvMsg_ db 2 "rcv_hash_2" connId rcvQueue1 $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
+      testCreateSndMsg_ db "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
+      testCreateSndMsg_ db "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
 
 testCloseReopenStore :: IO ()
 testCloseReopenStore = do
@@ -587,201 +565,3 @@ hasMigrations st = getMigrations st `shouldReturn` True
 
 errorGettingMigrations :: SQLiteStore -> Expectation
 errorGettingMigrations st = getMigrations st `shouldThrow` \(e :: SomeException) -> "ErrorMisuse" `isInfixOf` show e
-
-testGetPendingQueueMsg :: SQLiteStore -> Expectation
-testGetPendingQueueMsg st = do
-  g <- C.newRandom
-  withTransaction st $ \db -> do
-    Right (connId, sq) <- createSndConn db g cData1 {connId = ""} sndQueue1
-    Right Nothing <- getPendingQueueMsg db connId sq
-    testCreateSndMsg_ db "" connId sq $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
-    DB.execute db "UPDATE messages SET msg_type = cast('bad' as blob) WHERE conn_id = ? AND internal_id = ?" (connId, 1 :: Int)
-    testCreateSndMsg_ db "hash_dummy" connId sq $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
-
-    Left e <- getPendingQueueMsg db connId sq
-    show e `shouldContain` "bad AgentMessageType"
-    DB.query_ db "SELECT conn_id, internal_id FROM snd_message_deliveries WHERE failed = 1" `shouldReturn` [(connId, 1 :: Int)]
-
-    Right (Just (Nothing, PendingMsgData {msgId})) <- getPendingQueueMsg db connId sq
-    msgId `shouldBe` InternalId 2
-
-testGetPendingServerCommand :: SQLiteStore -> Expectation
-testGetPendingServerCommand st = do
-  g <- C.newRandom
-  withTransaction st $ \db -> do
-    Right Nothing <- getPendingServerCommand db Nothing
-    Right connId <- createNewConn db g cData1 {connId = ""} SCMInvitation
-    Right () <- createCommand db "1" connId Nothing command
-    corruptCmd db "1" connId
-    Right () <- createCommand db "2" connId Nothing command
-
-    Left e <- getPendingServerCommand db Nothing
-    show e `shouldContain` "bad AgentCmdType"
-    DB.query_ db "SELECT conn_id, corr_id FROM commands WHERE failed = 1" `shouldReturn` [(connId, "1" :: ByteString)]
-
-    Right (Just PendingCommand {corrId}) <- getPendingServerCommand db Nothing
-    corrId `shouldBe` "2"
-
-    Right _ <- updateNewConnRcv db connId rcvQueue1
-    Right Nothing <- getPendingServerCommand db $ Just smpServer1
-    Right () <- createCommand db "3" connId (Just smpServer1) command
-    corruptCmd db "3" connId
-    Right () <- createCommand db "4" connId (Just smpServer1) command
-
-    Left e' <- getPendingServerCommand db (Just smpServer1)
-    show e' `shouldContain` "bad AgentCmdType"
-    DB.query_ db "SELECT conn_id, corr_id FROM commands WHERE failed = 1" `shouldReturn` [(connId, "1" :: ByteString), (connId, "3" :: ByteString)]
-
-    Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db (Just smpServer1)
-    corrId' `shouldBe` "4"
-  where
-    command = AClientCommand $ APC SAEConn $ NEW True (ACM SCMInvitation) SMSubscribe
-    corruptCmd :: DB.Connection -> ByteString -> ConnId -> IO ()
-    corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId)
-
-xftpServer1 :: SMP.XFTPServer
-xftpServer1 = SMP.ProtocolServer SMP.SPXFTP "xftp.simplex.im" "5223" testKeyHash
-
-rcvFileDescr1 :: FileDescription 'FRecipient
-rcvFileDescr1 =
-  FileDescription
-    { party = SFRecipient,
-      size = FileSize $ mb 26,
-      digest = FileDigest "abc",
-      key = testFileSbKey,
-      nonce = testFileCbNonce,
-      chunkSize = defaultChunkSize,
-      chunks =
-        [ FileChunk
-            { chunkNo = 1,
-              digest = chunkDigest,
-              chunkSize = defaultChunkSize,
-              replicas = [FileChunkReplica {server = xftpServer1, replicaId, replicaKey = testFileReplicaKey}]
-            }
-        ]
-    }
-  where
-    defaultChunkSize = FileSize $ mb 8
-    replicaId = ChunkReplicaId "abc"
-    chunkDigest = FileDigest "ghi"
-
-testFileSbKey :: C.SbKey
-testFileSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY="
-
-testFileCbNonce :: C.CbNonce
-testFileCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
-
-testFileReplicaKey :: C.APrivateSignKey
-testFileReplicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
-
-testGetNextRcvChunkToDownload :: SQLiteStore -> Expectation
-testGetNextRcvChunkToDownload st = do
-  g <- C.newRandom
-  withTransaction st $ \db -> do
-    Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400
-
-    Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
-    DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
-    Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
-
-    Left e <- getNextRcvChunkToDownload db xftpServer1 86400
-    show e `shouldContain` "ConversionFailed"
-    DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
-
-    Right (Just RcvFileChunk {rcvFileEntityId}) <- getNextRcvChunkToDownload db xftpServer1 86400
-    rcvFileEntityId `shouldBe` fId2
-
-testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation
-testGetNextRcvFileToDecrypt st = do
-  g <- C.newRandom
-  withTransaction st $ \db -> do
-    Right Nothing <- getNextRcvFileToDecrypt db 86400
-
-    Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
-    DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 1"
-    DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
-    Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
-    DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 2"
-
-    Left e <- getNextRcvFileToDecrypt db 86400
-    show e `shouldContain` "ConversionFailed"
-    DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
-
-    Right (Just RcvFile {rcvFileEntityId}) <- getNextRcvFileToDecrypt db 86400
-    rcvFileEntityId `shouldBe` fId2
-
-testGetNextSndFileToPrepare :: SQLiteStore -> Expectation
-testGetNextSndFileToPrepare st = do
-  g <- C.newRandom
-  withTransaction st $ \db -> do
-    Right Nothing <- getNextSndFileToPrepare db 86400
-
-    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
-    DB.execute_ db "UPDATE snd_files SET status = 'new', num_recipients = 'bad' WHERE snd_file_id = 1"
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
-    DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2"
-
-    Left e <- getNextSndFileToPrepare db 86400
-    show e `shouldContain` "ConversionFailed"
-    DB.query_ db "SELECT snd_file_id FROM snd_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
-
-    Right (Just SndFile {sndFileEntityId}) <- getNextSndFileToPrepare db 86400
-    sndFileEntityId `shouldBe` fId2
-
-newSndChunkReplica1 :: NewSndChunkReplica
-newSndChunkReplica1 =
-  NewSndChunkReplica
-    { server = xftpServer1,
-      replicaId = ChunkReplicaId "abc",
-      replicaKey = testFileReplicaKey,
-      rcvIdsKeys = [(ChunkReplicaId "abc", testFileReplicaKey)]
-    }
-
-testGetNextSndChunkToUpload :: SQLiteStore -> Expectation
-testGetNextSndChunkToUpload st = do
-  g <- C.newRandom
-  withTransaction st $ \db -> do
-    Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400
-
-    -- create file 1
-    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
-    updateSndFileEncrypted db 1 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
-    createSndFileReplica_ db 1 newSndChunkReplica1
-    DB.execute_ db "UPDATE snd_files SET num_recipients = 'bad' WHERE snd_file_id = 1"
-    -- create file 2
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
-    updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
-    createSndFileReplica_ db 2 newSndChunkReplica1
-
-    Left e <- getNextSndChunkToUpload db xftpServer1 86400
-    show e `shouldContain` "ConversionFailed"
-    DB.query_ db "SELECT snd_file_id FROM snd_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
-
-    Right (Just SndFileChunk {sndFileEntityId}) <- getNextSndChunkToUpload db xftpServer1 86400
-    sndFileEntityId `shouldBe` fId2
-
-testGetNextDeletedSndChunkReplica :: SQLiteStore -> Expectation
-testGetNextDeletedSndChunkReplica st = do
-  withTransaction st $ \db -> do
-    Right Nothing <- getNextDeletedSndChunkReplica db xftpServer1 86400
-
-    createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId "abc") testFileReplicaKey) (FileDigest "ghi")
-    DB.execute_ db "UPDATE deleted_snd_chunk_replicas SET delay = 'bad' WHERE deleted_snd_chunk_replica_id = 1"
-    createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId "abc") testFileReplicaKey) (FileDigest "ghi")
-
-    Left e <- getNextDeletedSndChunkReplica db xftpServer1 86400
-    show e `shouldContain` "ConversionFailed"
-    DB.query_ db "SELECT deleted_snd_chunk_replica_id FROM deleted_snd_chunk_replicas WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
-
-    Right (Just DeletedSndChunkReplica {deletedSndChunkReplicaId}) <- getNextDeletedSndChunkReplica db xftpServer1 86400
-    deletedSndChunkReplicaId `shouldBe` 2
-
-testMarkNtfSubActionNtfFailed :: SQLiteStore -> Expectation
-testMarkNtfSubActionNtfFailed st = do
-  withTransaction st $ \db -> do
-    markNtfSubActionNtfFailed_ db "abc"
-
-testMarkNtfSubActionSMPFailed :: SQLiteStore -> Expectation
-testMarkNtfSubActionSMPFailed st = do
-  withTransaction st $ \db -> do
-    markNtfSubActionSMPFailed_ db "abc"

tests/AgentTests/SchemaDump.hs

@@ -7,10 +7,7 @@ import Control.DeepSeq
 import Control.Monad (unless, void)
 import Data.List (dropWhileEnd)
 import Data.Maybe (fromJust, isJust)
-import Database.SQLite.Simple (Only (..))
-import qualified Database.SQLite.Simple as SQL
 import Simplex.Messaging.Agent.Store.SQLite
-import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..), MigrationsToRun (..), toDownMigration)
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Util (ifM)
@@ -31,8 +28,6 @@ schemaDumpTest :: Spec
 schemaDumpTest = do
   it "verify and overwrite schema dump" testVerifySchemaDump
   it "verify schema down migrations" testSchemaMigrations
-  it "should NOT create user record for new database" testUsersMigrationNew
-  it "should create user record for old database" testUsersMigrationOld
 
 testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
@@ -66,25 +61,6 @@ testSchemaMigrations = do
       schema''' <- getSchema testDB testSchema
       schema''' `shouldBe` schema'
 
-testUsersMigrationNew :: IO ()
-testUsersMigrationNew = do
-  Right st <- createSQLiteStore testDB "" False Migrations.app MCError
-  withTransaction' st (`SQL.query_` "SELECT user_id FROM users;")
-    `shouldReturn` ([] :: [Only Int])
-  closeSQLiteStore st
-
-testUsersMigrationOld :: IO ()
-testUsersMigrationOld = do
-  let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app
-  Right st <- createSQLiteStore testDB "" False beforeUsers MCError
-  withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';")
-    `shouldReturn` ([] :: [Only String])
-  closeSQLiteStore st
-  Right st' <- createSQLiteStore testDB "" False Migrations.app MCYesUp
-  withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;")
-    `shouldReturn` ([Only (1 :: Int)])
-  closeSQLiteStore st'
-
 skipComparisonForDownMigrations :: [String]
 skipComparisonForDownMigrations =
   [ -- on down migration idx_messages_internal_snd_id_ts index moves down to the end of the file

tests/CoreTests/BatchingTests.hs

@@ -4,8 +4,9 @@ module CoreTests.BatchingTests (batchingTests) where
 
 import Control.Concurrent.STM
 import Control.Monad
+import Crypto.Random (MonadRandom (..))
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B
 import qualified Data.List.NonEmpty as L
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
@@ -20,27 +21,27 @@ batchingTests = do
     it "should batch with 90 subscriptions per batch" testBatchSubscriptions
     it "should break on message that does not fit" testBatchWithMessage
     it "should break on large message" testBatchWithLargeMessage
-  describe "batchTransmissions'" $ do
+  describe "batchClientTransmissions" $ do
     it "should batch with 90 subscriptions per batch" testClientBatchSubscriptions
     it "should break on message that does not fit" testClientBatchWithMessage
     it "should break on large message" testClientBatchWithLargeMessage
 
 testBatchSubscriptions :: IO ()
 testBatchSubscriptions = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  sessId <- getRandomBytes 32
   subs <- replicateM 200 $ randomSUB sessId
   let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 200
   let batches = batchTransmissions True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
-  [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (20, 90, 90)
+  [TBTransmissions n1 s1, TBTransmissions n2 s2, TBTransmissions n3 s3] <- pure batches
+  (n1, n2, n3) `shouldBe` (90, 90, 20)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchWithMessage :: IO ()
 testBatchWithMessage = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  sessId <- getRandomBytes 32
   subs1 <- replicateM 60 $ randomSUB sessId
   send <- randomSEND sessId 8000
   subs2 <- replicateM 40 $ randomSUB sessId
@@ -50,13 +51,13 @@ testBatchWithMessage = do
   length batches1 `shouldBe` 101
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 2
-  [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
-  (n1, n2) `shouldBe` (55, 46)
+  [TBTransmissions n1 s1, TBTransmissions n2 s2] <- pure batches
+  (n1, n2) `shouldBe` (60, 41)
   all lenOk [s1, s2] `shouldBe` True
 
 testBatchWithLargeMessage :: IO ()
 testBatchWithLargeMessage = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  sessId <- getRandomBytes 32
   subs1 <- replicateM 60 $ randomSUB sessId
   send <- randomSEND sessId 17000
   subs2 <- replicateM 100 $ randomSUB sessId
@@ -69,110 +70,111 @@ testBatchWithLargeMessage = do
   length batches1' `shouldBe` 160
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
-  [TBTransmissions s1 n1 _, TBLargeTransmission _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (60, 10, 90)
+  [TBTransmissions n1 s1, TBLargeTransmission, TBTransmissions n2 s2, TBTransmissions n3 s3] <- pure batches
+  (n1, n2, n3) `shouldBe` (60, 90, 10)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchSubscriptions :: IO ()
 testClientBatchSubscriptions = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  sessId <- getRandomBytes 32
   client <- atomically $ clientStub sessId
   subs <- replicateM 200 $ randomSUBCmd client
-  let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
-  all lenOk1 batches1 `shouldBe` True
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
+  let batches1 = batchClientTransmissions False smpBlockSize $ L.fromList subs
+  all lenOk1' batches1 `shouldBe` True
+  let batches = batchClientTransmissions True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
-  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (20, 90, 90)
-  (length rs1, length rs2, length rs3) `shouldBe` (20, 90, 90)
+  [CBTransmissions s1 n1 rs1, CBTransmissions s2 n2 rs2, CBTransmissions s3 n3 rs3] <- pure batches
+  (n1, n2, n3) `shouldBe` (90, 90, 20)
+  (length rs1, length rs2, length rs3) `shouldBe` (90, 90, 20)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchWithMessage :: IO ()
 testClientBatchWithMessage = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  sessId <- getRandomBytes 32
   client <- atomically $ clientStub sessId
   subs1 <- replicateM 60 $ randomSUBCmd client
   send <- randomSENDCmd client 8000
   subs2 <- replicateM 40 $ randomSUBCmd client
   let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
-  all lenOk1 batches1 `shouldBe` True
+      batches1 = batchClientTransmissions False smpBlockSize $ L.fromList cmds
+  all lenOk1' batches1 `shouldBe` True
   length batches1 `shouldBe` 101
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  let batches = batchClientTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 2
-  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
-  (n1, n2) `shouldBe` (55, 46)
-  (length rs1, length rs2) `shouldBe` (55, 46)
+  [CBTransmissions s1 n1 rs1, CBTransmissions s2 n2 rs2] <- pure batches
+  (n1, n2) `shouldBe` (60, 41)
+  (length rs1, length rs2) `shouldBe` (60, 41)
   all lenOk [s1, s2] `shouldBe` True
 
 testClientBatchWithLargeMessage :: IO ()
 testClientBatchWithLargeMessage = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  sessId <- getRandomBytes 32
   client <- atomically $ clientStub sessId
   subs1 <- replicateM 60 $ randomSUBCmd client
   send <- randomSENDCmd client 17000
   subs2 <- replicateM 100 $ randomSUBCmd client
   let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
-  all lenOk1 batches1 `shouldBe` False
+      batches1 = batchClientTransmissions False smpBlockSize $ L.fromList cmds
+  all lenOk1' batches1 `shouldBe` False
   length batches1 `shouldBe` 161
   let batches1' = take 60 batches1 <> drop 61 batches1
-  all lenOk1 batches1' `shouldBe` True
+  all lenOk1' batches1' `shouldBe` True
   length batches1' `shouldBe` 160
   --
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  let batches = batchClientTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
-  [TBTransmissions s1 n1 rs1, TBLargeTransmission _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (60, 10, 90)
-  (length rs1, length rs2, length rs3) `shouldBe` (60, 10, 90)
+  [CBTransmissions s1 n1 rs1, CBLargeTransmission _, CBTransmissions s2 n2 rs2, CBTransmissions s3 n3 rs3] <- pure batches
+  (n1, n2, n3) `shouldBe` (60, 90, 10)
+  (length rs1, length rs2, length rs3) `shouldBe` (60, 90, 10)
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
-  let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
+  let batches' = batchClientTransmissions True smpBlockSize $ L.fromList cmds'
   length batches' `shouldBe` 3
-  [TBLargeTransmission _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
-  (n1', n2') `shouldBe` (70, 90)
-  (length rs1', length rs2') `shouldBe` (70, 90)
+  [CBLargeTransmission _, CBTransmissions s1' n1' rs1', CBTransmissions s2' n2' rs2'] <- pure batches'
+  (n1', n2') `shouldBe` (90, 70)
+  (length rs1', length rs2') `shouldBe` (90, 70)
   all lenOk [s1', s2'] `shouldBe` True
 
 randomSUB :: ByteString -> IO (Maybe C.ASignature, ByteString)
 randomSUB sessId = do
-  g <- C.newRandom
-  rId <- atomically $ C.randomBytes 24 g
-  corrId <- atomically $ CorrId <$> C.randomBytes 3 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  rId <- getRandomBytes 24
+  corrId <- CorrId <$> getRandomBytes 3
+  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
   let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, rId, Cmd SRecipient SUB)
   pure (Just $ C.sign rpKey s, s)
 
 randomSUBCmd :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
 randomSUBCmd c = do
-  g <- C.newRandom
-  rId <- atomically $ C.randomBytes 24 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  rId <- getRandomBytes 24
+  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
   mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB)
 
 randomSEND :: ByteString -> Int -> IO (Maybe C.ASignature, ByteString)
 randomSEND sessId len = do
-  g <- C.newRandom
-  sId <- atomically $ C.randomBytes 24 g
-  corrId <- atomically $ CorrId <$> C.randomBytes 3 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-  msg <- atomically $ C.randomBytes len g
+  sId <- getRandomBytes 24
+  corrId <- CorrId <$> getRandomBytes 3
+  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
+  msg <- getRandomBytes len
   let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
   pure (Just $ C.sign rpKey s, s)
 
 randomSENDCmd :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
 randomSENDCmd c len = do
-  g <- C.newRandom
-  sId <- atomically $ C.randomBytes 24 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-  msg <- atomically $ C.randomBytes len g
+  sId <- getRandomBytes 24
+  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
+  msg <- getRandomBytes len
   mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg)
 
 lenOk :: ByteString -> Bool
 lenOk s = 0 < B.length s && B.length s <= smpBlockSize - 2
 
-lenOk1 :: TransportBatch r -> Bool
+lenOk1 :: TransportBatch -> Bool
 lenOk1 = \case
-  TBTransmission s _ -> lenOk s
+  TBTransmission s -> lenOk s
+  _ -> False
+
+lenOk1' :: ClientBatch err msg -> Bool
+lenOk1' = \case
+  CBTransmission s _ -> lenOk s
   _ -> False

tests/CoreTests/CryptoFileTests.hs

@@ -3,13 +3,12 @@
 module CoreTests.CryptoFileTests (cryptoFileTests) where
 
 import AgentTests.FunctionalAPITests (runRight_)
-import Control.Concurrent.STM
 import Control.Monad.Except
 import Control.Monad.IO.Class
-import Crypto.Random (ChaChaDRG)
+import Crypto.Random (getRandomBytes)
 import qualified Data.ByteString.Lazy as LB
 import GHC.IO.IOMode (IOMode (..))
-import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.FileTransfer.Types as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import System.Directory (getFileSize)
@@ -28,9 +27,8 @@ testFilePath = "tests/tmp/testcryptofile"
 
 testWriteReadFile :: IO ()
 testWriteReadFile = do
-  g <- C.newRandom
-  s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g
-  file <- atomically $ mkCryptoFile g
+  s <- LB.fromStrict <$> getRandomBytes 100000
+  file <- mkCryptoFile
   runRight_ $ do
     CF.writeFile file s
     liftIO $ CF.getFileContentsSize file `shouldReturn` 100000
@@ -40,10 +38,9 @@ testWriteReadFile = do
 
 testPutGetFile :: IO ()
 testPutGetFile = do
-  g <- C.newRandom
-  s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
-  s' <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
-  file <- atomically $ mkCryptoFile g
+  s <- LB.fromStrict <$> getRandomBytes 50000
+  s' <- LB.fromStrict <$> getRandomBytes 50000
+  file <- mkCryptoFile
   runRight_ $ do
     CF.withFile file WriteMode $ \h -> liftIO $ do
       CF.hPut h s
@@ -60,9 +57,8 @@ testPutGetFile = do
 
 testWriteGetFile :: IO ()
 testWriteGetFile = do
-  g <- C.newRandom
-  s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g
-  file <- atomically $ mkCryptoFile g
+  s <- LB.fromStrict <$> getRandomBytes 100000
+  file <- mkCryptoFile
   runRight_ $ do
     CF.writeFile file s
     CF.withFile file ReadMode $ \h -> do
@@ -74,10 +70,9 @@ testWriteGetFile = do
 
 testPutReadFile :: IO ()
 testPutReadFile = do
-  g <- C.newRandom
-  s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
-  s' <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
-  file <- atomically $ mkCryptoFile g
+  s <- LB.fromStrict <$> getRandomBytes 50000
+  s' <- LB.fromStrict <$> getRandomBytes 50000
+  file <- mkCryptoFile
   runRight_ $ do
     CF.withFile file WriteMode $ \h -> liftIO $ do
       CF.hPut h s
@@ -93,12 +88,11 @@ testPutReadFile = do
 
 testSmallFile :: IO ()
 testSmallFile = do
-  g <- C.newRandom
-  file <- atomically $ mkCryptoFile g
+  file <- mkCryptoFile
   LB.writeFile testFilePath ""
   runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize
   LB.writeFile testFilePath "123"
   runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize
 
-mkCryptoFile :: TVar ChaChaDRG -> STM CryptoFile
-mkCryptoFile g = CryptoFile testFilePath . Just <$> CF.randomArgs g
+mkCryptoFile :: IO CryptoFile
+mkCryptoFile = CryptoFile testFilePath . Just <$> CF.randomArgs

tests/CoreTests/CryptoTests.hs

@@ -5,6 +5,7 @@ module CoreTests.CryptoTests (cryptoTests) where
 
 import Control.Concurrent.STM
 import Control.Monad.Except
+import Crypto.Random (drgNew, getRandomBytes)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (isRight)
@@ -104,16 +105,14 @@ testPadUnpadFile = do
 
 testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec
 testSignature alg = it "should sign / verify string" . ioProperty $ do
-  g <- C.newRandom
-  (k, pk) <- atomically $ C.generateSignatureKeyPair alg g
+  (k, pk) <- C.generateSignatureKeyPair alg
   pure $ \s -> let b = encodeUtf8 $ T.pack s in C.verify k (C.sign pk b) b
 
 testDHCryptoBox :: Spec
 testDHCryptoBox = it "should encrypt / decrypt string with asymmetric DH keys" . ioProperty $ do
-  g <- C.newRandom
-  (sk, spk) <- atomically $ C.generateKeyPair g
-  (rk, rpk) <- atomically $ C.generateKeyPair g
-  nonce <- atomically $ C.randomCbNonce g
+  (sk, spk) <- C.generateKeyPair'
+  (rk, rpk) <- C.generateKeyPair'
+  nonce <- C.randomCbNonce
   pure $ \(s, pad) ->
     let b = encodeUtf8 $ T.pack s
         paddedLen = B.length b + abs pad + 2
@@ -123,9 +122,8 @@ testDHCryptoBox = it "should encrypt / decrypt string with asymmetric DH keys" .
 
 testSecretBox :: Spec
 testSecretBox = it "should encrypt / decrypt string with a random symmetric key" . ioProperty $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
   pure $ \(s, pad) ->
     let b = encodeUtf8 $ T.pack s
         pad' = min (abs pad) 100000
@@ -136,9 +134,8 @@ testSecretBox = it "should encrypt / decrypt string with a random symmetric key"
 
 testLazySecretBox :: Spec
 testLazySecretBox = it "should lazily encrypt / decrypt string with a random symmetric key" . ioProperty $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
   pure $ \(s, pad) ->
     let b = LE.encodeUtf8 $ LT.pack s
         len = LB.length b
@@ -150,9 +147,8 @@ testLazySecretBox = it "should lazily encrypt / decrypt string with a random sym
 
 testLazySecretBoxFile :: Spec
 testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random symmetric key" $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
   let f = "tests/tmp/testsecretbox"
       paddedLen = 4 * 1024 * 1024
       len = 4 * 1000 * 1000 :: Int64
@@ -164,9 +160,8 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s
 
 testLazySecretBoxTailTag :: Spec
 testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a random symmetric key (tail tag)" . ioProperty $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
   pure $ \(s, pad) ->
     let b = LE.encodeUtf8 $ LT.pack s
         len = LB.length b
@@ -178,9 +173,8 @@ testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a ran
 
 testLazySecretBoxFileTailTag :: Spec
 testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a random symmetric key (tail tag)" $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
   let f = "tests/tmp/testsecretbox"
       paddedLen = 4 * 1024 * 1024
       len = 4 * 1000 * 1000 :: Int64
@@ -193,10 +187,9 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r
 
 testAESGCM :: Spec
 testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomAesKey g
-  iv <- atomically $ C.randomGCMIV g
-  s <- atomically $ C.randomBytes 100 g
+  k <- C.randomAesKey
+  iv <- C.randomGCMIV
+  s <- getRandomBytes 100
   Right (tag, cipher) <- runExceptT $ C.encryptAESNoPad k iv s
   Right plain <- runExceptT $ C.decryptAESNoPad k iv cipher tag
   cipher `shouldNotBe` plain
@@ -204,15 +197,14 @@ testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $
 
 testEncoding :: C.AlgorithmI a => C.SAlgorithm a -> Spec
 testEncoding alg = it "should encode / decode key" . ioProperty $ do
-  g <- C.newRandom
-  (k, pk) <- atomically $ C.generateAKeyPair alg g
+  (k, pk) <- C.generateKeyPair alg
   pure $ \(_ :: Int) ->
     C.decodePubKey (C.encodePubKey k) == Right k
       && C.decodePrivKey (C.encodePrivKey pk) == Right pk
 
 testSNTRUP761 :: IO ()
 testSNTRUP761 = do
-  drg <- C.newRandom
+  drg <- newTVarIO =<< drgNew
   (pk, sk) <- sntrup761Keypair drg
   (c, KEMSharedKey k) <- sntrup761Enc drg pk
   KEMSharedKey k' <- sntrup761Dec c sk

tests/NtfClient.hs

@@ -57,9 +57,6 @@ testHost = "localhost"
 ntfTestPort :: ServiceName
 ntfTestPort = "6001"
 
-ntfTestPort2 :: ServiceName
-ntfTestPort2 = "6002"
-
 apnsTestPort :: ServiceName
 apnsTestPort = "6010"
 
@@ -80,7 +77,7 @@ testNtfClient client = do
 ntfServerCfg :: NtfServerConfig
 ntfServerCfg =
   NtfServerConfig
-    { transports = [],
+    { transports = undefined,
       subIdBytes = 24,
       regCodeBytes = 32,
       clientQSize = 1,
@@ -108,19 +105,16 @@ ntfServerCfg =
     }
 
 withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
-withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]}
+withNtfServerStoreLog t = withNtfServerCfg t ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile}
 
 withNtfServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
-withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t)]}
+withNtfServerThreadOn t port' = withNtfServerCfg t ntfServerCfg {transports = [(port', t)]}
 
-withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a
-withNtfServerCfg cfg@NtfServerConfig {transports} =
-  case transports of
-    [] -> error "no transports configured"
-    _ ->
-      serverBracket
-        (\started -> runNtfServerBlocking started cfg)
-        (pure ())
+withNtfServerCfg :: ATransport -> NtfServerConfig -> (ThreadId -> IO a) -> IO a
+withNtfServerCfg t cfg =
+  serverBracket
+    (\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]})
+    (pure ())
 
 withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a
 withNtfServerOn t port' = withNtfServerThreadOn t port' . const
@@ -142,7 +136,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
     tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO ()
     tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId, corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+      [Right ()] <- tPut h Nothing [(sig, t')]
       pure ()
     tGet' h = do
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h

tests/NtfServerTests.hs

@@ -88,11 +88,10 @@ testNotificationSubscription :: ATransport -> Spec
 testNotificationSubscription (ATransport t) =
   -- hangs on Ubuntu 20/22
   xit' "should create notification subscription and notify when message is received" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (tknPub, tknKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
+    (tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519
+    (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
     let tkn = DeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \APNSMockServer {apnsQ} ->
       smpTest2 t $ \rh sh ->
@@ -111,7 +110,7 @@ testNotificationSubscription (ATransport t) =
           RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code)
           RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK)
           -- enable queue notifications
-          (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
+          (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- C.generateKeyPair'
           Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv rh rKey ("3", rId, NKEY nPub rcvNtfPubDhKey)
           let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
               q = SMPQueueNtf srv nId

tests/RemoteControl.hs

@@ -6,10 +6,9 @@ module RemoteControl where
 
 import AgentTests.FunctionalAPITests (runRight)
 import Control.Logger.Simple
-import Crypto.Random (ChaChaDRG)
+import Crypto.Random (ChaChaDRG, drgNew)
 import qualified Data.Aeson as J
 import Data.List.NonEmpty (NonEmpty (..))
-import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import qualified Simplex.RemoteControl.Client as HC (RCHostClient (action))
 import qualified Simplex.RemoteControl.Client as RC
@@ -63,8 +62,8 @@ testPreferAddress = do
 
 testNewPairing :: IO ()
 testNewPairing = do
-  drg <- C.newRandom
-  hp <- RC.newRCHostPairing drg
+  drg <- drgNew >>= newTVarIO
+  hp <- RC.newRCHostPairing
   invVar <- newEmptyMVar
   ctrlSessId <- async . runRight $ do
     logNote "c 1"
@@ -109,9 +108,9 @@ testNewPairing = do
 
 testExistingPairing :: IO ()
 testExistingPairing = do
-  drg <- C.newRandom
+  drg <- drgNew >>= newTVarIO
   invVar <- newEmptyMVar
-  hp <- RC.newRCHostPairing drg
+  hp <- liftIO $ RC.newRCHostPairing
   ctrl <- runCtrl drg False hp invVar
   inv <- takeMVar invVar
   let cp_ = Nothing
@@ -140,10 +139,10 @@ testExistingPairing = do
 
 testMulticast :: IO ()
 testMulticast = do
-  drg <- C.newRandom
+  drg <- drgNew >>= newTVarIO
   subscribers <- newTMVarIO 0
   invVar <- newEmptyMVar
-  hp <- RC.newRCHostPairing drg
+  hp <- liftIO RC.newRCHostPairing
   ctrl <- runCtrl drg False hp invVar
   inv <- takeMVar invVar
   let cp_ = Nothing

tests/SMPAgentClient.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -10,14 +9,12 @@
 
 module SMPAgentClient where
 
-import Control.Monad
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import qualified Data.ByteString.Char8 as B
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import qualified Database.SQLite.Simple as SQL
 import Network.Socket (ServiceName)
 import NtfClient (ntfTestPort)
 import SMPClient
@@ -33,11 +30,10 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
-import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
-import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Test.Hspec
@@ -180,17 +176,11 @@ testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:50
 testSMPServer2 :: SMPServer
 testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
 
-testNtfServer :: NtfServer
-testNtfServer = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"
-
-testNtfServer2 :: NtfServer
-testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6002"
-
 initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
     { smp = userServers [noAuthSrv testSMPServer],
-      ntf = [testNtfServer],
+      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
       xftp = userServers [noAuthSrv testXFTPServer],
       netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}
     }
@@ -204,36 +194,27 @@ agentCfg =
     { tcpPort = agentTestPort,
       tbqSize = 4,
       -- database = testDB,
-      smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig},
-      ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig},
-      reconnectInterval = fastRetryInterval,
+      smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS)},
+      ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS)},
+      reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
       xftpNotifyErrsOnRetry = False,
-      ntfWorkerDelay = 100,
-      ntfSMPWorkerDelay = 100,
+      ntfWorkerDelay = 1000,
+      ntfSMPWorkerDelay = 1000,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"
     }
-  where
-    networkConfig = defaultNetworkConfig {tcpConnectTimeout = 3_000_000, tcpTimeout = 2_000_000}
-
-fastRetryInterval :: RetryInterval
-fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
-
-fastMessageRetryInterval :: RetryInterval2
-fastMessageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
 
 type AgentTestMonad m = (MonadUnliftIO m, MonadRandom m, MonadFail m)
 
-withSmpAgentThreadOn_ :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> Int -> m () -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn_ t (port', smpPort', db') initClientId afterProcess =
+withSmpAgentThreadOn_ :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> m () -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
   let cfg' = agentCfg {tcpPort = port'}
       initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
    in serverBracket
         ( \started -> do
             Right st <- liftIO $ createAgentStore db' "" False MCError
-            when (dbNew st) . liftIO $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)")
-            runSMPAgentBlocking t cfg' initServers' st initClientId started
+            runSMPAgentBlocking t cfg' initServers' st started
         )
         afterProcess
 
@@ -241,7 +222,7 @@ userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoSe
 userServers srvs = M.fromList [(1, srvs)]
 
 withSmpAgentThreadOn :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a 0 $ removeFile db'
+withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile db'
 
 withSmpAgentOn :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> m a -> m a
 withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const

tests/SMPClient.hs

@@ -82,7 +82,6 @@ cfg :: ServerConfig
 cfg =
   ServerConfig
     { transports = undefined,
-      smpHandshakeTimeout = 60000000,
       tbqSize = 1,
       -- serverTbqSize = 1,
       msgQueueQuota = 4,
@@ -130,7 +129,7 @@ serverBracket process afterProcess f = do
   E.bracket
     (forkIOWithUnmask ($ process started))
     (\t -> killThread t >> afterProcess >> waitFor started "stop")
-    (\t -> waitFor started "start" >> f t >>= \r -> r <$ threadDelay 100000)
+    (\t -> waitFor started "start" >> f t)
   where
     waitFor started s =
       5_000_000 `timeout` atomically (takeTMVar started) >>= \case
@@ -164,7 +163,7 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
     tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO ()
     tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId, corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+      [Right ()] <- tPut h Nothing [(sig, t')]
       pure ()
     tGet' h = do
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h

tests/ServerTests.hs

@@ -89,7 +89,7 @@ signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
 
 tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
 tPut1 h t = do
-  [r] <- tPut h [t]
+  [r] <- tPut h Nothing [t]
   pure r
 
 tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd)
@@ -120,9 +120,8 @@ testCreateSecureV2 :: forall c. Transport c => TProxy c -> Spec
 testCreateSecureV2 _ =
   it "should create (NEW) and secure (KEY) queue" $
     withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
       let dec = decryptMsgV2 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
@@ -140,7 +139,7 @@ testCreateSecureV2 _ =
       Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK mId1)
       (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages"
 
-      (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (sPub, sKey) <- C.generateSignatureKeyPair C.SEd448
       Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, _SEND "hello")
       (err1, ERR AUTH) #== "rejects signed SEND"
       (sId2, sId) #== "same queue ID in response 2"
@@ -156,7 +155,7 @@ testCreateSecureV2 _ =
       (rId2, rId) #== "same queue ID in response 3"
 
       Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub)
-      (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
       Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub')
       (err4, ERR AUTH) #== "rejects if secured with different key"
 
@@ -185,9 +184,8 @@ testCreateSecure :: ATransport -> Spec
 testCreateSecure (ATransport t) =
   it "should create (NEW) and secure (KEY) queue" $
     smpTest2 t $ \r s -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
@@ -205,7 +203,7 @@ testCreateSecure (ATransport t) =
       Resp "dabc" _ err6 <- signSendRecv r rKey ("dabc", rId, ACK mId1)
       (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages"
 
-      (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (sPub, sKey) <- C.generateSignatureKeyPair C.SEd448
       Resp "abcd" sId2 err1 <- signSendRecv s sKey ("abcd", sId, _SEND "hello")
       (err1, ERR AUTH) #== "rejects signed SEND"
       (sId2, sId) #== "same queue ID in response 2"
@@ -221,7 +219,7 @@ testCreateSecure (ATransport t) =
       (rId2, rId) #== "same queue ID in response 3"
 
       Resp "abcd" _ OK <- signSendRecv r rKey ("abcd", rId, KEY sPub)
-      (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
       Resp "abcd" _ err4 <- signSendRecv r rKey ("abcd", rId, KEY sPub')
       (err4, ERR AUTH) #== "rejects if secured with different key"
 
@@ -250,14 +248,13 @@ testCreateDelete :: ATransport -> Spec
 testCreateDelete (ATransport t) =
   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
     smpTest2 t $ \rh sh -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
 
-      (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+      (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
       Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)
       (ok1, OK) #== "secures queue"
 
@@ -321,9 +318,8 @@ stressTest :: ATransport -> Spec
 stressTest (ATransport t) =
   it "should create many queues, disconnect and re-connect" $
     smpTest3 t $ \h1 h2 h3 -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-      (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
+      (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
       rIds <- forM ([1 .. 50] :: [Int]) . const $ do
         Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe)
         pure rId
@@ -340,9 +336,8 @@ testAllowNewQueues t =
   it "should prohibit creating new queues with allowNewQueues = False" $ do
     withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ ->
       testSMPClient @c $ \h -> do
-        g <- C.newRandom
-        (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-        (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+        (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
+        (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
         Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
         pure ()
 
@@ -350,14 +345,13 @@ testDuplex :: ATransport -> Spec
 testDuplex (ATransport t) =
   it "should create 2 simplex connections and exchange messages" $
     smpTest2 t $ \alice bob -> do
-      g <- C.newRandom
-      (arPub, arKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-      (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448
+      (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe)
       let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
       -- aSnd ID is passed to Bob out-of-band
 
-      (bsPub, bsKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (bsPub, bsKey) <- C.generateSignatureKeyPair C.SEd448
       Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
       -- "key ..." is ad-hoc, not a part of SMP protocol
 
@@ -367,8 +361,8 @@ testDuplex (ATransport t) =
       (bobKey, strEncode bsPub) #== "key received from Bob"
       Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub)
 
-      (brPub, brKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-      (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448
+      (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe)
       let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
       Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
@@ -379,7 +373,7 @@ testDuplex (ATransport t) =
       Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
       (bId, encode bSnd) #== "reply queue ID received from Bob"
 
-      (asPub, asKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (asPub, asKey) <- C.generateSignatureKeyPair C.SEd448
       Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
       -- "key ..." is ad-hoc, not a part of  SMP protocol
 
@@ -405,9 +399,8 @@ testSwitchSub :: ATransport -> Spec
 testSwitchSub (ATransport t) =
   it "should create simplex connections and switch subscription to another TCP connection" $
     smpTest3 t $ \rh1 rh2 sh -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
@@ -445,8 +438,7 @@ testSwitchSub (ATransport t) =
 testGetCommand :: forall c. Transport c => TProxy c -> Spec
 testGetCommand t =
   it "should retrieve messages from the queue using GET command" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     smpTest t $ \sh -> do
       queue <- newEmptyTMVarIO
       testSMPClient @c $ \rh ->
@@ -464,8 +456,7 @@ testGetCommand t =
 testGetSubCommands :: forall c. Transport c => TProxy c -> Spec
 testGetSubCommands t =
   it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     smpTest3 t $ \rh1 rh2 sh -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub
       let dec = decryptMsgV3 dhShared
@@ -516,8 +507,7 @@ testExceedQueueQuota t =
   it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ do
     withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ ->
       testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do
-        g <- C.newRandom
-        (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+        (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
         (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
         let dec = decryptMsgV3 dhShared
         Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1")
@@ -541,10 +531,9 @@ testExceedQueueQuota t =
 testWithStoreLog :: ATransport -> Spec
 testWithStoreLog at@(ATransport t) =
   it "should store simplex queues to log and restore them after server restart" $ do
-    g <- C.newRandom
-    (sPub1, sKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (sPub2, sKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub1, sKey1) <- C.generateSignatureKeyPair C.SEd25519
+    (sPub2, sKey2) <- C.generateSignatureKeyPair C.SEd25519
+    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
     recipientId1 <- newTVarIO ""
     recipientKey1 <- newTVarIO Nothing
     dhShared1 <- newTVarIO Nothing
@@ -554,7 +543,7 @@ testWithStoreLog at@(ATransport t) =
 
     withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
-      (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
+      (rcvNtfPubDhKey, _) <- C.generateKeyPair'
       Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey)
       atomically $ do
         writeTVar recipientId1 rId1
@@ -630,8 +619,7 @@ testRestoreMessages at@(ATransport t) =
     removeFileIfExists testStoreMsgsFile
     removeFileIfExists testServerStatsBackupFile
 
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
@@ -662,7 +650,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 2
     logSize testStoreMsgsFile `shouldReturn` 5
-    logSize testServerStatsBackupFile `shouldReturn` 18
+    logSize testServerStatsBackupFile `shouldReturn` 16
     Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats1 [rId] 5 1
 
@@ -680,7 +668,7 @@ testRestoreMessages at@(ATransport t) =
     logSize testStoreLogFile `shouldReturn` 1
     -- the last message is not removed because it was not ACK'd
     logSize testStoreMsgsFile `shouldReturn` 3
-    logSize testServerStatsBackupFile `shouldReturn` 18
+    logSize testServerStatsBackupFile `shouldReturn` 16
     Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats2 [rId] 5 3
 
@@ -699,7 +687,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 1
     logSize testStoreMsgsFile `shouldReturn` 0
-    logSize testServerStatsBackupFile `shouldReturn` 18
+    logSize testServerStatsBackupFile `shouldReturn` 16
     Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats3 [rId] 5 5
 
@@ -732,8 +720,7 @@ checkStats s qs sent received = do
 testRestoreMessagesV2 :: ATransport -> Spec
 testRestoreMessagesV2 at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
@@ -802,8 +789,7 @@ testRestoreMessagesV2 at@(ATransport t) =
 testRestoreExpireMessages :: ATransport -> Spec
 testRestoreExpireMessages at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
@@ -830,7 +816,7 @@ testRestoreExpireMessages at@(ATransport t) =
     length (B.lines msgs) `shouldBe` 4
 
     let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200}
-        cfg1 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile}
+        cfg1 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1}
     withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure ()
 
     logSize testStoreLogFile `shouldReturn` 1
@@ -838,7 +824,7 @@ testRestoreExpireMessages at@(ATransport t) =
     msgs' `shouldBe` msgs
 
     let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200}
-        cfg2 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile}
+        cfg2 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2}
     withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure ()
 
     logSize testStoreLogFile `shouldReturn` 1
@@ -846,8 +832,6 @@ testRestoreExpireMessages at@(ATransport t) =
     msgs'' <- B.readFile testStoreMsgsFile
     length (B.lines msgs'') `shouldBe` 2
     B.lines msgs'' `shouldBe` drop 2 (B.lines msgs)
-    Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile
-    _msgExpired `shouldBe` 2
   where
     runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
@@ -859,9 +843,8 @@ testRestoreExpireMessages at@(ATransport t) =
 
 createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
 createAndSecureQueue h sPub = do
-  g <- C.newRandom
-  (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-  (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+  (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
+  (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
   Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
   let dhShared = C.dh' srvDh dhPriv
   Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
@@ -876,26 +859,25 @@ testTiming (ATransport t) =
   where
     timingTests :: [(Int, Int, Int)]
     timingTests =
-      [ (32, 32, 300),
-        (32, 57, 150),
-        (57, 32, 300),
-        (57, 57, 150)
+      [ (32, 32, 200),
+        (32, 57, 100),
+        (57, 32, 200),
+        (57, 57, 100)
       ]
     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
-    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25
+    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True
     testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
     testSameTiming rh sh (goodKeySize, badKeySize, n) = do
-      g <- C.newRandom
-      (rPub, rKey) <- generateKeys g goodKeySize
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      (rPub, rKey) <- generateKeys goodKeySize
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
       Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
 
-      (_, badKey) <- generateKeys g badKeySize
+      (_, badKey) <- generateKeys badKeySize
       -- runTimingTest rh badKey rId "SUB"
 
-      (sPub, sKey) <- generateKeys g goodKeySize
+      (sPub, sKey) <- generateKeys goodKeySize
       Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
 
       Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
@@ -904,40 +886,35 @@ testTiming (ATransport t) =
 
       runTimingTest sh badKey sId $ _SEND "hello"
       where
-        generateKeys g = \case
-          32 -> atomically $ C.generateSignatureKeyPair C.SEd25519 g
-          57 -> atomically $ C.generateSignatureKeyPair C.SEd448 g
+        generateKeys = \case
+          32 -> C.generateSignatureKeyPair C.SEd25519
+          57 -> C.generateSignatureKeyPair C.SEd448
           _ -> error "unsupported key size"
         runTimingTest h badKey qId cmd = do
-          threadDelay 100000
           timeWrongKey <- timeRepeat n $ do
             Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd)
             return ()
-          threadDelay 100000
           timeNoQueue <- timeRepeat n $ do
             Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
             return ()
-          let ok = similarTime timeNoQueue timeWrongKey
-          unless ok $
-            (putStrLn . unwords . map show)
-              [ fromIntegral goodKeySize,
-                fromIntegral badKeySize,
-                timeWrongKey,
-                timeNoQueue,
-                abs (timeWrongKey / timeNoQueue - 1)
-              ]
-          ok `shouldBe` True
+          -- (putStrLn . unwords . map show)
+          --   [ fromIntegral goodKeySize,
+          --     fromIntegral badKeySize,
+          --     timeWrongKey,
+          --     timeNoQueue,
+          --     timeWrongKey / timeNoQueue - 1
+          --   ]
+          similarTime timeNoQueue timeWrongKey
 
 testMessageNotifications :: ATransport -> Spec
 testMessageNotifications (ATransport t) =
   it "should create simplex connection, subscribe notifier and deliver notifications" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
     smpTest4 t $ \rh sh nh1 nh2 -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
       let dec = decryptMsgV3 dhShared
-      (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
+      (rcvNtfPubDhKey, _) <- C.generateKeyPair'
       Resp "1" _ (NID nId' _) <- signSendRecv rh rKey ("1", rId, NKEY nPub rcvNtfPubDhKey)
       Resp "1a" _ (NID nId _) <- signSendRecv rh rKey ("1a", rId, NKEY nPub rcvNtfPubDhKey)
       nId' `shouldNotBe` nId
@@ -968,8 +945,7 @@ testMessageNotifications (ATransport t) =
 testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec
 testMsgExpireOnSend t =
   it "should expire messages that are not received before messageTTL on SEND" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
@@ -989,8 +965,7 @@ testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
 testMsgExpireOnInterval t =
   -- fails on ubuntu
   xit' "should expire messages that are not received before messageTTL after expiry interval" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
@@ -1008,8 +983,7 @@ testMsgExpireOnInterval t =
 testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
 testMsgNOTExpireOnInterval t =
   it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do
-    g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do

tests/Test.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 import AgentTests (agentTests)
 import AgentTests.SchemaDump (schemaDumpTest)
@@ -68,9 +68,8 @@ main = do
 eventuallyRemove :: FilePath -> Int -> IO ()
 eventuallyRemove path retries = case retries of
   0 -> action
-  n ->
-    action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of
-      IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1)
-      _ -> E.throwIO ioe
+  n -> action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of
+    IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1)
+    _ -> E.throwIO ioe
   where
     action = removeDirectoryRecursive path

tests/XFTPAgent.hs

@@ -8,7 +8,6 @@ module XFTPAgent where
 
 import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet)
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.STM
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
@@ -25,13 +24,11 @@ import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
 import Simplex.Messaging.Agent (AgentClient, disconnectAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
-import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
-import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
-import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
+import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory)
 import System.FilePath ((</>))
 import System.Timeout (timeout)
 import Test.Hspec
@@ -48,9 +45,6 @@ xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do
   it "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
   it "should delete sent file on server" testXFTPAgentDelete
   it "should resume deleting file after restart" testXFTPAgentDeleteRestore
-  -- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error
-  it "if file is deleted on server, should limit retries and continue receiving next file" testXFTPAgentDeleteOnServer
-  it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer
   it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
   describe "XFTP server test via agent API" $ do
     it "should pass without basic auth" $ testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
@@ -94,18 +88,18 @@ testXFTPAgentSendReceive :: HasCallStack => IO ()
 testXFTPAgentSendReceive = withXFTPServer $ do
   filePath <- createRandomFile
   -- send file, delete snd file internally
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
   (rfd1, rfd2) <- runRight $ do
     (sfId, _, rfd1, rfd2) <- testSend sndr filePath
     xftpDeleteSndFileInternal sndr sfId
     pure (rfd1, rfd2)
 
   -- receive file, delete rcv file
-  testReceiveDelete 2 rfd1 filePath
-  testReceiveDelete 3 rfd2 filePath
+  testReceiveDelete rfd1 filePath
+  testReceiveDelete rfd2 filePath
   where
-    testReceiveDelete clientId rfd originalFilePath = do
-      rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2
+    testReceiveDelete rfd originalFilePath = do
+      rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
       runRight_ $ do
         rfId <- testReceive rcp rfd originalFilePath
         xftpDeleteRcvFile rcp rfId
@@ -113,34 +107,30 @@ testXFTPAgentSendReceive = withXFTPServer $ do
 
 testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
 testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
-  g <- C.newRandom
   filePath <- createRandomFile
   s <- LB.readFile filePath
-  file <- atomically $ CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs g
+  file <- CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs
   runRight_ $ CF.writeFile file s
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
   (rfd1, rfd2) <- runRight $ do
     (sfId, _, rfd1, rfd2) <- testSendCF sndr file
     xftpDeleteSndFileInternal sndr sfId
     pure (rfd1, rfd2)
   -- receive file, delete rcv file
-  testReceiveDelete 2 rfd1 filePath g
-  testReceiveDelete 3 rfd2 filePath g
+  testReceiveDelete rfd1 filePath
+  testReceiveDelete rfd2 filePath
   where
-    testReceiveDelete clientId rfd originalFilePath g = do
-      rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2
-      cfArgs <- atomically $ Just <$> CF.randomArgs g
+    testReceiveDelete rfd originalFilePath = do
+      rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
+      cfArgs <- Just <$> CF.randomArgs
       runRight_ $ do
         rfId <- testReceiveCF rcp rfd cfArgs originalFilePath
         xftpDeleteRcvFile rcp rfId
       disconnectAgentClient rcp
 
 createRandomFile :: HasCallStack => IO FilePath
-createRandomFile = createRandomFile' "testfile"
-
-createRandomFile' :: HasCallStack => FilePath -> IO FilePath
-createRandomFile' fileName = do
-  let filePath = senderFiles </> fileName
+createRandomFile = do
+  let filePath = senderFiles </> "testfile"
   xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   getFileSize filePath `shouldReturn` mb 17
   pure filePath
@@ -163,13 +153,6 @@ testReceive rcp rfd = testReceiveCF rcp rfd Nothing
 testReceiveCF :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
 testReceiveCF rcp rfd cfArgs originalFilePath = do
   xftpStartWorkers rcp (Just recipientFiles)
-  testReceiveCF' rcp rfd cfArgs originalFilePath
-
-testReceive' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
-testReceive' rcp rfd = testReceiveCF' rcp rfd Nothing
-
-testReceiveCF' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
-testReceiveCF' rcp rfd cfArgs originalFilePath = do
   rfId <- xftpReceiveFile rcp 1 rfd cfArgs
   rfProgress rcp $ mb 18
   ("", rfId', RFDONE path) <- rfGet rcp
@@ -188,13 +171,13 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
 
   rfd <- withXFTPServerStoreLogOn $ \_ -> do
     -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight $ do
       (_, _, rfd, _) <- testSend sndr filePath
       pure rfd
 
   -- receive file - should not succeed with server down
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
   rfId <- runRight $ do
     xftpStartWorkers rcp (Just recipientFiles)
     rfId <- xftpReceiveFile rcp 1 rfd Nothing
@@ -208,7 +191,7 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerStoreLogOn $ \_ -> do
     -- receive file - should start downloading with server up
-    rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+    rcp' <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
     ("", rfId', RFPROG _ _) <- rfGet rcp'
     liftIO $ rfId' `shouldBe` rfId
@@ -218,7 +201,7 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerStoreLogOn $ \_ -> do
     -- receive file - should continue downloading with server up
-    rcp' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
+    rcp' <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
     rfProgress rcp' $ mb 18
     ("", rfId', RFDONE path) <- rfGet rcp'
@@ -236,13 +219,13 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
 
   rfd <- withXFTPServerStoreLogOn $ \_ -> do
     -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight $ do
       (_, _, rfd, _) <- testSend sndr filePath
       pure rfd
 
   -- receive file - should not succeed with server down
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
   rfId <- runRight $ do
     xftpStartWorkers rcp (Just recipientFiles)
     rfId <- xftpReceiveFile rcp 1 rfd Nothing
@@ -256,7 +239,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerThreadOn $ \_ -> do
     -- receive file - should fail with AUTH error
-    rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+    rcp' <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
     ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
     rfId' `shouldBe` rfId
@@ -269,7 +252,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
   filePath <- createRandomFile
 
   -- send file - should not succeed with server down
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
   sfId <- runRight $ do
     xftpStartWorkers sndr (Just senderFiles)
     sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
@@ -286,7 +269,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerStoreLogOn $ \_ -> do
     -- send file - should start uploading with server up
-    sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
     ("", sfId', SFPROG _ _) <- sfGet sndr'
     liftIO $ sfId' `shouldBe` sfId
@@ -296,7 +279,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerStoreLogOn $ \_ -> do
     -- send file - should continue uploading with server up
-    sndr' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
     sfProgress sndr' $ mb 18
     ("", sfId', SFDONE _sndDescr [rfd1, _rfd2]) <- sfGet sndr'
@@ -308,7 +291,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
     doesFileExist encPath `shouldReturn` False
 
     -- receive file
-    rcp <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
+    rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ . void $
       testReceive rcp rfd1 filePath
 
@@ -318,7 +301,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
 
   sfId <- withXFTPServerStoreLogOn $ \_ -> do
     -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
     sfId <- runRight $ do
       xftpStartWorkers sndr (Just senderFiles)
       sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
@@ -339,7 +322,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerThreadOn $ \_ -> do
     -- send file - should fail with AUTH error
-    sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
     ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
     sfId' `shouldBe` sfId
@@ -354,11 +337,11 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
     filePath <- createRandomFile
 
     -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
     (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
 
     -- receive file
-    rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+    rcp1 <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ . void $
       testReceive rcp1 rfd1 filePath
 
@@ -376,7 +359,7 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
     length <$> listDirectory xftpServerFiles `shouldReturn` 0
 
     -- receive file - should fail with AUTH error
-    rcp2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
+    rcp2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight $ do
       xftpStartWorkers rcp2 (Just recipientFiles)
       rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
@@ -389,11 +372,11 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
 
   (sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do
     -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
     (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
 
     -- receive file
-    rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+    rcp1 <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ . void $
       testReceive rcp1 rfd1 filePath
     disconnectAgentClient rcp1
@@ -401,7 +384,7 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
     pure (sfId, sndDescr, rfd2)
 
   -- delete file - should not succeed with server down
-  sndr <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight $ do
     xftpStartWorkers sndr (Just senderFiles)
     xftpDeleteSndFileRemote sndr 1 sfId sndDescr
@@ -413,103 +396,26 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
 
   withXFTPServerStoreLogOn $ \_ -> do
     -- delete file - should succeed with server up
-    sndr' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
 
     threadDelay 1000000
     length <$> listDirectory xftpServerFiles `shouldReturn` 0
 
     -- receive file - should fail with AUTH error
-    rcp2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB3
+    rcp2 <- getSMPAgentClient' agentCfg initAgentServers testDB3
     runRight $ do
       xftpStartWorkers rcp2 (Just recipientFiles)
       rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
       ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
       liftIO $ rfId' `shouldBe` rfId
 
-testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
-testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
-  withXFTPServer $ do
-    filePath1 <- createRandomFile' "testfile1"
-
-    -- send file 1
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
-
-    -- receive file 1 successfully
-    rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp rfd1_1 filePath1
-
-    serverFiles <- listDirectory xftpServerFiles
-    length serverFiles `shouldBe` 6
-
-    -- delete file 1 on server from file system
-    forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
-
-    threadDelay 1000000
-    length <$> listDirectory xftpServerFiles `shouldReturn` 0
-
-    -- create and send file 2
-    filePath2 <- createRandomFile' "testfile2"
-    (_, _, rfd2, _) <- runRight $ testSend sndr filePath2
-
-    length <$> listDirectory xftpServerFiles `shouldReturn` 6
-
-    runRight_ . void $ do
-      -- receive file 1 again
-      -- TODO should fail with AUTH error
-      _rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
-
-      -- receive file 2
-      testReceive' rcp rfd2 filePath2
-
-testXFTPAgentExpiredOnServer :: HasCallStack => IO ()
-testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
-  let fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
-  withXFTPServerCfg testXFTPServerConfig {fileExpiration = Just fastExpiration} . const $ do
-    filePath1 <- createRandomFile' "testfile1"
-
-    -- send file 1
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
-
-    -- receive file 1 successfully
-    rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp rfd1_1 filePath1
-
-    serverFiles <- listDirectory xftpServerFiles
-    length serverFiles `shouldBe` 6
-
-    -- wait until file 1 expires on server
-    forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
-
-    threadDelay 3500000
-    length <$> listDirectory xftpServerFiles `shouldReturn` 0
-
-    -- receive file 1 again - should fail with AUTH error
-    runRight $ do
-      rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing
-      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp
-      liftIO $ rfId' `shouldBe` rfId
-
-    -- create and send file 2
-    filePath2 <- createRandomFile' "testfile2"
-    (_, _, rfd2, _) <- runRight $ testSend sndr filePath2
-
-    length <$> listDirectory xftpServerFiles `shouldReturn` 6
-
-    -- receive file 2 successfully
-    runRight_ . void $
-      testReceive' rcp rfd2 filePath2
-
 testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO ()
 testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
   filePath <- createRandomFile
 
   -- send file
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
   rfds <- runRight $ do
     xftpStartWorkers sndr (Just senderFiles)
     sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500
@@ -522,7 +428,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
 
   -- receive file using different descriptions
   -- ! revise number of recipients and indexes if xftpMaxRecipientsPerRequest is changed
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+  rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     void $ testReceive rcp (head rfds) filePath
     void $ testReceive rcp (rfds !! 99) filePath
@@ -532,5 +438,5 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
 testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testXFTPServerTest newFileBasicAuth srv =
   withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do
-    a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running
+    a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
     runRight $ testProtocolServer a 1 srv

tests/XFTPClient.hs

@@ -12,7 +12,7 @@ import SMPClient (serverBracket)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Server (runXFTPServerBlocking)
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Transport.Server
 import Test.Hspec
@@ -97,7 +97,6 @@ testXFTPServerConfig :: XFTPServerConfig
 testXFTPServerConfig =
   XFTPServerConfig
     { xftpPort = xftpTestPort,
-      controlPort = Nothing,
       fileIdSize = 16,
       storeLogFile = Nothing,
       filesPath = xftpServerFiles,
@@ -106,7 +105,6 @@ testXFTPServerConfig =
       allowNewFiles = True,
       newFileBasicAuth = Nothing,
       fileExpiration = Just defaultFileExpiration,
-      inactiveClientExpiration = Just defaultInactiveClientExpiration,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",

tests/XFTPServerTests.hs

@@ -8,10 +8,12 @@ module XFTPServerTests where
 
 import AgentTests.FunctionalAPITests (runRight_)
 import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
 import Control.Exception (SomeException)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
+import Crypto.Random (getRandomBytes)
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -28,11 +30,9 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol (BasicAuth, SenderId)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
-import Simplex.Messaging.Util (liftIOEither)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
 import Test.Hspec
-import UnliftIO.STM
 import XFTPClient
 
 xftpServerTests :: Spec
@@ -50,7 +50,6 @@ xftpServerTests =
       it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
       it "should not allow chunks of wrong size" testWrongChunkSize
       it "should expire chunks after set interval" testFileChunkExpiration
-      it "should disconnect inactive clients" testInactiveClientExpiration
       it "should not allow uploading chunks after specified storage quota" testFileStorageQuota
       it "should store file records to log and restore them after server restart" testFileLog
       describe "XFTP basic auth" $ do
@@ -69,8 +68,7 @@ testChunkPath = "tests/tmp/chunk1"
 
 createTestChunk :: FilePath -> IO ByteString
 createTestChunk fp = do
-  g <- C.newRandom
-  bytes <- atomically $ C.randomBytes chSize g
+  bytes <- getRandomBytes chSize
   B.writeFile fp bytes
   pure bytes
 
@@ -85,9 +83,8 @@ testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDeliver
 
 runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
 runTestFileChunkDelivery s r = do
-  g <- liftIO C.newRandom
-  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -98,18 +95,17 @@ runTestFileChunkDelivery s r = do
   uploadXFTPChunk s spKey sId' chunkSpec
     `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
   liftIO $ readChunk sId `shouldReturn` bytes
-  downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
     `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
-  downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
 
 testFileChunkDeliveryAddRecipients :: Expectation
 testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
-  g <- liftIO C.newRandom
-  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey3, rpKey3) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey3, rpKey3) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -118,7 +114,7 @@ testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
   [rId2, rId3] <- addXFTPRecipients s spKey sId [rcvKey2, rcvKey3]
   uploadXFTPChunk s spKey sId chunkSpec
   let testReceiveChunk r rpKey rId fPath = do
-        downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest
+        downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest
         liftIO $ B.readFile fPath `shouldReturn` bytes
   testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1"
   testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2"
@@ -132,9 +128,8 @@ testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s
 
 runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
 runTestFileChunkDelete s r = do
-  g <- liftIO C.newRandom
-  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -142,13 +137,13 @@ runTestFileChunkDelete s r = do
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
 
-  downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
   deleteXFTPChunk s spKey sId
   liftIO $
     readChunk sId
       `shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e
-  downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   deleteXFTPChunk s spKey sId
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
@@ -161,9 +156,8 @@ testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
 
 runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
 runTestFileChunkAck s r = do
-  g <- liftIO C.newRandom
-  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -171,33 +165,30 @@ runTestFileChunkAck s r = do
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
 
-  downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
   ackXFTPChunk r rpKey rId
   liftIO $ readChunk sId `shouldReturn` bytes
-  downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   ackXFTPChunk r rpKey rId
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
 
 testWrongChunkSize :: Expectation
-testWrongChunkSize = xftpTest $ \c -> do
-  g <- C.newRandom
-  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey, _rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  B.writeFile testChunkPath =<< atomically (C.randomBytes (kb 96) g)
-  digest <- LC.sha256Hash <$> LB.readFile testChunkPath
+testWrongChunkSize = xftpTest $ \c -> runRight_ $ do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, _rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  liftIO $ B.writeFile testChunkPath =<< getRandomBytes (kb 96)
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = kb 96, digest}
-  runRight_ $
-    void (createXFTPChunk c spKey file [rcvKey] Nothing)
-      `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
+  void (createXFTPChunk c spKey file [rcvKey] Nothing)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
 
 testFileChunkExpiration :: Expectation
 testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $
   \_ -> testXFTPClient $ \c -> runRight_ $ do
-    g <- liftIO C.newRandom
-    (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     bytes <- liftIO $ createTestChunk testChunkPath
     digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
     let file = FileInfo {sndKey, size = chSize, digest}
@@ -205,44 +196,28 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
     (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId chunkSpec
 
-    downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+    downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
     liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
 
     liftIO $ threadDelay 1000000
-    downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+    downloadXFTPChunk c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
     deleteXFTPChunk c spKey sId
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   where
     fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
 
-testInactiveClientExpiration :: Expectation
-testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
-  disconnected <- newEmptyTMVarIO
-  c <- liftIOEither $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
-  pingXFTP c
-  liftIO $ do
-    threadDelay 100000
-    atomically (tryReadTMVar disconnected) `shouldReturn` Nothing
-  pingXFTP c
-  liftIO $ do
-    threadDelay 3000000
-    atomically (tryTakeTMVar disconnected) `shouldReturn` Just ()
-  where
-    inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
-
 testFileStorageQuota :: Expectation
 testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $
   \_ -> testXFTPClient $ \c -> runRight_ $ do
-    g <- liftIO C.newRandom
-    (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     bytes <- liftIO $ createTestChunk testChunkPath
     digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
     let file = FileInfo {sndKey, size = chSize, digest}
         chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
         download rId = do
-          downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+          downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
           liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
     (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId1 chunkSpec
@@ -261,11 +236,10 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
 
 testFileLog :: Expectation
 testFileLog = do
-  g <- C.newRandom
   bytes <- liftIO $ createTestChunk testChunkPath
-  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-  (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   sIdVar <- newTVarIO ""
   rIdVar1 <- newTVarIO ""
@@ -283,10 +257,10 @@ testFileLog = do
         writeTVar rIdVar1 rId1
         writeTVar rIdVar2 rId2
     uploadXFTPChunk c spKey sId chunkSpec
-    download g c rpKey1 rId1 digest bytes
-    download g c rpKey2 rId2 digest bytes
+    download c rpKey1 rId1 digest bytes
+    download c rpKey2 rId2 digest bytes
   logSize testXFTPLogFile `shouldReturn` 3
-  logSize testXFTPStatsBackupFile `shouldReturn` 14
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   threadDelay 100000
 
@@ -295,9 +269,9 @@ testFileLog = do
     rId1 <- liftIO $ readTVarIO rIdVar1
     rId2 <- liftIO $ readTVarIO rIdVar2
     -- recipients and sender get AUTH error because server restarted without log
-    downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
+    downloadXFTPChunk c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
-    downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
+    downloadXFTPChunk c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
     deleteXFTPChunk c spKey sId
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
@@ -308,12 +282,12 @@ testFileLog = do
     rId1 <- liftIO $ readTVarIO rIdVar1
     rId2 <- liftIO $ readTVarIO rIdVar2
     -- recipient 1 can download, acknowledges - +1 to log
-    download g c rpKey1 rId1 digest bytes
+    download c rpKey1 rId1 digest bytes
     ackXFTPChunk c rpKey1 rId1
     -- recipient 2 can download
-    download g c rpKey2 rId2 digest bytes
+    download c rpKey2 rId2 digest bytes
   logSize testXFTPLogFile `shouldReturn` 4
-  logSize testXFTPStatsBackupFile `shouldReturn` 14
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   threadDelay 100000
 
@@ -327,48 +301,46 @@ testFileLog = do
     rId1 <- liftIO $ readTVarIO rIdVar1
     rId2 <- liftIO $ readTVarIO rIdVar2
     -- recipient 1 can't download due to previous acknowledgement
-    download g c rpKey1 rId1 digest bytes
+    download c rpKey1 rId1 digest bytes
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
     -- recipient 2 can download
-    download g c rpKey2 rId2 digest bytes
+    download c rpKey2 rId2 digest bytes
     -- sender can delete - +1 to log
     deleteXFTPChunk c spKey sId
   logSize testXFTPLogFile `shouldReturn` 4
-  logSize testXFTPStatsBackupFile `shouldReturn` 14
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   threadDelay 100000
 
   withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start
   logSize testXFTPLogFile `shouldReturn` 0
-  logSize testXFTPStatsBackupFile `shouldReturn` 14
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   threadDelay 100000
 
   removeFile testXFTPLogFile
   removeFile testXFTPStatsBackupFile
   where
-    download g c rpKey rId digest bytes = do
-      downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+    download c rpKey rId digest bytes = do
+      downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
       liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
 
 testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO ()
 testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success =
   withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $
-    \_ -> testXFTPClient $ \c -> do
-      g <- C.newRandom
-      (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-      (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-      bytes <- createTestChunk testChunkPath
-      digest <- LC.sha256Hash <$> LB.readFile testChunkPath
+    \_ -> testXFTPClient $ \c -> runRight_ $ do
+      (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+      (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+      bytes <- liftIO $ createTestChunk testChunkPath
+      digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
       let file = FileInfo {sndKey, size = chSize, digest}
           chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
-      runRight_ $
-        if success
-          then do
-            (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
-            uploadXFTPChunk c spKey sId chunkSpec
-            downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
-            liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
-          else do
-            void (createXFTPChunk c spKey file [rcvKey] clntAuth)
-              `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+      if success
+        then do
+          (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
+          uploadXFTPChunk c spKey sId chunkSpec
+          downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
+          liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
+        else do
+          void (createXFTPChunk c spKey file [rcvKey] clntAuth)
+            `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))