5.5.0.2

* xftp-server: add inactiveClientExpiration

* fix test config

* add test

* add xftpPing

* switch to PCEUnexpectedResponse

* remove watchdog when server quits

* rename, loop

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

.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'
+        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' && matrix.ghc == '9.6.3'
         uses: softprops/action-gh-release@v1
         with:
           body: |

apps/smp-agent/Main.hs

@@ -35,6 +35,7 @@ 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.4.0.7
+version: 5.5.0.2
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -65,8 +65,7 @@ dependencies:
   - sqlcipher-simple == 0.4.*
   - stm == 2.5.*
   - temporary == 1.3.*
-  - time == 1.9.*
-  - time-compat == 1.9.*
+  - time == 1.12.*
   - time-manager == 0.0.*
   - tls >= 1.7.0 && < 1.8
   - transformers == 0.6.*

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.4.0.7
+version:        5.5.0.2
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -98,6 +98,8 @@ 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.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
@@ -212,8 +214,7 @@ library
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
@@ -285,8 +286,7 @@ executable ntf-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
@@ -358,8 +358,7 @@ executable smp-agent
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
@@ -431,8 +430,7 @@ executable smp-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
@@ -504,8 +502,7 @@ executable xftp
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
@@ -577,8 +574,7 @@ executable xftp-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
@@ -687,8 +683,7 @@ test-suite simplexmq-test
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , temporary ==1.3.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
     , tls >=1.7.0 && <1.8

src/Simplex/FileTransfer/Agent.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
@@ -31,6 +30,7 @@ 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,8 +58,6 @@ 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
@@ -69,37 +67,34 @@ startXFTPWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
 startXFTPWorkers c workDir = do
   wd <- asks $ xftpWorkDir . xftpAgent
   atomically $ writeTVar wd workDir
-  startRcvFiles
-  startSndFiles
-  startDelFiles
+  cfg <- asks config
+  startRcvFiles cfg
+  startSndFiles cfg
+  startDelFiles cfg
   where
-    startRcvFiles = do
-      rcvFilesTTL <- asks $ rcvFilesTTL . config
+    startRcvFiles AgentConfig {rcvFilesTTL} = do
       pendingRcvServers <- withStore' c (`getPendingRcvFilesServers` rcvFilesTTL)
-      forM_ pendingRcvServers $ \s -> addXFTPRcvWorker c (Just s)
+      forM_ pendingRcvServers $ \s -> resumeXFTPRcvWork 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
-      addXFTPRcvWorker c Nothing
-    startSndFiles = do
-      sndFilesTTL <- asks $ sndFilesTTL . config
+      resumeXFTPRcvWork c Nothing
+    startSndFiles AgentConfig {sndFilesTTL} = do
       -- start worker for files pending encryption/creation
-      addXFTPSndWorker c Nothing
+      resumeXFTPSndWork c Nothing
       pendingSndServers <- withStore' c (`getPendingSndFilesServers` sndFilesTTL)
-      forM_ pendingSndServers $ \s -> addXFTPSndWorker c (Just s)
-    startDelFiles = do
-      rcvFilesTTL <- asks $ rcvFilesTTL . config
+      forM_ pendingSndServers $ \s -> resumeXFTPSndWork c (Just s)
+    startDelFiles AgentConfig {rcvFilesTTL} = do
       pendingDelServers <- withStore' c (`getPendingDelFilesServers` rcvFilesTTL)
-      forM_ pendingDelServers $ addXFTPDelWorker c
+      forM_ pendingDelServers $ resumeXFTPDelWork c
 
 closeXFTPAgent :: MonadUnliftIO m => XFTPAgent -> m ()
-closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
-  stopWorkers xftpRcvWorkers
-  stopWorkers xftpSndWorkers
+closeXFTPAgent a = do
+  stopWorkers $ xftpRcvWorkers a
+  stopWorkers $ xftpSndWorkers a
+  stopWorkers $ xftpDelWorkers a
   where
-    stopWorkers wsSel = do
-      ws <- atomically $ stateTVar wsSel (,M.empty)
-      mapM_ (uninterruptibleCancel . snd) ws
+    stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 
 xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
 xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfArgs = do
@@ -118,7 +113,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfA
   where
     downloadChunk :: AgentMonad m => FileChunk -> m ()
     downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
-      addXFTPRcvWorker c (Just server)
+      void $ getXFTPRcvWorker True c (Just server)
     downloadChunk _ = throwError $ INTERNAL "no replicas"
 
 getPrefixPath :: AgentMonad m => String -> m FilePath
@@ -134,55 +129,35 @@ toFSFilePath f = (</> f) <$> getXFTPWorkPath
 createEmptyFile :: AgentMonad m => FilePath -> m ()
 createEmptyFile fPath = liftIO $ B.writeFile fPath ""
 
-addXFTPRcvWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
-addXFTPRcvWorker c = addWorker c xftpRcvWorkers runXFTPRcvWorker runXFTPRcvLocalWorker
+resumeXFTPRcvWork :: AgentMonad' m => AgentClient -> Maybe XFTPServer -> m ()
+resumeXFTPRcvWork = void .: getXFTPRcvWorker False
 
-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 ()
+getXFTPRcvWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe XFTPServer -> m Worker
+getXFTPRcvWorker hasWork c server = do
+  ws <- asks $ xftpRcvWorkers . xftpAgent
+  getAgentWorker hasWork c server ws $
+    maybe (runXFTPRcvLocalWorker c) (runXFTPRcvWorker c) server
 
-runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
-runXFTPRcvWorker c srv doWork = do
+runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
+runXFTPRcvWorker c srv Worker {doWork} = do
+  cfg <- asks config
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation
+    runXFTPOperation cfg
   where
-    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
+    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
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryInterval ri' $ \delay' loop ->
+          withRetryIntervalLimit xftpConsecutiveRetries 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
@@ -205,7 +180,8 @@ runXFTPRcvWorker c srv doWork = do
         liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
         pure (complete, RFPROG rcvd total)
       notify c rcvFileEntityId progress
-      when complete $ addXFTPRcvWorker c Nothing
+      when complete . void $
+        getXFTPRcvWorker True c Nothing
       where
         receivedSize :: [RcvFileChunk] -> Int64
         receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0
@@ -214,6 +190,12 @@ runXFTPRcvWorker c srv 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
@@ -227,22 +209,19 @@ 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 -> TMVar () -> m ()
-runXFTPRcvLocalWorker c doWork = do
+runXFTPRcvLocalWorker :: forall m. AgentMonad m => AgentClient -> Worker -> m ()
+runXFTPRcvLocalWorker c Worker {doWork} = do
+  cfg <- asks config
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation
+    runXFTPOperation cfg
   where
-    runXFTPOperation :: m ()
-    runXFTPOperation = do
-      rcvFilesTTL <- asks (rcvFilesTTL . config)
-      nextFile <- withStore' c (`getNextRcvFileToDecrypt` rcvFilesTTL)
-      case nextFile of
-        Nothing -> noWorkToDo
-        Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
+    runXFTPOperation :: AgentConfig -> m ()
+    runXFTPOperation AgentConfig {rcvFilesTTL} =
+      withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
+        \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
@@ -286,36 +265,39 @@ xftpSendFile' c userId file numRecipients = do
   prefixPath <- getPrefixPath "snd.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
-  key <- liftIO C.randomSbKey
-  nonce <- liftIO C.randomCbNonce
+  key <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
   -- 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
-  addXFTPSndWorker c Nothing
+  void $ getXFTPSndWorker True c Nothing
   pure fId
 
-addXFTPSndWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
-addXFTPSndWorker c = addWorker c xftpSndWorkers runXFTPSndWorker runXFTPSndPrepareWorker
+resumeXFTPSndWork :: AgentMonad' m => AgentClient -> Maybe XFTPServer -> m ()
+resumeXFTPSndWork = void .: getXFTPSndWorker False
 
-runXFTPSndPrepareWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
-runXFTPSndPrepareWorker c doWork = do
+getXFTPSndWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe XFTPServer -> m Worker
+getXFTPSndWorker hasWork c server = do
+  ws <- asks $ xftpSndWorkers . xftpAgent
+  getAgentWorker 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
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation
+    runXFTPOperation cfg
   where
-    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} =
+    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} =
       throwError $ INTERNAL "no prefix path"
-    prepareFile sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do
+    prepareFile cfg sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do
       SndFile {numRecipients, chunks} <-
         if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
           then do
@@ -328,12 +310,13 @@ runXFTPSndPrepareWorker c 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
@@ -358,10 +341,9 @@ runXFTPSndPrepareWorker c doWork = do
           atomically $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate
           withStore' c $ \db -> createSndFileReplica db ch replica
-          addXFTPSndWorker c $ Just srv
+          void $ getXFTPSndWorker True c (Just srv)
           where
             tryCreate = do
-              ri <- asks $ messageRetryInterval . config
               usedSrvs <- newTVarIO ([] :: [XFTPServer])
               withRetryInterval (riFast ri) $ \_ loop ->
                 createWithNextSrv usedSrvs
@@ -381,39 +363,34 @@ 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 -> TMVar () -> m ()
-runXFTPSndWorker c srv doWork = do
+runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
+runXFTPSndWorker c srv Worker {doWork} = do
+  cfg <- asks config
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation
+    runXFTPOperation cfg
   where
-    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
+    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
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryInterval ri' $ \delay' loop ->
-            uploadFileChunk fc replica
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
+            uploadFileChunk cfg 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 :: SndFileChunk -> SndFileChunkReplica -> m ()
-    uploadFileChunk sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
+    uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> m ()
+    uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} 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"
@@ -439,7 +416,6 @@ runXFTPSndWorker c srv 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'
@@ -527,55 +503,47 @@ 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
-      addXFTPDelWorker c server
+      void $ getXFTPDelWorker True c server
     deleteFileChunk _ = pure ()
 
-addXFTPDelWorker :: AgentMonad m => AgentClient -> XFTPServer -> m ()
-addXFTPDelWorker c srv = do
-  ws <- asks $ xftpDelWorkers . xftpAgent
-  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 ()
+resumeXFTPDelWork :: AgentMonad' m => AgentClient -> XFTPServer -> m ()
+resumeXFTPDelWork = void .: getXFTPDelWorker False
 
-runXFTPDelWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
-runXFTPDelWorker c srv doWork = do
+getXFTPDelWorker :: AgentMonad' m => Bool -> AgentClient -> XFTPServer -> m Worker
+getXFTPDelWorker hasWork c server = do
+  ws <- asks $ xftpDelWorkers . xftpAgent
+  getAgentWorker hasWork c server ws $ runXFTPDelWorker c server
+
+runXFTPDelWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
+runXFTPDelWorker c srv Worker {doWork} = do
+  cfg <- asks config
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     atomically $ assertAgentForeground c
-    runXFTPOperation
+    runXFTPOperation cfg
   where
-    noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    runXFTPOperation :: m ()
-    runXFTPOperation = do
+    runXFTPOperation :: AgentConfig -> m ()
+    runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do
       -- no point in deleting files older than rcv ttl, as they will be expired on server
-      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
+      withWork c doWork (\db -> getNextDeletedSndChunkReplica db srv rcvFilesTTL) processDeletedReplica
+      where
+        processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryInterval ri' $ \delay' loop ->
-            deleteChunkReplica replica
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
+            deleteChunkReplica
               `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 :: DeletedSndChunkReplica -> m ()
-    deleteChunkReplica replica@DeletedSndChunkReplica {userId, deletedSndChunkReplicaId} = do
-      agentXFTPDeleteChunk c userId replica
-      withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
+            deleteChunkReplica = 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,6 +11,7 @@ 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)
@@ -131,11 +132,15 @@ 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 XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
+sendXFTPCommand c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
   t <-
     liftEither . first PCETransportError $
       xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
-  let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
+  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
       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
@@ -147,8 +152,8 @@ sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}}
       _ -> pure (r, body)
     Left e -> throwError $ PCEResponseError e
   where
-    streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
-    streamBody t send done = do
+    streamBody :: (Builder -> IO ()) -> IO () -> IO ()
+    streamBody send done = do
       send $ byteString t
       forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
         withFile filePath ReadMode $ \h -> do
@@ -178,9 +183,9 @@ uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpe
 uploadXFTPChunk c spKey fId chunkSpec =
   sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
-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'
+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
   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
@@ -206,6 +211,16 @@ 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,7 +15,6 @@ module Simplex.FileTransfer.Client.Main
     CLIError (..),
     xftpClientCLI,
     cliSendFile,
-    cliSendFileOpts,
     prepareChunkSizes,
     prepareChunkSpecs,
     maxFileSize,
@@ -28,7 +27,7 @@ where
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
-import Crypto.Random (getRandomBytes)
+import Crypto.Random (ChaChaDRG)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
@@ -264,10 +263,11 @@ 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..."
-  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName
+  g <- liftIO C.newRandom
+  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload g fileName
   liftIO $ when printInfo $ printNoNewLine "Uploading file..."
   uploadedChunks <- newTVarIO []
-  sentChunks <- uploadFile chunkSpecs uploadedChunks encSize
+  sentChunks <- uploadFile g 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 :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
-    encryptFileForUpload fileName = do
+    encryptFileForUpload :: TVar ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
+    encryptFileForUpload g fileName = do
       fileSize <- fromInteger <$> getFileSize filePath
       when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
       encPath <- getEncPath tempPath "xftp"
-      key <- liftIO C.randomSbKey
-      nonce <- liftIO C.randomCbNonce
+      key <- atomically $ C.randomSbKey g
+      nonce <- atomically $ C.randomCbNonce g
       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 :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
-    uploadFile chunks uploadedChunks encSize = do
+    uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
+    uploadFile g 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) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-          rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
+          (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+          rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519 g)
           digest <- liftIO $ getChunkDigest chunkSpec
           let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
@@ -423,7 +423,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
             [] -> error "empty FileChunk.replicas"
             FileChunkReplica {server} : _ -> server
           srvChunks = groupAllOn srv chunks
-      chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks)
+      g <- liftIO C.newRandom
+      chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk g 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
@@ -435,13 +436,13 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       liftIO $ do
         printNoNewLine $ "File downloaded: " <> path
         removeFD yes fileDescription
-    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
+    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
       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 c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      withReconnect a server retryCount $ \c -> downloadXFTPChunk g 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')
@@ -449,7 +450,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
@@ -593,7 +594,8 @@ cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
   putStrLn $ "File created: " <> filePath
   where
     saveRandomFile h sz = do
-      bytes <- getRandomBytes $ fromIntegral $ min mb' sz
+      g <- C.newRandom
+      bytes <- atomically $ C.randomBytes (fromIntegral $ min mb' sz) g
       B.hPut h bytes
       when (sz > mb') $ saveRandomFile h (sz - mb')
     mb' = mb 1

src/Simplex/FileTransfer/Server.hs

@@ -16,7 +16,6 @@ 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)
@@ -71,7 +70,7 @@ runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
 runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
 
 xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig} started = do
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration} started = do
   restoreServerStats
   raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer
   where
@@ -80,7 +79,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig} started = do
       serverParams <- asks tlsServerParams
       env <- ask
       liftIO $
-        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig $ \sessionId r sendResponse -> do
+        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do
           reqBody <- getHTTP2Body r xftpBlockSize
           processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
 
@@ -318,9 +317,10 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
       readTVarIO filePath >>= \case
         Just path -> do
-          (sDhKey, spDhKey) <- liftIO C.generateKeyPair'
+          g <- asks random
+          (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g
           let dhSecret = C.dh' rDhKey spDhKey
-          cbNonce <- liftIO C.randomCbNonce
+          cbNonce <- atomically $ C.randomCbNonce g
           case LC.cbInit dhSecret cbNonce of
             Right sbState -> do
               stats <- asks serverStats
@@ -360,12 +360,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       pure FROk
 
 randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
-randomId n = do
-  gVar <- asks idsDrg
-  atomically (C.pseudoRandomBytes n gVar)
+randomId n = atomically . C.randomBytes n =<< asks random
 
 getFileId :: M XFTPFileId
-getFileId = liftIO . getRandomBytes =<< asks (fileIdSize . config)
+getFileId = do
+  size <- asks (fileIdSize . config)
+  atomically . C.randomBytes size =<< asks random
 
 withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
 withFileLog action = liftIO . mapM_ action =<< asks storeLog

src/Simplex/FileTransfer/Server/Env.hs

@@ -46,6 +46,8 @@ 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,
@@ -58,11 +60,18 @@ 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),
-    idsDrg :: TVar ChaChaDRG,
+    random :: TVar ChaChaDRG,
     serverIdentity :: C.KeyHash,
     tlsServerParams :: T.ServerParams,
     serverStats :: FileServerStats
@@ -80,7 +89,7 @@ defaultFileExpiration =
 
 newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv
 newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
-  idsDrg <- drgNew >>= newTVarIO
+  random <- liftIO C.newRandom
   store <- atomically newFileStore
   storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
   used <- readTVarIO (usedStorage store)
@@ -90,7 +99,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, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+  pure XFTPEnv {config, store, storeLog, random, 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)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
 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.1.3"
+xftpServerVersion = "1.2.0.2"
 
 xftpServerCLI :: FilePath -> FilePath -> IO ()
 xftpServerCLI cfgPath logPath = do
@@ -104,6 +104,12 @@ xftpServerCLI cfgPath logPath = do
                \[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
@@ -118,13 +124,16 @@ 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} = do
+        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = 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
@@ -147,6 +156,12 @@ 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/Messaging/Agent.hs

@@ -64,6 +64,7 @@ module Simplex.Messaging.Agent
     resubscribeConnection,
     resubscribeConnections,
     sendMessage,
+    sendMessages,
     ackMessage,
     switchConnection,
     abortConnectionSwitch,
@@ -113,20 +114,22 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
-import Crypto.Random (MonadRandom)
+import Crypto.Random (ChaChaDRG, MonadRandom)
 import qualified Data.Aeson as J
 import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:), (.:.), (.::), (.::.))
-import Data.Foldable (foldl')
+import Data.Either (rights)
+import Data.Foldable (foldl', toList)
 import Data.Functor (($>))
+import Data.Functor.Identity
 import Data.List (find)
 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 (catMaybes, fromMaybe, isJust, isNothing)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock
@@ -164,21 +167,24 @@ import Simplex.Messaging.Version
 import Simplex.RemoteControl.Client
 import Simplex.RemoteControl.Invitation
 import Simplex.RemoteControl.Types
-import UnliftIO.Async (async, race_)
+import UnliftIO.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 -> m AgentClient
-getSMPAgentClient cfg initServers store =
+getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> m AgentClient
+getSMPAgentClient cfg initServers store backgroundMode =
   liftIO (newSMPAgentEnv cfg store) >>= runReaderT runAgent
   where
     runAgent = do
       c <- getAgentClient initServers
-      void $ raceAny_ [subscriber c, runNtfSupervisor c, cleanupManager c] `forkFinally` const (disconnectAgentClient c)
+      void $ runAgentThreads 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
@@ -277,6 +283,12 @@ resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
 sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
 sendMessage c = withAgentEnv c .:. sendMessage' c
 
+type MsgReq = (ConnId, MsgFlags, MsgBody)
+
+-- | Send multiple messages to different connections (SEND command)
+sendMessages :: MonadUnliftIO m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
+sendMessages c = withAgentEnv c . sendMessages' c
+
 ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
 ackMessage c = withAgentEnv c .:. ackMessage' c
 
@@ -388,8 +400,8 @@ xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFile
 xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c
 
 -- | Create new remote host pairing
-rcNewHostPairing :: MonadIO m => m RCHostPairing
-rcNewHostPairing = liftIO newRCHostPairing
+rcNewHostPairing :: AgentErrorMonad m => AgentClient -> m RCHostPairing
+rcNewHostPairing c = withAgentEnv c $ liftIO . newRCHostPairing =<< asks random
 
 -- | start TLS server for remote host with optional multicast
 rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> m RCHostConnection
@@ -614,10 +626,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
-  void . withStore c $ \db -> updateNewConnRcv db connId rq
+  rq' <- 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)
@@ -625,7 +637,8 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do
   case cMode of
     SCMContact -> pure (connId, CRContactUri crData)
     SCMInvitation -> do
-      (pk1, pk2, e2eRcvParams) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange
+      g <- asks random
+      (pk1, pk2, e2eRcvParams) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange
       withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2
       pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
 
@@ -637,7 +650,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, SndQueue, CR.Ratchet 'C.X448, CR.E2ERatchetParams 'C.X448)
+startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> m (Compatible Version, ConnData, NewSndQueue, 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,
@@ -645,8 +658,9 @@ startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {cr
          crAgentVRange `compatibleVersion` smpAgentVRange
        ) of
     (Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just aVersion@(Compatible connAgentVersion)) -> do
-      (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams
-      (_, rcDHRs) <- liftIO C.generateKeyPair'
+      g <- asks random
+      (pk1, pk2, e2eSndParams) <- atomically . CR.generateE2EParams g $ version e2eRcvParams
+      (_, rcDHRs) <- atomically $ C.generateKeyPair g
       let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
       q <- newSndQueue userId "" qInfo
       let duplexHS = connAgentVersion /= 1
@@ -659,12 +673,11 @@ 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' <- withStore c $ \db -> runExceptT $ do
-      connId' <- ExceptT $ createSndConn db g cData q
+    (connId', sq) <- withStore c $ \db -> runExceptT $ do
+      r@(connId', _) <- ExceptT $ createSndConn db g cData q
       liftIO $ createRatchet db connId' rc
-      pure connId'
-    let sq = (q :: SndQueue) {connId = connId'}
-        cData' = (cData :: ConnData) {connId = connId'}
+      pure r
+    let cData' = (cData :: ConnData) {connId = connId'}
         duplexHS = connAgentVersion /= 1
     tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
       Right _ -> do
@@ -689,10 +702,9 @@ 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
-  dbQueueId <- withStore c $ \db -> runExceptT $ do
+  q' <- 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
@@ -701,10 +713,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
-  void . withStore c $ \db -> upgradeSndConnToDuplex db connId rq
+    SMSubscribe -> addSubscription c rq'
   when enableNtfs $ do
     ns <- asks ntfSupervisor
     atomically $ sendNtfSubCommand ns (connId, NSCCreate)
@@ -867,75 +879,64 @@ 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 = withConnLock c connId "sendMessage" $ do
-  SomeConn _ conn <- withStore c (`getConn` connId)
-  case conn of
-    DuplexConnection cData _ sqs -> enqueueMsgs cData sqs
-    SndConnection cData sq -> enqueueMsgs cData [sq]
-    _ -> throwError $ CONN SIMPLEX
+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
+
+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)
+  let reqs'' = fmap (>>= prepareConn) reqs'
+  enqueueMessagesB c reqs''
   where
-    enqueueMsgs :: ConnData -> NonEmpty SndQueue -> m AgentMsgId
-    enqueueMsgs cData sqs = do
-      when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
-      enqueueMessages c cData sqs msgFlags $ A_MSG msg
+    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]
+      _ -> Left $ CONN SIMPLEX
+      where
+        prepareMsg :: ConnData -> NonEmpty SndQueue -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
+        prepareMsg cData sqs
+          | ratchetSyncSendProhibited cData = Left $ CMD PROHIBITED
+          | otherwise = Right (cData, sqs, msgFlags, A_MSG msg)
+    connIds = map (\(connId, _, _) -> connId) $ rights $ toList reqs
 
 -- / async command processing v v v
 
 enqueueCommand :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> m ()
 enqueueCommand c corrId connId server aCommand = do
-  resumeSrvCmds c server
-  commandId <- withStore c $ \db -> createCommand db corrId connId server aCommand
-  queuePendingCommands c server [commandId]
+  withStore c $ \db -> createCommand db corrId connId server aCommand
+  void $ getAsyncCmdWorker True c server
 
-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)
+resumeSrvCmds :: forall m. AgentMonad' m => AgentClient -> Maybe SMPServer -> m ()
+resumeSrvCmds = void .: getAsyncCmdWorker False
 
 resumeConnCmds :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
 resumeConnCmds c connId =
   unlessM connQueued $
-    withStore' c (`getPendingCommands` connId)
-      >>= mapM_ (uncurry enqueueConnCmds)
+    withStore' c (`getPendingCommandServers` connId)
+      >>= mapM_ (resumeSrvCmds c)
   where
-    enqueueConnCmds srv cmdIds = do
-      resumeSrvCmds c srv
-      queuePendingCommands c srv cmdIds
     connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
 
-cmdProcessExists :: AgentMonad' m => AgentClient -> Maybe SMPServer -> m Bool
-cmdProcessExists c srv = atomically $ TM.member srv (asyncCmdProcesses c)
+getAsyncCmdWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe SMPServer -> m Worker
+getAsyncCmdWorker hasWork c server =
+  getAgentWorker hasWork c server (asyncCmdWorkers c) (runCommandProcessing c server)
 
-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_
+runCommandProcessing :: forall m. AgentMonad m => AgentClient -> Maybe SMPServer -> Worker -> m ()
+runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
   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
-    tryAgentError (withStore c $ \db -> getPendingCommand db cmdId) >>= \case
-      Left e -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR e)
-      Right cmd -> processCmd (riFast ri) cmdId cmd
+    withWork c doWork (`getPendingServerCommand` server_) $ processCmd (riFast ri)
   where
-    processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m ()
-    processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of
+    processCmd :: RetryInterval -> PendingCommand -> m ()
+    processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} = case command of
       AClientCommand (APC _ cmd) -> case cmd of
         NEW enableNtfs (ACM cMode) subMode -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
@@ -1056,22 +1057,34 @@ enqueueMessages c cData sqs msgFlags aMessage = do
   enqueueMessages' c cData sqs msgFlags aMessage
 
 enqueueMessages' :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
-enqueueMessages' c cData (sq :| sqs) msgFlags aMessage = do
-  msgId <- enqueueMessage c cData sq msgFlags aMessage
-  mapM_ (enqueueSavedMessage c cData msgId) $
-    filter (\SndQueue {status} -> status == Secured || status == Active) sqs
-  pure msgId
+enqueueMessages' c cData sqs msgFlags aMessage =
+  liftEither . runIdentity =<< enqueueMessagesB c (Identity (Right (cData, sqs, msgFlags, aMessage)))
+
+enqueueMessagesB :: (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType AgentMsgId))
+enqueueMessagesB c reqs = do
+  reqs' <- enqueueMessageB c reqs
+  enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs'
+  pure $ fst <$$> reqs'
+
+isActiveSndQ :: SndQueue -> Bool
+isActiveSndQ SndQueue {status} = status == Secured || status == Active
 
 enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
-enqueueMessage c cData@ConnData {connId} sq msgFlags aMessage = do
-  resumeMsgDelivery c cData sq
-  aVRange <- asks $ smpAgentVRange . config
-  msgId <- storeSentMsg $ maxVersion aVRange
-  queuePendingMsgs c sq [msgId]
-  pure $ unId msgId
+enqueueMessage c cData sq msgFlags aMessage =
+  liftEither . fmap fst . runIdentity =<< enqueueMessageB c (Identity (Right (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
+  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
+    let sqs' = filter isActiveSndQ sqs
+    pure $ Right (msgId, if null sqs' then Nothing else Just (cData, sqs', msgId))
   where
-    storeSentMsg :: Version -> m InternalId
-    storeSentMsg agentVersion = withStore c $ \db -> runExceptT $ do
+    storeSentMsg :: DB.Connection -> Version -> (ConnData, NonEmpty SndQueue, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, MsgFlags, AMessage), InternalId))
+    storeSentMsg db agentVersion req@(ConnData {connId}, sq :| _, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
       internalTs <- liftIO getCurrentTime
       (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
@@ -1084,65 +1097,53 @@ enqueueMessage c cData@ConnData {connId} sq msgFlags aMessage = do
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, internalHash, prevMsgHash}
       liftIO $ createSndMsg db connId msgData
       liftIO $ createSndMsgDelivery db connId sq internalId
-      pure internalId
+      pure (req, internalId)
 
-enqueueSavedMessage :: AgentMonad m => AgentClient -> ConnData -> AgentMsgId -> SndQueue -> m ()
-enqueueSavedMessage c cData@ConnData {connId} msgId sq = do
-  resumeMsgDelivery c cData sq
-  let mId = InternalId msgId
-  queuePendingMsgs c sq [mId]
-  withStore' c $ \db -> createSndMsgDelivery db connId sq mId
+enqueueSavedMessage :: AgentMonad' m => AgentClient -> ConnData -> AgentMsgId -> SndQueue -> m ()
+enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId)
 
-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
+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
+  void $ withStoreBatch' c $ \db -> concatMap (storeDeliveries db) reqs
+  forM_ reqs $ \(cData, sqs, _) ->
+    forM sqs $ submitPendingMsg c cData
   where
-    queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
-    msgsQueued = atomically $ isJust <$> TM.lookupInsert (server, sndId) True (pendingMsgsQueued c)
+    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
 
-queuePendingMsgs :: AgentMonad' m => AgentClient -> SndQueue -> [InternalId] -> m ()
-queuePendingMsgs c = queuePendingMsgs' c True
+resumeMsgDelivery :: forall m. AgentMonad' m => AgentClient -> ConnData -> SndQueue -> m ()
+resumeMsgDelivery = void .:. getDeliveryWorker False
 
-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)
+getDeliveryWorker :: AgentMonad' m => Bool -> AgentClient -> ConnData -> SndQueue -> m (Worker, TMVar ())
+getDeliveryWorker hasWork c cData sq =
+  getAgentWorker' fst mkLock hasWork c (qAddress sq) (smpDeliveryWorkers c) (runSmpQueueMsgDelivery c cData sq)
   where
-    newMsgQueue qKey = do
-      q <- (,) <$> newTQueue <*> newEmptyTMVar
-      TM.insert qKey q $ smpQueueMsgQueues c
-      pure q
+    mkLock w = do
+      retryLock <- newEmptyTMVar
+      pure (w, retryLock)
 
-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
+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
+
+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
   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
-    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
+    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
         withRetryLock2 ri' qLock $ \riState loop -> do
           resp <- tryError $ case msgType of
             AM_CONN_INFO -> sendConfirmation c sq msgBody
@@ -1248,7 +1249,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') $ smpQueueMsgQueues c
+                              atomically $ TM.delete (qAddress sq') $ smpDeliveryWorkers c
                               withStore' c $ \db -> do
                                 when primary $ setSndQueuePrimary db connId sq
                                 deletePendingMsgs db connId sq'
@@ -1334,19 +1335,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, sndId} = do
+switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId 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 :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-  void . withStore c $ \db -> addConnRcvQueue db connId rq'
-  addSubscription c rq'
+  let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
+  rq'' <- 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
@@ -1380,8 +1381,9 @@ synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet"
       | ratchetSyncAllowed cData || force -> do
           -- check queues are not switching?
           AgentConfig {e2eEncryptVRange} <- asks config
-          (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange
-          void $ enqueueRatchetKeyMsgs c cData sqs e2eParams
+          g <- asks random
+          (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange
+          enqueueRatchetKeyMsgs c cData sqs e2eParams
           withStore' c $ \db -> do
             setConnRatchetSync db connId RSStarted
             setRatchetX3dhKeys db connId pk1 pk2 k1 k2
@@ -1616,8 +1618,9 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
         Just ntfServer ->
           asks (cmdSignAlg . config) >>= \case
             C.SignAlg a -> do
-              tknKeys <- liftIO $ C.generateSignatureKeyPair a
-              dhKeys <- liftIO C.generateKeyPair'
+              g <- asks random
+              tknKeys <- atomically $ C.generateSignatureKeyPair a g
+              dhKeys <- atomically $ C.generateKeyPair g
               let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode
               withStore' c (`createNtfToken` tkn)
               registerToken tkn
@@ -1885,7 +1888,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
       conn
       cData@ConnData {userId, connId, duplexHandshake, connAgentVersion, ratchetSyncState = rss} =
         withConnLock c connId "processSMP" $ case cmd of
-          SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> 
+          SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} ->
             handleNotifyAck $ do
               msg' <- decryptSMPMessage v rq msg
               handleNotifyAck $ case msg' of
@@ -1907,9 +1910,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 conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
+                        smpConfirmation srvMsgId conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
                       (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
-                        smpInvitation conn connReq connInfo >> ack
+                        smpInvitation srvMsgId conn connReq connInfo >> ack
                       _ -> prohibited >> ack
                   (Just e2eDh, Nothing) -> do
                     decryptClientMessage e2eDh clientMsg >>= \case
@@ -1933,24 +1936,25 @@ 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
-                        tryError (agentClientMsg encryptedMsgHash) >>= \case
+                        g <- asks random
+                        tryError (agentClientMsg g encryptedMsgHash) >>= \case
                           Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do
                             conn'' <- resetRatchetSync
                             case aMessage of
-                              HELLO -> helloMsg conn'' >> ackDel msgId
-                              REPLY cReq -> replyMsg conn'' cReq >> ackDel msgId
+                              HELLO -> helloMsg srvMsgId conn'' >> ackDel msgId
+                              REPLY cReq -> replyMsg srvMsgId 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>"
+                                logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
                                 notify $ MSG msgMeta msgFlags body
                               A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta
-                              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
+                              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
                               -- 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>" >> ackDel msgId
+                              QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret srvMsgId) >> ackDel msgId
                               EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev
                             where
                               qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> m ()) -> m ()
@@ -1972,7 +1976,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>"
+                                        logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
                                         notify $ MSG msgMeta msgFlags body
                                       _ -> pure ()
                               _ -> checkDuplicateHash e encryptedMsgHash >> ack
@@ -1995,10 +1999,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                           checkDuplicateHash e encryptedMsgHash =
                             unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $
                               throwError e
-                          agentClientMsg :: ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
-                          agentClientMsg encryptedMsgHash = withStore c $ \db -> runExceptT $ do
+                          agentClientMsg :: TVar ChaChaDRG -> ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
+                          agentClientMsg g encryptedMsgHash = withStore c $ \db -> runExceptT $ do
                             rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY
-                            agentMsgBody <- agentRatchetDecrypt' db connId rc encAgentMessage
+                            agentMsgBody <- agentRatchetDecrypt' g db connId rc encAgentMessage
                             liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
                               agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
                                 let msgType = agentMessageType agentMsg
@@ -2078,9 +2082,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           parseMessage :: Encoding a => ByteString -> m a
           parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
 
-          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>"
+          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
             AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
             unless
               (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
@@ -2092,7 +2096,8 @@ 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
-                  (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt rc M.empty encConnInfo
+                  g <- asks random
+                  (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt g rc M.empty encConnInfo
                   case (agentMsgBody_, skipped) of
                     (Right agentMsgBody, CR.SMDNoChange) ->
                       parseMessage agentMsgBody >>= \case
@@ -2104,7 +2109,6 @@ 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
@@ -2113,7 +2117,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                     _ -> prohibited
                 -- party accepting connection
                 (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
-                  withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case
+                  g <- asks random
+                  withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage >>= \case
                     AgentConnInfo connInfo -> do
                       notify $ INFO connInfo
                       let dhSecret = C.dh' e2ePubKey e2ePrivKey
@@ -2123,9 +2128,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 _ -> prohibited
               _ -> prohibited
 
-          helloMsg :: Connection c -> m ()
-          helloMsg conn' = do
-            logServer "<--" c srv rId "MSG <HELLO>"
+          helloMsg :: SMP.MsgId -> Connection c -> m ()
+          helloMsg srvMsgId conn' = do
+            logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret srvMsgId
             case status of
               Active -> prohibited
               _ ->
@@ -2145,9 +2150,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 :: Connection c -> NonEmpty SMPQueueInfo -> m ()
-          replyMsg conn' smpQueues = do
-            logServer "<--" c srv rId "MSG <REPLY>"
+          replyMsg :: SMP.MsgId -> Connection c -> NonEmpty SMPQueueInfo -> m ()
+          replyMsg srvMsgId conn' smpQueues = do
+            logServer "<--" c srv rId $ "MSG <REPLY>:" <> logSecret srvMsgId
             case duplexHandshake of
               Just True -> prohibited
               _ -> case conn' of
@@ -2157,19 +2162,19 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   connectReplyQueues c cData' ownConnInfo smpQueues `catchAgentError` (notify . ERR)
                 _ -> prohibited
 
-          continueSending :: (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
-          continueSending addr (DuplexConnection _ _ sqs) =
+          continueSending :: SMP.MsgId -> (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
+          continueSending srvMsgId addr (DuplexConnection _ _ sqs) =
             case findQ addr sqs of
               Just sq -> do
-                logServer "<--" c srv rId "MSG <QCONT>"
-                atomically $ do
-                  (_, qLock) <- getPendingMsgQ c sq
-                  void $ tryPutTMVar qLock ()
+                logServer "<--" c srv rId $ "MSG <QCONT>:" <> logSecret srvMsgId
+                atomically $
+                  TM.lookup (qAddress sq) (smpDeliveryWorkers c)
+                    >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ())
               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>"
+            logServer "<--" c srv rId $ "MSG <RCPT>:" <> logSecret srvMsgId
             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
@@ -2190,28 +2195,27 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                       pure $ Just rcpt
 
           -- processed by queue sender
-          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
+          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
             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}) -> do
-                    let (delSqs, keepSqs) = L.partition ((Just dbQueueId == ) . dbReplaceQId) sqs
+                  (_, Just sq@SndQueue {dbQueueId = DBQueueId 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_ :: SndQueue) {primary = True, dbQueueId, dbReplaceQueueId = Just dbQueueId}
-                        dbId <- withStore c $ \db -> addConnSndQueue db connId sq''
-                        let sq2 = (sq'' :: SndQueue) {dbQueueId = dbId}
+                        let sq'' = (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
+                        sq2 <- withStore c $ \db -> addConnSndQueue db connId sq''
                         case (sndPublicKey, e2ePubKey) of
                           (Just sndPubKey, Just dhPublicKey) -> do
-                            logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
+                            logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret srvMsgId <> " " <> 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
@@ -2224,8 +2228,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               _ -> throwError $ AGENT A_VERSION
 
           -- processed by queue recipient
-          qKeyMsg :: NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
-          qKeyMsg ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do
+          qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
+          qKeyMsg srvMsgId ((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
@@ -2233,7 +2237,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 senderId
+                    logServer "<--" c srv rId $ "MSG <QKEY>:" <> logSecret srvMsgId <> " " <> 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
@@ -2245,16 +2249,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 :: NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> m ()
+          qUseMsg :: SMP.MsgId -> NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> m ()
           -- NOTE: does not yet support the change of the primary status during the rotation
-          qUseMsg ((addr, _primary) :| _) (DuplexConnection cData' rqs sqs) = do
+          qUseMsg srvMsgId ((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 (snd addr)
+                    logServer "<--" c srv rId $ "MSG <QUSE>:" <> logSecret srvMsgId <> " " <> 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
@@ -2276,9 +2280,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 :: Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-          smpInvitation conn' connReq@(CRInvitationUri crData _) cInfo = do
-            logServer "<--" c srv rId "MSG <KEY>"
+          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
             case conn' of
               ContactConnection {} -> do
                 g <- asks random
@@ -2324,8 +2328,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   throwError $ AGENT (A_CRYPTO RATCHET_SYNC)
                 where
                   sendReplyKey = do
-                    (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ version e2eOtherPartyParams
-                    void $ enqueueRatchetKeyMsgs c cData' sqs e2eParams
+                    g <- asks random
+                    (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- atomically . CR.generateE2EParams g $ version e2eOtherPartyParams
+                    enqueueRatchetKeyMsgs c cData' sqs e2eParams
                     pure (pk1, pk2, k1, k2)
                   notifyRatchetSyncError = do
                     let cData'' = cData' {ratchetSyncState = RSRequired} :: ConnData
@@ -2348,7 +2353,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) <- liftIO C.generateKeyPair'
+                    (_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random
                     recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams
                     void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
 
@@ -2383,14 +2388,13 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) =
     Nothing -> throwError $ AGENT A_VERSION
     Just qInfo' -> do
       sq <- newSndQueue userId connId qInfo'
-      dbQueueId <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
-      enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing
+      sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
+      enqueueConfirmation c cData sq' 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
-  resumeMsgDelivery c cData sq
-  msgId <- storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation v c cData sq srv connInfo subMode
-  queuePendingMsgs c sq [msgId]
+  storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation v c cData sq srv connInfo subMode
+  submitPendingMsg c cData sq
 
 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
@@ -2413,11 +2417,10 @@ 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
-  resumeMsgDelivery c cData sq
-  msgId <- storeConfirmation c cData sq e2eEncryption_ $ AgentConnInfo connInfo
-  queuePendingMsgs c sq [msgId]
+  storeConfirmation c cData sq e2eEncryption_ $ AgentConnInfo connInfo
+  submitPendingMsg c cData sq
 
-storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.E2ERatchetParams 'C.X448) -> AgentMessage -> m InternalId
+storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.E2ERatchetParams 'C.X448) -> AgentMessage -> m ()
 storeConfirmation c ConnData {connId, connAgentVersion} sq e2eEncryption_ agentMsg = withStore c $ \db -> runExceptT $ do
   internalTs <- liftIO getCurrentTime
   (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
@@ -2429,21 +2432,17 @@ 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 AgentMsgId
+enqueueRatchetKeyMsgs :: forall m. AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> CR.E2ERatchetParams 'C.X448 -> m ()
 enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do
   msgId <- enqueueRatchetKey c cData sq e2eEncryption
-  mapM_ (enqueueSavedMessage c cData msgId) $
-    filter (\SndQueue {status} -> status == Secured || status == Active) sqs
-  pure msgId
+  mapM_ (enqueueSavedMessage c cData msgId) $ filter isActiveSndQ sqs
 
 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
-  queuePendingMsgs c sq [msgId]
+  submitPendingMsg c cData sq
   pure $ unId msgId
   where
     storeRatchetKey :: Version -> m InternalId
@@ -2469,23 +2468,24 @@ agentRatchetEncrypt db connId msg paddedLen = do
   pure encMsg
 
 -- encoded EncAgentMessage -> encoded AgentMessage
-agentRatchetDecrypt :: DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
-agentRatchetDecrypt db connId encAgentMsg = do
+agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
+agentRatchetDecrypt g db connId encAgentMsg = do
   rc <- ExceptT $ getRatchet db connId
-  agentRatchetDecrypt' db connId rc encAgentMsg
+  agentRatchetDecrypt' g db connId rc encAgentMsg
 
-agentRatchetDecrypt' :: DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString
-agentRatchetDecrypt' db connId rc encAgentMsg = do
+agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString
+agentRatchetDecrypt' g db connId rc encAgentMsg = do
   skipped <- liftIO $ getSkippedMsgKeys db connId
-  (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg
+  (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt g 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 SndQueue
+newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m NewSndQueue
 newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do
   C.SignAlg a <- asks $ cmdSignAlg . config
-  (sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
-  (e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
+  g <- asks random
+  (sndPublicKey, sndPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
+  (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
   pure
     SndQueue
       { userId,
@@ -2497,7 +2497,7 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd
         e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
         e2ePubKey = Just e2ePubKey,
         status = New,
-        dbQueueId = 0,
+        dbQueueId = DBNewQueue,
         primary = True,
         dbReplaceQueueId = Nothing,
         sndSwchStatus = Nothing,

src/Simplex/Messaging/Agent/Client.hs

@@ -24,6 +24,7 @@ module Simplex.Messaging.Agent.Client
     ProtocolTestStep (..),
     newAgentClient,
     withConnLock,
+    withConnLocks,
     withInvLock,
     closeAgentClient,
     closeProtocolServerClients,
@@ -76,6 +77,7 @@ module Simplex.Messaging.Agent.Client
     agentClientStore,
     agentDRG,
     getAgentSubscriptions,
+    Worker (..),
     SubscriptionsInfo (..),
     SubInfo (..),
     AgentOperation (..),
@@ -83,6 +85,13 @@ module Simplex.Messaging.Agent.Client
     AgentState (..),
     AgentLocks (..),
     AgentStatsKey (..),
+    getAgentWorker,
+    getAgentWorker',
+    cancelWorker,
+    waitForWork,
+    hasWorkToDo,
+    hasWorkToDo',
+    withWork,
     agentOperations,
     agentOperationBracket,
     waitUntilActive,
@@ -99,6 +108,8 @@ module Simplex.Messaging.Agent.Client
     withStore',
     withStoreCtx,
     withStoreCtx',
+    withStoreBatch,
+    withStoreBatch',
     storeError,
     userServers,
     pickServer,
@@ -118,7 +129,7 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Crypto.Random (ChaChaDRG, getRandomBytes)
+import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Base64
@@ -131,7 +142,7 @@ 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 (isJust, listToMaybe)
+import Data.Maybe (isNothing, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -200,7 +211,9 @@ import Simplex.Messaging.Version
 import System.Random (randomR)
 import System.Timeout (timeout)
 import UnliftIO (mapConcurrently)
+import UnliftIO.Async (async)
 import UnliftIO.Directory (getTemporaryDirectory)
+import UnliftIO.Exception (bracket)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -234,12 +247,10 @@ data AgentClient = AgentClient
     activeSubs :: TRcvQueues,
     pendingSubs :: TRcvQueues,
     removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
-    pendingMsgsQueued :: TMap SndQAddr Bool,
-    smpQueueMsgQueues :: TMap SndQAddr (TQueue (InternalId, Bool), TMVar ()),
-    smpQueueMsgDeliveries :: TMap SndQAddr (Async ()),
+    workerSeq :: TVar Int,
+    smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
+    asyncCmdWorkers :: TMap (Maybe SMPServer) Worker,
     connCmdsQueued :: TMap ConnId Bool,
-    asyncCmdQueues :: TMap (Maybe SMPServer) (TQueue AsyncCmdId),
-    asyncCmdProcesses :: TMap (Maybe SMPServer) (Async ()),
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -262,6 +273,43 @@ data AgentClient = AgentClient
     agentEnv :: Env
   }
 
+getAgentWorker :: (AgentMonad' m, Ord k) => Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT AgentErrorType m ()) -> m Worker
+getAgentWorker = getAgentWorker' id pure
+
+getAgentWorker' :: (AgentMonad' m, Ord k) => (a -> Worker) -> (Worker -> STM a) -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT AgentErrorType m ()) -> m a
+getAgentWorker' toW fromW hasWork c key ws work = do
+  atomically (getWorker >>= maybe createWorker whenExists) >>= \w -> runWorker w $> w
+  where
+    getWorker = TM.lookup key ws
+    deleteWorker wId = mapM_ $ \w -> when (wId == workerId (toW w)) $ TM.delete 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 = do
+      let w'@Worker {workerId} = toW w
+      runWorkerAsync w' . void . runExceptT $
+        work w `agentFinally` atomically (getWorker >>= deleteWorker workerId)
+
+newWorker :: AgentClient -> STM Worker
+newWorker c = do
+  workerId <- stateTVar (workerSeq c) $ \next -> (next, next + 1)
+  doWork <- newTMVar ()
+  action <- newTMVar Nothing
+  pure Worker {workerId, doWork, action}
+
+runWorkerAsync :: AgentMonad' m => Worker -> m () -> m ()
+runWorkerAsync Worker {action} worker =
+  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 worker
+
 data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
   deriving (Eq, Show)
 
@@ -316,12 +364,10 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
   activeSubs <- RQ.empty
   pendingSubs <- RQ.empty
   removedSubs <- TM.empty
-  pendingMsgsQueued <- TM.empty
-  smpQueueMsgQueues <- TM.empty
-  smpQueueMsgDeliveries <- TM.empty
+  workerSeq <- newTVar 0
+  smpDeliveryWorkers <- TM.empty
+  asyncCmdWorkers <- 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
@@ -354,12 +400,10 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
         activeSubs,
         pendingSubs,
         removedSubs,
-        pendingMsgsQueued,
-        smpQueueMsgQueues,
-        smpQueueMsgDeliveries,
+        workerSeq,
+        smpDeliveryWorkers,
+        asyncCmdWorkers,
         connCmdsQueued,
-        asyncCmdQueues,
-        asyncCmdProcesses,
         ntfNetworkOp,
         rcvNetworkOp,
         msgDeliveryOp,
@@ -601,33 +645,35 @@ closeAgentClient c = liftIO $ do
   closeProtocolServerClients c xftpClients
   cancelActions . actions $ reconnections c
   cancelActions . actions $ asyncClients c
-  cancelActions $ smpQueueMsgDeliveries c
-  cancelActions $ asyncCmdProcesses c
+  clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst)
+  clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker
+  clear connCmdsQueued
   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
 
+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
 
 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 SndQueue {server, sndId} =
-  unlessM (isJust <$> TM.lookup k (smpQueueMsgQueues c)) $ do
-    TM.delete k $ smpQueueMsgDeliveries c
+throwWhenNoDelivery c sq =
+  unlessM (TM.member (qAddress sq) $ smpDeliveryWorkers c) $
     throwSTM ThreadKilled
-  where
-    k = (server, sndId)
 
 closeProtocolServerClients :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
@@ -658,8 +704,17 @@ 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)
+
 withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
-withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pure
+withLockMap_ = withGetLock . getMapLock
+
+withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> [k] -> String -> m a -> m a
+withLocksMap_ = withGetLocks . getMapLock
+
+getMapLock :: Ord k => TMap k Lock -> k -> STM Lock
+getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
   where
     newLock = createLock >>= \l -> TM.insert key l locks $> l
 
@@ -750,13 +805,14 @@ 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) <- C.generateSignatureKeyPair a
-        (sKey, _) <- C.generateSignatureKeyPair a
-        (dhKey, _) <- C.generateKeyPair'
+        (rKey, rpKey) <- atomically $ C.generateSignatureKeyPair a g
+        (sKey, _) <- atomically $ C.generateSignatureKeyPair a g
+        (dhKey, _) <- atomically $ C.generateKeyPair g
         r <- runExceptT $ do
           SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe
           liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
@@ -773,6 +829,7 @@ 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
@@ -781,8 +838,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) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-        (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+        (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+        (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
         createTestChunk filePath
         digest <- liftIO $ C.sha256Hash <$> B.readFile filePath
         let file = FileInfo {sndKey, size = chSize, digest}
@@ -790,7 +847,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 xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
+          liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g 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
@@ -809,8 +866,9 @@ 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 =<< getRandomBytes chSize
+    createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom
 
 getXFTPWorkPath :: AgentMonad m => m FilePath
 getXFTPWorkPath = do
@@ -832,12 +890,13 @@ 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 (RcvQueue, SMPQueueUri)
+newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (NewRcvQueue, SMPQueueUri)
 newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
   C.SignAlg a <- asks (cmdSignAlg . config)
-  (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
-  (dhKey, privDhKey) <- liftIO C.generateKeyPair'
-  (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
+  g <- asks random
+  (recipientKey, rcvPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
+  (dhKey, privDhKey) <- atomically $ C.generateKeyPair g
+  (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
   logServer "-->" c srv "" "NEW"
   tSess <- mkTransportSession c userId srv connId
   QIK {rcvId, sndId, rcvPublicDhKey} <-
@@ -855,7 +914,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
             e2eDhSecret = Nothing,
             sndId,
             status = New,
-            dbQueueId = 0,
+            dbQueueId = DBNewQueue,
             primary = True,
             dbReplaceQueueId = Nothing,
             rcvSwchStatus = Nothing,
@@ -1046,7 +1105,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueue
 
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
 sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
-  withSMPClient c rq "ACK" $ \smp ->
+  withSMPClient c rq ("ACK:" <> logSecret msgId) $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId msgId
   atomically $ releaseGetLock c rq
 
@@ -1115,13 +1174,14 @@ 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 =
-  withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk xftp replicaKey fId chunkSpec
+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
 
 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) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (sndKey, replicaKey) <- atomically . C.generateSignatureKeyPair C.SEd25519 =<< asks random
   let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest}
   logServer "-->" c srv "" "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
@@ -1145,7 +1205,7 @@ agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkR
 
 xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair)
 xftpRcvKeys n = do
-  rKeys <- liftIO $ replicateM n $ C.generateSignatureKeyPair C.SEd25519
+  rKeys <- atomically . replicateM n . C.generateSignatureKeyPair C.SEd25519 =<< asks random
   case L.nonEmpty rKeys of
     Just rKeys' -> pure rKeys'
     _ -> throwError $ INTERNAL "non-positive number of recipients"
@@ -1155,7 +1215,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 <- liftIO C.randomCbNonce
+  cmNonce <- atomically . C.randomCbNonce =<< asks random
   let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey
   cmEncBody <-
     liftEither . first cryptoError $
@@ -1166,9 +1226,10 @@ 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
-  (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
+  g <- asks random
+  (dhSndPubKey, dhSndPrivKey) <- atomically $ C.generateKeyPair g
   let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
-  cmNonce <- liftIO C.randomCbNonce
+  cmNonce <- atomically $ C.randomCbNonce g
   cmEncBody <-
     liftEither . first cryptoError $
       C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength
@@ -1196,6 +1257,29 @@ 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 e
+    Left e -> notifyErr e
+  where
+    noWork = liftIO $ noWorkToDo doWork
+    notifyErr e = atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ 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 ()
@@ -1291,6 +1375,19 @@ withStoreCtx_ ctx_ c action = do
     handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
     handleInternal ctxStr e = pure . Left . SEInternal . B.pack $ show e <> ctxStr
 
+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
+  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)
+
 storeError :: StoreError -> AgentErrorType
 storeError = \case
   SEConnNotFound -> CONN NOT_FOUND

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

@@ -27,6 +27,7 @@ module Simplex.Messaging.Agent.Env.SQLite
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
     XFTPAgent (..),
+    Worker (..),
   )
 where
 
@@ -93,6 +94,7 @@ data AgentConfig = AgentConfig
     rcvFilesTTL :: NominalDiffTime,
     sndFilesTTL :: NominalDiffTime,
     xftpNotifyErrsOnRetry :: Bool,
+    xftpConsecutiveRetries :: Int,
     xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
     ntfCron :: Word16,
@@ -158,6 +160,7 @@ defaultAgentConfig =
       rcvFilesTTL = 2 * nominalDay,
       sndFilesTTL = nominalDay,
       xftpNotifyErrsOnRetry = True,
+      xftpConsecutiveRetries = 3,
       xftpMaxRecipientsPerRequest = 200,
       deleteErrorCount = 10,
       ntfCron = 20, -- minutes
@@ -189,7 +192,7 @@ data Env = Env
 
 newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env
 newSMPAgentEnv config@AgentConfig {initialClientId} store = do
-  random <- newTVarIO =<< drgNew
+  random <- C.newRandom
   clientCounter <- newTVarIO initialClientId
   randomServer <- newTVarIO =<< liftIO newStdGen
   ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
@@ -203,8 +206,8 @@ createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey k
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
     ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
-    ntfWorkers :: TMap NtfServer (TMVar (), Async ()),
-    ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
+    ntfWorkers :: TMap NtfServer Worker,
+    ntfSMPWorkers :: TMap SMPServer Worker
   }
 
 data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
@@ -221,9 +224,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) (TMVar (), Async ()),
-    xftpSndWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
-    xftpDelWorkers :: TMap XFTPServer (TMVar (), Async ())
+    xftpRcvWorkers :: TMap (Maybe XFTPServer) Worker,
+    xftpSndWorkers :: TMap (Maybe XFTPServer) Worker,
+    xftpDelWorkers :: TMap XFTPServer Worker
   }
 
 newXFTPAgent :: STM XFTPAgent
@@ -249,3 +252,9 @@ agentFinally = allFinally mkInternal
 mkInternal :: SomeException -> AgentErrorType
 mkInternal = INTERNAL . show
 {-# INLINE mkInternal #-}
+
+data Worker = Worker
+  { workerId :: Int,
+    doWork :: TMVar (),
+    action :: TMVar (Maybe (Async ()))
+  }

src/Simplex/Messaging/Agent/Lock.hs

@@ -1,8 +1,18 @@
-module Simplex.Messaging.Agent.Lock where
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Agent.Lock
+  ( Lock,
+    createLock,
+    withLock,
+    withGetLock,
+    withGetLocks,
+  )
+where
 
 import Control.Monad (void)
 import Control.Monad.IO.Unlift
 import Data.Functor (($>))
+import UnliftIO.Async (forConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -18,9 +28,22 @@ withLock lock name =
     (atomically $ putTMVar lock name)
     (void . atomically $ takeTMVar lock)
 
-withGetLock :: MonadUnliftIO m => STM Lock -> String -> m a -> m a
-withGetLock getLock name a =
+withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> String -> m a -> m a
+withGetLock getLock key name a =
   E.bracket
-    (atomically $ getLock >>= \l -> putTMVar l name $> l)
+    (atomically $ getPutLock getLock key name)
     (atomically . takeTMVar)
     (const a)
+
+withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> [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
+    -- only this withGetLocks would be holding the locks,
+    -- so it's safe to combine all lock releases into one transaction
+    releaseLocks = atomically . mapM_ takeTMVar
+
+-- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists,
+-- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock.
+getPutLock :: (k -> STM Lock) -> k -> String -> STM Lock
+getPutLock getLock key name = getLock key >>= \l -> putTMVar l name $> l

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -37,9 +37,7 @@ 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, ProtocolServer, SMPServer, sameSrvAddr)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Protocol (NtfServer, SMPServer, sameSrvAddr)
 import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
 import System.Random (randomR)
 import UnliftIO
@@ -79,11 +77,11 @@ processNtfSub c (connId, cmd) = do
               Just ClientNtfCreds {notifierId} -> do
                 let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
                 withStore c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
-                addNtfNTFWorker ntfServer
+                void $ getNtfNTFWorker True c ntfServer
               Nothing -> do
                 let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
                 withStore c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
-                addNtfSMPWorker smpServer
+                void $ getNtfSMPWorker True c smpServer
         (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
           case (clientNtfCreds, ntfQueueId) of
             (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
@@ -103,80 +101,70 @@ processNtfSub c (connId, cmd) = do
                       then resetSubscription
                       else withNtfServer c $ \ntfServer -> do
                         withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
-                        addNtfNTFWorker ntfServer
+                        void $ getNtfNTFWorker True c ntfServer
                 | otherwise -> case action of
-                    NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
-                    NtfSubSMPAction _ -> addNtfSMPWorker smpServer
+                    NtfSubNTFAction _ -> void $ getNtfNTFWorker True c subNtfServer
+                    NtfSubSMPAction _ -> void $ getNtfSMPWorker True c smpServer
             rotate :: m ()
             rotate = do
               withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
-              addNtfNTFWorker subNtfServer
+              void $ getNtfNTFWorker True c subNtfServer
             resetSubscription :: m ()
             resetSubscription =
               withNtfServer c $ \ntfServer -> do
                 let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
                 withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
-                addNtfSMPWorker smpServer
+                void $ getNtfSMPWorker True c 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}, _)) -> addNtfNTFWorker ntfServer
+        (Just (NtfSubscription {ntfServer}, _)) -> void $ getNtfNTFWorker True c 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)
-          addNtfSMPWorker smpServer
+          void $ getNtfSMPWorker True c smpServer
         _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    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 ()
+    NSCNtfWorker ntfServer -> void $ getNtfNTFWorker True c ntfServer
+    NSCNtfSMPWorker smpServer -> void $ getNtfSMPWorker True c smpServer
+
+getNtfNTFWorker :: AgentMonad' m => Bool -> AgentClient -> NtfServer -> m Worker
+getNtfNTFWorker hasWork c server = do
+  ws <- asks $ ntfWorkers . ntfSupervisor
+  getAgentWorker hasWork c server ws $ runNtfWorker c server
+
+getNtfSMPWorker :: AgentMonad' m => Bool -> AgentClient -> SMPServer -> m Worker
+getNtfSMPWorker hasWork c server = do
+  ws <- asks $ ntfSMPWorkers . ntfSupervisor
+  getAgentWorker hasWork c server ws $ runNtfSMPWorker c server
 
 withNtfServer :: AgentMonad' m => AgentClient -> (NtfServer -> m ()) -> m ()
 withNtfServer c action = getNtfServer c >>= mapM_ action
 
-runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
-runNtfWorker c srv doWork = do
+runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> Worker -> m ()
+runNtfWorker c srv Worker {doWork} = do
   delay <- asks $ ntfWorkerDelay . config
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
     threadDelay delay
   where
     runNtfOperation :: m ()
-    runNtfOperation = do
-      nextSub_ <- withStore' c (`getNextNtfSubNTFAction` srv)
-      logInfo $ "runNtfWorker, nextSub_ " <> tshow nextSub_
-      case nextSub_ of
-        Nothing -> noWorkToDo
-        Just a@(NtfSubscription {connId}, _, _) -> do
+    runNtfOperation =
+      withWork c doWork (`getNextNtfSubNTFAction` srv) $
+        \nextSub@(NtfSubscription {connId}, _, _) -> do
+          logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop ->
-            processAction a
+            processSub nextSub
               `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
-    noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
-    processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
+    processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
+    processSub (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
       ts <- liftIO getCurrentTime
       unlessM (rescheduleAction doWork ts actionTs) $
         case action of
@@ -240,27 +228,24 @@ runNtfWorker c srv doWork = do
           withStore' c $ \db ->
             updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
 
-runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
-runNtfSMPWorker c srv doWork = do
+runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> Worker -> m ()
+runNtfSMPWorker c srv Worker {doWork} = do
   delay <- asks $ ntfSMPWorkerDelay . config
   forever $ do
-    void . atomically $ readTMVar doWork
+    waitForWork doWork
     agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
     threadDelay delay
   where
-    runNtfSMPOperation = do
-      nextSub_ <- withStore' c (`getNextNtfSubSMPAction` srv)
-      logInfo $ "runNtfSMPWorker, nextSub_ " <> tshow nextSub_
-      case nextSub_ of
-        Nothing -> noWorkToDo
-        Just a@(NtfSubscription {connId}, _, _) -> do
+    runNtfSMPOperation =
+      withWork c doWork (`getNextNtfSubSMPAction` srv) $
+        \nextSub@(NtfSubscription {connId}, _, _) -> do
+          logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop ->
-            processAction a
+            processSub nextSub
               `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
-    noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
-    processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
+    processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
+    processSub (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
       ts <- liftIO getCurrentTime
       unlessM (rescheduleAction doWork ts actionTs) $
         case smpAction of
@@ -269,8 +254,9 @@ runNtfSMPWorker c srv doWork = do
               Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
                 rq <- withStore c (`getPrimaryRcvQueue` connId)
                 C.SignAlg a <- asks (cmdSignAlg . config)
-                (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
-                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
+                g <- asks random
+                (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
+                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
                 (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
                 let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
                 withStore' c $ \db -> do
@@ -293,7 +279,7 @@ rescheduleAction doWork ts actionTs
       void . atomically $ tryTakeTMVar doWork
       void . forkIO $ do
         liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
-        void . atomically $ tryPutTMVar doWork ()
+        atomically $ hasWorkToDo' doWork
       pure True
 
 retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
@@ -342,13 +328,10 @@ instantNotifications = \case
 
 closeNtfSupervisor :: MonadUnliftIO m => NtfSupervisor -> m ()
 closeNtfSupervisor ns = do
-  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
+  stopWorkers $ ntfWorkers ns
+  stopWorkers $ ntfSMPWorkers ns
+  where
+    stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 
 getNtfServer :: AgentMonad' m => AgentClient -> m (Maybe NtfServer)
 getNtfServer c = do

src/Simplex/Messaging/Agent/Protocol.hs

@@ -1703,8 +1703,8 @@ commandP binaryP =
     >>= \case
       ACmdTag SClient e cmd ->
         ACmd SClient e <$> case cmd of
-          NEW_ -> s (NEW <$> strP_ <*> strP_ <*> strP)
-          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> strP_ <*> binaryP)
+          NEW_ -> s (NEW <$> strP_ <*> strP_ <*> (strP <|> pure SMP.SMSubscribe))
+          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
           LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
           ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> binaryP)
           RJCT_ -> s (RJCT <$> A.takeByteString)

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -8,6 +8,7 @@ module Simplex.Messaging.Agent.RetryInterval
     RetryIntervalMode (..),
     RI2State (..),
     withRetryInterval,
+    withRetryIntervalCount,
     withRetryLock2,
     updateRetryInterval2,
   )
@@ -48,15 +49,18 @@ data RetryIntervalMode = RISlow | RIFast
   deriving (Eq, Show)
 
 withRetryInterval :: forall m a. MonadIO m => RetryInterval -> (Int64 -> m a -> m a) -> m a
-withRetryInterval ri action = callAction 0 $ initialInterval ri
+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
   where
-    callAction :: Int64 -> Int64 -> m a
-    callAction elapsed delay = action delay loop
+    callAction :: Int -> Int64 -> Int64 -> m a
+    callAction n elapsed delay = action n delay loop
       where
         loop = do
           liftIO $ threadDelay' delay
           let elapsed' = elapsed + delay
-          callAction elapsed' $ nextDelay elapsed' delay ri
+          callAction (n + 1) 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/Store.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
@@ -49,8 +50,26 @@ 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 RcvQueue = RcvQueue
+data StoredRcvQueue (q :: QueueStored) = RcvQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -69,7 +88,7 @@ data RcvQueue = RcvQueue
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: Int64,
+    dbQueueId :: DBQueueId q,
     -- | 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
@@ -110,8 +129,12 @@ 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 SndQueue = SndQueue
+data StoredSndQueue (q :: QueueStored) = SndQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -127,7 +150,7 @@ data SndQueue = SndQueue
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: Int64,
+    dbQueueId :: DBQueueId q,
     -- | 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
@@ -194,7 +217,7 @@ instance SMPQueueRec RcvQueue where
   {-# INLINE qUserId #-}
   qConnId RcvQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId RcvQueue {dbQueueId} = dbQueueId
+  dbQId RcvQueue {dbQueueId = DBQueueId qId} = qId
   {-# INLINE dbQId #-}
   dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
@@ -204,7 +227,7 @@ instance SMPQueueRec SndQueue where
   {-# INLINE qUserId #-}
   qConnId SndQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId SndQueue {dbQueueId} = dbQueueId
+  dbQId SndQueue {dbQueueId = DBQueueId qId} = qId
   {-# INLINE dbQId #-}
   dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
@@ -316,7 +339,8 @@ ratchetSyncSendProhibited ConnData {ratchetSyncState} =
   ratchetSyncState `elem` ([RSRequired, RSStarted, RSAgreed] :: [RatchetSyncState])
 
 data PendingCommand = PendingCommand
-  { corrId :: ACorrId,
+  { cmdId :: AsyncCmdId,
+    corrId :: ACorrId,
     userId :: UserId,
     connId :: ConnId,
     command :: AgentCommand
@@ -621,4 +645,6 @@ 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,
+    createRcvConn, -- no longer used
     createSndConn,
     getConn,
     getDeletedConn,
@@ -107,9 +107,8 @@ module Simplex.Messaging.Agent.Store.SQLite
     createSndMsgDelivery,
     getSndMsgViaRcpt,
     updateSndMsgRcpt,
-    getPendingMsgData,
+    getPendingQueueMsg,
     updatePendingMsgRIState,
-    getPendingMsgs,
     deletePendingMsgs,
     setMsgUserAck,
     getRcvMsg,
@@ -133,8 +132,8 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateRatchet,
     -- Async commands
     createCommand,
-    getPendingCommands,
-    getPendingCommand,
+    getPendingCommandServers,
+    getPendingServerCommand,
     deleteCommand,
     -- Notification device token persistence
     createNtfToken,
@@ -153,7 +152,9 @@ module Simplex.Messaging.Agent.Store.SQLite
     setNullNtfSubscriptionAction,
     deleteNtfSubscription,
     getNextNtfSubNTFAction,
+    markNtfSubActionNtfFailed_, -- exported for tests
     getNextNtfSubSMPAction,
+    markNtfSubActionSMPFailed_, -- exported for tests
     getActiveNtfToken,
     getNtfRcvQueue,
     setConnectionNtfs,
@@ -192,6 +193,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     deleteSndFile',
     getSndFileDeleted,
     createSndFileReplica,
+    createSndFileReplica_, -- exported for tests
     getNextSndChunkToUpload,
     updateSndChunkReplicaDelay,
     addSndChunkReplicaRecipients,
@@ -223,7 +225,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 (second)
+import Data.Bifunctor (first, second)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
@@ -272,7 +274,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, eitherToMaybe, groupOn, ifM, safeDecodeUtf8, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
@@ -530,54 +532,56 @@ deleteUsersWithoutConns db = do
 createConn_ ::
   TVar ChaChaDRG ->
   ConnData ->
-  (ByteString -> IO ()) ->
-  IO (Either StoreError ByteString)
+  (ConnId -> IO a) ->
+  IO (Either StoreError (ConnId, a))
 createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of
-  ConnData {connId = ""} -> createWithRandomId gVar create
-  ConnData {connId} -> create connId $> Right connId
+  ConnData {connId = ""} -> createWithRandomId' gVar create
+  ConnData {connId} -> Right . (connId,) <$> create connId
 
 createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId)
-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)
+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)
 
-updateNewConnRcv :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
+updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 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 Int64)
+    updateConn :: IO (Either StoreError RcvQueue)
     updateConn = Right <$> addConnRcvQueue_ db connId rq
 
-updateNewConnSnd :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
+updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 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 Int64)
+    updateConn :: IO (Either StoreError SndQueue)
     updateConn = Right <$> addConnSndQueue_ db connId sq
 
-createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId)
+createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue))
 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)
-    void $ insertRcvQueue_ db connId q serverKeyHash_
+    insertRcvQueue_ db connId q serverKeyHash_
 
-createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId)
+createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue))
 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)
-      void $ insertSndQueue_ db connId q serverKeyHash_
+      insertSndQueue_ db connId q serverKeyHash_
 
-checkConfirmedSndQueueExists_ :: DB.Connection -> SndQueue -> IO Bool
+checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
 checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
   fromMaybe False
     <$> maybeFirstRow
@@ -602,39 +606,39 @@ deleteConn db connId =
     "DELETE FROM connections WHERE conn_id = :conn_id;"
     [":conn_id" := connId]
 
-upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
+upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 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 -> RcvQueue -> IO (Either StoreError Int64)
+upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 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 -> RcvQueue -> IO (Either StoreError Int64)
+addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 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 -> RcvQueue -> IO Int64
+addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
 addConnRcvQueue_ db connId rq@RcvQueue {server} = do
   serverKeyHash_ <- createServer_ db server
   insertRcvQueue_ db connId rq serverKeyHash_
 
-addConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
+addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 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 -> SndQueue -> IO Int64
+addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
 addConnSndQueue_ db connId sq@SndQueue {server} = do
   serverKeyHash_ <- createServer_ db server
   insertSndQueue_ db connId sq serverKeyHash_
@@ -974,36 +978,65 @@ 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)
 
-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_
+getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
+getPendingQueueMsg db connId SndQueue {dbQueueId} =
+  getWorkItem "message" getMsgId getMsgData markMsgFailed
   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)
-    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}
+    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
 
 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)
@@ -1096,7 +1129,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 = ?" (connId, msgId)
+  (Only cnt : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ? AND failed = 0" (connId, msgId)
   pure cnt
 
 deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
@@ -1202,15 +1235,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 AsyncCmdId)
+createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO (Either StoreError ())
 createCommand db corrId connId srv_ cmd = runExceptT $ do
   (host_, port_, serverKeyHash_) <- serverFields
-  liftIO $ do
+  createdAt <- liftIO getCurrentTime
+  liftIO $
     DB.execute
       db
-      "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
+      "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)
   where
     serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash)
     serverFields = case srv_ of
@@ -1221,38 +1254,63 @@ createCommand db corrId connId srv_ cmd = runExceptT $ do
 insertedRowId :: DB.Connection -> IO Int64
 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
 
-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.
+getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer]
+getPendingCommandServers db connId = do
   -- TODO review whether this can break if, e.g., the server has another key hash.
-  map (\ids -> (fst $ head ids, map snd ids)) . groupOn fst . map srvCmdId
+  map smpServer
     <$> DB.query
       db
       [sql|
-        SELECT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash), c.command_id
+        SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
         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
-    srvCmdId (host, port, keyHash, cmdId) = (SMPServer <$> host <*> port <*> keyHash, cmdId)
+    smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
 
-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)
+getPendingServerCommand :: DB.Connection -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
+getPendingServerCommand db srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
   where
-    pendingCommand (corrId, userId, connId, command) = PendingCommand {corrId, userId, connId, command}
+    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)
 
 deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
 deleteCommand db cmdId =
@@ -1477,53 +1535,95 @@ 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 (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
+getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs)))
+getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
+  getWorkItem "ntf NTF" getNtfConnId getNtfSubAction (markNtfSubActionNtfFailed_ db)
   where
-    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)
+    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)
 
-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
+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)
   where
-    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)
+    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)
 
 getActiveNtfToken :: DB.Connection -> IO (Maybe NtfToken)
 getActiveNtfToken db =
@@ -1571,6 +1671,10 @@ 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
@@ -1711,8 +1815,8 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> Maybe C.KeyHash -> IO Int64
-insertRcvQueue_ db connId' RcvQueue {..} serverKeyHash_ = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue
+insertRcvQueue_ db connId' rq@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
@@ -1721,12 +1825,12 @@ insertRcvQueue_ db connId' 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 qId
+  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
 
 -- * createSndConn helpers
 
-insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> Maybe C.KeyHash -> IO Int64
-insertSndQueue_ db connId' SndQueue {..} serverKeyHash_ = do
+insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue
+insertSndQueue_ db connId' sq@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
@@ -1735,11 +1839,11 @@ insertSndQueue_ db connId' 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 qId
+  pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
 
-newQueueId_ :: [Only Int64] -> Int64
-newQueueId_ [] = 1
-newQueueId_ (Only maxId : _) = maxId + 1
+newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored
+newQueueId_ [] = DBQueueId 1
+newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
 
 -- * getConn helpers
 
@@ -1853,7 +1957,7 @@ rcvQueueQuery =
 
 toRcvQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
-    :. (Int64, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
+    :. (DBQueueId 'QSStored, 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_)) =
@@ -1894,7 +1998,7 @@ sndQueueQuery =
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId)
     :. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
-    :. (Int64, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
+    :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
   SndQueue
 toSndQueue
   ( (userId, keyHash, connId, host, port, sndId)
@@ -2093,20 +2197,23 @@ updateHashSnd_ dbConn connId SndMsgData {..} =
 
 -- create record with a random ID
 createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString)
-createWithRandomId gVar create = tryCreate 3
+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
   where
-    tryCreate :: Int -> IO (Either StoreError ByteString)
+    tryCreate :: Int -> IO (Either StoreError (ByteString, a))
     tryCreate 0 = pure $ Left SEUniqueID
     tryCreate n = do
       id' <- randomId gVar 12
       E.try (create id') >>= \case
-        Right _ -> pure $ Right id'
+        Right r -> pure $ Right (id', r)
         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.pseudoRandomBytes n gVar
+randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar
 
 ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction)
 ntfSubAndSMPAction (NtfSubNTFAction action) = (Just action, Nothing)
@@ -2273,60 +2380,84 @@ 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 (Maybe RcvFileChunk)
+getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFileChunk))
 getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
-  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)
+  getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
   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}]
-        }
+    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}]
+            }
 
-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
+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)
 
 getPendingRcvFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer]
 getPendingRcvFilesServers db ttl = do
@@ -2478,23 +2609,28 @@ getChunkReplicaRecipients_ db replicaId =
     |]
     (Only replicaId)
 
-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
+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)
 
 updateSndFileError :: DB.Connection -> DBSndFileId -> String -> IO ()
 updateSndFileError db sndFileId errStr = do
@@ -2538,7 +2674,10 @@ 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} NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
+createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId
+
+createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO ()
+createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
   srvId <- createXFTPServer_ db server
   DB.execute
     db
@@ -2559,50 +2698,69 @@ createSndFileReplica db SndFileChunk {sndChunkId} NewSndChunkReplica {server, re
       |]
       (rId, rcvId, rcvKey)
 
-getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe SndFileChunk)
+getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe SndFileChunk))
 getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
-  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)
+  getWorkItem "snd_file_upload" getReplicaId getChunkData (markSndFileFailed db . snd)
   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 = []}]
-            }
+    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 = []}]
+                }
 
 updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()
 updateSndChunkReplicaDelay db replicaId delay = do
@@ -2707,25 +2865,30 @@ 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 (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
+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)
 
 updateDeletedSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()
 updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId delay = do

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

@@ -65,6 +65,8 @@ 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.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -98,7 +100,9 @@ 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)
+    ("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)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -0,0 +1,20 @@
+{-# 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

@@ -0,0 +1,38 @@
+{-# 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/agent_schema.sql

@@ -213,6 +213,8 @@ 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,
@@ -229,6 +231,8 @@ 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
 );
@@ -237,6 +241,7 @@ 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);
@@ -273,6 +278,7 @@ 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(
@@ -315,7 +321,8 @@ CREATE TABLE snd_files(
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
   ,
   src_file_key BLOB,
-  src_file_nonce BLOB
+  src_file_nonce BLOB,
+  failed INTEGER DEFAULT 0
 );
 CREATE TABLE snd_file_chunks(
   snd_file_chunk_id INTEGER PRIMARY KEY,
@@ -359,6 +366,8 @@ 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,
@@ -479,3 +488,12 @@ 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);

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 (..))
+import Simplex.Messaging.Agent.Store (RcvQueue, StoredRcvQueue (..))
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM

src/Simplex/Messaging/Crypto.hs

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

src/Simplex/Messaging/Crypto/File.hs

@@ -23,6 +23,7 @@ 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)
@@ -109,8 +110,8 @@ data FTCryptoError
 plain :: FilePath -> CryptoFile
 plain = (`CryptoFile` Nothing)
 
-randomArgs :: IO CryptoFileArgs
-randomArgs = CFArgs <$> C.randomSbKey <*> C.randomCbNonce
+randomArgs :: TVar ChaChaDRG -> STM CryptoFileArgs
+randomArgs g = CFArgs <$> C.randomSbKey g <*> C.randomCbNonce g
 
 getFileContentsSize :: CryptoFile -> IO Integer
 getFileContentsSize (CryptoFile path cfArgs) = do

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,6 +40,7 @@ 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
@@ -81,10 +82,10 @@ instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where
       [key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2
       _ -> fail "bad e2e params"
 
-generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => Version -> IO (PrivateKey a, PrivateKey a, E2ERatchetParams a)
-generateE2EParams v = do
-  (k1, pk1) <- generateKeyPair'
-  (k2, pk2) <- generateKeyPair'
+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
   pure (pk1, pk2, E2ERatchetParams v k1 k2)
 
 data RatchetInitParams = RatchetInitParams
@@ -345,11 +346,12 @@ maxSkip = 512
 rcDecrypt ::
   forall a.
   (AlgorithmI a, DhAlgorithm a) =>
+  TVar ChaChaDRG ->
   Ratchet a ->
   SkippedMsgKeys ->
   ByteString ->
   ExceptT CryptoError IO (DecryptResult a)
-rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
+rcDecrypt g 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)
@@ -389,7 +391,7 @@ rcDecrypt 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') <- liftIO $ generateKeyPair' @a
+              (_, rcDHRs') <- atomically $ generateKeyPair @a g
               -- 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.pseudoRandomBytes (fromIntegral sz) drg
+    bs <- atomically $ C.randomBytes (fromIntegral sz) drg
     copyByteArrayToPtr bs buf
 
 type RNGContext = ()

src/Simplex/Messaging/Notifications/Server.hs

@@ -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 c activeAt expCfg]
+    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (pure True)]
     disconnectThread_ _ _ = []
 
 clientDisconnected :: NtfServerClient -> IO ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
 receive :: Transport c => THandle c -> NtfServerClient -> M ()
-receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
+receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
   ts <- liftIO $ tGet th
   forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
-    atomically . writeTVar activeAt =<< liftIO getSystemTime
+    atomically . writeTVar rcvActiveAt =<< 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, activeAt} = forever $ do
     write q t = atomically $ writeTBQueue q t
 
 send :: Transport c => THandle c -> NtfServerClient -> IO ()
-send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
+send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
   void . liftIO $ tPut h Nothing [(Nothing, encodeTransmission v sessionId t)]
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
+  atomically . writeTVar sndActiveAt =<< 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) <- liftIO C.generateKeyPair'
+        ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random
         let dhSecret = C.dh' dhPubKey srvDhPrivKey
         tknId <- getId
         regCode <- getRegCode
@@ -565,13 +565,11 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
           PING -> pure NRPong
       NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
     getId :: M NtfEntityId
-    getId = getRandomBytes =<< asks (subIdBytes . config)
+    getId = randomBytes =<< asks (subIdBytes . config)
     getRegCode :: M NtfRegCode
-    getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
-    getRandomBytes :: Int -> M ByteString
-    getRandomBytes n = do
-      gVar <- asks idsDrg
-      atomically (C.pseudoRandomBytes n gVar)
+    getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config))
+    randomBytes :: Int -> M ByteString
+    randomBytes n = atomically . C.randomBytes n =<< asks random
     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 = 7200, -- 2 hours
-      checkInterval = 3600 -- seconds, 1 hour
+    { ttl = 43200, -- seconds, 12 hours
+      checkInterval = 3600 -- seconds, 1 hours
     }
 
 data NtfEnv = NtfEnv
@@ -76,7 +76,7 @@ data NtfEnv = NtfEnv
     pushServer :: NtfPushServer,
     store :: NtfStore,
     storeLog :: Maybe (StoreLog 'WriteMode),
-    idsDrg :: TVar ChaChaDRG,
+    random :: 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
-  idsDrg <- newTVarIO =<< drgNew
+  random <- liftIO C.newRandom
   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, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+  pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriber,
@@ -160,7 +160,8 @@ data NtfServerClient = NtfServerClient
     sndQ :: TBQueue (Transmission NtfResponse),
     sessionId :: ByteString,
     connected :: TVar Bool,
-    activeAt :: TVar SystemTime
+    rcvActiveAt :: TVar SystemTime,
+    sndActiveAt :: TVar SystemTime
   }
 
 newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
@@ -168,5 +169,6 @@ newNtfServerClient qSize sessionId ts = do
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
-  activeAt <- newTVar ts
-  return NtfServerClient {rcvQ, sndQ, sessionId, connected, activeAt}
+  rcvActiveAt <- newTVar ts
+  sndActiveAt <- newTVar ts
+  return NtfServerClient {rcvQ, sndQ, sessionId, connected, rcvActiveAt, sndActiveAt}

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

@@ -17,10 +17,11 @@ 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 (..))
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
 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)
@@ -29,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.6.4"
+ntfServerVersion = "1.7.0.2"
 
 defaultSMPBatchDelay :: Int
 defaultSMPBatchDelay = 10000
@@ -86,7 +87,12 @@ 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"
+            <> "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")
     runServer ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
@@ -115,7 +121,12 @@ ntfServerCLI cfgPath logPath =
               smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
               apnsConfig = defaultAPNSPushClientConfig,
               subsBatchSize = 900,
-              inactiveClientExpiration = Nothing,
+              inactiveClientExpiration =
+                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
+                  $> ExpirationConfig
+                    { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
+                      checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
+                    },
               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, drgNew)
+import Crypto.Random (ChaChaDRG)
 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 <- drgNew >>= newTVarIO
+  nonceDrg <- C.newRandom
   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.pseudoRandomCbNonce nonceDrg
+  nonce <- atomically $ C.randomCbNonce 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/Server.hs

@@ -83,8 +83,9 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
-import System.IO (hPutStrLn, hSetNewlineMode, universalNewlineMode)
+import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode)
 import System.Mem.Weak (deRefWeak)
+import UnliftIO (timeout)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
@@ -129,7 +130,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
     runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams tCfg (runClient t)
+      ss <- asks sockets
+      runTransportServerState ss started tcpPort serverParams tCfg (runClient t)
 
     saveServer :: Bool -> M ()
     saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
@@ -143,11 +145,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       (Client -> TMap QueueId s) ->
       (s -> IO ()) ->
       M ()
-    serverThread s label subQ subs clientSubs unsub = forever $ do
+    serverThread s label subQ subs clientSubs unsub = do
       labelMyThread label
-      atomically updateSubscribers
-        $>>= endPreviousSubscriptions
-        >>= liftIO . mapM_ unsub
+      forever $
+        atomically updateSubscribers
+          $>>= endPreviousSubscriptions
+          >>= liftIO . mapM_ unsub
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
         updateSubscribers = do
@@ -161,9 +164,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
-          labelMyThread $ label <> ".endPreviousSubscriptions"
-          void . forkIO . atomically $
-            writeTBQueue (sndQ c) [(CorrId "", qId, END)]
+          void . forkIO $ do
+            labelMyThread $ label <> ".endPreviousSubscriptions"
+            atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)]
           atomically $ TM.lookupDelete qId (clientSubs c)
 
     expireMessagesThread_ :: ServerConfig -> [M ()]
@@ -238,11 +241,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
     runClient :: Transport c => TProxy c -> c -> M ()
     runClient tp h = do
       kh <- asks serverIdentity
-      smpVRange <- asks $ smpServerVRange . config
+      ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
       labelMyThread $ "smp handshake for " <> transportName tp
-      liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
-        Right th -> runClientTransport th
-        Left _ -> pure ()
+      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h kh smpServerVRange) >>= \case
+        Just (Right th) -> runClientTransport th
+        _ -> pure ()
 
     controlPortThread_ :: ServerConfig -> [M ()]
     controlPortThread_ ServerConfig {controlPort = Just port} = [runCPServer port]
@@ -276,14 +279,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
               CPSuspend -> hPutStrLn h "suspend not implemented"
               CPResume -> hPutStrLn h "resume not implemented"
               CPClients -> do
-                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
+                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']
               CPStats -> do
                 ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
                 putStat "fromTime" fromTime
@@ -299,7 +304,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 >>= hPutStrLn h . show
+              CPStatsRTS -> getRTSStats >>= hPrint h
               CPThreads -> do
 #if MIN_VERSION_base(4,18,0)
                 threads <- liftIO listThreads
@@ -311,11 +316,47 @@ 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
+                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, threads, save, help, quit"
+              CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, delete, save, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
 
@@ -323,24 +364,32 @@ runClientTransport :: Transport c => THandle c -> M ()
 runClientTransport th@THandle {thVersion, sessionId} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
-  c <- atomically $ newClient q thVersion sessionId ts
+  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
   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 c activeAt expCfg]
+    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)]
     disconnectThread_ _ _ = []
+    noSubscriptions c = atomically $ (&&) <$> TM.null (subscriptions c) <*> TM.null (ntfSubscriptions c)
 
 clientDisconnected :: Client -> M ()
-clientDisconnected c@Client {subscriptions, connected} = do
+clientDisconnected c@Client {clientId, subscriptions, connected, sessionId} = do
+  labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc"
   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'
@@ -357,11 +406,11 @@ cancelSub sub =
     _ -> return ()
 
 receive :: Transport c => THandle c -> Client -> M ()
-receive th Client {rcvQ, sndQ, activeAt, sessionId} = do
+receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
   forever $ do
     ts <- L.toList <$> liftIO (tGet th)
-    atomically . writeTVar activeAt =<< liftIO getSystemTime
+    atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
     as <- partitionEithers <$> mapM cmdAction ts
     write sndQ $ fst as
     write rcvQ $ snd as
@@ -378,12 +427,12 @@ receive th Client {rcvQ, sndQ, activeAt, 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, activeAt} = do
+send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
   forever $ do
     ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
     void . liftIO . tPut h Nothing $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
-    atomically . writeTVar activeAt =<< liftIO getSystemTime
+    atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
   where
     tOrder :: Transmission BrokerMsg -> Int
     tOrder (_, _, cmd) = case cmd of
@@ -391,15 +440,18 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = do
       NMSG {} -> 0
       _ -> 1
 
-disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()
-disconnectTransport THandle {connection, sessionId} c activeAt expCfg = do
+disconnectTransport :: Transport c => THandle c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
+disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport"
-  let interval = checkInterval expCfg * 1000000
-  forever . liftIO $ do
-    threadDelay' interval
-    old <- expireBeforeEpoch expCfg
-    ts <- readTVarIO $ activeAt c
-    when (systemSeconds ts < old) $ closeConnection connection
+  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
 
 data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 
@@ -487,7 +539,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) <- liftIO C.generateKeyPair'
+          (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
           let rcvDhSecret = C.dh' dhKey privDhKey
               qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
               qRec (recipientId, senderId) =
@@ -542,7 +594,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) <- liftIO C.generateKeyPair'
+          (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
           let rcvNtfDhSecret = C.dh' dhKey privDhKey
           (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
           where
@@ -688,7 +740,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 idsDrg
+                          atomically . trySendNotification msg =<< asks random
                           atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
                           atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
                         atomically $ modifyTVar' (msgSent stats) (+ 1)
@@ -723,7 +775,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.pseudoRandomCbNonce ntfNonceDrg
+              cbNonce <- C.randomCbNonce ntfNonceDrg
               let msgMeta = NMsgMeta {msgId, msgTs}
                   encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
               pure . (cbNonce,) $ fromRight "" encNMsgMeta
@@ -748,6 +800,7 @@ 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
@@ -822,9 +875,7 @@ timed name qId a = do
     sec = 1000_000000
 
 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
-randomId n = do
-  gVar <- asks idsDrg
-  atomically (C.pseudoRandomBytes n gVar)
+randomId n = atomically . C.randomBytes n =<< asks random
 
 saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => Bool -> m ()
 saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages

src/Simplex/Messaging/Server/Control.hs

@@ -4,6 +4,7 @@
 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
@@ -13,6 +14,9 @@ data ControlProtocol
   | CPStats
   | CPStatsRTS
   | CPThreads
+  | CPSockets
+  | CPSocketThreads
+  | CPDelete ByteString
   | CPSave
   | CPHelp
   | CPQuit
@@ -26,6 +30,9 @@ 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"
@@ -38,6 +45,9 @@ 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,6 +21,7 @@ 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
@@ -31,7 +32,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 (TransportServerConfig, loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState)
 import Simplex.Messaging.Version
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
@@ -39,6 +40,7 @@ import UnliftIO.STM
 
 data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport)],
+    smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
     -- serverTbqSize :: Natural,
     msgQueueQuota :: Int,
@@ -89,8 +91,8 @@ defaultMessageExpiration =
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
-    { ttl = 86400, -- seconds, 24 hours
-      checkInterval = 43200 -- seconds, 12 hours
+    { ttl = 43200, -- seconds, 12 hours
+      checkInterval = 3600 -- seconds, 1 hours
     }
 
 data Env = Env
@@ -99,10 +101,13 @@ data Env = Env
     serverIdentity :: KeyHash,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
-    idsDrg :: TVar ChaChaDRG,
+    random :: TVar ChaChaDRG,
     storeLog :: Maybe (StoreLog 'WriteMode),
     tlsServerParams :: T.ServerParams,
-    serverStats :: ServerStats
+    serverStats :: ServerStats,
+    sockets :: SocketState,
+    clientSeq :: TVar Int,
+    clients :: TMap Int Client
   }
 
 data Server = Server
@@ -114,14 +119,17 @@ data Server = Server
   }
 
 data Client = Client
-  { subscriptions :: TMap RecipientId (TVar Sub),
+  { clientId :: Int,
+    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,
-    activeAt :: TVar SystemTime
+    createdAt :: SystemTime,
+    rcvActiveAt :: TVar SystemTime,
+    sndActiveAt :: TVar SystemTime
   }
 
 data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
@@ -140,15 +148,17 @@ newServer = do
   savingLock <- createLock
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
 
-newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
-newClient qSize thVersion sessionId ts = do
+newClient :: TVar Int -> Natural -> Version -> ByteString -> SystemTime -> STM Client
+newClient nextClientId qSize thVersion sessionId createdAt = do
+  clientId <- stateTVar nextClientId $ \next -> (next, next + 1)
   subscriptions <- TM.empty
   ntfSubscriptions <- TM.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
-  activeAt <- newTVar ts
-  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, activeAt}
+  rcvActiveAt <- newTVar createdAt
+  sndActiveAt <- newTVar createdAt
+  return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription subThread = do
@@ -160,13 +170,16 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
   server <- atomically newServer
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
-  idsDrg <- drgNew >>= newTVarIO
+  random <- liftIO C.newRandom
   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
-  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog, tlsServerParams, serverStats}
+  sockets <- atomically newSocketState
+  clientSeq <- newTVarIO 0
+  clients <- atomically TM.empty
+  return Env {config, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients}
   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 <$> (getRandomBytes 32 :: IO B.ByteString)
+              SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom)
             iniFileContent host basicAuth =
               "[STORE_LOG]\n\
               \# The server uses STM memory for persistence,\n\
@@ -165,6 +165,7 @@ smpServerCLI cfgPath logPath =
         serverConfig =
           ServerConfig
             { transports = iniTransports ini,
+              smpHandshakeTimeout = 120000000,
               tbqSize = 64,
               -- serverTbqSize = 1024,
               msgQueueQuota = 128,

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

@@ -12,6 +12,7 @@ module Simplex.Messaging.Server.MsgStore.STM
     newMsgStore,
     getMsgQueue,
     delMsgQueue,
+    delMsgQueueSize,
     flushMsgQueue,
     snapshotMsgQueue,
     writeMsg,
@@ -60,6 +61,9 @@ 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)
 

src/Simplex/Messaging/Server/Stats.hs

@@ -11,7 +11,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Time.Calendar.Month.Compat (pattern MonthDay)
+import Data.Time.Calendar.Month (pattern MonthDay)
 import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..))
 import Simplex.Messaging.Encoding.String

src/Simplex/Messaging/Transport/Credentials.hs

@@ -9,6 +9,8 @@ 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)
@@ -45,9 +47,9 @@ privateToTls (C.APrivateSignKey _ k) = case k of
 
 type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate)
 
-genCredentials :: Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
-genCredentials parent (before, after) subjectName = do
-  subjectKeys <- C.generateSignatureKeyPair C.SEd25519
+genCredentials :: TVar ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
+genCredentials g parent (before, after) subjectName = do
+  subjectKeys <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
   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,15 +5,20 @@ 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.Transport (SessionId, TLS)
+import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (SessionId, TLS, closeConnection)
 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 ()
 
@@ -49,7 +54,7 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig $ \sessionId r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing $ \sessionId r sendResponse -> do
       reqBody <- getHTTP2Body r bodyHeadSize
       atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
@@ -58,12 +63,29 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port bufferSize serverParams transportConfig = runHTTP2ServerWith bufferSize setup
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ = runHTTP2ServerWith_ expCfg_ bufferSize setup
   where
     setup = runTransportServer started port serverParams transportConfig
 
-runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> (SessionId -> Request -> (Response -> IO ()) -> IO ()) -> a
-runHTTP2ServerWith bufferSize setup http2Server = setup $ withHTTP2 bufferSize run
+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_
   where
-    run cfg sessId = H.run cfg $ \req _aux sendResp -> http2Server sessId req (`sendResp` [])
+    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

src/Simplex/Messaging/Transport/Server.hs

@@ -7,6 +7,9 @@
 module Simplex.Messaging.Transport.Server
   ( TransportServerConfig (..),
     defaultTransportServerConfig,
+    runTransportServerState,
+    SocketState,
+    newSocketState,
     runTransportServer,
     runTransportServerSocket,
     runTCPServer,
@@ -38,12 +41,14 @@ 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)
@@ -52,6 +57,7 @@ defaultTransportServerConfig :: TransportServerConfig
 defaultTransportServerConfig =
   TransportServerConfig
     { logTLSErrors = True,
+      tlsSetupTimeout = 60000000,
       transportTimeout = 40000000
     }
 
@@ -64,39 +70,57 @@ 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 = runTransportServerSocket started (startTCPServer started port) (transportName (TProxy :: TProxy c))
+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))
 
 -- | 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 started getSocket $ \conn ->
-    E.bracket
-      (connectTLS Nothing tCfg serverParams conn >>= getServerConnection tCfg)
-      closeConnection
-      (unliftIO u . server)
+  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
 
 -- | Run TCP server without TLS
 runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
-runTCPServer started port = runTCPServerSocket started $ startTCPServer started port
+runTCPServer started port server = do
+  ss <- atomically newSocketState
+  runTCPServerSocket ss started (startTCPServer started port) server
 
 -- | Wrap socket provider in a TCP server bracket.
-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 ()
+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)
       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/Util.hs

@@ -85,6 +85,18 @@ unlessM b = ifM b $ pure ()
 ($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b)
 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)
+{-# INLINE mapME #-}
+
+bindRight :: Monad m => (a -> m (Either e b)) -> Either e a -> m (Either e b)
+bindRight = either (pure . Left)
+{-# INLINE bindRight #-}
+
+forME :: (Monad m, Traversable t) => t (Either e a) -> (a -> m (Either e b)) -> m (t (Either e b))
+forME = flip mapME
+{-# 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 :: IO RCHostPairing
-newRCHostPairing = do
-  ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca"
-  (_, idPrivKey) <- C.generateKeyPair'
+newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
+newRCHostPairing drg = do
+  ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca"
+  (_, idPrivKey) <- atomically $ C.generateKeyPair drg
   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 <- liftIO genHostKeys
+  hostKeys <- atomically 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 caKey caCert
+      tlsCreds <- liftIO $ genTLSCredentials drg 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 :: IO RCHostKeys
+    genHostKeys :: STM RCHostKeys
     genHostKeys = do
-      sessKeys <- C.generateKeyPair'
-      dhKeys <- C.generateKeyPair'
+      sessKeys <- C.generateKeyPair drg
+      dhKeys <- C.generateKeyPair drg
       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 :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
-genTLSCredentials caKey caCert = do
+genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
+genTLSCredentials drg caKey caCert = do
   let caCreds = (C.signatureKeyPair caKey, caCert)
-  leaf <- genCredentials (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
+  leaf <- genCredentials drg (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.pseudoRandomCbNonce drg
+    nonce' <- liftIO . atomically $ C.randomCbNonce 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 Nothing (0, 24 * 999999) "ca"
-      (_, dhPrivKey) <- C.generateKeyPair'
+      ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca"
+      (_, dhPrivKey) <- atomically $ C.generateKeyPair drg
       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) <- liftIO C.generateKeyPair'
+      (_, dhPrivKey) <- atomically $ C.generateKeyPair drg
       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 caKey caCert) >>= \case
+        liftIO (genTLSCredentials drg 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.pseudoRandomCbNonce drg
+        nonce <- liftIO . atomically $ C.randomCbNonce 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.pseudoRandomCbNonce drg
+    nonce <- atomically $ C.randomCbNonce 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.pseudoRandomCbNonce drg
+  nonce <- atomically $ C.randomCbNonce 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,6 +20,7 @@ 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)
@@ -44,10 +45,11 @@ agentTests (ATransport t) = do
   describe "SQLite store" storeTests
   describe "Migration tests" migrationTests
   describe "SMP agent protocol syntax" $ syntaxTests t
-  describe "Establishing duplex connection" $ do
-    it "should connect via one server and one agent" $ do
+  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
       smpAgentTest2_1_1 $ testDuplexConnection t
-    it "should connect via one server and one agent (random IDs)" $ do
+    xit "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
@@ -137,18 +139,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
-(<#) :: Transport c => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
-h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd)
+(<#) :: (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 'AENone -> 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)
 
 -- | receive message to handle `h` and validate it using predicate `p`
-(<#=) :: Transport c => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
-h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
+(<#=) :: (HasCallStack, Transport c) => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
+h <#= p = timeout 5000000 (h <#:) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
 
-(<#=?) :: Transport c => c -> (ATransmission 'Agent -> 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)
 
 -- | test that nothing is delivered to handle `h` during 10ms
 (#:#) :: Transport c => c -> String -> Expectation
@@ -162,7 +164,10 @@ h #:# err = tryGet `shouldReturn` ()
 pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
-testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
+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 _ alice bob = do
   ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV subscribe")
   let cReq' = strEncode cReq
@@ -175,19 +180,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 "hello") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg' 4 "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 "how are you?") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg' 5 "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 "hello too") -> True; _ -> False
+  alice <#= \case ("", "bob", Msg' 6 "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 "message 1") -> True; _ -> False
+  alice <#= \case ("", "bob", Msg' 7 "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)

tests/AgentTests/DoubleRatchetTests.hs

@@ -11,6 +11,7 @@ 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)
@@ -58,14 +59,14 @@ fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen
 
 testMessageHeader :: Expectation
 testMessageHeader = do
-  (k, _) <- C.generateKeyPair' @X25519
+  (k, _) <- atomically . C.generateKeyPair @X25519 =<< C.newRandom
   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 (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()
+type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()
 
 testEncryptDecrypt :: TestRatchets a
 testEncryptDecrypt alice bob = do
@@ -153,7 +154,7 @@ testSkippedAfterRatchetAdvance alice bob = do
 
 testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO ()
 testKeyJSON _ = do
-  (k, pk) <- C.generateKeyPair' @a
+  (k, pk) <- atomically . C.generateKeyPair @a =<< C.newRandom
   testEncodeDecode k
   testEncodeDecode pk
 
@@ -171,46 +172,51 @@ testEncodeDecode x = do
 
 testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dh _ = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a currentE2EEncryptVersion
+  g <- C.newRandom
+  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g 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
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a 1
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a 1
+  g <- C.newRandom
+  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g 1
+  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g 1
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   paramsAlice `shouldBe` paramsBob
 
-(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys), ByteString) -> TVar (Ratchet a, SkippedMsgKeys) -> Expectation
+(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (TVar ChaChaDRG, 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 (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation
+withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation
 withRatchets test = do
+  ga <- C.newRandom
+  gb <- C.newRandom
   (a, b) <- initRatchets @a
-  alice <- newTVarIO (a, M.empty)
-  bob <- newTVarIO (b, M.empty)
+  alice <- newTVarIO (ga, a, M.empty)
+  bob <- newTVarIO (gb, b, M.empty)
   test alice bob `shouldReturn` ()
 
 initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)
 initRatchets = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams currentE2EEncryptVersion
+  g <- C.newRandom
+  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams g currentE2EEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams g currentE2EEncryptVersion
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
-  (_, pkBob3) <- C.generateKeyPair'
+  (_, pkBob3) <- atomically $ C.generateKeyPair g
   let bob = initSndRatchet supportedE2EEncryptVRange (C.publicKey pkAlice2) pkBob3 paramsBob
       alice = initRcvRatchet supportedE2EEncryptVRange pkAlice2 paramsAlice
   pure (alice, bob)
 
-encrypt_ :: AlgorithmI a => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
-encrypt_ (rc, _) msg =
+encrypt_ :: AlgorithmI a => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
+encrypt_ (_, rc, _) msg =
   runExceptT (rcEncrypt rc paddedMsgLen msg)
     >>= either (pure . Left) checkLength
   where
@@ -218,26 +224,26 @@ encrypt_ (rc, _) msg =
       B.length msg' `shouldBe` fullMsgLen
       pure $ Right (msg', rc', SMDNoChange)
 
-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
+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
 
-encrypt :: AlgorithmI a => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)
+encrypt :: AlgorithmI a => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)
 encrypt = withTVar encrypt_
 
-decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))
+decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))
 decrypt = withTVar decrypt_
 
 withTVar ::
   AlgorithmI a =>
-  ((Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) ->
-  TVar (Ratchet a, SkippedMsgKeys) ->
+  ((TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) ->
+  TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) ->
   ByteString ->
   IO (Either e r)
-withTVar op rcVar msg =
-  readTVarIO rcVar
-    >>= (\(rc, smks) -> applyDiff smks <$$> (testEncodeDecode rc >> op (rc, smks) msg))
+withTVar op rcVar msg = do
+  (g, rc, smks) <- readTVarIO rcVar
+  applyDiff smks <$$> (testEncodeDecode rc >> op (g, rc, smks) msg)
     >>= \case
-      Right (res, rc', smks') -> atomically (writeTVar rcVar (rc', smks')) >> pure (Right res)
+      Right (res, rc', smks') -> atomically (writeTVar rcVar (g, 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

@@ -115,31 +115,41 @@ pattern Rcvd :: AgentMsgId -> ACommand 'Agent e
 pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
 
 smpCfgVPrev :: ProtocolClientConfig
-smpCfgVPrev = (smpCfg agentCfg) {serverVRange = serverVRangePrev}
-  where
-    serverVRangePrev = prevRange $ serverVRange $ smpCfg agentCfg
+smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
+
+smpCfgV1 :: ProtocolClientConfig
+smpCfgV1 = (smpCfg agentCfg) {serverVRange = v1Range}
 
 agentCfgVPrev :: AgentConfig
 agentCfgVPrev =
   agentCfg
-    { smpAgentVRange = smpAgentVRangePrev,
-      smpClientVRange = smpClientVRangePrev,
-      e2eEncryptVRange = e2eEncryptVRangePrev,
+    { smpAgentVRange = prevRange $ smpAgentVRange agentCfg,
+      smpClientVRange = prevRange $ smpClientVRange agentCfg,
+      e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg,
       smpCfg = smpCfgVPrev
     }
-  where
-    smpAgentVRangePrev = prevRange $ smpAgentVRange agentCfg
-    smpClientVRangePrev = prevRange $ smpClientVRange agentCfg
-    e2eEncryptVRangePrev = prevRange $ e2eEncryptVRange agentCfg
+
+agentCfgV1 :: AgentConfig
+agentCfgV1 =
+  agentCfg
+    { smpAgentVRange = v1Range,
+      smpClientVRange = v1Range,
+      e2eEncryptVRange = v1Range,
+      smpCfg = smpCfgV1
+    }
 
 agentCfgRatchetVPrev :: AgentConfig
-agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = e2eEncryptVRangePrev}
-  where
-    e2eEncryptVRangePrev = prevRange $ e2eEncryptVRange agentCfg
+agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg}
+
+agentCfgRatchetV1 :: AgentConfig
+agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = v1Range}
 
 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 ()
 
@@ -167,6 +177,8 @@ 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" $
@@ -215,8 +227,10 @@ functionalAPITests t = do
       it "messages delivered only when polled" $
         withSmpServer t testOnlyCreatePull
   describe "Inactive client disconnection" $ do
-    it "should disconnect clients if it was inactive longer than TTL" $
-      testInactiveClientDisconnected t
+    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 NOT disconnect active clients" $
       testActiveClientNotDisconnected t
   describe "Suspending agent" $ do
@@ -336,6 +350,9 @@ 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
@@ -343,6 +360,9 @@ 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
@@ -399,6 +419,32 @@ runAgentClientTest alice bob baseId = do
   where
     msgId = subtract baseId
 
+testAgentClient3 :: HasCallStack => IO ()
+testAgentClient3 = do
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  c <- getSMPAgentClient' 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 = do
   runRight_ $ do
@@ -519,9 +565,6 @@ 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
@@ -1054,14 +1097,26 @@ makeConnectionForUsers alice aliceUserId bob bobUserId = do
   get bob ##> ("", aliceId, CON)
   pure (aliceId, bobId)
 
-testInactiveClientDisconnected :: ATransport -> IO ()
-testInactiveClientDisconnected t = do
+testInactiveNoSubs :: ATransport -> IO ()
+testInactiveNoSubs t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient' agentCfg initAgentServers testDB
-    runRight_ $ do
-      (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-      nGet alice ##> ("", "", DOWN testSMPServer [connId])
+    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' 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
     disconnectAgentClient alice
 
 testActiveClientNotDisconnected :: ATransport -> IO ()
@@ -1088,8 +1143,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 DOWN is sent
-          nGet alice ##> ("", "", DOWN testSMPServer [connId])
+          -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
+          liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
     milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
 
 testSuspendingAgent :: IO ()
@@ -1823,8 +1878,8 @@ testSwitch2ConnectionsAbort1 servers = do
 
 testCreateQueueAuth :: HasCallStack => (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
 testCreateQueueAuth clnt1 clnt2 = do
-  a <- getClient clnt1
-  b <- getClient clnt2
+  a <- getClient clnt1 testDB
+  b <- getClient clnt2 testDB2
   r <- runRight $ do
     tryError (createConnection a 1 True SCMInvitation Nothing SMSubscribe) >>= \case
       Left (SMP AUTH) -> pure 0
@@ -1845,10 +1900,10 @@ testCreateQueueAuth clnt1 clnt2 = do
   disconnectAgentClient b
   pure r
   where
-    getClient (clntAuth, clntVersion) =
+    getClient (clntAuth, clntVersion) db =
       let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]}
           smpCfg = (defaultClientConfig :: ProtocolClientConfig) {serverVRange = mkVersionRange 4 clntVersion}
-       in getSMPAgentClient' agentCfg {smpCfg} servers testDB
+       in getSMPAgentClient' agentCfg {smpCfg} servers db
 
 testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testSMPServerConnectionTest t newQueueBasicAuth srv =
@@ -2051,7 +2106,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
 getSMPAgentClient' :: AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient
 getSMPAgentClient' cfg' initServers dbPath = do
   Right st <- liftIO $ createAgentStore dbPath "" False MCError
-  getSMPAgentClient cfg' initServers st
+  getSMPAgentClient cfg' initServers st False
 
 testServerMultipleIdentities :: HasCallStack => IO ()
 testServerMultipleIdentities =

tests/AgentTests/SQLiteTests.hs

@@ -15,7 +15,6 @@ 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)
@@ -23,9 +22,14 @@ 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
@@ -33,6 +37,9 @@ import Simplex.Messaging.Agent.Store.SQLite
 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
@@ -110,6 +117,16 @@ 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
@@ -118,17 +135,17 @@ storeTests = do
 testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
 testConcurrentWrites =
   it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do
-    g <- newTVarIO =<< drgNew
-    _ <- withTransaction s1 $ \db ->
+    g <- C.newRandom
+    Right (_, rq) <- withTransaction s1 $ \db ->
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let ConnData {connId} = cData1
-    concurrently_ (runTest s1 connId) (runTest s2 connId)
+    concurrently_ (runTest s1 connId rq) (runTest s2 connId rq)
   where
-    runTest :: SQLiteStore -> ConnId -> IO ()
-    runTest st connId = replicateM_ 100 . withTransaction st $ \db -> do
+    runTest :: SQLiteStore -> ConnId -> RcvQueue -> IO ()
+    runTest st connId rq = replicateM_ 100 . withTransaction st $ \db -> do
       (internalId, internalRcvId, _, _) <- updateRcvIds db connId
       let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
-      createRcvMsg db connId rcvQueue1 rcvMsgData
+      createRcvMsg db connId rq rcvMsgData
 
 testCompiledThreadsafe :: SpecWith SQLiteStore
 testCompiledThreadsafe =
@@ -164,12 +181,15 @@ testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOp
 testDhSecret :: C.DhSecretX25519
 testDhSecret = "01234567890123456789012345678901"
 
-rcvQueue1 :: RcvQueue
+smpServer1 :: SMPServer
+smpServer1 = SMPServer "smp.simplex.im" "5223" testKeyHash
+
+rcvQueue1 :: NewRcvQueue
 rcvQueue1 =
   RcvQueue
     { userId = 1,
       connId = "conn1",
-      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+      server = smpServer1,
       rcvId = "1234",
       rcvPrivateKey = testPrivateSignKey,
       rcvDhSecret = testDhSecret,
@@ -177,7 +197,7 @@ rcvQueue1 =
       e2eDhSecret = Nothing,
       sndId = "2345",
       status = New,
-      dbQueueId = 1,
+      dbQueueId = DBNewQueue,
       primary = True,
       dbReplaceQueueId = Nothing,
       rcvSwchStatus = Nothing,
@@ -186,19 +206,19 @@ rcvQueue1 =
       deleteErrors = 0
     }
 
-sndQueue1 :: SndQueue
+sndQueue1 :: NewSndQueue
 sndQueue1 =
   SndQueue
     { userId = 1,
       connId = "conn1",
-      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+      server = smpServer1,
       sndId = "3456",
       sndPublicKey = Nothing,
       sndPrivateKey = testPrivateSignKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
       status = New,
-      dbQueueId = 1,
+      dbQueueId = DBNewQueue,
       primary = True,
       dbReplaceQueueId = Nothing,
       sndSwchStatus = Nothing,
@@ -208,34 +228,33 @@ sndQueue1 =
 testCreateRcvConn :: SpecWith SQLiteStore
 testCreateRcvConn =
   it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    createRcvConn db g cData1 rcvQueue1 SCMInvitation
-      `shouldReturn` Right "conn1"
+    g <- C.newRandom
+    Right (connId, rq@RcvQueue {dbQueueId}) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    connId `shouldBe` "conn1"
+    dbQueueId `shouldBe` DBQueueId 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
-    upgradeRcvConnToDuplex db "conn1" sndQueue1
-      `shouldReturn` Right 1
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
+    Right sq@SndQueue {dbQueueId = dbQueueId'} <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    dbQueueId' `shouldBe` DBQueueId 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
 
 testCreateRcvConnRandomId :: SpecWith SQLiteStore
 testCreateRcvConnRandomId =
   it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
-    let rq' = (rcvQueue1 :: RcvQueue) {connId}
-        sq' = (sndQueue1 :: SndQueue) {connId}
+    g <- C.newRandom
+    Right (connId, rq) <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
     getConn db connId
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq'))
-    upgradeRcvConnToDuplex db connId sndQueue1
-      `shouldReturn` Right 1
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq))
+    Right sq@SndQueue {dbQueueId = dbQueueId'} <- upgradeRcvConnToDuplex db connId sndQueue1
+    dbQueueId' `shouldBe` DBQueueId 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 <- newTVarIO =<< drgNew
+    g <- C.newRandom
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     createRcvConn db g cData1 rcvQueue1 SCMInvitation
       `shouldReturn` Left SEConnDuplicate
@@ -243,34 +262,33 @@ testCreateRcvConnDuplicate =
 testCreateSndConn :: SpecWith SQLiteStore
 testCreateSndConn =
   it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    createSndConn db g cData1 sndQueue1
-      `shouldReturn` Right "conn1"
+    g <- C.newRandom
+    Right (connId, sq@SndQueue {dbQueueId}) <- createSndConn db g cData1 sndQueue1
+    connId `shouldBe` "conn1"
+    dbQueueId `shouldBe` DBQueueId 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
-    upgradeSndConnToDuplex db "conn1" rcvQueue1
-      `shouldReturn` Right 1
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
+    Right rq@RcvQueue {dbQueueId = dbQueueId'} <- upgradeSndConnToDuplex db "conn1" rcvQueue1
+    dbQueueId' `shouldBe` DBQueueId 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
 
 testCreateSndConnRandomID :: SpecWith SQLiteStore
 testCreateSndConnRandomID =
   it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1
-    let rq' = (rcvQueue1 :: RcvQueue) {connId}
-        sq' = (sndQueue1 :: SndQueue) {connId}
+    g <- C.newRandom
+    Right (connId, sq) <- createSndConn db g cData1 {connId = ""} sndQueue1
     getConn db connId
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq'))
-    upgradeSndConnToDuplex db connId rcvQueue1
-      `shouldReturn` Right 1
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq))
+    Right (rq@RcvQueue {dbQueueId = dbQueueId'}) <- upgradeSndConnToDuplex db connId rcvQueue1
+    dbQueueId' `shouldBe` DBQueueId 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 <- newTVarIO =<< drgNew
+    g <- C.newRandom
     _ <- createSndConn db g cData1 sndQueue1
     createSndConn db g cData1 sndQueue1
       `shouldReturn` Left SEConnDuplicate
@@ -280,18 +298,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 <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    g <- C.newRandom
+    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getRcvConn db smpServer recipientId
-      `shouldReturn` Right (rcvQueue1, SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+      `shouldReturn` Right (rq, SomeConn SCRcv (RcvConnection cData1 rq))
 
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
   it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    g <- C.newRandom
+    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
     deleteConn db "conn1"
       `shouldReturn` ()
     getConn db "conn1"
@@ -300,10 +318,10 @@ testDeleteRcvConn =
 testDeleteSndConn :: SpecWith SQLiteStore
 testDeleteSndConn =
   it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    _ <- createSndConn db g cData1 sndQueue1
+    g <- C.newRandom
+    Right (_, sq) <- createSndConn db g cData1 sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
     deleteConn db "conn1"
       `shouldReturn` ()
     getConn db "conn1"
@@ -312,11 +330,11 @@ testDeleteSndConn =
 testDeleteDuplexConn :: SpecWith SQLiteStore
 testDeleteDuplexConn =
   it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    g <- C.newRandom
+    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
     deleteConn db "conn1"
       `shouldReturn` ()
     getConn db "conn1"
@@ -325,7 +343,7 @@ testDeleteDuplexConn =
 testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
 testUpgradeRcvConnToDuplex =
   it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
+    g <- C.newRandom
     _ <- createSndConn db g cData1 sndQueue1
     let anotherSndQueue =
           SndQueue
@@ -338,7 +356,7 @@ testUpgradeRcvConnToDuplex =
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
               status = New,
-              dbQueueId = 1,
+              dbQueueId = DBNewQueue,
               sndSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -353,7 +371,7 @@ testUpgradeRcvConnToDuplex =
 testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
 testUpgradeSndConnToDuplex =
   it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
+    g <- C.newRandom
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let anotherRcvQueue =
           RcvQueue
@@ -367,7 +385,7 @@ testUpgradeSndConnToDuplex =
               e2eDhSecret = Nothing,
               sndId = "4567",
               status = New,
-              dbQueueId = 1,
+              dbQueueId = DBNewQueue,
               rcvSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -384,43 +402,43 @@ testUpgradeSndConnToDuplex =
 testSetRcvQueueStatus :: SpecWith SQLiteStore
 testSetRcvQueueStatus =
   it "should update status of RcvQueue" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    g <- C.newRandom
+    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
-    setRcvQueueStatus db rcvQueue1 Confirmed
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
+    setRcvQueueStatus db rq Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq {status = Confirmed}))
 
 testSetSndQueueStatus :: SpecWith SQLiteStore
 testSetSndQueueStatus =
   it "should update status of SndQueue" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    _ <- createSndConn db g cData1 sndQueue1
+    g <- C.newRandom
+    Right (_, sq) <- createSndConn db g cData1 sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
-    setSndQueueStatus db sndQueue1 Confirmed
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
+    setSndQueueStatus db sq Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq {status = Confirmed}))
 
 testSetQueueStatusDuplex :: SpecWith SQLiteStore
 testSetQueueStatusDuplex =
   it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do
-    g <- newTVarIO =<< drgNew
-    _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
-    _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
+    g <- C.newRandom
+    Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
+    Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
-    setRcvQueueStatus db rcvQueue1 Secured
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
+    setRcvQueueStatus db rq Secured
       `shouldReturn` ()
-    let rq' = (rcvQueue1 :: RcvQueue) {status = Secured}
-        sq' = (sndQueue1 :: SndQueue) {status = Confirmed}
+    let rq' = (rq :: RcvQueue) {status = Secured}
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sndQueue1]))
-    setSndQueueStatus db sndQueue1 Confirmed
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sq]))
+    setSndQueueStatus db sq Confirmed
       `shouldReturn` ()
+    let sq' = (sq :: SndQueue) {status = Confirmed}
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sq']))
 
@@ -460,13 +478,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 <- newTVarIO =<< drgNew
+    g <- C.newRandom
     let ConnData {connId} = cData1
-    _ <- withTransaction st $ \db -> do
+    Right (_, rq) <- withTransaction st $ \db -> do
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     withTransaction st $ \db -> do
-      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"
+      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"
 
 mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
 mkSndMsgData internalId internalSndId internalHash =
@@ -481,39 +499,41 @@ mkSndMsgData internalId internalSndId internalHash =
       prevMsgHash = internalHash
     }
 
-testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
-testCreateSndMsg_ db expectedPrevHash connId sndMsgData@SndMsgData {..} = do
+testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndQueue -> SndMsgData -> Expectation
+testCreateSndMsg_ db expectedPrevHash connId sq 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 <- newTVarIO =<< drgNew
+    g <- C.newRandom
     let ConnData {connId} = cData1
-    _ <- withTransaction st $ \db -> do
+    Right (_, sq) <- withTransaction st $ \db -> do
       createSndConn db g cData1 sndQueue1
     withTransaction st $ \db -> do
-      testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
-      testCreateSndMsg_ db "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
+      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"
 
 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
-    _ <- withTransaction st $ \db -> do
-      g <- newTVarIO =<< drgNew
+    Right (_, rq) <- withTransaction st $ \db -> do
+      g <- C.newRandom
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     withTransaction st $ \db -> do
-      _ <- 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"
+      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"
 
 testCloseReopenStore :: IO ()
 testCloseReopenStore = do
@@ -565,3 +585,201 @@ 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/CoreTests/BatchingTests.hs

@@ -4,7 +4,6 @@ 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.Char8 as B
 import qualified Data.List.NonEmpty as L
@@ -28,7 +27,7 @@ batchingTests = do
 
 testBatchSubscriptions :: IO ()
 testBatchSubscriptions = do
-  sessId <- getRandomBytes 32
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   subs <- replicateM 200 $ randomSUB sessId
   let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
@@ -41,7 +40,7 @@ testBatchSubscriptions = do
 
 testBatchWithMessage :: IO ()
 testBatchWithMessage = do
-  sessId <- getRandomBytes 32
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   subs1 <- replicateM 60 $ randomSUB sessId
   send <- randomSEND sessId 8000
   subs2 <- replicateM 40 $ randomSUB sessId
@@ -57,7 +56,7 @@ testBatchWithMessage = do
 
 testBatchWithLargeMessage :: IO ()
 testBatchWithLargeMessage = do
-  sessId <- getRandomBytes 32
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   subs1 <- replicateM 60 $ randomSUB sessId
   send <- randomSEND sessId 17000
   subs2 <- replicateM 100 $ randomSUB sessId
@@ -76,7 +75,7 @@ testBatchWithLargeMessage = do
 
 testClientBatchSubscriptions :: IO ()
 testClientBatchSubscriptions = do
-  sessId <- getRandomBytes 32
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   client <- atomically $ clientStub sessId
   subs <- replicateM 200 $ randomSUBCmd client
   let batches1 = batchClientTransmissions False smpBlockSize $ L.fromList subs
@@ -90,7 +89,7 @@ testClientBatchSubscriptions = do
 
 testClientBatchWithMessage :: IO ()
 testClientBatchWithMessage = do
-  sessId <- getRandomBytes 32
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   client <- atomically $ clientStub sessId
   subs1 <- replicateM 60 $ randomSUBCmd client
   send <- randomSENDCmd client 8000
@@ -108,7 +107,7 @@ testClientBatchWithMessage = do
 
 testClientBatchWithLargeMessage :: IO ()
 testClientBatchWithLargeMessage = do
-  sessId <- getRandomBytes 32
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   client <- atomically $ clientStub sessId
   subs1 <- replicateM 60 $ randomSUBCmd client
   send <- randomSENDCmd client 17000
@@ -138,32 +137,36 @@ testClientBatchWithLargeMessage = do
 
 randomSUB :: ByteString -> IO (Maybe C.ASignature, ByteString)
 randomSUB sessId = do
-  rId <- getRandomBytes 24
-  corrId <- CorrId <$> getRandomBytes 3
-  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
+  g <- C.newRandom
+  rId <- atomically $ C.randomBytes 24 g
+  corrId <- atomically $ CorrId <$> C.randomBytes 3 g
+  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
   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
-  rId <- getRandomBytes 24
-  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
+  g <- C.newRandom
+  rId <- atomically $ C.randomBytes 24 g
+  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
   mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB)
 
 randomSEND :: ByteString -> Int -> IO (Maybe C.ASignature, ByteString)
 randomSEND sessId len = do
-  sId <- getRandomBytes 24
-  corrId <- CorrId <$> getRandomBytes 3
-  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
-  msg <- getRandomBytes len
+  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
   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
-  sId <- getRandomBytes 24
-  (_, rpKey) <- C.generateSignatureKeyPair C.SEd448
-  msg <- getRandomBytes len
+  g <- C.newRandom
+  sId <- atomically $ C.randomBytes 24 g
+  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  msg <- atomically $ C.randomBytes len g
   mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg)
 
 lenOk :: ByteString -> Bool

tests/CoreTests/CryptoFileTests.hs

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

tests/CoreTests/CryptoTests.hs

@@ -5,7 +5,6 @@ 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)
@@ -105,14 +104,16 @@ testPadUnpadFile = do
 
 testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec
 testSignature alg = it "should sign / verify string" . ioProperty $ do
-  (k, pk) <- C.generateSignatureKeyPair alg
+  g <- C.newRandom
+  (k, pk) <- atomically $ C.generateSignatureKeyPair alg g
   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
-  (sk, spk) <- C.generateKeyPair'
-  (rk, rpk) <- C.generateKeyPair'
-  nonce <- C.randomCbNonce
+  g <- C.newRandom
+  (sk, spk) <- atomically $ C.generateKeyPair g
+  (rk, rpk) <- atomically $ C.generateKeyPair g
+  nonce <- atomically $ C.randomCbNonce g
   pure $ \(s, pad) ->
     let b = encodeUtf8 $ T.pack s
         paddedLen = B.length b + abs pad + 2
@@ -122,8 +123,9 @@ 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
-  k <- C.randomSbKey
-  nonce <- C.randomCbNonce
+  g <- C.newRandom
+  k <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
   pure $ \(s, pad) ->
     let b = encodeUtf8 $ T.pack s
         pad' = min (abs pad) 100000
@@ -134,8 +136,9 @@ 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
-  k <- C.randomSbKey
-  nonce <- C.randomCbNonce
+  g <- C.newRandom
+  k <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
   pure $ \(s, pad) ->
     let b = LE.encodeUtf8 $ LT.pack s
         len = LB.length b
@@ -147,8 +150,9 @@ 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
-  k <- C.randomSbKey
-  nonce <- C.randomCbNonce
+  g <- C.newRandom
+  k <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
   let f = "tests/tmp/testsecretbox"
       paddedLen = 4 * 1024 * 1024
       len = 4 * 1000 * 1000 :: Int64
@@ -160,8 +164,9 @@ 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
-  k <- C.randomSbKey
-  nonce <- C.randomCbNonce
+  g <- C.newRandom
+  k <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
   pure $ \(s, pad) ->
     let b = LE.encodeUtf8 $ LT.pack s
         len = LB.length b
@@ -173,8 +178,9 @@ 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
-  k <- C.randomSbKey
-  nonce <- C.randomCbNonce
+  g <- C.newRandom
+  k <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
   let f = "tests/tmp/testsecretbox"
       paddedLen = 4 * 1024 * 1024
       len = 4 * 1000 * 1000 :: Int64
@@ -187,9 +193,10 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r
 
 testAESGCM :: Spec
 testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do
-  k <- C.randomAesKey
-  iv <- C.randomGCMIV
-  s <- getRandomBytes 100
+  g <- C.newRandom
+  k <- atomically $ C.randomAesKey g
+  iv <- atomically $ C.randomGCMIV g
+  s <- atomically $ C.randomBytes 100 g
   Right (tag, cipher) <- runExceptT $ C.encryptAESNoPad k iv s
   Right plain <- runExceptT $ C.decryptAESNoPad k iv cipher tag
   cipher `shouldNotBe` plain
@@ -197,14 +204,15 @@ 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
-  (k, pk) <- C.generateKeyPair alg
+  g <- C.newRandom
+  (k, pk) <- atomically $ C.generateAKeyPair alg g
   pure $ \(_ :: Int) ->
     C.decodePubKey (C.encodePubKey k) == Right k
       && C.decodePrivKey (C.encodePrivKey pk) == Right pk
 
 testSNTRUP761 :: IO ()
 testSNTRUP761 = do
-  drg <- newTVarIO =<< drgNew
+  drg <- C.newRandom
   (pk, sk) <- sntrup761Keypair drg
   (c, KEMSharedKey k) <- sntrup761Enc drg pk
   KEMSharedKey k' <- sntrup761Dec c sk

tests/NtfServerTests.hs

@@ -88,10 +88,11 @@ testNotificationSubscription :: ATransport -> Spec
 testNotificationSubscription (ATransport t) =
   -- hangs on Ubuntu 20/22
   xit' "should create notification subscription and notify when message is received" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
-    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
-    (tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519
-    (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+    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
     let tkn = DeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \APNSMockServer {apnsQ} ->
       smpTest2 t $ \rh sh ->
@@ -110,7 +111,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) <- C.generateKeyPair'
+          (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
           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,9 +6,10 @@ module RemoteControl where
 
 import AgentTests.FunctionalAPITests (runRight)
 import Control.Logger.Simple
-import Crypto.Random (ChaChaDRG, drgNew)
+import Crypto.Random (ChaChaDRG)
 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
@@ -62,8 +63,8 @@ testPreferAddress = do
 
 testNewPairing :: IO ()
 testNewPairing = do
-  drg <- drgNew >>= newTVarIO
-  hp <- RC.newRCHostPairing
+  drg <- C.newRandom
+  hp <- RC.newRCHostPairing drg
   invVar <- newEmptyMVar
   ctrlSessId <- async . runRight $ do
     logNote "c 1"
@@ -108,9 +109,9 @@ testNewPairing = do
 
 testExistingPairing :: IO ()
 testExistingPairing = do
-  drg <- drgNew >>= newTVarIO
+  drg <- C.newRandom
   invVar <- newEmptyMVar
-  hp <- liftIO $ RC.newRCHostPairing
+  hp <- RC.newRCHostPairing drg
   ctrl <- runCtrl drg False hp invVar
   inv <- takeMVar invVar
   let cp_ = Nothing
@@ -139,10 +140,10 @@ testExistingPairing = do
 
 testMulticast :: IO ()
 testMulticast = do
-  drg <- drgNew >>= newTVarIO
+  drg <- C.newRandom
   subscribers <- newTMVarIO 0
   invVar <- newEmptyMVar
-  hp <- liftIO RC.newRCHostPairing
+  hp <- RC.newRCHostPairing drg
   ctrl <- runCtrl drg False hp invVar
   inv <- takeMVar invVar
   let cp_ = Nothing

tests/SMPClient.hs

@@ -82,6 +82,7 @@ cfg :: ServerConfig
 cfg =
   ServerConfig
     { transports = undefined,
+      smpHandshakeTimeout = 60000000,
       tbqSize = 1,
       -- serverTbqSize = 1,
       msgQueueQuota = 4,

tests/ServerTests.hs

@@ -120,8 +120,9 @@ 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
-      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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"
@@ -139,7 +140,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) <- C.generateSignatureKeyPair C.SEd448
+      (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
       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"
@@ -155,7 +156,7 @@ testCreateSecureV2 _ =
       (rId2, rId) #== "same queue ID in response 3"
 
       Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub)
-      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
+      (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
       Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub')
       (err4, ERR AUTH) #== "rejects if secured with different key"
 
@@ -184,8 +185,9 @@ testCreateSecure :: ATransport -> Spec
 testCreateSecure (ATransport t) =
   it "should create (NEW) and secure (KEY) queue" $
     smpTest2 t $ \r s -> do
-      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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"
@@ -203,7 +205,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) <- C.generateSignatureKeyPair C.SEd448
+      (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
       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"
@@ -219,7 +221,7 @@ testCreateSecure (ATransport t) =
       (rId2, rId) #== "same queue ID in response 3"
 
       Resp "abcd" _ OK <- signSendRecv r rKey ("abcd", rId, KEY sPub)
-      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
+      (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
       Resp "abcd" _ err4 <- signSendRecv r rKey ("abcd", rId, KEY sPub')
       (err4, ERR AUTH) #== "rejects if secured with different key"
 
@@ -248,13 +250,14 @@ testCreateDelete :: ATransport -> Spec
 testCreateDelete (ATransport t) =
   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
     smpTest2 t $ \rh sh -> do
-      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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) <- C.generateSignatureKeyPair C.SEd25519
+      (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
       Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)
       (ok1, OK) #== "secures queue"
 
@@ -318,8 +321,9 @@ stressTest :: ATransport -> Spec
 stressTest (ATransport t) =
   it "should create many queues, disconnect and re-connect" $
     smpTest3 t $ \h1 h2 h3 -> do
-      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
-      (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+      (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       rIds <- forM ([1 .. 50] :: [Int]) . const $ do
         Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe)
         pure rId
@@ -336,8 +340,9 @@ testAllowNewQueues t =
   it "should prohibit creating new queues with allowNewQueues = False" $ do
     withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ ->
       testSMPClient @c $ \h -> do
-        (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
-        (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
+        g <- C.newRandom
+        (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+        (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
         Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
         pure ()
 
@@ -345,13 +350,14 @@ testDuplex :: ATransport -> Spec
 testDuplex (ATransport t) =
   it "should create 2 simplex connections and exchange messages" $
     smpTest2 t $ \alice bob -> do
-      (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448
-      (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (arPub, arKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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) <- C.generateSignatureKeyPair C.SEd448
+      (bsPub, bsKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
       Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
       -- "key ..." is ad-hoc, not a part of SMP protocol
 
@@ -361,8 +367,8 @@ testDuplex (ATransport t) =
       (bobKey, strEncode bsPub) #== "key received from Bob"
       Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub)
 
-      (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448
-      (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      (brPub, brKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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)
@@ -373,7 +379,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) <- C.generateSignatureKeyPair C.SEd448
+      (asPub, asKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
       Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
       -- "key ..." is ad-hoc, not a part of  SMP protocol
 
@@ -399,8 +405,9 @@ testSwitchSub :: ATransport -> Spec
 testSwitchSub (ATransport t) =
   it "should create simplex connections and switch subscription to another TCP connection" $
     smpTest3 t $ \rh1 rh2 sh -> do
-      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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")
@@ -438,7 +445,8 @@ testSwitchSub (ATransport t) =
 testGetCommand :: forall c. Transport c => TProxy c -> Spec
 testGetCommand t =
   it "should retrieve messages from the queue using GET command" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     smpTest t $ \sh -> do
       queue <- newEmptyTMVarIO
       testSMPClient @c $ \rh ->
@@ -456,7 +464,8 @@ 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
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     smpTest3 t $ \rh1 rh2 sh -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub
       let dec = decryptMsgV3 dhShared
@@ -507,7 +516,8 @@ 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
-        (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+        g <- C.newRandom
+        (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
         (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
         let dec = decryptMsgV3 dhShared
         Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1")
@@ -531,9 +541,10 @@ testExceedQueueQuota t =
 testWithStoreLog :: ATransport -> Spec
 testWithStoreLog at@(ATransport t) =
   it "should store simplex queues to log and restore them after server restart" $ do
-    (sPub1, sKey1) <- C.generateSignatureKeyPair C.SEd25519
-    (sPub2, sKey2) <- C.generateSignatureKeyPair C.SEd25519
-    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
+    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
     recipientId1 <- newTVarIO ""
     recipientKey1 <- newTVarIO Nothing
     dhShared1 <- newTVarIO Nothing
@@ -543,7 +554,7 @@ testWithStoreLog at@(ATransport t) =
 
     withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
-      (rcvNtfPubDhKey, _) <- C.generateKeyPair'
+      (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
       Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey)
       atomically $ do
         writeTVar recipientId1 rId1
@@ -619,7 +630,8 @@ testRestoreMessages at@(ATransport t) =
     removeFileIfExists testStoreMsgsFile
     removeFileIfExists testServerStatsBackupFile
 
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
@@ -720,7 +732,8 @@ checkStats s qs sent received = do
 testRestoreMessagesV2 :: ATransport -> Spec
 testRestoreMessagesV2 at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
@@ -789,7 +802,8 @@ testRestoreMessagesV2 at@(ATransport t) =
 testRestoreExpireMessages :: ATransport -> Spec
 testRestoreExpireMessages at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
@@ -843,8 +857,9 @@ testRestoreExpireMessages at@(ATransport t) =
 
 createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
 createAndSecureQueue h sPub = do
-  (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
-  (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+  g <- C.newRandom
+  (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
   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)
@@ -859,25 +874,26 @@ testTiming (ATransport t) =
   where
     timingTests :: [(Int, Int, Int)]
     timingTests =
-      [ (32, 32, 200),
-        (32, 57, 100),
-        (57, 32, 200),
-        (57, 57, 100)
+      [ (32, 32, 300),
+        (32, 57, 150),
+        (57, 32, 300),
+        (57, 57, 150)
       ]
     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
-    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True
+    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25
     testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
     testSameTiming rh sh (goodKeySize, badKeySize, n) = do
-      (rPub, rKey) <- generateKeys goodKeySize
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
+      g <- C.newRandom
+      (rPub, rKey) <- generateKeys g goodKeySize
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       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 badKeySize
+      (_, badKey) <- generateKeys g badKeySize
       -- runTimingTest rh badKey rId "SUB"
 
-      (sPub, sKey) <- generateKeys goodKeySize
+      (sPub, sKey) <- generateKeys g goodKeySize
       Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
 
       Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
@@ -886,35 +902,40 @@ testTiming (ATransport t) =
 
       runTimingTest sh badKey sId $ _SEND "hello"
       where
-        generateKeys = \case
-          32 -> C.generateSignatureKeyPair C.SEd25519
-          57 -> C.generateSignatureKeyPair C.SEd448
+        generateKeys g = \case
+          32 -> atomically $ C.generateSignatureKeyPair C.SEd25519 g
+          57 -> atomically $ C.generateSignatureKeyPair C.SEd448 g
           _ -> 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 ()
-          -- (putStrLn . unwords . map show)
-          --   [ fromIntegral goodKeySize,
-          --     fromIntegral badKeySize,
-          --     timeWrongKey,
-          --     timeNoQueue,
-          --     timeWrongKey / timeNoQueue - 1
-          --   ]
-          similarTime timeNoQueue timeWrongKey
+          let ok = similarTime timeNoQueue timeWrongKey
+          unless ok $
+            (putStrLn . unwords . map show)
+              [ fromIntegral goodKeySize,
+                fromIntegral badKeySize,
+                timeWrongKey,
+                timeNoQueue,
+                abs (timeWrongKey / timeNoQueue - 1)
+              ]
+          ok `shouldBe` True
 
 testMessageNotifications :: ATransport -> Spec
 testMessageNotifications (ATransport t) =
   it "should create simplex connection, subscribe notifier and deliver notifications" $ do
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
-    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     smpTest4 t $ \rh sh nh1 nh2 -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
       let dec = decryptMsgV3 dhShared
-      (rcvNtfPubDhKey, _) <- C.generateKeyPair'
+      (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
       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
@@ -945,7 +966,8 @@ 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
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
@@ -965,7 +987,8 @@ 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
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
@@ -983,7 +1006,8 @@ 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
-    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     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 TypeApplications #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
 
 import AgentTests (agentTests)
 import AgentTests.SchemaDump (schemaDumpTest)
@@ -68,8 +68,9 @@ 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,6 +8,7 @@ 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
@@ -24,11 +25,13 @@ 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 System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory)
+import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
+import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
 import System.FilePath ((</>))
 import System.Timeout (timeout)
 import Test.Hspec
@@ -45,6 +48,9 @@ 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
@@ -107,9 +113,10 @@ testXFTPAgentSendReceive = withXFTPServer $ do
 
 testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
 testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
+  g <- C.newRandom
   filePath <- createRandomFile
   s <- LB.readFile filePath
-  file <- CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs
+  file <- atomically $ CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs g
   runRight_ $ CF.writeFile file s
   sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
   (rfd1, rfd2) <- runRight $ do
@@ -117,20 +124,23 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
     xftpDeleteSndFileInternal sndr sfId
     pure (rfd1, rfd2)
   -- receive file, delete rcv file
-  testReceiveDelete rfd1 filePath
-  testReceiveDelete rfd2 filePath
+  testReceiveDelete rfd1 filePath g
+  testReceiveDelete rfd2 filePath g
   where
-    testReceiveDelete rfd originalFilePath = do
+    testReceiveDelete rfd originalFilePath g = do
       rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
-      cfArgs <- Just <$> CF.randomArgs
+      cfArgs <- atomically $ Just <$> CF.randomArgs g
       runRight_ $ do
         rfId <- testReceiveCF rcp rfd cfArgs originalFilePath
         xftpDeleteRcvFile rcp rfId
       disconnectAgentClient rcp
 
 createRandomFile :: HasCallStack => IO FilePath
-createRandomFile = do
-  let filePath = senderFiles </> "testfile"
+createRandomFile = createRandomFile' "testfile"
+
+createRandomFile' :: HasCallStack => FilePath -> IO FilePath
+createRandomFile' fileName = do
+  let filePath = senderFiles </> fileName
   xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   getFileSize filePath `shouldReturn` mb 17
   pure filePath
@@ -153,6 +163,13 @@ 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
@@ -410,6 +427,83 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
       ("", 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' agentCfg initAgentServers testDB
+    (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
+
+    -- receive file 1 successfully
+    rcp <- getSMPAgentClient' 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' agentCfg initAgentServers testDB
+    (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
+
+    -- receive file 1 successfully
+    rcp <- getSMPAgentClient' 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

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)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration)
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Transport.Server
 import Test.Hspec
@@ -105,6 +105,7 @@ 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,12 +8,10 @@ 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
@@ -30,9 +28,11 @@ 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,6 +50,7 @@ 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
@@ -68,7 +69,8 @@ testChunkPath = "tests/tmp/chunk1"
 
 createTestChunk :: FilePath -> IO ByteString
 createTestChunk fp = do
-  bytes <- getRandomBytes chSize
+  g <- C.newRandom
+  bytes <- atomically $ C.randomBytes chSize g
   B.writeFile fp bytes
   pure bytes
 
@@ -83,8 +85,9 @@ testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDeliver
 
 runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
 runTestFileChunkDelivery s r = do
-  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  g <- liftIO C.newRandom
+  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -95,17 +98,18 @@ runTestFileChunkDelivery s r = do
   uploadXFTPChunk s spKey sId' chunkSpec
     `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
   liftIO $ readChunk sId `shouldReturn` bytes
-  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
+  downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
     `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
-  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk g 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
-  (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
+  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
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -114,7 +118,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 r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest
+        downloadXFTPChunk g 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"
@@ -128,8 +132,9 @@ testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s
 
 runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
 runTestFileChunkDelete s r = do
-  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  g <- liftIO C.newRandom
+  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -137,13 +142,13 @@ runTestFileChunkDelete s r = do
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
 
-  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk g 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 r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+  downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   deleteXFTPChunk s spKey sId
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
@@ -156,8 +161,9 @@ testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
 
 runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
 runTestFileChunkAck s r = do
-  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  g <- liftIO C.newRandom
+  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -165,30 +171,33 @@ runTestFileChunkAck s r = do
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
 
-  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk g 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 r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+  downloadXFTPChunk g 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 -> 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
+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
   let file = FileInfo {sndKey, size = kb 96, digest}
-  void (createXFTPChunk c spKey file [rcvKey] Nothing)
-    `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
+  runRight_ $
+    void (createXFTPChunk c spKey file [rcvKey] Nothing)
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
 
 testFileChunkExpiration :: Expectation
 testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $
   \_ -> testXFTPClient $ \c -> runRight_ $ do
-    (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-    (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    g <- liftIO C.newRandom
+    (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     bytes <- liftIO $ createTestChunk testChunkPath
     digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
     let file = FileInfo {sndKey, size = chSize, digest}
@@ -196,28 +205,44 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
     (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId chunkSpec
 
-    downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+    downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
     liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
 
     liftIO $ threadDelay 1000000
-    downloadXFTPChunk c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+    downloadXFTPChunk g 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
-    (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-    (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    g <- liftIO C.newRandom
+    (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
     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 c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+          downloadXFTPChunk g 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
@@ -236,10 +261,11 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
 
 testFileLog :: Expectation
 testFileLog = do
+  g <- C.newRandom
   bytes <- liftIO $ createTestChunk testChunkPath
-  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+  (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   sIdVar <- newTVarIO ""
   rIdVar1 <- newTVarIO ""
@@ -257,8 +283,8 @@ testFileLog = do
         writeTVar rIdVar1 rId1
         writeTVar rIdVar2 rId2
     uploadXFTPChunk c spKey sId chunkSpec
-    download c rpKey1 rId1 digest bytes
-    download c rpKey2 rId2 digest bytes
+    download g c rpKey1 rId1 digest bytes
+    download g c rpKey2 rId2 digest bytes
   logSize testXFTPLogFile `shouldReturn` 3
   logSize testXFTPStatsBackupFile `shouldReturn` 11
 
@@ -269,9 +295,9 @@ testFileLog = do
     rId1 <- liftIO $ readTVarIO rIdVar1
     rId2 <- liftIO $ readTVarIO rIdVar2
     -- recipients and sender get AUTH error because server restarted without log
-    downloadXFTPChunk c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
+    downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
-    downloadXFTPChunk c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
+    downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
     deleteXFTPChunk c spKey sId
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
@@ -282,10 +308,10 @@ testFileLog = do
     rId1 <- liftIO $ readTVarIO rIdVar1
     rId2 <- liftIO $ readTVarIO rIdVar2
     -- recipient 1 can download, acknowledges - +1 to log
-    download c rpKey1 rId1 digest bytes
+    download g c rpKey1 rId1 digest bytes
     ackXFTPChunk c rpKey1 rId1
     -- recipient 2 can download
-    download c rpKey2 rId2 digest bytes
+    download g c rpKey2 rId2 digest bytes
   logSize testXFTPLogFile `shouldReturn` 4
   logSize testXFTPStatsBackupFile `shouldReturn` 11
 
@@ -301,10 +327,10 @@ testFileLog = do
     rId1 <- liftIO $ readTVarIO rIdVar1
     rId2 <- liftIO $ readTVarIO rIdVar2
     -- recipient 1 can't download due to previous acknowledgement
-    download c rpKey1 rId1 digest bytes
+    download g c rpKey1 rId1 digest bytes
       `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
     -- recipient 2 can download
-    download c rpKey2 rId2 digest bytes
+    download g c rpKey2 rId2 digest bytes
     -- sender can delete - +1 to log
     deleteXFTPChunk c spKey sId
   logSize testXFTPLogFile `shouldReturn` 4
@@ -321,26 +347,28 @@ testFileLog = do
   removeFile testXFTPLogFile
   removeFile testXFTPStatsBackupFile
   where
-    download c rpKey rId digest bytes = do
-      downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+    download g c rpKey rId digest bytes = do
+      downloadXFTPChunk g 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 -> 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
+    \_ -> 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
       let file = FileInfo {sndKey, size = chSize, digest}
           chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
-      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))
+      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))