From 4a3c5abf32df782d2d3c4a745a3381328fdd5d16 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 26 May 2023 20:33:48 +0400
Subject: [PATCH 01/49] add with withTransaction version with logging (#757)

---
 src/Simplex/Messaging/Agent/Store/SQLite.hs | 22 +++++++++++++++++----
 1 file changed, 18 insertions(+), 4 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 8e74fbd17..5e9df8562 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -184,6 +184,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- * utilities
     withConnection,
     withTransaction,
+    withTransactionCtx,
     firstRow,
     firstRow',
     maybeFirstRow,
@@ -214,7 +215,7 @@ import Data.Ord (Down (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
 import Data.Word (Word32)
 import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..))
 import qualified Database.SQLite.Simple as DB
@@ -243,7 +244,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, s
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
@@ -430,16 +431,29 @@ withConnection SQLiteStore {dbConnection} =
     (atomically . putTMVar dbConnection)
 
 withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withTransaction st action = withConnection st $ loop 500 3_000_000
+withTransaction = withTransactionCtx Nothing
+
+withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withTransactionCtx ctx_ st action = withConnection st $ loop 500 3_000_000
   where
     loop :: Int -> Int -> DB.Connection -> IO a
     loop t tLim db =
-      DB.withImmediateTransaction db (action db) `E.catch` \(e :: SQLError) ->
+      transactionWithCtx `E.catch` \(e :: SQLError) ->
         if tLim > t && DB.sqlError e == DB.ErrorBusy
           then do
             threadDelay t
             loop (t * 9 `div` 8) (tLim - t) db
           else E.throwIO e
+      where
+        transactionWithCtx = case ctx_ of
+          Nothing -> DB.withImmediateTransaction db (action db)
+          Just ctx -> do
+            t1 <- getCurrentTime
+            r <- DB.withImmediateTransaction db (action db)
+            t2 <- getCurrentTime
+            putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
+            putStrLn $ "withTransactionCtx end   :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
+            pure r
 
 createUserRecord :: DB.Connection -> IO UserId
 createUserRecord db = do

From a5a3a2cbad3aed0cab89c0e0c33fb447a6b76246 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 27 May 2023 15:18:53 +0100
Subject: [PATCH 02/49] server: increase server main queue size

---
 src/Simplex/Messaging/Server/Main.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index e39b8ab0c..80f9bc18a 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -165,7 +165,7 @@ smpServerCLI cfgPath logPath =
           ServerConfig
             { transports = iniTransports ini,
               tbqSize = 32,
-              serverTbqSize = 128,
+              serverTbqSize = 1024,
               msgQueueQuota = 128,
               queueIdBytes = 24,
               msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20

From 03eca19d384d381bfc8b86fa10e623025c50f2b6 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 27 May 2023 16:52:49 +0200
Subject: [PATCH 03/49] server: expire messages when restoring them (#758)

* server: expire messages when restoring them

* add test

* specify constructor

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* improve test

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/Messaging/Server.hs | 18 +++++-----
 tests/ServerTests.hs            | 60 ++++++++++++++++++++++++++++++++-
 2 files changed, 69 insertions(+), 9 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 0854506b6..c02d6927d 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -741,7 +741,8 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
       st <- asks queueStore
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
-      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
+      old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch)
+      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota old_) . B.lines) >>= \case
         Left e -> do
           logError . T.pack $ "error restoring messages: " <> e
           liftIO exitFailure
@@ -749,7 +750,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
           renameFile f $ f <> ".bak"
           logInfo "messages restored"
       where
-        restoreMsg st ms quota s = do
+        restoreMsg st ms quota old_ s = do
           r <- liftEither . first (msgErr "parsing") $ strDecode s
           case r of
             MLRv3 rId msg -> addToMsgQueue rId msg
@@ -759,13 +760,14 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
               addToMsgQueue rId msg'
           where
             addToMsgQueue rId msg = do
-              full <- atomically $ do
+              logFull <- atomically $ do
                 q <- getMsgQueue ms rId quota
-                isNothing <$> writeMsg q msg
-              case msg of
-                Message {} ->
-                  when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
-                MessageQuota {} -> pure ()
+                case msg of
+                  Message {msgTs}
+                    | maybe True (systemSeconds msgTs >=) old_ -> isNothing <$> writeMsg q msg
+                    | otherwise -> pure False
+                  MessageQuota {} -> writeMsg q msg $> False
+              when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
             updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
               let nonce = C.cbNonce msgId
               msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs
index 934832202..581e18166 100644
--- a/tests/ServerTests.hs
+++ b/tests/ServerTests.hs
@@ -55,7 +55,9 @@ serverTests t@(ATransport t') = do
     describe "Exceeding queue quota" $ testExceedQueueQuota t'
   describe "Store log" $ testWithStoreLog t
   describe "Restore messages" $ testRestoreMessages t
-  describe "Restore messages (old / v2)" $ testRestoreMessagesV2 t
+  describe "Restore messages (old / v2)" $ do
+    testRestoreMessagesV2 t
+    testRestoreExpireMessages t
   describe "Timing of AUTH error" $ testTiming t
   describe "Message notifications" $ testMessageNotifications t
   describe "Message expiration" $ do
@@ -779,6 +781,62 @@ testRestoreMessagesV2 at@(ATransport t) =
     runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
+testRestoreExpireMessages :: ATransport -> Spec
+testRestoreExpireMessages at@(ATransport t) =
+  it "should store messages on exit and restore on start" $ do
+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+    recipientId <- newTVarIO ""
+    recipientKey <- newTVarIO Nothing
+    dhShared <- newTVarIO Nothing
+    senderId <- newTVarIO ""
+
+    withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do
+      runClient t $ \h1 -> do
+        (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
+        atomically $ do
+          writeTVar recipientId rId
+          writeTVar recipientKey $ Just rKey
+          writeTVar dhShared $ Just dh
+          writeTVar senderId sId
+      sId <- readTVarIO senderId
+      Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello 1")
+      Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2")
+      threadDelay 3000000
+      Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3")
+      Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4")
+      pure ()
+
+    logSize testStoreLogFile `shouldReturn` 2
+    msgs <- B.readFile testStoreMsgsFile
+    length (B.lines msgs) `shouldBe` 4
+
+    let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200}
+        cfg1 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1}
+    withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure ()
+
+    logSize testStoreLogFile `shouldReturn` 1
+    msgs' <- B.readFile testStoreMsgsFile
+    msgs' `shouldBe` msgs
+
+    let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200}
+        cfg2 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2}
+    withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure ()
+
+    logSize testStoreLogFile `shouldReturn` 1
+    -- two messages expired
+    msgs'' <- B.readFile testStoreMsgsFile
+    length (B.lines msgs'') `shouldBe` 2
+    B.lines msgs'' `shouldBe` drop 2 (B.lines msgs)
+
+  where
+    runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
+    runTest _ test' server = do
+      testSMPClient test' `shouldReturn` ()
+      killThread server
+
+    runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
+    runClient _ test' = testSMPClient test' `shouldReturn` ()
+
 createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
 createAndSecureQueue h sPub = do
   (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448

From c08cfb460bc120e6e9323b7269cc280b5c974682 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 27 May 2023 15:54:40 +0100
Subject: [PATCH 04/49] 5.1.1

---
 package.yaml    | 2 +-
 simplexmq.cabal | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/package.yaml b/package.yaml
index caf0d0cf3..c610d89f7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.1.0
+version: 5.1.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 6993d48c9..eb205f1a9 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.1.0
+version:        5.1.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and

From 89caf5572980b776bd750caa3c918ae4488612d8 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 27 May 2023 19:28:14 +0200
Subject: [PATCH 05/49] agent: ack message in case of decryption error (#759)

---
 src/Simplex/Messaging/Agent.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 326a6af0a..f6181bb92 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -1656,6 +1656,8 @@ cleanupManager c@AgentClient {subQ} = do
     notify :: forall e. AEntityI e => EntityId -> ACommand 'Agent e -> ExceptT AgentErrorType m ()
     notify entId cmd = atomically $ writeTBQueue subQ ("", entId, APC (sAEntity @e) cmd)
 
+-- | make sure to ACK or throw in each message processing branch
+-- it cannot be finally, unfortunately, as sometimes it needs to be ACK+DEL
 processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
 processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do
   (rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId)
@@ -1733,8 +1735,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                                     logServer "<--" c srv rId "MSG <MSG>"
                                     notify $ MSG msgMeta msgFlags body
                                   _ -> pure ()
-                            _ -> checkDuplicateHash e encryptedMsgHash
-                        Left e -> checkDuplicateHash e encryptedMsgHash
+                            _ -> checkDuplicateHash e encryptedMsgHash >> ack
+                        Left e -> checkDuplicateHash e encryptedMsgHash >> ack
                       where
                         checkDuplicateHash :: AgentErrorType -> ByteString -> m ()
                         checkDuplicateHash e encryptedMsgHash =

From 20f7b538e52ce47eefbe0dbb8e44fb5298df7820 Mon Sep 17 00:00:00 2001
From: tcely <tcely@users.noreply.github.com>
Date: Mon, 29 May 2023 07:12:23 -0400
Subject: [PATCH 06/49] Docker entrypoint fixes (#753)

* docker entrypoint: DRY store log backup

Don't Repeat Yourself

Set a variable for the full path to the source file.

Create the backup path by appending an extension from `date` output.

Also fixed quoting and switched to an `if` block.

Clean up block level variables.

* docker entrypoint: use ISO 8601 format

The previous format discards information about the local time zone.

* docker entrypoint: always use UTC

Now the format always ends in +00:00, and we can ignore that part again.

* docker entrypoint: provide the date format again

* docker entrypoint: remove time zone from the date format

* docker entrypoint: use an unambiguous date format

Present a leading zero before the month:
YYYY-0MM-DD

Both YYYY-MM-DD and YYYY-DD-MM are used by people and can be confusing in the beginning of the month.

* docker entrypoint: use appropriate quoting

Without avoiding field splitting a password containing a space changes the number of arguments being set.

* docker entrypoint: use explicit braces for custom variables

Make the intentions clear and don't assume the user knows the special cases for when variables won't be extended.

Example:
word=animal
words=mistake
echo "$words vs $word vs ${word}s"

* docker entrypoint-xftp-server: braces and quoting

* docker entrypoint-xftp-server: backup block

* docker entrypoints: explain date format in a comment

* switched from long to short option to date for POSIX

* docker entrypoint-smp-server: explain date format

* docker entrypoint-xftp-server: explain date format

* docker entrypoints: further explain format

I fixed the case to match the date format letters.

Also, use words to explain since I don't want everyone to need to read about date formats to understand.

* docker entrypoints: only quote letters

I was either going to quote the dashes too or stop quoting the colons.

Having less quotes was more readable.

* Revert "docker entrypoint: use an unambiguous date format"

This reverts commit ba2a93bad98d5dbd9a27b737bcfab36bae7bd0f7.

* docker entrypoints: remove %F

* docker entrypoint-smp-server: remove %F

Used part of the explicit ISO 8601 format,
provided by the coreutils date invocation guide.

* docker entrypoint-xftp-server: remove %F

Used part of the explicit ISO 8601 format,
provided by the coreutils date invocation guide.
---
 scripts/docker/entrypoint-smp-server  | 37 ++++++++++++++++---------
 scripts/docker/entrypoint-xftp-server | 39 ++++++++++++++++++---------
 2 files changed, 51 insertions(+), 25 deletions(-)

diff --git a/scripts/docker/entrypoint-smp-server b/scripts/docker/entrypoint-smp-server
index 8958874f8..5817b7b56 100755
--- a/scripts/docker/entrypoint-smp-server
+++ b/scripts/docker/entrypoint-smp-server
@@ -1,25 +1,25 @@
 #!/usr/bin/env sh
-confd="/etc/opt/simplex"
-logd="/var/opt/simplex/"
+confd='/etc/opt/simplex'
+logd='/var/opt/simplex/'
 
 # Check if server has been initialized
-if [ ! -f "$confd/smp-server.ini" ]; then
+if [ ! -f "${confd}/smp-server.ini" ]; then
   # If not, determine ip or domain
-  case "$ADDR" in
-    '') printf "Please specify \$ADDR environment variable.\n"; exit 1 ;;
+  case "${ADDR}" in
+    '') printf 'Please specify $ADDR environment variable.\n'; exit 1 ;;
     *[a-zA-Z]*)
-      case "$ADDR" in
-        *:*) set -- --ip "$ADDR" ;;
-        *) set -- -n "$ADDR" ;;
+      case "${ADDR}" in
+        *:*) set -- --ip "${ADDR}" ;;
+        *) set -- -n "${ADDR}" ;;
       esac
       ;;
-    *) set -- --ip "$ADDR" ;;
+    *) set -- --ip "${ADDR}" ;;
   esac
 
   # Optionally, set password
-  case "$PASS" in
+  case "${PASS}" in
     '') set -- "$@" --no-password ;;
-    *) set -- "$@" --password "$PASS" ;;
+    *) set -- "$@" --password "${PASS}" ;;
   esac
 
   # And init certificates and configs
@@ -27,7 +27,20 @@ if [ ! -f "$confd/smp-server.ini" ]; then
 fi
 
 # Backup store log just in case
-[ -f "$logd/smp-server-store.log" ] && cp "$logd"/smp-server-store.log "$logd"/smp-server-store.log."$(date +'%FT%T')"
+#
+# Uses the UTC (universal) time zone and this
+# format: YYYY-mm-dd'T'HH:MM:SS
+# year, month, day, letter T, hour, minute, second
+#
+# This is the ISO 8601 format without the time zone at the end.
+#
+_file="${logd}/smp-server-store.log"
+if [ -f "${_file}" ]; then
+  _backup_extension="$(date -u '+%Y-%m-%dT%H:%M:%S')"
+  cp -v -p "${_file}" "${_file}.${_backup_extension:-date-failed}"
+  unset -v _backup_extension
+fi
+unset -v _file
 
 # Finally, run smp-sever. Notice that "exec" here is important:
 # smp-server replaces our helper script, so that it can catch INT signal
diff --git a/scripts/docker/entrypoint-xftp-server b/scripts/docker/entrypoint-xftp-server
index c23262670..55757401e 100755
--- a/scripts/docker/entrypoint-xftp-server
+++ b/scripts/docker/entrypoint-xftp-server
@@ -1,25 +1,25 @@
 #!/usr/bin/env sh
-confd="/etc/opt/simplex-xftp"
-logd="/var/opt/simplex-xftp"
+confd='/etc/opt/simplex-xftp'
+logd='/var/opt/simplex-xftp'
 
 # Check if server has been initialized
-if [ ! -f "$confd/file-server.ini" ]; then
+if [ ! -f "${confd}/file-server.ini" ]; then
   # If not, determine ip or domain
-  case "$ADDR" in
-    '') printf "Please specify \$ADDR environment variable.\n"; exit 1 ;;
+  case "${ADDR}" in
+    '') printf 'Please specify $ADDR environment variable.\n'; exit 1 ;;
     *[a-zA-Z]*)
-      case "$ADDR" in
-        *:*) set -- --ip "$ADDR" ;;
-        *) set -- -n "$ADDR" ;;
+      case "${ADDR}" in
+        *:*) set -- --ip "${ADDR}" ;;
+        *) set -- -n "${ADDR}" ;;
       esac
       ;;
-    *) set -- --ip "$ADDR" ;;
+    *) set -- --ip "${ADDR}" ;;
   esac
 
   # Set quota
-  case "$QUOTA" in
-    '') printf "Please specify \$QUOTA environment variable.\n"; exit 1 ;;
-    *) set -- "$@" --quota "$QUOTA" ;;
+  case "${QUOTA}" in
+    '') printf 'Please specify $QUOTA environment variable.\n'; exit 1 ;;
+    *) set -- "$@" --quota "${QUOTA}" ;;
   esac
 
   # Init the certificates and configs
@@ -27,7 +27,20 @@ if [ ! -f "$confd/file-server.ini" ]; then
 fi
 
 # Backup store log just in case
-[ -f "$logd/file-server-store.log" ] && cp "$logd"/file-server-store.log "$logd"/file-server-store.log."$(date +'%FT%T')"
+#
+# Uses the UTC (universal) time zone and this
+# format: YYYY-mm-dd'T'HH:MM:SS
+# year, month, day, letter T, hour, minute, second
+#
+# This is the ISO 8601 format without the time zone at the end.
+#
+_file="${logd}/file-server-store.log"
+if [ -f "${_file}" ]; then
+  _backup_extension="$(date -u '+%Y-%m-%dT%H:%M:%S')"
+  cp -v -p "${_file}" "${_file}.${_backup_extension:-date-failed}"
+  unset -v _backup_extension
+fi
+unset -v _file
 
 # Finally, run xftp-sever. Notice that "exec" here is important:
 # smp-server replaces our helper script, so that it can catch INT signal

From b747080db3f4ec507849d463ec4f52f0bc8ecabd Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 2 Jun 2023 18:00:24 +0400
Subject: [PATCH 07/49] add more message delivery tests (#763)

---
 .gitignore                             |   4 +
 tests/AgentTests/FunctionalAPITests.hs | 123 +++++++++++++++++++++++--
 2 files changed, 118 insertions(+), 9 deletions(-)

diff --git a/.gitignore b/.gitignore
index 3e7898442..fe58f6e91 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,3 +7,7 @@ dist-newstyle/
 
 cabal.project.local
 cabal.project.local~
+
+.hpc/
+*.tix
+.coverage
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index ea3bc918a..79bb4b6bb 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -61,6 +61,7 @@ import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (ATransport (..))
 import Simplex.Messaging.Util (tryError)
 import Simplex.Messaging.Version
+import System.Directory (copyFile, renameFile)
 import Test.Hspec
 import UnliftIO
 import XFTPClient (testXFTPServer)
@@ -147,9 +148,13 @@ functionalAPITests t = do
       testAsyncServerOffline t
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
-  describe "Duplicate message delivery" $
+  describe "Message delivery" $ do
     it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
       testDuplicateMessage t
+    it "should report error via msg integrity on skipped messages" $
+      testSkippedMessages t
+    it "should report decryption error on ratchet becoming out of sync" $
+      testDecryptionError t
   describe "Inactive client disconnection" $ do
     it "should disconnect clients if it was inactive longer than TTL" $
       testInactiveClientDisconnected t
@@ -163,8 +168,10 @@ functionalAPITests t = do
     it "should suspend agent on timeout, even if pending messages not sent" $
       testSuspendingAgentTimeout t
   describe "Batching SMP commands" $ do
-    it "should subscribe to multiple subscriptions with batching" $
-      testBatchedSubscriptions t
+    it "should subscribe to multiple (200) subscriptions with batching" $
+      testBatchedSubscriptions 200 10 t
+    it "should subscribe to multiple (6) subscriptions with batching" $
+      testBatchedSubscriptions 6 3 t
   describe "Async agent commands" $ do
     it "should connect using async agent commands" $
       withSmpServer t testAsyncCommands
@@ -491,6 +498,101 @@ testDuplicateMessage t = do
       get alice2 ##> ("", bobId, SENT 6)
       get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
 
+testSkippedMessages :: HasCallStack => ATransport -> IO ()
+testSkippedMessages t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do
+    (aliceId, bobId) <- runRight $ makeConnection alice bob
+    runRight_ $ do
+      4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+      get alice ##> ("", bobId, SENT 4)
+      get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+      ackMessage bob aliceId 4
+
+    disconnectAgentClient bob
+
+    runRight_ $ do
+      5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
+      get alice ##> ("", bobId, SENT 5)
+      6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
+      get alice ##> ("", bobId, SENT 6)
+      7 <- sendMessage alice bobId SMP.noMsgFlags "hello 4"
+      get alice ##> ("", bobId, SENT 7)
+
+    pure (aliceId, bobId)
+
+  nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+  threadDelay 200000
+
+  disconnectAgentClient alice
+
+  alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
+
+  withSmpServerStoreLogOn t testPort $ \_ -> do
+    runRight_ $ do
+      subscribeConnection bob2 aliceId
+      subscribeConnection alice2 bobId
+
+      8 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5"
+      get alice2 ##> ("", bobId, SENT 8)
+      get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 4, toMsgId = 6}}} _ "hello 5") -> c == aliceId; _ -> False
+      ackMessage bob2 aliceId 5
+
+      9 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6"
+      get alice2 ##> ("", bobId, SENT 9)
+      get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False
+      ackMessage bob2 aliceId 6
+
+testDecryptionError :: HasCallStack => ATransport -> IO ()
+testDecryptionError t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    (aliceId, bobId) <- runRight $ makeConnection alice bob
+    runRight_ $ do
+      4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+      get alice ##> ("", bobId, SENT 4)
+      get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+      ackMessage bob aliceId 4
+
+      5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2"
+      get bob ##> ("", aliceId, SENT 5)
+      get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False
+      ackMessage alice bobId 5
+
+      liftIO $ copyFile testDB2 (testDB2 <> ".bak")
+
+      6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
+      get alice ##> ("", bobId, SENT 6)
+      get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
+      ackMessage bob aliceId 6
+
+      7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4"
+      get bob ##> ("", aliceId, SENT 7)
+      get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False
+      ackMessage alice bobId 7
+
+    disconnectAgentClient bob
+
+    -- importing database backup after progressing ratchet de-synchronizes ratchet,
+    -- this will be fixed by ratchet re-negotiation
+    liftIO $ renameFile (testDB2 <> ".bak") testDB2
+
+    bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
+
+    runRight_ $ do
+      subscribeConnection bob2 aliceId
+
+      8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5"
+      get alice ##> ("", bobId, SENT 8)
+      get bob2 =##> \case ("", c, ERR AGENT {agentErr = A_CRYPTO {cryptoErr = RATCHET_HEADER}}) -> c == aliceId; _ -> False
+
+      6 <- sendMessage bob2 aliceId SMP.noMsgFlags "hello 6"
+      get bob2 ##> ("", aliceId, SENT 6)
+      get alice =##> \case ("", c, ERR AGENT {agentErr = A_CRYPTO {cryptoErr = RATCHET_HEADER}}) -> c == bobId; _ -> False
+
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection alice bob = makeConnectionForUsers alice 1 bob 1
 
@@ -612,14 +714,14 @@ testSuspendingAgentTimeout t = do
     ("", "", SUSPENDED) <- nGet b
     pure ()
 
-testBatchedSubscriptions :: ATransport -> IO ()
-testBatchedSubscriptions t = do
+testBatchedSubscriptions :: Int -> Int -> ATransport -> IO ()
+testBatchedSubscriptions nCreate nDel t = do
   a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
   b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
   conns <- runServers $ do
-    conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
+    conns <- forM [1 .. nCreate :: Int] . const $ makeConnection a b
     forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
-    let (aIds', bIds') = unzip $ take 10 conns
+    let (aIds', bIds') = unzip $ take nDel conns
     delete a bIds'
     delete b aIds'
     liftIO $ threadDelay 1000000
@@ -635,11 +737,14 @@ testBatchedSubscriptions t = do
     ("", "", UP {}) <- nGet b
     liftIO $ threadDelay 1000000
     let (aIds, bIds) = unzip conns
-        conns' = drop 10 conns
+        conns' = drop nDel conns
         (aIds', bIds') = unzip conns'
     subscribe a bIds
     subscribe b aIds
     forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
+    void $ resubscribeConnections a bIds
+    void $ resubscribeConnections b aIds
+    forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId 8 a bId b aId
     delete a bIds'
     delete b aIds'
     deleteFail a bIds'
@@ -649,7 +754,7 @@ testBatchedSubscriptions t = do
     subscribe c cs = do
       r <- subscribeConnections c cs
       liftIO $ do
-        let dc = S.fromList $ take 10 cs
+        let dc = S.fromList $ take nDel cs
         all isRight (M.withoutKeys r dc) `shouldBe` True
         all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
         M.keys r `shouldMatchList` cs

From 182229648117d7ca6e9e23ed57836c02797d8aad Mon Sep 17 00:00:00 2001
From: sh <37271604+shumvgolove@users.noreply.github.com>
Date: Mon, 5 Jun 2023 09:27:02 +0300
Subject: [PATCH 08/49] install.sh: fixes (#765)

* install.sh: fixes

* change back to stable
---
 README.md                        | 2 +-
 install.sh                       | 4 ++--
 scripts/main/smp-server.service  | 2 +-
 scripts/main/xftp-server.service | 2 +-
 4 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/README.md b/README.md
index eb850aaf1..a13d176b6 100644
--- a/README.md
+++ b/README.md
@@ -150,7 +150,7 @@ You can install and setup servers automatically using our script:
 
 ```sh
 curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
-&& if echo '1268d605e90bca1a8c7ef476038a8bd9aa9b1a28f79ea0a1485669ccf8fc23cd simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm /simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
+&& if echo '797eeb941ccbf2d4125b174bf44088ffd0e2ef0c64c66d7ad055ebd3753d1ced simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
 ```
 
 ### Build from source
diff --git a/install.sh b/install.sh
index 3bcac3f49..42ef8027b 100755
--- a/install.sh
+++ b/install.sh
@@ -87,9 +87,9 @@ setup_users() {
 setup_dirs() {
  # Unquoted varibles, so field splitting can occur
  mkdir -p $path_conf_smp
- chown "$user_smp":"$user_smp" "$path_conf_smp"
+ chown "$user_smp":"$user_smp" $path_conf_smp
  mkdir -p $path_conf_xftp
- chown "$user_xftp":"$user_xftp" "$path_conf_xftp"
+ chown "$user_xftp":"$user_xftp" $path_conf_xftp
 }
 
 setup_systemd() {
diff --git a/scripts/main/smp-server.service b/scripts/main/smp-server.service
index db3da7d9c..e9fb25ca7 100644
--- a/scripts/main/smp-server.service
+++ b/scripts/main/smp-server.service
@@ -6,7 +6,7 @@ User=smp
 Group=smp
 Type=simple
 ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS 
-ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%FT%T)'
+ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%%FT%T)'
 LimitNOFILE=65535
 KillSignal=SIGINT
 TimeoutStopSec=infinity
diff --git a/scripts/main/xftp-server.service b/scripts/main/xftp-server.service
index 80bb2bb08..74cd6dcbf 100644
--- a/scripts/main/xftp-server.service
+++ b/scripts/main/xftp-server.service
@@ -6,7 +6,7 @@ User=xftp
 Group=xftp
 Type=simple
 ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
-ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%FT%T)'
+ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%%FT%T)'
 LimitNOFILE=65535
 KillSignal=SIGINT
 TimeoutStopSec=infinity

From 1c2fbdb2c5989f1e3e04032fb3a354f8e2e41160 Mon Sep 17 00:00:00 2001
From: sh <37271604+shumvgolove@users.noreply.github.com>
Date: Mon, 5 Jun 2023 10:12:09 +0300
Subject: [PATCH 09/49] install: some more fixes (#770)

---
 scripts/main/simplex-servers-update | 8 ++++----
 scripts/main/smp-server.service     | 2 +-
 scripts/main/xftp-server.service    | 2 +-
 3 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/scripts/main/simplex-servers-update b/scripts/main/simplex-servers-update
index 450665e09..abedb03d4 100755
--- a/scripts/main/simplex-servers-update
+++ b/scripts/main/simplex-servers-update
@@ -95,7 +95,7 @@ update_bins() {
       systemctl stop smp-server
       printf "${GRN}Done!${NC}\n"
 
-      print -- "- Updating smp-server bin to %s..." "$remote_version"
+      printf -- "- Updating smp-server bin to %s..." "$remote_version"
       curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
       printf "${GRN}Done!${NC}\n"
       
@@ -103,7 +103,7 @@ update_bins() {
       systemctl stop smp-server
       printf "${GRN}Done!${NC}\n"
     else
-      print -- "- Updating smp-server bin..."
+      printf -- "- Updating smp-server bin..."
       curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
       printf "${GRN}Done!${NC}\n"
     fi
@@ -113,7 +113,7 @@ update_bins() {
       systemctl stop xftp-server
       printf "${GRN}Done!${NC}\n"
 
-      print -- "- Updating xftp-server bin to %s..." "$remote_version"
+      printf -- "- Updating xftp-server bin to %s..." "$remote_version"
       curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
       printf "${GRN}Done!${NC}\n"
       
@@ -121,7 +121,7 @@ update_bins() {
       systemctl stop xftp-server
       printf "${GRN}Done!${NC}\n"
     else
-      print -- "- Updating xftp-server bin..."
+      printf -- "- Updating xftp-server bin..."
       curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
       printf "${GRN}Done!${NC}\n"
     fi
diff --git a/scripts/main/smp-server.service b/scripts/main/smp-server.service
index e9fb25ca7..c3bd3d17a 100644
--- a/scripts/main/smp-server.service
+++ b/scripts/main/smp-server.service
@@ -6,7 +6,7 @@ User=smp
 Group=smp
 Type=simple
 ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS 
-ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%%FT%T)'
+ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%%Y-%%m-%%dT%%H:%%M:%%S)'
 LimitNOFILE=65535
 KillSignal=SIGINT
 TimeoutStopSec=infinity
diff --git a/scripts/main/xftp-server.service b/scripts/main/xftp-server.service
index 74cd6dcbf..5e9455b5f 100644
--- a/scripts/main/xftp-server.service
+++ b/scripts/main/xftp-server.service
@@ -6,7 +6,7 @@ User=xftp
 Group=xftp
 Type=simple
 ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
-ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%%FT%T)'
+ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%%Y-%%m-%%dT%%H:%%M:%%S)'
 LimitNOFILE=65535
 KillSignal=SIGINT
 TimeoutStopSec=infinity

From 76e3863cbb4648d38a0f0abe82f38330f0582d25 Mon Sep 17 00:00:00 2001
From: sh <37271604+shumvgolove@users.noreply.github.com>
Date: Mon, 5 Jun 2023 12:01:16 +0300
Subject: [PATCH 10/49] install: simplify systemd service and add new helper
 stopscript (#771)

* install: simplify systemd service and add new helper stopscript

* README: update hash
---
 README.md                               |  2 +-
 install.sh                              |  9 ++++---
 scripts/main/simplex-servers-stopscript | 30 ++++++++++++++++++++++
 scripts/main/simplex-servers-uninstall  |  7 ++++-
 scripts/main/simplex-servers-update     | 34 +++++++++++++++++--------
 scripts/main/smp-server.service         |  2 +-
 scripts/main/xftp-server.service        |  2 +-
 7 files changed, 69 insertions(+), 17 deletions(-)
 create mode 100755 scripts/main/simplex-servers-stopscript

diff --git a/README.md b/README.md
index a13d176b6..d946b8ec6 100644
--- a/README.md
+++ b/README.md
@@ -150,7 +150,7 @@ You can install and setup servers automatically using our script:
 
 ```sh
 curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
-&& if echo '797eeb941ccbf2d4125b174bf44088ffd0e2ef0c64c66d7ad055ebd3753d1ced simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
+&& if echo 'b8cf2be103f21f9461d9a500bcd3db06ab7d01d68871b07f4bd245195cbead1d simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
 ```
 
 ### Build from source
diff --git a/install.sh b/install.sh
index 42ef8027b..18c2cdf11 100755
--- a/install.sh
+++ b/install.sh
@@ -11,6 +11,7 @@ scripts_systemd_smp="$scripts/smp-server.service"
 scripts_systemd_xftp="$scripts/xftp-server.service"
 scripts_update="$scripts/simplex-servers-update"
 scripts_uninstall="$scripts/simplex-servers-uninstall"
+scripts_stopscript="$scripts/simplex-servers-stopscript"
 
 # Default installation paths
 path_bin="/usr/local/bin"
@@ -18,6 +19,7 @@ path_bin_smp="$path_bin/smp-server"
 path_bin_xftp="$path_bin/xftp-server"
 path_bin_update="$path_bin/simplex-servers-update"
 path_bin_uninstall="$path_bin/simplex-servers-uninstall"
+path_bin_stopscript="$path_bin/simplex-servers-stopscript"
 
 path_conf_etc="/etc/opt"
 path_conf_var="/var/opt"
@@ -60,8 +62,8 @@ ${GRN}3.${NC} Setup user for each server:
 ${GRN}4.${NC} Create systemd services:
     - smp: ${YLW}${path_systemd_smp}${NC}
     - xftp: ${YLW}${path_systemd_xftp}${NC}
-${GRN}5.${NC} Install update and uninstallation script:
-    - all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}
+${GRN}5.${NC} Install stopscript (systemd), update and uninstallation script:
+    - all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}, ${YLW}${path_bin_stopscript}${NC}
 
 Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
 
@@ -100,6 +102,7 @@ setup_systemd() {
 setup_scripts() {
  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_bin_update" && chmod +x "$path_bin_update"
  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_bin_uninstall" && chmod +x "$path_bin_uninstall"
+ curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_bin_stopscript" && chmod +x "$path_bin_stopscript"
  }
 
 checks() {
@@ -131,7 +134,7 @@ main() {
  setup_systemd
  printf "${GRN} Done!${NC}\n"
 
- printf "Installing update and uninstallation script..."
+ printf "Installing stopscript, update and uninstallation script..."
  setup_scripts
  printf "${GRN} Done!${NC}\n"
 
diff --git a/scripts/main/simplex-servers-stopscript b/scripts/main/simplex-servers-stopscript
new file mode 100755
index 000000000..53d9f13bf
--- /dev/null
+++ b/scripts/main/simplex-servers-stopscript
@@ -0,0 +1,30 @@
+#!/usr/bin/env sh
+set -eu
+
+path_conf_var="/var/opt"
+path_conf_smp="$path_conf_var/simplex"
+path_conf_xftp="$path_conf_var/simplex-xftp"
+path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
+path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
+date="$(date -u '+%Y-%m-%dT%H:%M:%S')"
+
+backup_smp() {
+ if [ -e "$path_conf_storelog_smp" ]; then
+  cp "$path_conf_storelog_smp" "${path_conf_storelog_smp}.${date:-date-failed}"
+ fi
+}
+
+backup_xftp() {
+ if [ -e "$path_conf_storelog_xftp" ]; then
+  cp "$path_conf_storelog_xftp" "${path_conf_storelog_xftp}.${date:-date-failed}"
+ fi
+}
+
+if [ "$1" = 'smp-server' ]; then
+ backup_smp
+elif [ "$1" = 'xftp-server' ]; then
+ backup_xftp
+else
+ backup_smp
+ backup_xftp
+fi
diff --git a/scripts/main/simplex-servers-uninstall b/scripts/main/simplex-servers-uninstall
index f08fc0efc..4860dff34 100755
--- a/scripts/main/simplex-servers-uninstall
+++ b/scripts/main/simplex-servers-uninstall
@@ -13,6 +13,11 @@ fi
 printf "${RED}This action will permanently remove all configs, directories, binaries from Installation Script. Please backup any relevant configs if they are needed.${NC}\n\nPress ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
 read ans
 
-rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall && userdel smp && userdel xftp
+systemctl stop smp-server
+systemctl stop xftp-server
+
+rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall
+
+userdel smp && userdel xftp
 
 printf "Uninstallation is complete! Thanks for trying out SimpleX!\n"
diff --git a/scripts/main/simplex-servers-update b/scripts/main/simplex-servers-update
index abedb03d4..c1c7aa738 100755
--- a/scripts/main/simplex-servers-update
+++ b/scripts/main/simplex-servers-update
@@ -11,6 +11,7 @@ scripts_systemd_smp="$scripts/smp-server.service"
 scripts_systemd_xftp="$scripts/xftp-server.service"
 scripts_update="$scripts/simplex-servers-update"
 scripts_uninstall="$scripts/simplex-servers-uninstall"
+scripts_stopscript="$scripts/simplex-servers-stopscript"
 
 # Default installation paths
 path_bin="/usr/local/bin"
@@ -18,6 +19,7 @@ path_bin_smp="$path_bin/smp-server"
 path_bin_xftp="$path_bin/xftp-server"
 path_bin_update="$path_bin/simplex-servers-update"
 path_bin_uninstall="$path_bin/simplex-servers-uninstall"
+path_bin_stopscript="$path_bin/simplex-servers-stopscript"
 
 path_systemd="/etc/systemd/system"
 path_systemd_smp="$path_systemd/smp-server.service"
@@ -27,6 +29,7 @@ path_systemd_xftp="$path_systemd/xftp-server.service"
 path_tmp_bin="$(mktemp -d)"
 path_tmp_bin_update="$path_tmp_bin/simplex-servers-update"
 path_tmp_bin_uninstall="$path_tmp_bin/simplex-servers-uninstall"
+path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
 path_tmp_systemd_smp="$path_tmp_bin/smp-server.service"
 path_tmp_systemd_xftp="$path_tmp_bin/xftp-server.service"
 
@@ -43,8 +46,9 @@ remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com
 update_scripts() {
   curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
   curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_tmp_bin_uninstall" && chmod +x "$path_tmp_bin_uninstall"
+  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_tmp_bin_stopscript" && chmod +x "$path_tmp_bin_stopscript"
 
-  if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null; then
+  if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null 2>&1; then
     printf -- "- ${YLW}Uninstall script is up-to-date${NC}.\n"
     rm "$path_tmp_bin_uninstall"
   else
@@ -52,7 +56,15 @@ update_scripts() {
     mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
     printf "${GRN}Done!${NC}\n"
   fi
-  if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null; then
+  if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
+    printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
+    rm "$path_tmp_bin_stopscript"
+  else
+    printf -- "- Updating stopscript script..."
+    mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
+    printf "${GRN}Done!${NC}\n"
+  fi
+  if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
     printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
     rm "$path_tmp_bin_update"
   else
@@ -68,7 +80,7 @@ update_systemd() {
   curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_tmp_systemd_smp"
   curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_tmp_systemd_xftp"
 
-  if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null; then
+  if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null 2>&1; then
     printf -- "- ${YLW}smp-server service is up-to-date${NC}.\n"
     rm "$path_tmp_systemd_smp"
   else
@@ -77,7 +89,7 @@ update_systemd() {
     systemctl daemon-reload
     printf "${GRN}Done!${NC}\n"
   fi
-  if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null; then
+  if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null 2>&1; then
     printf -- "- ${YLW}xftp-server service is up-to-date${NC}.\n"
     rm "$path_tmp_systemd_xftp"
   else
@@ -96,15 +108,15 @@ update_bins() {
       printf "${GRN}Done!${NC}\n"
 
       printf -- "- Updating smp-server bin to %s..." "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
       printf "${GRN}Done!${NC}\n"
       
       printf -- "- Starting smp-server service..."
-      systemctl stop smp-server
+      systemctl start smp-server
       printf "${GRN}Done!${NC}\n"
     else
       printf -- "- Updating smp-server bin..."
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
       printf "${GRN}Done!${NC}\n"
     fi
 
@@ -114,15 +126,15 @@ update_bins() {
       printf "${GRN}Done!${NC}\n"
 
       printf -- "- Updating xftp-server bin to %s..." "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
       printf "${GRN}Done!${NC}\n"
       
       printf -- "- Starting xftp-server service..."
-      systemctl stop xftp-server
+      systemctl start xftp-server
       printf "${GRN}Done!${NC}\n"
     else
       printf -- "- Updating xftp-server bin..."
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
       printf "${GRN}Done!${NC}\n"
     fi
   else
@@ -155,6 +167,8 @@ main() {
   
   printf "Updating simplex server binaries...\n"
   update_bins
+
+  rm -rf "$path_tmp_bin"
 }
 
 main "$@"
diff --git a/scripts/main/smp-server.service b/scripts/main/smp-server.service
index c3bd3d17a..3a845f1c6 100644
--- a/scripts/main/smp-server.service
+++ b/scripts/main/smp-server.service
@@ -6,7 +6,7 @@ User=smp
 Group=smp
 Type=simple
 ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS 
-ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%%Y-%%m-%%dT%%H:%%M:%%S)'
+ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server
 LimitNOFILE=65535
 KillSignal=SIGINT
 TimeoutStopSec=infinity
diff --git a/scripts/main/xftp-server.service b/scripts/main/xftp-server.service
index 5e9455b5f..51c8b1cd9 100644
--- a/scripts/main/xftp-server.service
+++ b/scripts/main/xftp-server.service
@@ -6,7 +6,7 @@ User=xftp
 Group=xftp
 Type=simple
 ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
-ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%%Y-%%m-%%dT%%H:%%M:%%S)'
+ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server
 LimitNOFILE=65535
 KillSignal=SIGINT
 TimeoutStopSec=infinity

From fbf1afc9f5e3c2d3574c37479979a0108c76b7cd Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Tue, 13 Jun 2023 19:36:47 +0400
Subject: [PATCH 11/49] run a single batch test to avoid hanging on server
 disconnect (#773)

---
 tests/AgentTests/FunctionalAPITests.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index 79bb4b6bb..fbf697b3b 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -170,7 +170,8 @@ functionalAPITests t = do
   describe "Batching SMP commands" $ do
     it "should subscribe to multiple (200) subscriptions with batching" $
       testBatchedSubscriptions 200 10 t
-    it "should subscribe to multiple (6) subscriptions with batching" $
+    -- 200 subscriptions gets very slow with test coverage, use below test instead
+    xit "should subscribe to multiple (6) subscriptions with batching" $
       testBatchedSubscriptions 6 3 t
   describe "Async agent commands" $ do
     it "should connect using async agent commands" $

From 011e1109e9f3a1626cd356c81881f4a1ca99c3c5 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 15 Jun 2023 11:15:46 +0400
Subject: [PATCH 12/49] connection switch - track status, stop switch command
 (#764)

* connection switch improvements

* stop in transaction

* refactor

* checks in transaction

* withSwitchingRQ in transaction

* withSwitchedSQ in transaction

* refactor

* refactor

* inverse some cases

* reset snd switch progress on repeat qadd

* remove unused functions

* connection info type

* correction

* SPFinalizing phase, correctly update connection in event

* refactor

* tests

* refactor switch conn lock taking, take lock in switch stop, remove ineligible test

* comment

* corrections

* corrections

* corrections

* refactor

* remove checks in transactions, remove some statuses

* remove diff

* refactor

* refactor tests

* update connection in memory

* revert diff

* corrections

* more tests

* remove statuses, change switching queue lookup

* async queue deletion

* refactor

* lock, phases

* test status

* refactor

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 simplexmq.cabal                               |   1 +
 src/Simplex/Messaging/Agent.hs                | 242 ++++++++---
 src/Simplex/Messaging/Agent/Client.hs         |   1 +
 src/Simplex/Messaging/Agent/Protocol.hs       | 112 +++++-
 src/Simplex/Messaging/Agent/Store.hs          |  40 +-
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 116 ++++--
 .../Agent/Store/SQLite/Migrations.hs          |   4 +-
 .../Migrations/M20230531_switch_status.hs     |  22 +
 .../Store/SQLite/Migrations/agent_schema.sql  |   3 +
 tests/AgentTests/FunctionalAPITests.hs        | 378 ++++++++++++++++--
 tests/AgentTests/SQLiteTests.hs               |   4 +
 11 files changed, 788 insertions(+), 135 deletions(-)
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230531_switch_status.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index eb205f1a9..3a3ef9c86 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -82,6 +82,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index f6181bb92..dcada9b9b 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -63,6 +63,7 @@ module Simplex.Messaging.Agent
     sendMessage,
     ackMessage,
     switchConnection,
+    stopConnectionSwitch,
     suspendConnection,
     deleteConnection,
     deleteConnections,
@@ -110,7 +111,7 @@ import Data.Composition ((.:), (.:.), (.::))
 import Data.Foldable (foldl')
 import Data.Functor (($>))
 import Data.List (find)
-import Data.List.NonEmpty (NonEmpty (..), (<|))
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -268,6 +269,10 @@ ackMessage c = withAgentEnv c .: ackMessage' c
 switchConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
 switchConnection c = withAgentEnv c . switchConnection' c
 
+-- | Stop switching connection to the new receive queue
+stopConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
+stopConnectionSwitch c = withAgentEnv c . stopConnectionSwitch' c
+
 -- | Suspend SMP agent connection (OFF command)
 suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 suspendConnection c = withAgentEnv c . suspendConnection' c
@@ -526,9 +531,14 @@ deleteConnectionsAsync_ onSuccess c connIds = case connIds of
 -- | Add connection to the new receive queue
 switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ()
 switchConnectionAsync' c corrId connId =
-  withStore c (`getConn` connId) >>= \case
-    SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
-    _ -> throwError $ CMD PROHIBITED
+  withConnLock c connId "switchConnectionAsync" $
+    withStore c (`getConn` connId) >>= \case
+      SomeConn _ (DuplexConnection _ rqs@(rq :| _rqs) _)
+        | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
+        | otherwise -> do
+          void $ withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
+          enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
+      _ -> throwError $ CMD PROHIBITED
 
 newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c)
 newConn c userId connId enableNtfs cMode clientData =
@@ -867,7 +877,12 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
             notify OK
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
         ACK msgId -> withServer' . tryCommand $ ackMessage' c connId msgId >> notify OK
-        SWCH -> noServer $ tryCommand $ switchConnection' c connId >>= notify . SWITCH QDRcv SPStarted
+        SWCH ->
+          noServer . tryCommand . withConnLock c connId "switchConnection" $
+            withStore c (`getConn` connId) >>= \case
+              SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) ->
+                switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted
+              _ -> throwError $ CMD PROHIBITED
         DEL -> withServer' . tryCommand $ deleteConnection' c connId >> notify OK
         _ -> notify $ ERR $ INTERNAL $ "unsupported async command " <> show (aCommandTag cmd)
       AInternalCommand cmd -> case cmd of
@@ -887,13 +902,24 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
             enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO
         -- ICDeleteConn is no longer used, but it can be present in old client databases
         ICDeleteConn -> withStore' c (`deleteCommand` cmdId)
+        ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do
+          rq <- withStore c (\db -> getDeletedRcvQueue db connId srv rId)
+          deleteQueue c rq
+          withStore' c (`deleteConnRcvQueue` rq)
         ICQSecure rId senderKey ->
           withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) ->
             case find (sameQueue (srv, rId)) rqs of
-              Just rq'@RcvQueue {server, sndId, status} -> when (status == Confirmed) $ do
-                secureQueue c rq' senderKey
-                withStore' c $ \db -> setRcvQueueStatus db rq' Secured
-                void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)]
+              Just rq'@RcvQueue {server, sndId, status, dbReplaceQueueId = Just replaceQId} ->
+                case find ((replaceQId ==) . dbQId) rqs of
+                  Just rq1 -> when (status == Confirmed) $ do
+                    secureQueue c rq' senderKey
+                    withStore' c $ \db -> setRcvQueueStatus db rq' Secured
+                    void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)]
+                    rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 $ Just RSSendingQUSE
+                    let rqs' = updatedQs rq1' rqs
+                        conn' = DuplexConnection cData rqs' sqs
+                    notify . SWITCH QDRcv SPSecured $ connectionStats conn'
+                  _ -> internalErr "ICQSecure: no switching queue found"
               _ -> internalErr "ICQSecure: queue address not found in connection"
         ICQDelete rId -> do
           withServer $ \srv -> tryWithLock "ICQDelete" . withDuplexConn $ \(DuplexConnection cData rqs sqs) -> do
@@ -902,13 +928,20 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
               Just (rq'@RcvQueue {primary}, rq'' : rqs')
                 | primary -> internalErr "ICQDelete: cannot delete primary rcv queue"
                 | otherwise -> do
-                  deleteQueue c rq'
-                  withStore' c $ \db -> deleteConnRcvQueue db rq'
-                  when (enableNtfs cData) $ do
-                    ns <- asks ntfSupervisor
-                    atomically $ sendNtfSubCommand ns (connId, NSCCreate)
-                  let conn' = DuplexConnection cData (rq'' :| rqs') sqs
-                  notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
+                  checkRQSwchStatus rq' RSReceivedMessage
+                  tryError (deleteQueue c rq') >>= \case
+                    Right () -> finalizeSwitch
+                    Left e
+                      | temporaryOrHostError e -> throwError e
+                      | otherwise -> finalizeSwitch >> throwError e
+                where
+                  finalizeSwitch = do
+                    withStore' c $ \db -> deleteConnRcvQueue db rq'
+                    when (enableNtfs cData) $ do
+                      ns <- asks ntfSupervisor
+                      atomically $ sendNtfSubCommand ns (connId, NSCCreate)
+                    let conn' = DuplexConnection cData (rq'' :| rqs') sqs
+                    notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
               _ -> internalErr "ICQDelete: cannot delete the only queue in connection"
         where
           ack srv rId srvMsgId = do
@@ -1112,9 +1145,11 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 AM_A_MSG_ -> notify $ SENT mId
                 AM_QCONT_ -> pure ()
                 AM_QADD_ -> pure ()
-                AM_QKEY_ -> pure ()
+                AM_QKEY_ -> do
+                  SomeConn _ conn <- withStore c (`getConn` connId)
+                  notify . SWITCH QDSnd SPConfirmed $ connectionStats conn
                 AM_QUSE_ -> pure ()
-                AM_QTEST_ -> do
+                AM_QTEST_ -> withConnLock c connId "runSmpQueueMsgDelivery AM_QTEST_" $ do
                   withStore' c $ \db -> setSndQueueStatus db sq Active
                   SomeConn _ conn <- withStore c (`getConn` connId)
                   case conn of
@@ -1125,9 +1160,10 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                         -- this is the same queue where this loop delivers messages to but with updated state
                         Just SndQueue {dbReplaceQueueId = Just replacedId, primary} ->
                           -- second part of this condition is a sanity check because dbReplaceQueueId cannot point to the same queue, see switchConnection'
-                          case removeQP (\sq'@SndQueue {dbQueueId} -> dbQueueId == replacedId && not (sameQueue addr sq')) sqs of
+                          case removeQP (\sq' -> dbQId sq' == replacedId && not (sameQueue addr sq')) sqs of
                             Nothing -> internalErr msgId "sent QTEST: queue not found in connection"
                             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
                               withStore' c $ \db -> do
@@ -1178,21 +1214,66 @@ ackMessage' c connId msgId = withConnLock c connId "ackMessage" $ do
       withStore' c $ \db -> deleteMsg db connId mId
 
 switchConnection' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
-switchConnection' c connId = withConnLock c connId "switchConnection" $ do
-  SomeConn _ conn <- withStore c (`getConn` connId)
-  case conn of
-    DuplexConnection cData@ConnData {userId} rqs@(rq@RcvQueue {server, dbQueueId, sndId} :| rqs_) sqs -> do
-      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
-      let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-      void . withStore c $ \db -> addConnRcvQueue db connId rq'
-      addSubscription c rq'
-      void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))]
-      pure . connectionStats $ DuplexConnection cData (rq <| rq' :| rqs_) sqs
-    _ -> throwError $ CMD PROHIBITED
+switchConnection' c connId =
+  withConnLock c connId "switchConnection" $
+    withStore c (`getConn` connId) >>= \case
+      SomeConn _ conn@(DuplexConnection _ rqs@(rq :| _rqs) _)
+        | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
+        | otherwise -> do
+          rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
+          switchDuplexConnection c conn rq'
+      _ -> 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
+  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
+  let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
+  void . withStore c $ \db -> addConnRcvQueue db connId rq'
+  addSubscription c rq'
+  void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))]
+  rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSendingQADD
+  let rqs' = updatedQs rq1 rqs <> [rq']
+  pure . connectionStats $ DuplexConnection cData rqs' sqs
+
+stopConnectionSwitch' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
+stopConnectionSwitch' c connId =
+  withConnLock c connId "stopConnectionSwitch" $
+    withStore c (`getConn` connId) >>= \case
+      SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
+        Just rq
+          | canStopRcvSwitch rq -> do
+            -- multiple queues to which the connections switches were possible when repeating switch was allowed
+            let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
+            case L.nonEmpty keepRqs of
+              Just rqs' -> do
+                rq' <- withStore' c $ \db -> do
+                  mapM_ (setRcvQueueDeleted db) delRqs
+                  setRcvSwitchStatus db rq Nothing
+                forM_ delRqs $ \RcvQueue {server, rcvId} -> enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICDeleteRcvQueue rcvId
+                let rqs'' = updatedQs rq' rqs'
+                    conn' = DuplexConnection cData rqs'' sqs
+                pure $ connectionStats conn'
+              _ -> throwError $ INTERNAL "won't delete all rcv queues in connection"
+          | otherwise -> throwError $ CMD PROHIBITED
+        _ -> throwError $ CMD PROHIBITED
+      _ -> throwError $ CMD PROHIBITED
+
+canStopRcvSwitch :: RcvQueue -> Bool
+canStopRcvSwitch = maybe False canStop . rcvSwchStatus
+  where
+    canStop = \case
+      RSSwitchStarted -> True
+      RSSendingQADD -> True
+      -- if switch is in RSSendingQUSE, a race condition with sender deleting the original queue is possible
+      RSSendingQUSE -> False
+      -- if switch is in RSReceivedMessage status, stopping switch (deleting new queue)
+      -- will break the connection because the sender would have original queue deleted
+      RSReceivedMessage -> False
 
 ackQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> SMP.MsgId -> m ()
 ackQueueMessage c rq srvMsgId =
@@ -1331,11 +1412,11 @@ getConnectionRatchetAdHash' c connId = do
 
 connectionStats :: Connection c -> ConnectionStats
 connectionStats = \case
-  RcvConnection _ rq -> ConnectionStats {rcvServers = [qServer rq], sndServers = []}
-  SndConnection _ sq -> ConnectionStats {rcvServers = [], sndServers = [qServer sq]}
-  DuplexConnection _ rqs sqs -> ConnectionStats {rcvServers = map qServer $ L.toList rqs, sndServers = map qServer $ L.toList sqs}
-  ContactConnection _ rq -> ConnectionStats {rcvServers = [qServer rq], sndServers = []}
-  NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
+  RcvConnection _ rq -> ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = []}
+  SndConnection _ sq -> ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [sndQueueInfo sq]}
+  DuplexConnection _ rqs sqs -> ConnectionStats {rcvQueuesInfo = map rcvQueueInfo $ L.toList rqs, sndQueuesInfo = map sndQueueInfo $ L.toList sqs}
+  ContactConnection _ rq -> ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = []}
+  NewConnection _ -> ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = []}
 
 -- | Change servers to be used for creating new queues, in Reader monad
 setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
@@ -1698,8 +1779,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                       case (conn, dbReplaceQueueId) of
                         (DuplexConnection _ rqs _, Just replacedId) -> do
                           when primary . withStore' c $ \db -> setRcvQueuePrimary db connId rq
-                          case find (\RcvQueue {dbQueueId} -> dbQueueId == replacedId) rqs of
-                            Just RcvQueue {server, rcvId} -> do
+                          case find ((replacedId ==) . dbQId) rqs of
+                            Just rq'@RcvQueue {server, rcvId} -> do
+                              checkRQSwchStatus rq' RSSendingQUSE
+                              void $ withStore' c $ \db -> setRcvSwitchStatus db rq' $ Just RSReceivedMessage
                               enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICQDelete rcvId
                             _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
                         _ -> pure ()
@@ -1901,24 +1984,33 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
         -- 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 _ rqs sqs@(sq :| sqs_)) = do
+        qAddMsg ((qUri, Just addr) :| _) (DuplexConnection _ rqs sqs) = do
           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 _replaced@SndQueue {dbQueueId}) -> do
-                  sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue userId connId qInfo
-                  let sq' = (sq_ :: SndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-                  void . 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)
-                      let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
-                      void . enqueueMessages c cData sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
-                      let conn' = DuplexConnection cData rqs (sq <| sq' :| sqs_)
-                      notify . SWITCH QDSnd SPStarted $ connectionStats conn'
-                    _ -> qError "absent sender keys"
+                (_, Just sq@SndQueue {dbQueueId}) -> do
+                  let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs
+                  case L.nonEmpty keepSqs of
+                    Just sqs' -> do
+                      -- move inside case?
+                      withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs
+                      sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue userId connId qInfo
+                      let sq'' = (sq_ :: SndQueue) {primary = True, dbQueueId, dbReplaceQueueId = Just dbQueueId}
+                      dbId <- withStore c $ \db -> addConnSndQueue db connId sq''
+                      let sq2 = (sq'' :: SndQueue) {dbQueueId = dbId}
+                      case (sndPublicKey, e2ePubKey) of
+                        (Just sndPubKey, Just dhPublicKey) -> do
+                          logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (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
+                          let sqs'' = updatedQs sq1 sqs' <> [sq2]
+                              conn' = DuplexConnection cData rqs sqs''
+                          notify . SWITCH QDSnd SPStarted $ connectionStats conn'
+                        _ -> qError "absent sender keys"
+                    _ -> qError "QADD: won't delete all snd queues in connection"
                 _ -> qError "QADD: replaced queue address is not found in connection"
             _ -> throwError $ AGENT A_VERSION
 
@@ -1930,6 +2022,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           case findRQ (smpServer, senderId) rqs of
             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
                 let dhSecret = C.dh' dhPublicKey dhPrivKey
                 withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
@@ -1944,16 +2037,23 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
         -- mark queue as Secured and to start sending messages to it
         qUseMsg :: 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 _ _ sqs) =
+        qUseMsg ((addr, _primary) :| _) (DuplexConnection _ rqs sqs) =
           case findQ addr sqs of
-            Just sq' -> do
-              logServer "<--" c srv rId $ "MSG <QUSE> " <> logSecret (snd addr)
-              withStore' c $ \db -> setSndQueueStatus db sq' Secured
-              let sq'' = (sq' :: SndQueue) {status = Secured}
-              -- sending QTEST to the new queue only, the old one will be removed if sent successfully
-              void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
-              notify . SWITCH QDSnd SPConfirmed $ connectionStats conn
-            _ -> qError "QUSE: queue address not found in connection"
+            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)
+                  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
+                  void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
+                  sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST
+                  let sqs' = updatedQs sq1' sqs
+                      conn' = DuplexConnection cData rqs sqs'
+                  notify . SWITCH QDSnd SPSecured $ connectionStats conn'
+                _ -> qError "QUSE: switching SndQueue not found in connection"
+            _ -> qError "QUSE: switched queue address not found in connection"
 
         qError :: String -> m ()
         qError = throwError . AGENT . A_QUEUE
@@ -1979,6 +2079,21 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
           | otherwise = MsgError MsgDuplicate -- this case is not possible
 
+checkRQSwchStatus :: AgentMonad m => RcvQueue -> RcvSwitchStatus -> m ()
+checkRQSwchStatus rq@RcvQueue {rcvSwchStatus} expected =
+  unless (rcvSwchStatus == Just expected) $ switchStatusError rq expected rcvSwchStatus
+
+checkSQSwchStatus :: AgentMonad m => SndQueue -> SndSwitchStatus -> m ()
+checkSQSwchStatus sq@SndQueue {sndSwchStatus} expected =
+  unless (sndSwchStatus == Just expected) $ switchStatusError sq expected sndSwchStatus
+
+switchStatusError :: (SMPQueueRec q, AgentMonad m, Show a) => q -> a -> Maybe a -> m ()
+switchStatusError q expected actual =
+  throwError . INTERNAL $
+    ("unexpected switch status, queueId=" <> show (queueId q))
+      <> (", expected=" <> show expected)
+      <> (", actual=" <> show actual)
+
 connectReplyQueues :: AgentMonad m => AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> m ()
 connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do
   clientVRange <- asks $ smpClientVRange . config
@@ -2063,5 +2178,6 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd
         dbQueueId = 0,
         primary = True,
         dbReplaceQueueId = Nothing,
+        sndSwchStatus = Nothing,
         smpClientVersion
       }
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 9a135b6c0..895f33943 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -841,6 +841,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do
             dbQueueId = 0,
             primary = True,
             dbReplaceQueueId = Nothing,
+            rcvSwchStatus = Nothing,
             smpClientVersion = maxVersion vRange,
             clientNtfCreds = Nothing,
             deleteErrors = 0
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 89c30eae0..0d260c150 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -55,8 +55,12 @@ module Simplex.Messaging.Agent.Protocol
     AEntityI (..),
     MsgHash,
     MsgMeta (..),
+    RcvQueueInfo (..),
+    SndQueueInfo (..),
     ConnectionStats (..),
     SwitchPhase (..),
+    RcvSwitchStatus (..),
+    SndSwitchStatus (..),
     QueueDirection (..),
     SMPConfirmation (..),
     AgentMsgEnvelope (..),
@@ -473,18 +477,20 @@ instance ToJSON QueueDirection where
 instance FromJSON QueueDirection where
   parseJSON = strParseJSON "QueueDirection"
 
-data SwitchPhase = SPStarted | SPConfirmed | SPCompleted
+data SwitchPhase = SPStarted | SPConfirmed | SPSecured | SPCompleted
   deriving (Eq, Show)
 
 instance StrEncoding SwitchPhase where
   strEncode = \case
     SPStarted -> "started"
     SPConfirmed -> "confirmed"
+    SPSecured -> "secured"
     SPCompleted -> "completed"
   strP =
     A.takeTill (== ' ') >>= \case
       "started" -> pure SPStarted
       "confirmed" -> pure SPConfirmed
+      "secured" -> pure SPSecured
       "completed" -> pure SPCompleted
       _ -> fail "bad SwitchPhase"
 
@@ -495,19 +501,109 @@ instance ToJSON SwitchPhase where
 instance FromJSON SwitchPhase where
   parseJSON = strParseJSON "SwitchPhase"
 
+data RcvSwitchStatus
+  = RSSwitchStarted
+  | RSSendingQADD
+  | RSSendingQUSE
+  | RSReceivedMessage
+  deriving (Eq, Show)
+
+instance StrEncoding RcvSwitchStatus where
+  strEncode = \case
+    RSSwitchStarted -> "switch_started"
+    RSSendingQADD -> "sending_qadd"
+    RSSendingQUSE -> "sending_quse"
+    RSReceivedMessage -> "received_message"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "switch_started" -> pure RSSwitchStarted
+      "sending_qadd" -> pure RSSendingQADD
+      "sending_quse" -> pure RSSendingQUSE
+      "received_message" -> pure RSReceivedMessage
+      _ -> fail "bad RcvSwitchStatus"
+
+instance ToField RcvSwitchStatus where toField = toField . strEncode
+
+instance FromField RcvSwitchStatus where fromField = blobFieldDecoder $ parseAll strP
+
+instance ToJSON RcvSwitchStatus where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance FromJSON RcvSwitchStatus where
+  parseJSON = strParseJSON "RcvSwitchStatus"
+
+data SndSwitchStatus
+  = SSSendingQKEY
+  | SSSendingQTEST
+  deriving (Eq, Show)
+
+instance StrEncoding SndSwitchStatus where
+  strEncode = \case
+    SSSendingQKEY -> "sending_qkey"
+    SSSendingQTEST -> "sending_qtest"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "sending_qkey" -> pure SSSendingQKEY
+      "sending_qtest" -> pure SSSendingQTEST
+      _ -> fail "bad SndSwitchStatus"
+
+instance ToField SndSwitchStatus where toField = toField . strEncode
+
+instance FromField SndSwitchStatus where fromField = blobFieldDecoder $ parseAll strP
+
+instance ToJSON SndSwitchStatus where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance FromJSON SndSwitchStatus where
+  parseJSON = strParseJSON "SndSwitchStatus"
+
+data RcvQueueInfo = RcvQueueInfo
+  { rcvServer :: SMPServer,
+    rcvSwitchStatus :: Maybe RcvSwitchStatus
+  }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON RcvQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+
+instance StrEncoding RcvQueueInfo where
+  strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus} =
+    "srv=" <> strEncode rcvServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus
+  strP = do
+    rcvServer <- "srv=" *> strP
+    rcvSwitchStatus <- optional $ ";switch=" *> strP
+    pure RcvQueueInfo {rcvServer, rcvSwitchStatus}
+
+data SndQueueInfo = SndQueueInfo
+  { sndServer :: SMPServer,
+    sndSwitchStatus :: Maybe SndSwitchStatus
+  }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON SndQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+
+instance StrEncoding SndQueueInfo where
+  strEncode SndQueueInfo {sndServer, sndSwitchStatus} =
+    "srv=" <> strEncode sndServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) sndSwitchStatus
+  strP = do
+    sndServer <- "srv=" *> strP
+    sndSwitchStatus <- optional $ ";switch=" *> strP
+    pure SndQueueInfo {sndServer, sndSwitchStatus}
+
 data ConnectionStats = ConnectionStats
-  { rcvServers :: [SMPServer],
-    sndServers :: [SMPServer]
+  { rcvQueuesInfo :: [RcvQueueInfo],
+    sndQueuesInfo :: [SndQueueInfo]
   }
   deriving (Eq, Show, Generic)
 
 instance StrEncoding ConnectionStats where
-  strEncode ConnectionStats {rcvServers, sndServers} =
-    "rcv=" <> strEncodeList rcvServers <> " snd=" <> strEncodeList sndServers
+  strEncode ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
+    "rcv=" <> strEncodeList rcvQueuesInfo <> " snd=" <> strEncodeList sndQueuesInfo
   strP = do
-    rcvServers <- "rcv=" *> strListP
-    sndServers <- " snd=" *> strListP
-    pure ConnectionStats {rcvServers, sndServers}
+    rcvQueuesInfo <- "rcv=" *> strListP
+    sndQueuesInfo <- " snd=" *> strListP
+    pure ConnectionStats {rcvQueuesInfo, sndQueuesInfo}
 
 instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
 
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index 59f5c06b0..8e83a1451 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -21,6 +21,7 @@ import Data.Kind (Type)
 import Data.List (find)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
+import Data.Maybe (isJust)
 import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
@@ -66,12 +67,13 @@ data RcvQueue = RcvQueue
     sndId :: SMP.SenderId,
     -- | queue status
     status :: QueueStatus,
-    -- | database queue ID (within connection), can be Nothing for old queues
+    -- | database queue ID (within connection)
     dbQueueId :: Int64,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
     primary :: Bool,
     -- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
     dbReplaceQueueId :: Maybe Int64,
+    rcvSwchStatus :: Maybe RcvSwitchStatus,
     -- | SMP client version
     smpClientVersion :: Version,
     -- | credentials used in context of notifications
@@ -80,6 +82,10 @@ data RcvQueue = RcvQueue
   }
   deriving (Eq, Show)
 
+rcvQueueInfo :: RcvQueue -> RcvQueueInfo
+rcvQueueInfo RcvQueue {server, rcvSwchStatus} =
+  RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus}
+
 data ClientNtfCreds = ClientNtfCreds
   { -- | key pair to be used by the notification server to sign transmissions
     ntfPublicKey :: NtfPublicVerifyKey,
@@ -107,17 +113,22 @@ data SndQueue = SndQueue
     e2eDhSecret :: C.DhSecretX25519,
     -- | queue status
     status :: QueueStatus,
-    -- | database queue ID (within connection), can be Nothing for old queues
+    -- | database queue ID (within connection)
     dbQueueId :: Int64,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
     primary :: Bool,
     -- | ID of the queue this one is replacing
     dbReplaceQueueId :: Maybe Int64,
+    sndSwchStatus :: Maybe SndSwitchStatus,
     -- | SMP client version
     smpClientVersion :: Version
   }
   deriving (Eq, Show)
 
+sndQueueInfo :: SndQueue -> SndQueueInfo
+sndQueueInfo SndQueue {server, sndSwchStatus} =
+  SndQueueInfo {sndServer = server, sndSwitchStatus = sndSwchStatus}
+
 instance SMPQueue RcvQueue where
   qServer RcvQueue {server} = server
   {-# INLINE qServer #-}
@@ -155,10 +166,20 @@ findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
 findRQ sAddr = find $ sameQAddress sAddr . sndAddress
 {-# INLINE findRQ #-}
 
+switchingRQ :: NonEmpty RcvQueue -> Maybe RcvQueue
+switchingRQ = find $ isJust . rcvSwchStatus
+{-# INLINE switchingRQ #-}
+
+updatedQs :: SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
+updatedQs q = L.map $ \q' -> if dbQId q == dbQId q' then q else q'
+{-# INLINE updatedQs #-}
+
 class SMPQueue q => SMPQueueRec q where
   qUserId :: q -> UserId
   qConnId :: q -> ConnId
   queueId :: q -> QueueId
+  dbQId :: q -> Int64
+  dbReplaceQId :: q -> Maybe Int64
 
 instance SMPQueueRec RcvQueue where
   qUserId = userId
@@ -167,6 +188,10 @@ instance SMPQueueRec RcvQueue where
   {-# INLINE qConnId #-}
   queueId = rcvId
   {-# INLINE queueId #-}
+  dbQId = dbQueueId
+  {-# INLINE dbQId #-}
+  dbReplaceQId = dbReplaceQueueId
+  {-# INLINE dbReplaceQId #-}
 
 instance SMPQueueRec SndQueue where
   qUserId = userId
@@ -175,6 +200,10 @@ instance SMPQueueRec SndQueue where
   {-# INLINE qConnId #-}
   queueId = sndId
   {-# INLINE queueId #-}
+  dbQId = dbQueueId
+  {-# INLINE dbQId #-}
+  dbReplaceQId = dbReplaceQueueId
+  {-# INLINE dbReplaceQId #-}
 
 -- * Connection types
 
@@ -308,6 +337,7 @@ data InternalCommand
   | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
   | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
   | ICDeleteConn
+  | ICDeleteRcvQueue SMP.RecipientId
   | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
   | ICQDelete SMP.RecipientId
 
@@ -317,6 +347,7 @@ data InternalCommandTag
   | ICAllowSecure_
   | ICDuplexSecure_
   | ICDeleteConn_
+  | ICDeleteRcvQueue_
   | ICQSecure_
   | ICQDelete_
   deriving (Show)
@@ -328,6 +359,7 @@ instance StrEncoding InternalCommand where
     ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
     ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
     ICDeleteConn -> strEncode ICDeleteConn_
+    ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId)
     ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
     ICQDelete rId -> strEncode (ICQDelete_, rId)
   strP =
@@ -337,6 +369,7 @@ instance StrEncoding InternalCommand where
       ICAllowSecure_ -> ICAllowSecure <$> _strP <*> _strP
       ICDuplexSecure_ -> ICDuplexSecure <$> _strP <*> _strP
       ICDeleteConn_ -> pure ICDeleteConn
+      ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP
       ICQSecure_ -> ICQSecure <$> _strP <*> _strP
       ICQDelete_ -> ICQDelete <$> _strP
 
@@ -347,6 +380,7 @@ instance StrEncoding InternalCommandTag where
     ICAllowSecure_ -> "ALLOW_SECURE"
     ICDuplexSecure_ -> "DUPLEX_SECURE"
     ICDeleteConn_ -> "DELETE_CONN"
+    ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE"
     ICQSecure_ -> "QSECURE"
     ICQDelete_ -> "QDELETE"
   strP =
@@ -356,6 +390,7 @@ instance StrEncoding InternalCommandTag where
       "ALLOW_SECURE" -> pure ICAllowSecure_
       "DUPLEX_SECURE" -> pure ICDuplexSecure_
       "DELETE_CONN" -> pure ICDeleteConn_
+      "DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_
       "QSECURE" -> pure ICQSecure_
       "QDELETE" -> pure ICQDelete_
       _ -> fail "bad InternalCommandTag"
@@ -372,6 +407,7 @@ internalCmdTag = \case
   ICAllowSecure {} -> ICAllowSecure_
   ICDuplexSecure {} -> ICDuplexSecure_
   ICDeleteConn -> ICDeleteConn_
+  ICDeleteRcvQueue {} -> ICDeleteRcvQueue_
   ICQSecure {} -> ICQSecure_
   ICQDelete _ -> ICQDelete_
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 5e9df8562..aacb7d54b 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -54,14 +54,19 @@ module Simplex.Messaging.Agent.Store.SQLite
     setConnDeleted,
     getDeletedConnIds,
     getRcvConn,
+    getRcvQueueById,
+    getSndQueueById,
     deleteConn,
     upgradeRcvConnToDuplex,
     upgradeSndConnToDuplex,
     addConnRcvQueue,
     addConnSndQueue,
     setRcvQueueStatus,
+    setRcvSwitchStatus,
+    setRcvQueueDeleted,
     setRcvQueueConfirmedE2E,
     setSndQueueStatus,
+    setSndSwitchStatus,
     setRcvQueuePrimary,
     setSndQueuePrimary,
     deleteConnRcvQueue,
@@ -69,6 +74,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     deleteConnSndQueue,
     getPrimaryRcvQueue,
     getRcvQueue,
+    getDeletedRcvQueue,
     setRcvQueueNtfCreds,
     -- Confirmations
     createConfirmation,
@@ -561,7 +567,7 @@ getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreE
 getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
   rq@RcvQueue {connId} <-
     ExceptT . firstRow toRcvQueue SEConnNotFound $
-      DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?") (host, port, rcvId)
+      DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId)
   (rq,) <$> ExceptT (getConn db connId)
 
 deleteConn :: DB.Connection -> ConnId -> IO ()
@@ -620,6 +626,29 @@ setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} stat
     |]
     [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
 
+setRcvSwitchStatus :: DB.Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
+setRcvSwitchStatus db rq@RcvQueue {rcvId, server = ProtocolServer {host, port}} rcvSwchStatus = do
+  DB.execute
+    db
+    [sql|
+      UPDATE rcv_queues
+      SET switch_status = ?
+      WHERE host = ? AND port = ? AND rcv_id = ?
+    |]
+    (rcvSwchStatus, host, port, rcvId)
+  pure rq {rcvSwchStatus}
+
+setRcvQueueDeleted :: DB.Connection -> RcvQueue -> IO ()
+setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = do
+  DB.execute
+    db
+    [sql|
+      UPDATE rcv_queues
+      SET deleted = 1
+      WHERE host = ? AND port = ? AND rcv_id = ?
+    |]
+    (host, port, rcvId)
+
 setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> Version -> IO ()
 setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion =
   DB.executeNamed
@@ -651,6 +680,18 @@ setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} stat
     |]
     [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]
 
+setSndSwitchStatus :: DB.Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue
+setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} sndSwchStatus = do
+  DB.execute
+    db
+    [sql|
+      UPDATE snd_queues
+      SET switch_status = ?
+      WHERE host = ? AND port = ? AND snd_id = ?
+    |]
+    (sndSwchStatus, host, port, sndId)
+  pure sq {sndSwchStatus}
+
 setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO ()
 setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do
   DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId)
@@ -687,7 +728,12 @@ getPrimaryRcvQueue db connId =
 getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
 getRcvQueue db connId (SMPServer host port _) rcvId =
   firstRow toRcvQueue SEConnNotFound $
-    DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ?") (connId, host, port, rcvId)
+    DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId)
+
+getDeletedRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
+getDeletedRcvQueue db connId (SMPServer host port _) rcvId =
+  firstRow toRcvQueue SEConnNotFound $
+    DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId)
 
 setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO ()
 setRcvQueueNtfCreds db connId clientNtfCreds =
@@ -918,7 +964,7 @@ setMsgUserAck db connId agentMsgId = runExceptT $ do
   (dbRcvId, srvMsgId) <-
     ExceptT . firstRow id SEMsgNotFound $
       DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
-  rq <- ExceptT $ getRcvQueueById_ db connId dbRcvId
+  rq <- ExceptT $ getRcvQueueById db connId dbRcvId
   pure (rq, srvMsgId)
 
 getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg)
@@ -1375,7 +1421,7 @@ getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId}
       [sql|
         SELECT conn_id, rcv_ntf_dh_secret
         FROM rcv_queues
-        WHERE host = ? AND port = ? AND ntf_id = ?
+        WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
       |]
       (host, port, notifierId)
   where
@@ -1611,7 +1657,7 @@ getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connect
 getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
 getRcvQueuesByConnId_ db connId =
   L.nonEmpty . sortBy primaryFirst . map toRcvQueue
-    <$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
+    <$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
   where
     primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
       -- the current primary queue is ordered first, the next primary - second
@@ -1622,7 +1668,7 @@ rcvQueueQuery =
   [sql|
     SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
       q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
-      q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.delete_errors,
+      q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
       q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
     FROM rcv_queues q
     JOIN servers s ON q.host = s.host AND q.port = s.port
@@ -1631,44 +1677,62 @@ 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 Version, Int)
+    :. (Int64, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
     :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
   RcvQueue
-toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
+toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
   let server = SMPServer host port keyHash
       smpClientVersion = fromMaybe 1 smpClientVersion_
       clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
         (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
         _ -> Nothing
-   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds, deleteErrors}
+   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
 
-getRcvQueueById_ :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
-getRcvQueueById_ db connId dbRcvId =
+getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
+getRcvQueueById db connId dbRcvId =
   firstRow toRcvQueue SEConnNotFound $
-    DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ?") (connId, dbRcvId)
+    DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ? AND q.deleted = 0") (connId, dbRcvId)
 
 -- | returns all connection queues, the first queue is the primary one
 getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue))
 getSndQueuesByConnId_ dbConn connId =
-  L.nonEmpty . sortBy primaryFirst . map sndQueue
-    <$> DB.query
-      dbConn
-      [sql|
-        SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
-        FROM snd_queues q
-        JOIN servers s ON q.host = s.host AND q.port = s.port
-        JOIN connections c ON q.conn_id = c.conn_id
-        WHERE q.conn_id = ?;
-      |]
-      (Only connId)
+  L.nonEmpty . sortBy primaryFirst . map toSndQueue
+    <$> DB.query dbConn (sndQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
   where
-    sndQueue ((userId, keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) =
-      let server = SMPServer host port keyHash
-       in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion}
     primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
       -- the current primary queue is ordered first, the next primary - second
       compare (Down p) (Down p') <> compare i i'
 
+sndQueueQuery :: Query
+sndQueueQuery =
+  [sql|
+    SELECT
+      c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id,
+      q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
+      q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
+    FROM snd_queues q
+    JOIN servers s ON q.host = s.host AND q.port = s.port
+    JOIN connections c ON q.conn_id = c.conn_id
+  |]
+
+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) ->
+  SndQueue
+toSndQueue
+  ( (userId, keyHash, connId, host, port, sndId)
+      :. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
+      :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
+    ) =
+    let server = SMPServer host port keyHash
+     in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
+
+getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
+getSndQueueById db connId dbSndId =
+  firstRow toSndQueue SEConnNotFound $
+    DB.query db (sndQueueQuery <> " WHERE q.conn_id = ? AND q.snd_queue_id = ?") (connId, dbSndId)
+
 -- * updateRcvIds helpers
 
 retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index 07d7b8486..4e03c4e1a 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
@@ -60,6 +60,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -86,7 +87,8 @@ schemaMigrations =
     ("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
     ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
     ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
-    ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes)
+    ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
+    ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status)
   ]
 
 -- | The list of migrations in ascending order by date
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230531_switch_status.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230531_switch_status.hs
new file mode 100644
index 000000000..7211e3ab1
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230531_switch_status.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230531_switch_status :: Query
+m20230531_switch_status =
+  [sql|
+ALTER TABLE rcv_queues ADD COLUMN switch_status TEXT;
+ALTER TABLE rcv_queues ADD COLUMN deleted INTEGER NOT NULL DEFAULT 0;
+ALTER TABLE snd_queues ADD COLUMN switch_status TEXT;
+|]
+
+down_m20230531_switch_status :: Query
+down_m20230531_switch_status =
+  [sql|
+ALTER TABLE snd_queues DROP COLUMN switch_status;
+ALTER TABLE rcv_queues DROP COLUMN deleted;
+ALTER TABLE rcv_queues DROP COLUMN switch_status;
+|]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 922a1e912..c391e484c 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -50,6 +50,8 @@ CREATE TABLE rcv_queues(
   replace_rcv_queue_id INTEGER NULL,
   delete_errors INTEGER DEFAULT 0 CHECK(delete_errors NOT NULL),
   server_key_hash BLOB,
+  switch_status TEXT,
+  deleted INTEGER NOT NULL DEFAULT 0,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -71,6 +73,7 @@ CREATE TABLE snd_queues(
   snd_primary INTEGER CHECK(snd_primary NOT NULL),
   replace_snd_queue_id INTEGER NULL,
   server_key_hash BLOB,
+  switch_status TEXT,
   PRIMARY KEY(host, port, snd_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index fbf697b3b..de66c1d6d 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -125,6 +125,18 @@ runRight action =
     Right x -> pure x
     Left e -> error $ "Unexpected error: " <> show e
 
+getInAnyOrder :: HasCallStack => AgentClient -> [AEntityTransmission 'AEConn -> Bool] -> Expectation
+getInAnyOrder _ [] = pure ()
+getInAnyOrder c rs = do
+  r <- get c
+  let rest = filter (not . expected r) rs
+  if length rest < length rs
+    then getInAnyOrder c rest
+    else error $ "unexpected event: " <> show r
+  where
+    expected :: AEntityTransmission 'AEConn -> (AEntityTransmission 'AEConn -> Bool) -> Bool
+    expected r rp = rp r
+
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
   describe "Establishing duplex connection" $ do
@@ -191,13 +203,23 @@ functionalAPITests t = do
       testUsersNoServer t
     it "should connect two users and switch session mode" $
       withSmpServer t testTwoUsers
-  describe "Queue rotation" $ do
+  describe "Connection switch" $ do
     describe "should switch delivery to the new queue" $
       testServerMatrix2 t testSwitchConnection
     describe "should switch to new queue asynchronously" $
       testServerMatrix2 t testSwitchAsync
-    describe "should delete connection during rotation" $
+    describe "should delete connection during switch" $
       testServerMatrix2 t testSwitchDelete
+    describe "should stop switch in Started phase" $
+      testServerMatrix2 t testStopSwitchStarted
+    describe "should stop switch in Started phase, reinitiate immediately" $
+      testServerMatrix2 t testStopSwitchStartedReinitiate
+    describe "should prohibit to stop switch in Secured phase" $
+      testServerMatrix2 t testCannotStopSwitchSecured
+    describe "should switch two connections simultaneously" $
+      testServerMatrix2 t testSwitch2Connections
+    describe "should switch two connections simultaneously, stop one" $
+      testServerMatrix2 t testSwitch2ConnectionsStop1
   describe "SMP basic auth" $ do
     describe "with server auth" $ do
       --                                       allow NEW | server auth, v | clnt1 auth, v  | clnt2 auth, v    |  2 - success, 1 - JOIN fail, 0 - NEW fail
@@ -961,28 +983,48 @@ testSwitchConnection servers = do
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    switchConnectionAsync a "" bId
-    switchComplete a bId b aId
-    exchangeGreetingsMsgId 10 a bId b aId
+    testFullSwitch a bId b aId 10
+    testFullSwitch a bId b aId 16
+
+testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO ()
+testFullSwitch a bId b aId msgId = do
+  switchConnectionAsync a "" bId
+  switchComplete a bId b aId
+  exchangeGreetingsMsgId msgId a bId b aId
 
 switchComplete :: AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()
 switchComplete a bId b aId = do
-  phase a bId QDRcv SPStarted
-  phase b aId QDSnd SPStarted
-  phase a bId QDRcv SPConfirmed
-  phase b aId QDSnd SPConfirmed
-  phase b aId QDSnd SPCompleted
-  phase a bId QDRcv SPCompleted
+  phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
+  phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
+  phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
+  phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
+  phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
+  phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
+  phaseSnd b aId SPCompleted [Nothing]
+  phaseRcv a bId SPCompleted [Nothing]
 
-phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> ExceptT AgentErrorType IO ()
-phase c connId d p =
+phaseRcv :: AgentClient -> ByteString -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ExceptT AgentErrorType IO ()
+phaseRcv c connId p swchStatuses = phase c connId QDRcv p (\stats -> rcvSwchStatuses' stats `shouldMatchList` swchStatuses)
+
+rcvSwchStatuses' :: ConnectionStats -> [Maybe RcvSwitchStatus]
+rcvSwchStatuses' ConnectionStats {rcvQueuesInfo} = map (\RcvQueueInfo {rcvSwitchStatus} -> rcvSwitchStatus) rcvQueuesInfo
+
+phaseSnd :: AgentClient -> ByteString -> SwitchPhase -> [Maybe SndSwitchStatus] -> ExceptT AgentErrorType IO ()
+phaseSnd c connId p swchStatuses = phase c connId QDSnd p (\stats -> sndSwchStatuses' stats `shouldMatchList` swchStatuses)
+
+sndSwchStatuses' :: ConnectionStats -> [Maybe SndSwitchStatus]
+sndSwchStatuses' ConnectionStats {sndQueuesInfo} = map (\SndQueueInfo {sndSwitchStatus} -> sndSwitchStatus) sndQueuesInfo
+
+phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Expectation) -> ExceptT AgentErrorType IO ()
+phase c connId d p statsExpectation =
   get c >>= \(_, connId', msg) -> do
     liftIO $ connId `shouldBe` connId'
     case msg of
-      SWITCH d' p' _ -> liftIO $ do
+      SWITCH d' p' stats -> liftIO $ do
         d `shouldBe` d'
         p `shouldBe` p'
-      ERR (AGENT A_DUPLICATE) -> phase c connId d p
+        statsExpectation stats
+      ERR (AGENT A_DUPLICATE) -> phase c connId d p statsExpectation
       r -> do
         liftIO . putStrLn $ "expected: " <> show p <> ", received: " <> show r
         SWITCH {} <- pure r
@@ -994,33 +1036,43 @@ testSwitchAsync servers = do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
     pure (aId, bId)
-  let withA' = session withA bId
-      withB' = session withB aId
+  let withA' = sessionSubscribe withA [bId]
+      withB' = sessionSubscribe withB [aId]
   withA' $ \a -> do
     switchConnectionAsync a "" bId
-    phase a bId QDRcv SPStarted
-  withB' $ \b -> phase b aId QDSnd SPStarted
-  withA' $ \a -> phase a bId QDRcv SPConfirmed
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
   withB' $ \b -> do
-    phase b aId QDSnd SPConfirmed
-    phase b aId QDSnd SPCompleted
-  withA' $ \a -> phase a bId QDRcv SPCompleted
+    phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
+    phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
+  withA' $ \a -> do
+    phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
+    phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
+  withB' $ \b -> do
+    phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
+    phaseSnd b aId SPCompleted [Nothing]
+  withA' $ \a -> phaseRcv a bId SPCompleted [Nothing]
   withA $ \a -> withB $ \b -> runRight_ $ do
     subscribeConnection a bId
     subscribeConnection b aId
     exchangeGreetingsMsgId 10 a bId b aId
+    testFullSwitch a bId b aId 16
   where
-    withAgent :: AgentConfig -> FilePath -> (AgentClient -> IO a) -> IO a
-    withAgent cfg' dbPath = bracket (getSMPAgentClient' cfg' servers dbPath) disconnectAgentClient
-    session :: (forall a. (AgentClient -> IO a) -> IO a) -> ConnId -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
-    session withC connId a =
-      withC $ \c -> runRight_ $ do
-        subscribeConnection c connId
-        r <- a c
-        liftIO $ threadDelay 500000
-        pure r
-    withA = withAgent agentCfg testDB
-    withB = withAgent agentCfg {initialClientId = 1} testDB2
+    withA :: (AgentClient -> IO a) -> IO a
+    withA = withAgent agentCfg servers testDB
+    withB :: (AgentClient -> IO a) -> IO a
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
+
+withAgent :: AgentConfig -> InitialAgentServers -> FilePath -> (AgentClient -> IO a) -> IO a
+withAgent cfg' servers dbPath = bracket (getSMPAgentClient' cfg' servers dbPath) disconnectAgentClient
+
+sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
+sessionSubscribe withC connIds a =
+  withC $ \c -> runRight_ $ do
+    void $ subscribeConnections c connIds
+    r <- a c
+    liftIO $ threadDelay 500000
+    liftIO $ noMessages c "nothing else should be delivered"
+    pure r
 
 testSwitchDelete :: InitialAgentServers -> IO ()
 testSwitchDelete servers = do
@@ -1031,13 +1083,269 @@ testSwitchDelete servers = do
     exchangeGreetingsMsgId 4 a bId b aId
     disconnectAgentClient b
     switchConnectionAsync a "" bId
-    phase a bId QDRcv SPStarted
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
     deleteConnectionAsync a bId
     get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
     get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
     get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
+testStopSwitchStarted :: HasCallStack => InitialAgentServers -> IO ()
+testStopSwitchStarted servers = do
+  (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    pure (aId, bId)
+  let withA' = sessionSubscribe withA [bId]
+      withB' = sessionSubscribe withB [aId]
+  withA' $ \a -> do
+    switchConnectionAsync a "" bId
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
+    -- repeat switch is prohibited
+    Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ switchConnectionAsync a "" bId
+    -- stop current switch
+    stats <- stopConnectionSwitch a bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
+  withB' $ \b -> do
+    phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
+    phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
+  withA' $ \a -> do
+    get a ##> ("", bId, ERR (AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}))
+    -- repeat switch
+    switchConnectionAsync a "" bId
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
+  withA $ \a -> withB $ \b -> runRight_ $ do
+    subscribeConnection a bId
+    subscribeConnection b aId
+
+    phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
+    phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
+
+    phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
+    phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
+
+    phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
+    phaseSnd b aId SPCompleted [Nothing]
+
+    phaseRcv a bId SPCompleted [Nothing]
+
+    exchangeGreetingsMsgId 12 a bId b aId
+
+    testFullSwitch a bId b aId 18
+  where
+    withA :: (AgentClient -> IO a) -> IO a
+    withA = withAgent agentCfg servers testDB
+    withB :: (AgentClient -> IO a) -> IO a
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
+
+testStopSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO ()
+testStopSwitchStartedReinitiate servers = do
+  (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    pure (aId, bId)
+  let withA' = sessionSubscribe withA [bId]
+      withB' = sessionSubscribe withB [aId]
+  withA' $ \a -> do
+    switchConnectionAsync a "" bId
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
+    -- stop current switch
+    stats <- stopConnectionSwitch a bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
+    -- repeat switch
+    switchConnectionAsync a "" bId
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
+  withB' $ \b -> do
+    phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
+    liftIO . getInAnyOrder b $
+      [ switchPhaseSndP aId SPStarted [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId SPConfirmed [Just SSSendingQKEY, Nothing]
+      ]
+    phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
+  withA $ \a -> withB $ \b -> runRight_ $ do
+    subscribeConnection a bId
+    subscribeConnection b aId
+
+    liftIO . getInAnyOrder a $
+      [ errQueueNotFoundP bId,
+        switchPhaseRcvP bId SPConfirmed [Just RSSendingQADD, Nothing]
+      ]
+
+    phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
+
+    phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
+    phaseSnd b aId SPCompleted [Nothing]
+
+    phaseRcv a bId SPCompleted [Nothing]
+
+    exchangeGreetingsMsgId 12 a bId b aId
+
+    testFullSwitch a bId b aId 18
+  where
+    withA :: (AgentClient -> IO a) -> IO a
+    withA = withAgent agentCfg servers testDB
+    withB :: (AgentClient -> IO a) -> IO a
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
+
+switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> AEntityTransmission 'AEConn -> Bool
+switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
+
+switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> AEntityTransmission 'AEConn -> Bool
+switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses)
+
+switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> AEntityTransmission 'AEConn -> Bool
+switchPhaseP cId qd sphase statsP = \case
+  (_, cId', SWITCH qd' sphase' stats) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
+  _ -> False
+
+errQueueNotFoundP :: ConnId -> AEntityTransmission 'AEConn -> Bool
+errQueueNotFoundP cId = \case
+  (_, cId', ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}) -> cId' == cId
+  _ -> False
+
+testCannotStopSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
+testCannotStopSwitchSecured servers = do
+  (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    pure (aId, bId)
+  let withA' = sessionSubscribe withA [bId]
+      withB' = sessionSubscribe withB [aId]
+  withA' $ \a -> do
+    switchConnectionAsync a "" bId
+    phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
+  withB' $ \b -> do
+    phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
+    phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
+  withA' $ \a -> do
+    phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
+    phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
+    Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ stopConnectionSwitch a bId
+    pure ()
+  withA $ \a -> withB $ \b -> runRight_ $ do
+    subscribeConnection a bId
+    subscribeConnection b aId
+
+    phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
+    phaseSnd b aId SPCompleted [Nothing]
+
+    phaseRcv a bId SPCompleted [Nothing]
+
+    exchangeGreetingsMsgId 10 a bId b aId
+
+    testFullSwitch a bId b aId 16
+  where
+    withA :: (AgentClient -> IO a) -> IO a
+    withA = withAgent agentCfg servers testDB
+    withB :: (AgentClient -> IO a) -> IO a
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
+
+testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO ()
+testSwitch2Connections servers = do
+  (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
+    (aId1, bId1) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId1 b aId1
+    (aId2, bId2) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId2 b aId2
+    pure (aId1, bId1, aId2, bId2)
+  withA $ \a -> runRight_ $ do
+    void $ subscribeConnections a [bId1, bId2]
+    switchConnectionAsync a "" bId1
+    phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
+    switchConnectionAsync a "" bId2
+    phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
+  withA $ \a -> withB $ \b -> runRight_ $ do
+    void $ subscribeConnections a [bId1, bId2]
+    void $ subscribeConnections b [aId1, aId2]
+
+    liftIO . getInAnyOrder b $
+      [ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
+      ]
+
+    liftIO . getInAnyOrder a $
+      [ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
+        switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
+        switchPhaseRcvP bId2 SPConfirmed [Just RSSendingQADD, Nothing],
+        switchPhaseRcvP bId2 SPSecured [Just RSSendingQUSE, Nothing]
+      ]
+
+    liftIO . getInAnyOrder b $
+      [ switchPhaseSndP aId1 SPSecured [Just SSSendingQTEST, Nothing],
+        switchPhaseSndP aId1 SPCompleted [Nothing],
+        switchPhaseSndP aId2 SPSecured [Just SSSendingQTEST, Nothing],
+        switchPhaseSndP aId2 SPCompleted [Nothing]
+      ]
+
+    liftIO . getInAnyOrder a $
+      [ switchPhaseRcvP bId1 SPCompleted [Nothing],
+        switchPhaseRcvP bId2 SPCompleted [Nothing]
+      ]
+
+    exchangeGreetingsMsgId 10 a bId1 b aId1
+    exchangeGreetingsMsgId 10 a bId2 b aId2
+
+    testFullSwitch a bId1 b aId1 16
+    testFullSwitch a bId2 b aId2 16
+  where
+    withA :: (AgentClient -> IO a) -> IO a
+    withA = withAgent agentCfg servers testDB
+    withB :: (AgentClient -> IO a) -> IO a
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
+
+testSwitch2ConnectionsStop1 :: HasCallStack => InitialAgentServers -> IO ()
+testSwitch2ConnectionsStop1 servers = do
+  (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
+    (aId1, bId1) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId1 b aId1
+    (aId2, bId2) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId2 b aId2
+    pure (aId1, bId1, aId2, bId2)
+  let withA' = sessionSubscribe withA [bId1, bId2]
+      withB' = sessionSubscribe withB [aId1, aId2]
+  withA' $ \a -> do
+    switchConnectionAsync a "" bId1
+    phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
+    switchConnectionAsync a "" bId2
+    phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
+    -- stop switch of second connection
+    stats <- stopConnectionSwitch a bId2
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
+  withB' $ \b -> do
+    liftIO . getInAnyOrder b $
+      [ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
+        switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
+      ]
+  withA' $ \a -> do
+    liftIO . getInAnyOrder a $
+      [ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
+        switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
+        errQueueNotFoundP bId2
+      ]
+  withA $ \a -> withB $ \b -> runRight_ $ do
+    void $ subscribeConnections a [bId1, bId2]
+    void $ subscribeConnections b [aId1, aId2]
+
+    phaseSnd b aId1 SPSecured [Just SSSendingQTEST, Nothing]
+    phaseSnd b aId1 SPCompleted [Nothing]
+
+    phaseRcv a bId1 SPCompleted [Nothing]
+
+    exchangeGreetingsMsgId 10 a bId1 b aId1
+    exchangeGreetingsMsgId 8 a bId2 b aId2
+
+    testFullSwitch a bId1 b aId1 16
+    testFullSwitch a bId2 b aId2 14
+  where
+    withA :: (AgentClient -> IO a) -> IO a
+    withA = withAgent agentCfg servers testDB
+    withB :: (AgentClient -> IO a) -> IO a
+    withB = withAgent agentCfg {initialClientId = 1} servers testDB2
+
 testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
 testCreateQueueAuth clnt1 clnt2 = do
   a <- getClient clnt1
diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs
index 43c95e0b8..89b54face 100644
--- a/tests/AgentTests/SQLiteTests.hs
+++ b/tests/AgentTests/SQLiteTests.hs
@@ -167,6 +167,7 @@ rcvQueue1 =
       dbQueueId = 1,
       primary = True,
       dbReplaceQueueId = Nothing,
+      rcvSwchStatus = Nothing,
       smpClientVersion = 1,
       clientNtfCreds = Nothing,
       deleteErrors = 0
@@ -187,6 +188,7 @@ sndQueue1 =
       dbQueueId = 1,
       primary = True,
       dbReplaceQueueId = Nothing,
+      sndSwchStatus = Nothing,
       smpClientVersion = 1
     }
 
@@ -324,6 +326,7 @@ testUpgradeRcvConnToDuplex =
               e2eDhSecret = testDhSecret,
               status = New,
               dbQueueId = 1,
+              sndSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
               smpClientVersion = 1
@@ -352,6 +355,7 @@ testUpgradeSndConnToDuplex =
               sndId = "4567",
               status = New,
               dbQueueId = 1,
+              rcvSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
               smpClientVersion = 1,

From 2efe1496d2622a56656a6a00a2cc19005e754468 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 16 Jun 2023 13:41:01 +0400
Subject: [PATCH 13/49] rename "stop switch" -> "abort switch", add
 canAbortSwitch to rcv queue info (#775)

---
 src/Simplex/Messaging/Agent.hs          | 28 +++++----------
 src/Simplex/Messaging/Agent/Protocol.hs | 12 ++++---
 src/Simplex/Messaging/Agent/Store.hs    | 16 +++++++--
 tests/AgentTests/FunctionalAPITests.hs  | 46 ++++++++++++-------------
 4 files changed, 53 insertions(+), 49 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index dcada9b9b..315c4260b 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -63,7 +63,7 @@ module Simplex.Messaging.Agent
     sendMessage,
     ackMessage,
     switchConnection,
-    stopConnectionSwitch,
+    abortConnectionSwitch,
     suspendConnection,
     deleteConnection,
     deleteConnections,
@@ -269,9 +269,9 @@ ackMessage c = withAgentEnv c .: ackMessage' c
 switchConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
 switchConnection c = withAgentEnv c . switchConnection' c
 
--- | Stop switching connection to the new receive queue
-stopConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
-stopConnectionSwitch c = withAgentEnv c . stopConnectionSwitch' c
+-- | Abort switching connection to the new receive queue
+abortConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
+abortConnectionSwitch c = withAgentEnv c . abortConnectionSwitch' c
 
 -- | Suspend SMP agent connection (OFF command)
 suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
@@ -1240,13 +1240,13 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s
   let rqs' = updatedQs rq1 rqs <> [rq']
   pure . connectionStats $ DuplexConnection cData rqs' sqs
 
-stopConnectionSwitch' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
-stopConnectionSwitch' c connId =
-  withConnLock c connId "stopConnectionSwitch" $
+abortConnectionSwitch' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
+abortConnectionSwitch' c connId =
+  withConnLock c connId "abortConnectionSwitch" $
     withStore c (`getConn` connId) >>= \case
       SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
         Just rq
-          | canStopRcvSwitch rq -> do
+          | canAbortRcvSwitch rq -> do
             -- multiple queues to which the connections switches were possible when repeating switch was allowed
             let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
             case L.nonEmpty keepRqs of
@@ -1263,18 +1263,6 @@ stopConnectionSwitch' c connId =
         _ -> throwError $ CMD PROHIBITED
       _ -> throwError $ CMD PROHIBITED
 
-canStopRcvSwitch :: RcvQueue -> Bool
-canStopRcvSwitch = maybe False canStop . rcvSwchStatus
-  where
-    canStop = \case
-      RSSwitchStarted -> True
-      RSSendingQADD -> True
-      -- if switch is in RSSendingQUSE, a race condition with sender deleting the original queue is possible
-      RSSendingQUSE -> False
-      -- if switch is in RSReceivedMessage status, stopping switch (deleting new queue)
-      -- will break the connection because the sender would have original queue deleted
-      RSReceivedMessage -> False
-
 ackQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> SMP.MsgId -> m ()
 ackQueueMessage c rq srvMsgId =
   sendAck c rq srvMsgId `catchError` \case
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 0d260c150..8f09b26ff 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -561,19 +561,23 @@ instance FromJSON SndSwitchStatus where
 
 data RcvQueueInfo = RcvQueueInfo
   { rcvServer :: SMPServer,
-    rcvSwitchStatus :: Maybe RcvSwitchStatus
+    rcvSwitchStatus :: Maybe RcvSwitchStatus,
+    canAbortSwitch :: Bool
   }
   deriving (Eq, Show, Generic)
 
 instance ToJSON RcvQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
 
 instance StrEncoding RcvQueueInfo where
-  strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus} =
-    "srv=" <> strEncode rcvServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus
+  strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
+    "srv=" <> strEncode rcvServer
+      <> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus
+      <> (";can_abort_switch=" <> strEncode canAbortSwitch)
   strP = do
     rcvServer <- "srv=" *> strP
     rcvSwitchStatus <- optional $ ";switch=" *> strP
-    pure RcvQueueInfo {rcvServer, rcvSwitchStatus}
+    canAbortSwitch <- ";can_abort_switch=" *> strP
+    pure RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch}
 
 data SndQueueInfo = SndQueueInfo
   { sndServer :: SMPServer,
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index 8e83a1451..7fbe9dfe2 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -83,8 +83,20 @@ data RcvQueue = RcvQueue
   deriving (Eq, Show)
 
 rcvQueueInfo :: RcvQueue -> RcvQueueInfo
-rcvQueueInfo RcvQueue {server, rcvSwchStatus} =
-  RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus}
+rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
+  RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
+
+canAbortRcvSwitch :: RcvQueue -> Bool
+canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
+  where
+    canAbort = \case
+      RSSwitchStarted -> True
+      RSSendingQADD -> True
+      -- if switch is in RSSendingQUSE, a race condition with sender deleting the original queue is possible
+      RSSendingQUSE -> False
+      -- if switch is in RSReceivedMessage status, aborting switch (deleting new queue)
+      -- will break the connection because the sender would have original queue deleted
+      RSReceivedMessage -> False
 
 data ClientNtfCreds = ClientNtfCreds
   { -- | key pair to be used by the notification server to sign transmissions
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index de66c1d6d..5f07288e6 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -210,16 +210,16 @@ functionalAPITests t = do
       testServerMatrix2 t testSwitchAsync
     describe "should delete connection during switch" $
       testServerMatrix2 t testSwitchDelete
-    describe "should stop switch in Started phase" $
-      testServerMatrix2 t testStopSwitchStarted
-    describe "should stop switch in Started phase, reinitiate immediately" $
-      testServerMatrix2 t testStopSwitchStartedReinitiate
-    describe "should prohibit to stop switch in Secured phase" $
-      testServerMatrix2 t testCannotStopSwitchSecured
+    describe "should abort switch in Started phase" $
+      testServerMatrix2 t testAbortSwitchStarted
+    describe "should abort switch in Started phase, reinitiate immediately" $
+      testServerMatrix2 t testAbortSwitchStartedReinitiate
+    describe "should prohibit to abort switch in Secured phase" $
+      testServerMatrix2 t testCannotAbortSwitchSecured
     describe "should switch two connections simultaneously" $
       testServerMatrix2 t testSwitch2Connections
-    describe "should switch two connections simultaneously, stop one" $
-      testServerMatrix2 t testSwitch2ConnectionsStop1
+    describe "should switch two connections simultaneously, abort one" $
+      testServerMatrix2 t testSwitch2ConnectionsAbort1
   describe "SMP basic auth" $ do
     describe "with server auth" $ do
       --                                       allow NEW | server auth, v | clnt1 auth, v  | clnt2 auth, v    |  2 - success, 1 - JOIN fail, 0 - NEW fail
@@ -1090,8 +1090,8 @@ testSwitchDelete servers = do
     get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
-testStopSwitchStarted :: HasCallStack => InitialAgentServers -> IO ()
-testStopSwitchStarted servers = do
+testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO ()
+testAbortSwitchStarted servers = do
   (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -1103,8 +1103,8 @@ testStopSwitchStarted servers = do
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
     -- repeat switch is prohibited
     Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ switchConnectionAsync a "" bId
-    -- stop current switch
-    stats <- stopConnectionSwitch a bId
+    -- abort current switch
+    stats <- abortConnectionSwitch a bId
     liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
   withB' $ \b -> do
     phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
@@ -1138,8 +1138,8 @@ testStopSwitchStarted servers = do
     withB :: (AgentClient -> IO a) -> IO a
     withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
-testStopSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO ()
-testStopSwitchStartedReinitiate servers = do
+testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO ()
+testAbortSwitchStartedReinitiate servers = do
   (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -1149,8 +1149,8 @@ testStopSwitchStartedReinitiate servers = do
   withA' $ \a -> do
     switchConnectionAsync a "" bId
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
-    -- stop current switch
-    stats <- stopConnectionSwitch a bId
+    -- abort current switch
+    stats <- abortConnectionSwitch a bId
     liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
     -- repeat switch
     switchConnectionAsync a "" bId
@@ -1203,8 +1203,8 @@ errQueueNotFoundP cId = \case
   (_, cId', ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}) -> cId' == cId
   _ -> False
 
-testCannotStopSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
-testCannotStopSwitchSecured servers = do
+testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
+testCannotAbortSwitchSecured servers = do
   (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -1220,7 +1220,7 @@ testCannotStopSwitchSecured servers = do
   withA' $ \a -> do
     phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
     phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
-    Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ stopConnectionSwitch a bId
+    Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ abortConnectionSwitch a bId
     pure ()
   withA $ \a -> withB $ \b -> runRight_ $ do
     subscribeConnection a bId
@@ -1295,8 +1295,8 @@ testSwitch2Connections servers = do
     withB :: (AgentClient -> IO a) -> IO a
     withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
-testSwitch2ConnectionsStop1 :: HasCallStack => InitialAgentServers -> IO ()
-testSwitch2ConnectionsStop1 servers = do
+testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO ()
+testSwitch2ConnectionsAbort1 servers = do
   (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
     (aId1, bId1) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId1 b aId1
@@ -1310,8 +1310,8 @@ testSwitch2ConnectionsStop1 servers = do
     phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
     switchConnectionAsync a "" bId2
     phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
-    -- stop switch of second connection
-    stats <- stopConnectionSwitch a bId2
+    -- abort switch of second connection
+    stats <- abortConnectionSwitch a bId2
     liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
   withB' $ \b -> do
     liftIO . getInAnyOrder b $

From c31668ce286380ed6cf6829f1fa0b246cd52d828 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Mon, 19 Jun 2023 14:51:14 +0400
Subject: [PATCH 14/49] return updated ConnectionStats from
 switchConnectionAsync (#777)

---
 src/Simplex/Messaging/Agent.hs         | 10 +++---
 tests/AgentTests/FunctionalAPITests.hs | 48 ++++++++++++++++----------
 2 files changed, 36 insertions(+), 22 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 315c4260b..b729c7bd9 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -205,7 +205,7 @@ ackMessageAsync :: forall m. AgentErrorMonad m => AgentClient -> ACorrId -> Conn
 ackMessageAsync c = withAgentEnv c .:. ackMessageAsync' c
 
 -- | Switch connection to the new receive queue
-switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> m ()
+switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> m ConnectionStats
 switchConnectionAsync c = withAgentEnv c .: switchConnectionAsync' c
 
 -- | Delete SMP agent connection (DEL command) asynchronously, no synchronous response
@@ -529,15 +529,17 @@ deleteConnectionsAsync_ onSuccess c connIds = case connIds of
         deleteConnQueues c True rqs >> onSuccess
 
 -- | Add connection to the new receive queue
-switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ()
+switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ConnectionStats
 switchConnectionAsync' c corrId connId =
   withConnLock c connId "switchConnectionAsync" $
     withStore c (`getConn` connId) >>= \case
-      SomeConn _ (DuplexConnection _ rqs@(rq :| _rqs) _)
+      SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs)
         | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
         | otherwise -> do
-          void $ withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
+          rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
           enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
+          let rqs' = updatedQs rq1 rqs
+          pure . connectionStats $ DuplexConnection cData rqs' sqs
       _ -> throwError $ CMD PROHIBITED
 
 newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c)
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index 5f07288e6..e33c52a09 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -988,7 +988,8 @@ testSwitchConnection servers = do
 
 testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO ()
 testFullSwitch a bId b aId msgId = do
-  switchConnectionAsync a "" bId
+  stats <- switchConnectionAsync a "" bId
+  liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
   switchComplete a bId b aId
   exchangeGreetingsMsgId msgId a bId b aId
 
@@ -1039,7 +1040,8 @@ testSwitchAsync servers = do
   let withA' = sessionSubscribe withA [bId]
       withB' = sessionSubscribe withB [aId]
   withA' $ \a -> do
-    switchConnectionAsync a "" bId
+    stats <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
   withB' $ \b -> do
     phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
@@ -1082,7 +1084,8 @@ testSwitchDelete servers = do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
     disconnectAgentClient b
-    switchConnectionAsync a "" bId
+    stats <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
     deleteConnectionAsync a bId
     get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
@@ -1099,20 +1102,22 @@ testAbortSwitchStarted servers = do
   let withA' = sessionSubscribe withA [bId]
       withB' = sessionSubscribe withB [aId]
   withA' $ \a -> do
-    switchConnectionAsync a "" bId
+    stats <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
     -- repeat switch is prohibited
     Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ switchConnectionAsync a "" bId
     -- abort current switch
-    stats <- abortConnectionSwitch a bId
-    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
+    stats' <- abortConnectionSwitch a bId
+    liftIO $ rcvSwchStatuses' stats' `shouldMatchList` [Nothing]
   withB' $ \b -> do
     phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
     phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
   withA' $ \a -> do
     get a ##> ("", bId, ERR (AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}))
     -- repeat switch
-    switchConnectionAsync a "" bId
+    stats <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
   withA $ \a -> withB $ \b -> runRight_ $ do
     subscribeConnection a bId
@@ -1147,13 +1152,15 @@ testAbortSwitchStartedReinitiate servers = do
   let withA' = sessionSubscribe withA [bId]
       withB' = sessionSubscribe withB [aId]
   withA' $ \a -> do
-    switchConnectionAsync a "" bId
+    stats <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
     -- abort current switch
-    stats <- abortConnectionSwitch a bId
-    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
+    stats' <- abortConnectionSwitch a bId
+    liftIO $ rcvSwchStatuses' stats' `shouldMatchList` [Nothing]
     -- repeat switch
-    switchConnectionAsync a "" bId
+    stats'' <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats'' `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
   withB' $ \b -> do
     phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
@@ -1212,7 +1219,8 @@ testCannotAbortSwitchSecured servers = do
   let withA' = sessionSubscribe withA [bId]
       withB' = sessionSubscribe withB [aId]
   withA' $ \a -> do
-    switchConnectionAsync a "" bId
+    stats <- switchConnectionAsync a "" bId
+    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
   withB' $ \b -> do
     phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
@@ -1250,9 +1258,11 @@ testSwitch2Connections servers = do
     pure (aId1, bId1, aId2, bId2)
   withA $ \a -> runRight_ $ do
     void $ subscribeConnections a [bId1, bId2]
-    switchConnectionAsync a "" bId1
+    stats1 <- switchConnectionAsync a "" bId1
+    liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
-    switchConnectionAsync a "" bId2
+    stats2 <- switchConnectionAsync a "" bId2
+    liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
   withA $ \a -> withB $ \b -> runRight_ $ do
     void $ subscribeConnections a [bId1, bId2]
@@ -1306,13 +1316,15 @@ testSwitch2ConnectionsAbort1 servers = do
   let withA' = sessionSubscribe withA [bId1, bId2]
       withB' = sessionSubscribe withB [aId1, aId2]
   withA' $ \a -> do
-    switchConnectionAsync a "" bId1
+    stats1 <- switchConnectionAsync a "" bId1
+    liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
-    switchConnectionAsync a "" bId2
+    stats2 <- switchConnectionAsync a "" bId2
+    liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
     -- abort switch of second connection
-    stats <- abortConnectionSwitch a bId2
-    liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing]
+    stats2' <- abortConnectionSwitch a bId2
+    liftIO $ rcvSwchStatuses' stats2' `shouldMatchList` [Nothing]
   withB' $ \b -> do
     liftIO . getInAnyOrder b $
       [ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],

From acea477aab54b14da1b6586db2cf2422cbbf529f Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sun, 25 Jun 2023 08:27:50 +0100
Subject: [PATCH 15/49] batch subscriptions for ntf server (#778)

* return updated ConnectionStats from switchConnectionAsync (#777)

* batch ntf server subscriptions to SMP servers

* refactor

* fix filtering queues in reconnect

* test, remove repeated grouping

* enable all tests

* reduce subscriptions count

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/Messaging/Client.hs               |  11 ++
 src/Simplex/Messaging/Client/Agent.hs         | 102 ++++++++++++++----
 src/Simplex/Messaging/Notifications/Server.hs |  72 ++++++++-----
 .../Messaging/Notifications/Server/Env.hs     |   5 +-
 .../Messaging/Notifications/Server/Store.hs   |   5 +-
 src/Simplex/Messaging/Util.hs                 |   2 +-
 tests/AgentTests/NotificationTests.hs         |  57 +++++++++-
 7 files changed, 197 insertions(+), 57 deletions(-)

diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index 02fcbfc2d..6cd14fcda 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -41,6 +41,7 @@ module Simplex.Messaging.Client
     subscribeSMPQueues,
     getSMPMessage,
     subscribeSMPQueueNotifications,
+    subscribeSMPQueuesNtfs,
     secureSMPQueue,
     enableSMPQueueNotifications,
     disableSMPQueueNotifications,
@@ -487,6 +488,16 @@ getSMPMessage c rpKey rId =
 subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
 subscribeSMPQueueNotifications = okSMPCommand NSUB
 
+-- | Subscribe to multiple SMP queues notifications batching commands if supported.
+subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
+subscribeSMPQueuesNtfs c qs = sendProtocolCommands c cs >>= mapM response
+  where
+    cs = L.map (\(npKey, nId) -> (Just npKey, nId, Cmd SNotifier NSUB)) qs
+    response r = pure $ case r of
+      Right OK -> Right ()
+      Right r' -> Left . PCEUnexpectedResponse $ bshow r'
+      Left e -> Left e
+
 -- | Secure the SMP queue by adding a sender public key.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index b99e9d61d..dad9d709a 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -16,27 +17,33 @@ import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except
+import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.List (find, partition)
+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.Set (Set)
 import Data.Text.Encoding
+import Data.Tuple (swap)
 import Numeric.Natural
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
+import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer, NtfPrivateSignKey, NotifierId, RcvPrivateSignKey, RecipientId)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
+import Simplex.Messaging.Util (catchAll_, tryE, ($>>=))
 import System.Timeout (timeout)
-import UnliftIO (async, forConcurrently_)
+import UnliftIO (async)
 import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
+import Data.Either (isLeft)
 
 type SMPClientVar = TMVar (Either SMPClientError SMPClient)
 
@@ -184,9 +191,9 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
             _ -> TM.insert srv sVar ps
 
     serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
-    serverDown ss = unless (M.null ss) . void . runExceptT $ do
+    serverDown ss = unless (M.null ss) $ do
       notify . CADisconnected srv $ M.keysSet ss
-      reconnectServer
+      void $ runExceptT reconnectServer
 
     reconnectServer :: ExceptT SMPClientError IO ()
     reconnectServer = do
@@ -201,27 +208,47 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
     reconnectClient :: ExceptT SMPClientError IO ()
     reconnectClient = do
       withSMP ca srv $ \smp -> do
-        notify $ CAReconnected srv
-        cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
-        forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
-          unlessM (atomically $ hasSub (srvSubs ca) srv s) $
-            subscribe_ smp sub `catchE` handleError s
+        liftIO . notify $ CAReconnected srv
+        cs_ <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
+        forM_ cs_ $ \cs -> do
+          subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
+          let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
+          nRs <- liftIO $ subscribe_ smp SPNotifier nSubs
+          rRs <- liftIO $ subscribe_ smp SPRecipient rSubs
+          case find isLeft $ nRs <> rRs of
+            Just (Left e) -> throwE e
+            _ -> pure ()
       where
-        subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
-        subscribe_ smp sub@(s, _) = do
-          smpSubscribe smp sub
-          atomically $ addSubscription ca srv sub
-          notify $ CAResubscribed srv s
+        isNotifier = \case
+          SPNotifier -> True
+          SPRecipient -> False
 
-        handleError :: SMPSub -> SMPClientError -> ExceptT SMPClientError IO ()
-        handleError s = \case
-          e@PCEResponseTimeout -> throwE e
-          e@PCENetworkError -> throwE e
-          e -> do
-            notify $ CASubError srv s e
-            atomically $ removePendingSubscription ca srv s
+        subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> IO [Either SMPClientError ()]
+        subscribe_ smp party subs =
+          case L.nonEmpty subs of
+            Just subs' -> do
+              let subs'' = L.map (first snd) subs'
+              rs <- L.zip subs'' <$> smpSubscribeQueues party ca smp srv subs''
+              rs' <- forM rs $ \(sub, r) -> do
+                let sub' = first (party,) sub
+                    s = fst sub'
+                case snd r of
+                  Right () -> do
+                    atomically $ addSubscription ca srv sub'
+                    notify $ CAResubscribed srv s
+                    pure $ Right ()
+                  Left e -> do
+                    case e of
+                      PCEResponseTimeout -> pure $ Left e
+                      PCENetworkError -> pure $ Left e
+                      _ -> do
+                        notify $ CASubError srv s e
+                        atomically $ removePendingSubscription ca srv s
+                        pure $ Right ()
+              pure $ L.toList rs'
+            Nothing -> pure []
 
-    notify :: SMPClientAgentEvent -> ExceptT SMPClientError IO ()
+    notify :: SMPClientAgentEvent -> IO ()
     notify evt = atomically $ writeTBQueue (agentQ ca) evt
 
 closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
@@ -263,6 +290,35 @@ subscribeQueue ca srv sub = do
         removePendingSubscription ca srv $ fst sub
       throwE e
 
+subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
+subscribeQueuesSMP = subscribeQueues_ SPRecipient
+
+subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateSignKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ()))
+subscribeQueuesNtfs = subscribeQueues_ SPNotifier
+
+subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
+subscribeQueues_ party ca srv subs = do
+  atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,)
+  runExceptT (getSMPServerClient' ca srv) >>= \case
+    Left e -> pure $ L.map ((,Left e) . fst) subs
+    Right smp -> smpSubscribeQueues party ca smp srv subs
+
+smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
+smpSubscribeQueues party ca smp srv subs = do
+  rs <- L.zip subs <$> subscribe smp (L.map swap subs)
+  atomically $ forM rs $ \(sub, r) -> (fst sub,) <$> case r of
+    Right () -> do
+      addSubscription ca srv $ first (party,) sub
+      pure $ Right ()
+    Left e -> do
+      when (e /= PCENetworkError && e /= PCEResponseTimeout) $
+        removePendingSubscription ca srv $ (party,) $ fst sub
+      pure $ Left e
+  where
+    subscribe = case party of
+      SPRecipient -> subscribeSMPQueues
+      SPNotifier -> subscribeSMPQueuesNtfs
+
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index ee5b3f508..209975d5b 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -18,10 +18,14 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Function (on)
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (intercalate)
+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 qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
@@ -55,6 +59,7 @@ import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.STM
+import Data.Bifunctor (second)
 
 runNtfServer :: NtfServerConfig -> IO ()
 runNtfServer cfg = do
@@ -141,11 +146,8 @@ ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
 
 resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
 resubscribe NtfSubscriber {newSubQ} subs = do
-  d <- asks $ resubscribeDelay . config
-  forM_ subs $ \sub@NtfSubData {} ->
-    whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
-      atomically $ writeTBQueue newSubQ $ NtfSub sub
-      threadDelay d
+  subs' <- atomically $ filterM (fmap ntfShouldSubscribe . readTVar . subStatus) $ M.elems subs
+  mapM_ (atomically . writeTBQueue newSubQ . L.map NtfSub) $ L.nonEmpty subs'
   liftIO $ logInfo "SMP connections resubscribed"
 
 ntfSubscriber :: NtfSubscriber -> M ()
@@ -153,12 +155,18 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
   raceAny_ [subscribe, receiveSMP, receiveAgent]
   where
     subscribe :: M ()
-    subscribe =
-      forever $
-        atomically (readTBQueue newSubQ) >>= \case
-          sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
-            SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
-            atomically $ writeTQueue subscriberSubQ sub
+    subscribe = do
+      d <- asks $ resubscribeDelay . config
+      forever $ do
+        subs <- atomically (readTBQueue newSubQ)
+        let ss = L.groupBy ((==) `on` server) subs
+        forM_ ss $ \serverSubs -> do
+          SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber $ server $ L.head serverSubs
+          atomically $ writeTQueue subscriberSubQ serverSubs
+          when (length serverSubs > 10) $ threadDelay d
+
+    server :: NtfEntityRec 'Subscription -> SMPServer
+    server (NtfSub sub) = ntfSubServer sub
 
     getSMPSubscriber :: SMPServer -> M SMPSubscriber
     getSMPSubscriber smpServer =
@@ -173,21 +181,31 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
     runSMPSubscriber :: SMPSubscriber -> M ()
     runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
-      forever $
-        atomically (peekTQueue subscriberSubQ)
-          >>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
-            updateSubStatus smpQueue NSPending
-            let SMPQueueNtf {smpServer, notifierId} = smpQueue
-            liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
-              Right _ -> do
-                updateSubStatus smpQueue NSActive
-                void . atomically $ readTQueue subscriberSubQ
-              Left err -> do
-                handleSubError smpQueue err
-                case err of
-                  PCEResponseTimeout -> pure ()
-                  PCENetworkError -> pure ()
-                  _ -> void . atomically $ readTQueue subscriberSubQ
+      forever $ do
+        subs <- atomically (peekTQueue subscriberSubQ)
+        let subs' = L.map (\(NtfSub sub) -> sub) subs
+        mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs'
+        rs <- liftIO $ subscribeQueues (server $ L.head subs) subs'
+        subs_ <- L.nonEmpty <$> foldM process [] rs
+        atomically $ do
+          void $ readTQueue subscriberSubQ
+          mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) subs_
+      where
+        process subs (sub@NtfSubData {smpQueue}, r) = case r of
+          Right _ -> updateSubStatus smpQueue NSActive $> subs
+          Left err -> do
+            handleSubError smpQueue err
+            pure $ case err of
+              PCEResponseTimeout -> sub : subs
+              PCENetworkError -> sub : subs
+              _ -> subs
+
+    -- | Subscribe to queues. The list of results can have a different order.
+    subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ()))
+    subscribeQueues srv subs =
+      L.map (second snd) . L.zip subs <$> subscribeQueuesNtfs ca srv (L.map sub subs)
+      where
+        sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey)
 
     receiveSMP :: M ()
     receiveSMP = forever $ do
@@ -504,7 +522,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         sub <- atomically $ mkNtfSubData subId newSub
         resp <-
           atomically (addNtfSubscription st subId sub) >>= \case
-            Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
+            Just _ -> atomically (writeTBQueue newSubQ [NtfSub sub]) $> NRSubId subId
             _ -> pure $ NRErr AUTH
         withNtfLog (`logCreateSubscription` sub)
         incNtfStat subCreated
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index 3736dffb1..5bff6df21 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -12,6 +12,7 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Word (Word16)
@@ -93,7 +94,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
 
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriber,
-    newSubQ :: TBQueue (NtfEntityRec 'Subscription),
+    newSubQ :: TBQueue (NonEmpty (NtfEntityRec 'Subscription)),
     smpAgent :: SMPClientAgent
   }
 
@@ -105,7 +106,7 @@ newNtfSubscriber qSize smpAgentCfg = do
   pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
 
 data SMPSubscriber = SMPSubscriber
-  { newSubQ :: TQueue (NtfEntityRec 'Subscription),
+  { newSubQ :: TQueue (NonEmpty (NtfEntityRec 'Subscription)),
     subThreadId :: TVar (Maybe (Weak ThreadId))
   }
 
diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs
index ee413cab1..7be6b3d54 100644
--- a/src/Simplex/Messaging/Notifications/Server/Store.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Store.hs
@@ -20,7 +20,7 @@ import qualified Data.Set as S
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (NtfPrivateSignKey)
+import Simplex.Messaging.Protocol (NtfPrivateSignKey, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
@@ -68,6 +68,9 @@ data NtfSubData = NtfSubData
     subStatus :: TVar NtfSubStatus
   }
 
+ntfSubServer :: NtfSubData -> SMPServer
+ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer
+
 data NtfEntityRec (e :: NtfEntity) where
   NtfTkn :: NtfTknData -> NtfEntityRec 'Token
   NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index 2804ff869..9db3901aa 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -16,7 +16,7 @@ import Data.Int (Int64)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
-import Data.Time (NominalDiffTime, nominalDiffTimeToSeconds)
+import Data.Time (NominalDiffTime)
 import UnliftIO.Async
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs
index 83d973015..36eaf8f7c 100644
--- a/tests/AgentTests/NotificationTests.hs
+++ b/tests/AgentTests/NotificationTests.hs
@@ -19,8 +19,8 @@ import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
-import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
-import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn, xit')
+import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2)
+import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit')
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
 import Simplex.Messaging.Agent.Protocol
@@ -31,6 +31,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Types (NtfToken (..))
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Util (tryE)
 import System.Directory (doesFileExist, removeFile)
@@ -85,6 +86,10 @@ notificationTests t =
       it "should resume subscriptions after SMP server is restarted" $ \_ ->
         withAPNSMockServer $ \apns ->
           withNtfServer t $ testNotificationsSMPRestart t apns
+    describe "Notifications after SMP server restart" $
+      it "should resume batched subscriptions after SMP server is restarted" $ \_ ->
+        withAPNSMockServer $ \apns ->
+          withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
     describe "should switch notifications to the new queue" $
       testServerMatrix2 t $ \servers ->
         withAPNSMockServer $ \apns ->
@@ -480,6 +485,52 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     liftIO $ killThread threadId
 
+testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
+testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
+  a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
+  conns <- runServers $ do
+    conns <- forM [1 .. n :: Int] . const $ makeConnection a b
+    _ <- registerTestToken a "abcd" NMInstant apnsQ
+    liftIO $ threadDelay 1500000
+    forM_ conns $ \(aliceId, bobId) -> do
+      msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
+      get b ##> ("", aliceId, SENT msgId)
+      void $ messageNotification apnsQ
+      get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+      ackMessage a bobId msgId
+    pure conns
+
+  runRight_ @AgentErrorType $ do
+    ("", "", DOWN _ bcs1) <- nGet a
+    ("", "", DOWN _ bcs2) <- nGet a
+    liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
+    ("", "", DOWN _ acs1) <- nGet b
+    ("", "", DOWN _ acs2) <- nGet b
+    liftIO $ length (acs1 <> acs2) `shouldBe` length conns
+
+  runServers $ do
+    ("", "", UP _ bcs1) <- nGet a
+    ("", "", UP _ bcs2) <- nGet a
+    liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
+    ("", "", UP _ acs1) <- nGet b
+    ("", "", UP _ acs2) <- nGet b
+    liftIO $ length (acs1 <> acs2) `shouldBe` length conns
+    liftIO $ threadDelay 1500000
+    forM_ conns $ \(aliceId, bobId) -> do
+      msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
+      get b ##> ("", aliceId, SENT msgId)
+      _ <- messageNotificationData a apnsQ
+      get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
+  where
+    runServers :: ExceptT AgentErrorType IO a -> IO a
+    runServers a = do
+      withSmpServerStoreLogOn t testPort $ \t1 -> do
+        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
+          runRight a `finally` killThread t2
+        killThread t1
+        pure res
+
 testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
 testSwitchNotifications servers APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient' agentCfg servers testDB
@@ -496,7 +547,7 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
           get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
           ackMessage a bId msgId
     testMessage "hello"
-    switchConnectionAsync a "" bId
+    _ <- switchConnectionAsync a "" bId
     switchComplete a bId b aId
     liftIO $ threadDelay 500000
     testMessage "hello again"

From e3fff98b1bb2802608fce2c8e33202c1d80e4a59 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sun, 25 Jun 2023 09:31:55 +0100
Subject: [PATCH 16/49] 5.1.2, ntf server 1.4.1

---
 package.yaml                                       | 2 +-
 simplexmq.cabal                                    | 2 +-
 src/Simplex/Messaging/Notifications/Server/Main.hs | 2 +-
 3 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/package.yaml b/package.yaml
index c610d89f7..bf8d45b26 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.1.1
+version: 5.1.2
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 3a3ef9c86..341e1a1d1 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.1.1
+version:        5.1.2
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index ccd5d6b31..5eee65e71 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -28,7 +28,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.4.0"
+ntfServerVersion = "1.4.1"
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =

From 3a74558e8449faa65dd6c72f01d3856d748f8102 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Mon, 26 Jun 2023 21:03:46 +0400
Subject: [PATCH 17/49] fix connection switch status db encoding (#781)

---
 src/Simplex/Messaging/Agent/Protocol.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 8f09b26ff..1f993b3b6 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -159,7 +159,7 @@ import qualified Data.Map as M
 import Data.Maybe (isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Time.ISO8601
@@ -522,9 +522,9 @@ instance StrEncoding RcvSwitchStatus where
       "received_message" -> pure RSReceivedMessage
       _ -> fail "bad RcvSwitchStatus"
 
-instance ToField RcvSwitchStatus where toField = toField . strEncode
+instance ToField RcvSwitchStatus where toField = toField . decodeLatin1 . strEncode
 
-instance FromField RcvSwitchStatus where fromField = blobFieldDecoder $ parseAll strP
+instance FromField RcvSwitchStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
 instance ToJSON RcvSwitchStatus where
   toEncoding = strToJEncoding
@@ -548,9 +548,9 @@ instance StrEncoding SndSwitchStatus where
       "sending_qtest" -> pure SSSendingQTEST
       _ -> fail "bad SndSwitchStatus"
 
-instance ToField SndSwitchStatus where toField = toField . strEncode
+instance ToField SndSwitchStatus where toField = toField . decodeLatin1 . strEncode
 
-instance FromField SndSwitchStatus where fromField = blobFieldDecoder $ parseAll strP
+instance FromField SndSwitchStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
 instance ToJSON SndSwitchStatus where
   toEncoding = strToJEncoding

From 4a927d1ae23985ab798a045bc0cfcfbf3b671a43 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 26 Jun 2023 20:14:35 +0100
Subject: [PATCH 18/49] ntf server: better batching and logging (#780)

* ntf server: better batching and logging

* reduce batch delay for ntf server

* comments

* 5.1.3, ntf 1.4.2

* more logging

* more logging

* split large batches, more logging

* remove some logs
---
 package.yaml                                  |   2 +-
 simplexmq.cabal                               |   2 +-
 src/Simplex/FileTransfer/Client/Main.hs       |   9 +-
 src/Simplex/FileTransfer/Description.hs       |  11 +-
 src/Simplex/Messaging/Agent/Store/SQLite.hs   |   9 +-
 src/Simplex/Messaging/Client.hs               |  15 ++-
 src/Simplex/Messaging/Client/Agent.hs         |  56 ++++-----
 .../Messaging/Notifications/Protocol.hs       |   2 +-
 src/Simplex/Messaging/Notifications/Server.hs | 106 ++++++++++--------
 .../Messaging/Notifications/Server/Env.hs     |   3 +-
 .../Messaging/Notifications/Server/Main.hs    |  23 ++--
 src/Simplex/Messaging/Protocol.hs             |   7 +-
 src/Simplex/Messaging/Server.hs               |   2 +-
 src/Simplex/Messaging/Server/Main.hs          |   2 +-
 src/Simplex/Messaging/Util.hs                 |  12 ++
 tests/AgentTests/FunctionalAPITests.hs        |   4 +-
 tests/NtfClient.hs                            |   3 +-
 tests/SMPClient.hs                            |   2 +-
 tests/ServerTests.hs                          |   2 +-
 19 files changed, 149 insertions(+), 123 deletions(-)

diff --git a/package.yaml b/package.yaml
index bf8d45b26..8a9b664db 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.1.2
+version: 5.1.3
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 341e1a1d1..601e0a2e5 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.1.2
+version:        5.1.3
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index badf4e7c0..20b6d177d 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -38,9 +38,8 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
-import Data.Function (on)
 import Data.Int (Int64)
-import Data.List (foldl', groupBy, sortOn)
+import Data.List (foldl', sortOn)
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
@@ -66,7 +65,7 @@ import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, XFTPServer, XFTPServerWithAuth)
 import Simplex.Messaging.Server.CLI (getCliCommand')
-import Simplex.Messaging.Util (ifM, tshow, whenM)
+import Simplex.Messaging.Util (groupAllOn, ifM, tshow, whenM)
 import System.Exit (exitFailure)
 import System.FilePath (splitFileName, (</>))
 import System.IO.Temp (getCanonicalTemporaryDirectory)
@@ -316,7 +315,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers)
       srvs <- liftIO $ replicateM (length chunks) $ getXFTPServer gen xftpSrvs
       let thd3 (_, _, x) = x
-          chunks' = groupBy ((==) `on` thd3) $ sortOn thd3 $ zip3 [1 ..] chunks srvs
+          chunks' = groupAllOn thd3 $ zip3 [1 ..] chunks srvs
       -- TODO shuffle/unshuffle chunks
       -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
       -- upload doesn't allow other requests within the same client until complete (but download does allow).
@@ -428,7 +427,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       liftIO $ printNoNewLine "Downloading file..."
       downloadedChunks <- newTVarIO []
       let srv FileChunk {replicas} = server (head replicas :: FileChunkReplica)
-          srvChunks = groupBy ((==) `on` srv) $ sortOn srv chunks
+          srvChunks = groupAllOn srv chunks
       chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks)
       encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
       when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 316070f7f..0fa99e372 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -42,9 +42,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Function (on)
 import Data.Int (Int64)
-import Data.List (foldl', groupBy, sortOn)
+import Data.List (foldl', sortOn)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
@@ -59,7 +58,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (XFTPServer)
-import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.Util (bshow, groupAllOn, (<$?>))
 
 data FileDescription (p :: FileParty) = FileDescription
   { party :: SFileParty p,
@@ -258,9 +257,7 @@ instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toFiel
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =
-  groupBy ((==) `on` replicaServer)
-    . sortOn replicaServer
-    . unfoldChunksToReplicas defChunkSize
+  groupAllOn replicaServer . unfoldChunksToReplicas defChunkSize
 
 encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas]
 encodeFileReplicas defChunkSize =
@@ -268,7 +265,7 @@ encodeFileReplicas defChunkSize =
   where
     encodeServerReplicas fs =
       YAMLServerReplicas
-        { server = replicaServer $ head fs, -- groupBy guarantees that fs is not empty
+        { server = replicaServer $ head fs, -- groupAllOn guarantees that fs is not empty
           chunks = map (B.unpack . encodeServerReplica) fs
         }
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index aacb7d54b..6a9341b74 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -208,11 +208,10 @@ import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import Data.Char (toLower)
-import Data.Function (on)
 import Data.Functor (($>))
 import Data.IORef
 import Data.Int (Int64)
-import Data.List (foldl', groupBy, intercalate, sortBy)
+import Data.List (foldl', intercalate, sortBy)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
@@ -250,7 +249,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, s
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, groupOn, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
@@ -1092,7 +1091,9 @@ insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
 
 getPendingCommands :: DB.Connection -> ConnId -> IO [(Maybe SMPServer, [AsyncCmdId])]
 getPendingCommands db connId = do
-  map (\ids -> (fst $ head ids, map snd ids)) . groupBy ((==) `on` fst) . map srvCmdId
+  -- `groupOn` is used instead of `groupAllOn` to avoid extra sorting by `server + cmdId`, as the query already sorts by them.
+  -- TODO review whether this can break if, e.g., the server has another key hash.
+  map (\ids -> (fst $ head ids, map snd ids)) . groupOn fst . map srvCmdId
     <$> DB.query
       db
       [sql|
diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index 6cd14fcda..6e8b22c2f 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -219,8 +219,10 @@ data ProtocolClientConfig = ProtocolClientConfig
     defaultTransport :: (ServiceName, ATransport),
     -- | network configuration
     networkConfig :: NetworkConfig,
-    -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange
+    -- | client-server protocol version range
+    serverVRange :: VersionRange,
+    -- | delay between sending batches of commands (microseconds)
+    batchDelay :: Maybe Int
   }
 
 -- | Default protocol client configuration.
@@ -230,7 +232,8 @@ defaultClientConfig =
     { qSize = 64,
       defaultTransport = ("443", transport @TLS),
       networkConfig = defaultNetworkConfig,
-      smpServerVRange = supportedSMPServerVRange
+      serverVRange = supportedSMPServerVRange,
+      batchDelay = Nothing
     }
 
 data Request err msg = Request
@@ -276,7 +279,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
 getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
-getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
+getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
@@ -329,7 +332,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
 
     client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO ()
     client _ c cVar h =
-      runExceptT (protocolClientHandshake @err @msg h (keyHash srv) smpServerVRange) >>= \case
+      runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {sessionId, thVersion} -> do
           sessionTs <- getCurrentTime
@@ -341,7 +344,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
             `finally` disconnected c'
 
     send :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
-    send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h batchDelay
 
     receive :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
     receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index dad9d709a..a59424f24 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -17,14 +17,16 @@ import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, bimap)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.List (find, partition)
+import Data.Either (partitionEithers)
+import Data.List (partition)
 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 (listToMaybe)
 import Data.Set (Set)
 import Data.Text.Encoding
 import Data.Tuple (swap)
@@ -43,7 +45,6 @@ import UnliftIO (async)
 import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
-import Data.Either (isLeft)
 
 type SMPClientVar = TMVar (Either SMPClientError SMPClient)
 
@@ -51,8 +52,8 @@ data SMPClientAgentEvent
   = CAConnected SMPServer
   | CADisconnected SMPServer (Set SMPSub)
   | CAReconnected SMPServer
-  | CAResubscribed SMPServer SMPSub
-  | CASubError SMPServer SMPSub SMPClientError
+  | CAResubscribed SMPServer (NonEmpty SMPSub)
+  | CASubError SMPServer (NonEmpty (SMPSub, SMPClientError))
 
 data SMPSubParty = SPRecipient | SPNotifier
   deriving (Eq, Ord, Show)
@@ -208,45 +209,36 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
     reconnectClient :: ExceptT SMPClientError IO ()
     reconnectClient = do
       withSMP ca srv $ \smp -> do
-        liftIO . notify $ CAReconnected srv
+        liftIO $ notify $ CAReconnected srv
         cs_ <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
         forM_ cs_ $ \cs -> do
           subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
           let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
-          nRs <- liftIO $ subscribe_ smp SPNotifier nSubs
-          rRs <- liftIO $ subscribe_ smp SPRecipient rSubs
-          case find isLeft $ nRs <> rRs of
-            Just (Left e) -> throwE e
-            _ -> pure ()
+          subscribe_ smp SPNotifier nSubs
+          subscribe_ smp SPRecipient rSubs
       where
         isNotifier = \case
           SPNotifier -> True
           SPRecipient -> False
 
-        subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> IO [Either SMPClientError ()]
+        subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> ExceptT SMPClientError IO ()
         subscribe_ smp party subs =
           case L.nonEmpty subs of
             Just subs' -> do
-              let subs'' = L.map (first snd) subs'
-              rs <- L.zip subs'' <$> smpSubscribeQueues party ca smp srv subs''
-              rs' <- forM rs $ \(sub, r) -> do
-                let sub' = first (party,) sub
-                    s = fst sub'
-                case snd r of
-                  Right () -> do
-                    atomically $ addSubscription ca srv sub'
-                    notify $ CAResubscribed srv s
-                    pure $ Right ()
-                  Left e -> do
-                    case e of
-                      PCEResponseTimeout -> pure $ Left e
-                      PCENetworkError -> pure $ Left e
-                      _ -> do
-                        notify $ CASubError srv s e
-                        atomically $ removePendingSubscription ca srv s
-                        pure $ Right ()
-              pure $ L.toList rs'
-            Nothing -> pure []
+              let subs'' :: (NonEmpty (QueueId, C.APrivateSignKey)) = L.map (first snd) subs'
+              rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
+              let rs' :: (NonEmpty ((SMPSub, C.APrivateSignKey), Either SMPClientError ())) =
+                    L.zipWith (first . const) subs' rs
+                  rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateSignKey)] =
+                    map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs'
+                  (errs, oks) = partitionEithers rs''
+                  (tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
+              mapM_ (atomically . addSubscription ca srv) oks
+              mapM_ (liftIO . notify . CAResubscribed srv) $ L.nonEmpty $ map fst oks
+              mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs 
+              mapM_ (liftIO . notify . CASubError srv) $ L.nonEmpty finalErrs
+              mapM_ (throwE . snd) $ listToMaybe tempErrs
+            Nothing -> pure ()
 
     notify :: SMPClientAgentEvent -> IO ()
     notify evt = atomically $ writeTBQueue (agentQ ca) evt
diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs
index 90e32bc38..34f93d8a7 100644
--- a/src/Simplex/Messaging/Notifications/Protocol.hs
+++ b/src/Simplex/Messaging/Notifications/Protocol.hs
@@ -429,7 +429,7 @@ data NtfSubStatus
     NSAuth
   | -- | SMP error other than AUTH
     NSErr ByteString
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 ntfShouldSubscribe :: NtfSubStatus -> Bool
 ntfShouldSubscribe = \case
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 209975d5b..8c6c6bc03 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -16,16 +16,17 @@ import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.Reader
+import Data.Bifunctor (second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Function (on)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (intercalate)
+import Data.List (intercalate, sort)
 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)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
@@ -55,11 +56,10 @@ import System.Exit (exitFailure)
 import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
 import System.Mem.Weak (deRefWeak)
 import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
-import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
+import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.STM
-import Data.Bifunctor (second)
 
 runNtfServer :: NtfServerConfig -> IO ()
 runNtfServer cfg = do
@@ -147,23 +147,28 @@ ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
 resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
 resubscribe NtfSubscriber {newSubQ} subs = do
   subs' <- atomically $ filterM (fmap ntfShouldSubscribe . readTVar . subStatus) $ M.elems subs
-  mapM_ (atomically . writeTBQueue newSubQ . L.map NtfSub) $ L.nonEmpty subs'
-  liftIO $ logInfo "SMP connections resubscribed"
+  atomically . writeTBQueue newSubQ $ map NtfSub subs'
+  liftIO $ logInfo $ "SMP resubscriptions queued (" <> tshow (length subs') <> " subscriptions)"
 
 ntfSubscriber :: NtfSubscriber -> M ()
 ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
   raceAny_ [subscribe, receiveSMP, receiveAgent]
   where
     subscribe :: M ()
-    subscribe = do
-      d <- asks $ resubscribeDelay . config
-      forever $ do
-        subs <- atomically (readTBQueue newSubQ)
-        let ss = L.groupBy ((==) `on` server) subs
-        forM_ ss $ \serverSubs -> do
-          SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber $ server $ L.head serverSubs
-          atomically $ writeTQueue subscriberSubQ serverSubs
-          when (length serverSubs > 10) $ threadDelay d
+    subscribe = forever $ do
+      subs <- atomically (readTBQueue newSubQ)
+      let ss = L.groupAllWith server subs
+      forM_ ss $ \serverSubs -> do
+        let srv = server $ L.head serverSubs
+            batches = toChunks 900 $ L.toList serverSubs
+        SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber srv
+        mapM_ (atomically . writeTQueue subscriberSubQ) batches
+
+    toChunks :: Int -> [a] -> [NonEmpty a]
+    toChunks _ [] = []
+    toChunks n xs =
+      let (ys, xs') = splitAt n xs
+      in maybe id (:) (L.nonEmpty ys) (toChunks n xs')
 
     server :: NtfEntityRec 'Subscription -> SMPServer
     server (NtfSub sub) = ntfSubServer sub
@@ -184,21 +189,26 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       forever $ do
         subs <- atomically (peekTQueue subscriberSubQ)
         let subs' = L.map (\(NtfSub sub) -> sub) subs
+            srv = server $ L.head subs
+        logSubStatus srv "subscribing" $ length subs
         mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs'
-        rs <- liftIO $ subscribeQueues (server $ L.head subs) subs'
-        subs_ <- L.nonEmpty <$> foldM process [] rs
+        rs <- liftIO $ subscribeQueues srv subs'
+        (subs'', oks, errs) <- foldM process ([], 0, []) rs
         atomically $ do
           void $ readTQueue subscriberSubQ
-          mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) subs_
+          mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) $ L.nonEmpty subs''
+        logSubStatus srv "retrying" $ length subs''
+        logSubStatus srv "subscribed" oks
+        logSubErrors srv errs
       where
-        process subs (sub@NtfSubData {smpQueue}, r) = case r of
-          Right _ -> updateSubStatus smpQueue NSActive $> subs
-          Left err -> do
-            handleSubError smpQueue err
-            pure $ case err of
-              PCEResponseTimeout -> sub : subs
-              PCENetworkError -> sub : subs
-              _ -> subs
+        process :: ([NtfSubData], Int, [NtfSubStatus]) -> (NtfSubData, Either SMPClientError ()) -> M ([NtfSubData], Int, [NtfSubStatus])
+        process (subs, oks, errs) (sub@NtfSubData {smpQueue}, r) = case r of
+          Right _ -> updateSubStatus smpQueue NSActive $> (subs, oks + 1, errs)
+          Left e -> update <$> handleSubError smpQueue e
+          where
+            update = \case
+              Just err -> (subs, oks, err : errs) -- permanent error, log and don't retry subscription
+              Nothing -> (sub : subs, oks, errs) -- temporary error, retry subscription
 
     -- | Subscribe to queues. The list of results can have a different order.
     subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ()))
@@ -230,37 +240,43 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
         atomically (readTBQueue agentQ) >>= \case
           CAConnected _ -> pure ()
           CADisconnected srv subs -> do
-            logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
+            logSubStatus srv "disconnected" $ length subs
             forM_ subs $ \(_, ntfId) -> do
               let smpQueue = SMPQueueNtf srv ntfId
               updateSubStatus smpQueue NSInactive
           CAReconnected srv ->
             logInfo $ "SMP server reconnected " <> showServer' srv
-          CAResubscribed srv sub -> do
-            let ntfId = snd sub
-                smpQueue = SMPQueueNtf srv ntfId
-            updateSubStatus smpQueue NSActive
-          CASubError srv (_, ntfId) err -> do
-            logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
-            handleSubError (SMPQueueNtf srv ntfId) err
-      where
-        showServer' = decodeLatin1 . strEncode . host
+          CAResubscribed srv subs -> do
+            forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive
+            logSubStatus srv "resubscribed" $ length subs
+          CASubError srv errs ->
+            forM errs (\((_, ntfId), err) -> handleSubError (SMPQueueNtf srv ntfId) err)
+              >>= logSubErrors srv . catMaybes . L.toList
 
-    handleSubError :: SMPQueueNtf -> SMPClientError -> M ()
+    logSubStatus srv event n = when (n > 0) $
+      logInfo $ "SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subscriptions)"
+
+    logSubErrors :: SMPServer -> [NtfSubStatus] -> M ()        
+    logSubErrors srv errs = forM_ (L.group $ sort errs) $ \errs' -> do
+      logError $ "SMP subscription errors on server " <> showServer' srv <> ": " <> tshow (L.head errs') <> " (" <> tshow (length errs') <> " errors)"
+
+    showServer' = decodeLatin1 . strEncode . host
+
+    handleSubError :: SMPQueueNtf -> SMPClientError -> M (Maybe NtfSubStatus)
     handleSubError smpQueue = \case
-      PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
+      PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth $> Just NSAuth
       PCEProtocolError e -> updateErr "SMP error " e
-      PCEIOError e -> updateErr "IOError " e
       PCEResponseError e -> updateErr "ResponseError " e
       PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
       PCETransportError e -> updateErr "TransportError " e
       PCECryptoError e -> updateErr "CryptoError " e
-      PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
-      PCEResponseTimeout -> pure ()
-      PCENetworkError -> pure ()
+      PCEIncompatibleHost -> let e = NSErr "IncompatibleHost" in updateSubStatus smpQueue e $> Just e
+      PCEResponseTimeout -> pure Nothing
+      PCENetworkError -> pure Nothing
+      PCEIOError _ -> pure Nothing
       where
-        updateErr :: Show e => ByteString -> e -> M ()
-        updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
+        updateErr :: Show e => ByteString -> e -> M (Maybe NtfSubStatus)
+        updateErr errType e = updateSubStatus smpQueue (NSErr $ errType <> bshow e) $> Just (NSErr errType)
 
     updateSubStatus smpQueue status = do
       st <- asks store
@@ -354,7 +370,7 @@ receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
 send :: Transport c => THandle c -> NtfServerClient -> IO ()
 send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
+  void . liftIO $ tPut h Nothing [(Nothing, encodeTransmission v sessionId t)]
   atomically . writeTVar activeAt =<< liftIO getSystemTime
 
 -- instance Show a => Show (TVar a) where
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index 5bff6df21..f9f3926c5 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -48,7 +48,6 @@ data NtfServerConfig = NtfServerConfig
     apnsConfig :: APNSPushClientConfig,
     inactiveClientExpiration :: Maybe ExpirationConfig,
     storeLogFile :: Maybe FilePath,
-    resubscribeDelay :: Int, -- microseconds
     -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -94,7 +93,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
 
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriber,
-    newSubQ :: TBQueue (NonEmpty (NtfEntityRec 'Subscription)),
+    newSubQ :: TBQueue [NtfEntityRec 'Subscription],
     smpAgent :: SMPClientAgent
   }
 
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index 5eee65e71..efe6aeb2a 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -14,7 +14,8 @@ import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Network.Socket (HostName)
 import Options.Applicative
-import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+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 (..))
@@ -28,7 +29,10 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.4.1"
+ntfServerVersion = "1.4.2"
+
+defaultSMPBatchDelay :: Int
+defaultSMPBatchDelay = 10000
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =
@@ -80,7 +84,9 @@ ntfServerCLI cfgPath logPath =
             <> ("host: " <> host <> "\n")
             <> ("port: " <> defaultServerPort <> "\n")
             <> "log_tls_errors: off\n\
-               \websockets: off\n"
+               \# delay between command batches sent to SMP relays (microseconds), 0 to disable\n"
+            <> ("smp_batch_delay: " <> show defaultSMPBatchDelay <> "\n")
+            <> "websockets: off\n"
     runServer ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
@@ -96,19 +102,20 @@ ntfServerCLI cfgPath logPath =
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
+        smpBatchDelay = readIniDefault defaultSMPBatchDelay "TRANSPORT" "smp_batch_delay" ini
+        batchDelay = if smpBatchDelay <= 0 then Nothing else Just smpBatchDelay
         serverConfig =
           NtfServerConfig
             { transports = iniTransports ini,
               subIdBytes = 24,
               regCodeBytes = 32,
-              clientQSize = 16,
-              subQSize = 64,
-              pushQSize = 128,
-              smpAgentCfg = defaultSMPClientAgentConfig,
+              clientQSize = 64,
+              subQSize = 512,
+              pushQSize = 1048,
+              smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
               apnsConfig = defaultAPNSPushClientConfig,
               inactiveClientExpiration = Nothing,
               storeLogFile = enableStoreLog $> storeLogFilePath,
-              resubscribeDelay = 50000, -- 50ms
               caCertificateFile = c caCrtFile,
               privateKeyFile = c serverKeyFile,
               certificateFile = c serverCrtFile,
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 31245e887..31bf0ee4c 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -146,6 +146,7 @@ module Simplex.Messaging.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Concurrent (threadDelay)
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
@@ -1244,8 +1245,8 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
-tPut th trs
+tPut :: Transport c => THandle c -> Maybe Int -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
+tPut th delay_ trs 
   | batch th = tPutBatch [] $ L.map tEncode trs
   | otherwise = forM (L.toList trs) $ tPutLog . tEncode
   where
@@ -1255,7 +1256,7 @@ tPut th trs
       r <- if n == 0 then largeMsg else replicate n <$> tPutLog (tEncodeBatch n s)
       let rs' = rs <> r
       case ts_ of
-        Just ts' -> tPutBatch rs' ts'
+        Just ts' -> mapM_ threadDelay delay_ >> tPutBatch rs' ts'
         _ -> pure rs'
     largeMsg = putStrLn "tPut error: large message" >> pure [Left TELargeMsg]
     tPutLog s = do
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index c02d6927d..e8d664799 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -281,7 +281,7 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
 send :: Transport c => THandle c -> Client -> IO ()
 send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
   ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-  void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
+  void . liftIO . tPut h Nothing $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
   atomically . writeTVar activeAt =<< liftIO getSystemTime
   where
     tOrder :: Transmission BrokerMsg -> Int
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index 80f9bc18a..004f72971 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -164,7 +164,7 @@ smpServerCLI cfgPath logPath =
         serverConfig =
           ServerConfig
             { transports = iniTransports ini,
-              tbqSize = 32,
+              tbqSize = 64,
               serverTbqSize = 1024,
               msgQueueQuota = 128,
               queueIdBytes = 24,
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index 9db3901aa..ec3678b39 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -18,6 +18,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Time (NominalDiffTime)
 import UnliftIO.Async
+import Data.List (groupBy, sortOn)
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
 raceAny_ = r []
@@ -102,6 +103,17 @@ eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
 
+groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
+groupOn = groupBy . eqOn
+    -- it is equivalent to groupBy ((==) `on` f),
+    -- but it redefines `on` to avoid duplicate computation for most values.
+    -- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
+    -- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
+    where eqOn f = \x -> let fx = f x in \y -> fx == f y
+
+groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
+groupAllOn f = groupOn f . sortOn f
+
 safeDecodeUtf8 :: ByteString -> Text
 safeDecodeUtf8 = decodeUtf8With onError
   where
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index e33c52a09..3d30f6548 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -105,7 +105,7 @@ pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 smpCfgV1 :: ProtocolClientConfig
-smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = vr11}
+smpCfgV1 = (smpCfg agentCfg) {serverVRange = vr11}
 
 agentCfgV1 :: AgentConfig
 agentCfgV1 = agentCfg {smpAgentVRange = vr11, smpClientVRange = vr11, e2eEncryptVRange = vr11, smpCfg = smpCfgV1}
@@ -1381,7 +1381,7 @@ testCreateQueueAuth clnt1 clnt2 = do
   where
     getClient (clntAuth, clntVersion) =
       let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]}
-          smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion}
+          smpCfg = (defaultClientConfig :: ProtocolClientConfig) {serverVRange = mkVersionRange 4 clntVersion}
        in getSMPAgentClient' agentCfg {smpCfg} servers testDB
 
 testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs
index f0a9a1d47..3984ff881 100644
--- a/tests/NtfClient.hs
+++ b/tests/NtfClient.hs
@@ -90,7 +90,6 @@ ntfServerCfg =
           },
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       storeLogFile = Nothing,
-      resubscribeDelay = 1000,
       -- CA certificate private key is not needed for initialization
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
@@ -134,7 +133,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
   where
     tPut' h (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+      [Right ()] <- tPut h Nothing [(sig, t')]
       pure ()
     tGet' h = do
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs
index 7d9113fdd..3e60b9061 100644
--- a/tests/SMPClient.hs
+++ b/tests/SMPClient.hs
@@ -159,7 +159,7 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
   where
     tPut' h (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+      [Right ()] <- tPut h Nothing [(sig, t')]
       pure ()
     tGet' h = do
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs
index 581e18166..74b24bbc3 100644
--- a/tests/ServerTests.hs
+++ b/tests/ServerTests.hs
@@ -88,7 +88,7 @@ signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
 
 tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
 tPut1 h t = do
-  [r] <- tPut h [t]
+  [r] <- tPut h Nothing [t]
   pure r
 
 tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd)

From f7d038ef20d7dc365ac88ce31b21a57699289cab Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 28 Jun 2023 19:50:11 +0100
Subject: [PATCH 19/49] agent: more batched commands (#782)

* agent: more batched commands

* layout
---
 src/Simplex/Messaging/Agent/Client.hs | 49 +++++++++++++++++----------
 src/Simplex/Messaging/Client.hs       |  8 +----
 src/Simplex/Messaging/Server.hs       |  1 +
 3 files changed, 33 insertions(+), 25 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 895f33943..05294aaaa 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -41,7 +41,9 @@ module Simplex.Messaging.Agent.Client
     temporaryOrHostError,
     secureQueue,
     enableQueueNotifications,
+    enableQueuesNtfs,
     disableQueueNotifications,
+    disableQueuesNtfs,
     sendAgentMessage,
     agentNtfRegisterToken,
     agentNtfVerifyToken,
@@ -161,9 +163,6 @@ import Simplex.Messaging.Protocol
     ErrorType,
     MsgFlags (..),
     MsgId,
-    NotifierId,
-    NtfPrivateSignKey,
-    NtfPublicVerifyKey,
     NtfServer,
     ProtoServer,
     ProtoServerWithAuth (..),
@@ -876,11 +875,13 @@ subscribeQueues c qs = do
     modifyTVar (subscrConns c) $ S.insert connId
     RQ.addQueue rq $ pendingSubs c
   u <- askUnliftIO
-  (errs <>) <$> sendTSessionBatches "SUB" 90 (subscribeQueues_ u) c qs
+  -- only "checked" queues are subscribed
+  (errs <>) <$> sendTSessionBatches "SUB" 90 id (subscribeQueues_ u) c qs'
   where
     checkQueue rq@RcvQueue {rcvId, server} = do
       prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
       pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq
+    subscribeQueues_ :: UnliftIO m -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
     subscribeQueues_ u smp qs' = do
       rs <- sendBatch subscribeSMPQueues smp qs'
       mapM_ (uncurry $ processSubResult c) rs
@@ -888,25 +889,25 @@ subscribeQueues c qs = do
         unliftIO u $ reconnectServer c $ transportSession' smp
       pure rs
 
-type BatchResponses e = (NonEmpty (RcvQueue, Either e ()))
+type BatchResponses e r = (NonEmpty (RcvQueue, Either e r))
 
 -- statBatchSize is not used to batch the commands, only for traffic statistics
-sendTSessionBatches :: forall m. AgentMonad m => ByteString -> Int -> (SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError)) -> AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
-sendTSessionBatches statCmd statBatchSize action c qs =
+sendTSessionBatches :: forall m q r. AgentMonad m => ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> m [(RcvQueue, Either AgentErrorType r)]
+sendTSessionBatches statCmd statBatchSize toRQ action c qs =
   concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
   where
-    batchQueues :: m [(SMPTransportSession, NonEmpty RcvQueue)]
+    batchQueues :: m [(SMPTransportSession, NonEmpty q)]
     batchQueues = do
       mode <- sessionMode <$> readTVarIO (useNetworkConfig c)
       pure . M.assocs $ foldl' (batch mode) M.empty qs
       where
-        batch mode m rq =
-          let tSess = mkSMPTSession rq mode
-           in M.alter (Just . maybe [rq] (rq <|)) tSess m
-    sendClientBatch :: (SMPTransportSession, NonEmpty RcvQueue) -> m (BatchResponses AgentErrorType)
+        batch mode m q =
+          let tSess = mkSMPTSession (toRQ q) mode
+           in M.alter (Just . maybe [q] (q <|)) tSess m
+    sendClientBatch :: (SMPTransportSession, NonEmpty q) -> m (BatchResponses AgentErrorType r)
     sendClientBatch (tSess@(userId, srv, _), qs') =
       tryError (getSMPServerClient c tSess) >>= \case
-        Left e -> pure $ L.map (,Left e) qs'
+        Left e -> pure $ L.map ((,Left e) . toRQ) qs'
         Right smp -> liftIO $ do
           logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
           rs <- L.map agentError <$> action smp qs'
@@ -916,9 +917,9 @@ sendTSessionBatches statCmd statBatchSize action c qs =
             agentError = second . first $ protocolClientError SMP $ clientServer smp
             statBatch =
               let n = (length qs - 1) `div` statBatchSize + 1
-               in incClientStatN c userId smp n (statCmd <> "S") "OK"
+               in incClientStatN c userId smp n statCmd "OK"
 
-sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError)
+sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
 sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
   where
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
@@ -1001,16 +1002,28 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
   withSMPClient c rq "KEY <key>" $ \smp ->
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
-enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (NotifierId, RcvNtfPublicDhKey)
+enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicVerifyKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
 enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
   withSMPClient c rq "NKEY <nkey>" $ \smp ->
     enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
 
+enableQueuesNtfs :: forall m. AgentMonad m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
+enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_
+  where
+    fst3 (x, _, _) = x
+    enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
+    enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
+    queueCreds :: (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateSignKey, SMP.RecipientId, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)
+    queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey)
+
 disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
   withSMPClient c rq "NDEL" $ \smp ->
     disableSMPQueueNotifications smp rcvPrivateKey rcvId
 
+disableQueuesNtfs :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueuesNtfs
+
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
 sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
   withSMPClient c rq "ACK" $ \smp ->
@@ -1032,7 +1045,7 @@ deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
     deleteSMPQueue smp rcvPrivateKey rcvId
 
 deleteQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
-deleteQueues = sendTSessionBatches "DEL" 90 $ sendBatch deleteSMPQueues
+deleteQueues = sendTSessionBatches "DEL" 90 id $ sendBatch deleteSMPQueues
 
 sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
 sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg =
@@ -1065,7 +1078,7 @@ agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> W
 agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
   withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
 
-agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> NtfPrivateSignKey -> m NtfSubscriptionId
+agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateSignKey -> m NtfSubscriptionId
 agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
   withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
 
diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index 6e8b22c2f..957bd3bad 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -493,13 +493,7 @@ subscribeSMPQueueNotifications = okSMPCommand NSUB
 
 -- | Subscribe to multiple SMP queues notifications batching commands if supported.
 subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
-subscribeSMPQueuesNtfs c qs = sendProtocolCommands c cs >>= mapM response
-  where
-    cs = L.map (\(npKey, nId) -> (Just npKey, nId, Cmd SNotifier NSUB)) qs
-    response r = pure $ case r of
-      Right OK -> Right ()
-      Right r' -> Left . PCEUnexpectedResponse $ bshow r'
-      Left e -> Left e
+subscribeSMPQueuesNtfs = okSMPCommands NSUB
 
 -- | Secure the SMP queue by adding a sender public key.
 --
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index e8d664799..fa30520ff 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -287,6 +287,7 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
     tOrder :: Transmission BrokerMsg -> Int
     tOrder (_, _, cmd) = case cmd of
       MSG {} -> 0
+      NMSG {} -> 0
       _ -> 1
 
 disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()

From c8a8e2c297f45b72184858f8ae098c8a55a5e1db Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 29 Jun 2023 10:00:53 +0400
Subject: [PATCH 20/49] differentiate agent INACTIVE error, treat as temporary
 (#784)

---
 src/Simplex/Messaging/Agent/Client.hs   |  7 +++---
 src/Simplex/Messaging/Agent/Protocol.hs |  4 ++++
 tests/AgentTests/FunctionalAPITests.hs  | 31 +++++++++++++++++++++++++
 3 files changed, 39 insertions(+), 3 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 05294aaaa..d4289749b 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -399,7 +399,7 @@ instance ProtocolServerClient XFTPErrorType FileResponse where
 
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
 getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
-  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  unlessM (readTVarIO active) . throwError $ INACTIVE
   atomically (getClientVar tSess smpClients)
     >>= either
       (newProtocolClient c tSess smpClients connectClient reconnectSMPClient)
@@ -467,7 +467,7 @@ reconnectSMPClient c tSess@(_, srv, _) =
 
 getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
 getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
-  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  unlessM (readTVarIO active) . throwError $ INACTIVE
   atomically (getClientVar tSess ntfClients)
     >>= either
       (newProtocolClient c tSess ntfClients connectClient $ \_ _ -> pure ())
@@ -487,7 +487,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
 
 getXFTPServerClient :: forall m. AgentMonad m => AgentClient -> XFTPTransportSession -> m XFTPClient
 getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do
-  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  unlessM (readTVarIO active) . throwError $ INACTIVE
   atomically (getClientVar tSess xftpClients)
     >>= either
       (newProtocolClient c tSess xftpClients connectClient $ \_ _ -> pure ())
@@ -860,6 +860,7 @@ temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
   BROKER _ NETWORK -> True
   BROKER _ TIMEOUT -> True
+  INACTIVE -> True
   _ -> False
 
 temporaryOrHostError :: AgentErrorType -> Bool
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 1f993b3b6..1a4f1f83f 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -1271,6 +1271,8 @@ data AgentErrorType
     AGENT {agentErr :: SMPAgentError}
   | -- | agent implementation or dependency errors
     INTERNAL {internalErr :: String}
+  | -- | agent inactive
+    INACTIVE
   deriving (Eq, Generic, Show, Exception)
 
 instance ToJSON AgentErrorType where
@@ -1385,6 +1387,7 @@ instance StrEncoding AgentErrorType where
       <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
       <|> "AGENT " *> (AGENT <$> parseRead1)
       <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
+      <|> "INACTIVE" *> pure INACTIVE
     where
       textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
   strEncode = \case
@@ -1400,6 +1403,7 @@ instance StrEncoding AgentErrorType where
     AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
     AGENT e -> "AGENT " <> bshow e
     INTERNAL e -> "INTERNAL " <> bshow e
+    INACTIVE -> "INACTIVE"
     where
       text = encodeUtf8 . T.pack
 
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index 3d30f6548..df0d9dfb5 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -161,6 +161,8 @@ functionalAPITests t = do
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
   describe "Message delivery" $ do
+    it "should deliver message after client restart" $
+      testDeliverClientRestart t
     it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
       testDuplicateMessage t
     it "should report error via msg integrity on skipped messages" $
@@ -473,6 +475,35 @@ testAsyncHelloTimeout = do
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
 
+testDeliverClientRestart :: HasCallStack => ATransport -> IO ()
+testDeliverClientRestart t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+
+  (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    runRight $ do
+      (aliceId, bobId) <- makeConnection alice bob
+      exchangeGreetingsMsgId 4 alice bobId bob aliceId
+      pure (aliceId, bobId)
+
+  ("", "", DOWN _ _) <- nGet alice
+  ("", "", DOWN _ _) <- nGet bob
+
+  6 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello"
+
+  disconnectAgentClient bob
+
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    runRight_ $ do
+      ("", "", UP _ _) <- nGet alice
+
+      subscribeConnection bob2 aliceId
+
+      get bob2 ##> ("", aliceId, SENT 6)
+      get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+
 testDuplicateMessage :: HasCallStack => ATransport -> IO ()
 testDuplicateMessage t = do
   alice <- getSMPAgentClient' agentCfg initAgentServers testDB

From a000419bd7c7d4d67b23672edf39d1336f17e83c Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 29 Jun 2023 10:10:34 +0400
Subject: [PATCH 21/49] restore confirmation after client restart (#783)

---
 src/Simplex/Messaging/Agent.hs         |  1 +
 tests/AgentTests/FunctionalAPITests.hs | 40 ++++++++++++++++++++++++++
 2 files changed, 41 insertions(+)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index b729c7bd9..9c1185ab2 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -2130,6 +2130,7 @@ enqueueConfirmation c cData@ConnData {connId, connAgentVersion} sq connInfo e2eE
           msgType = agentMessageType agentMsg
           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
 
 -- encoded AgentMessage -> encoded EncAgentMessage
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index df0d9dfb5..c95d8f304 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -160,6 +160,8 @@ functionalAPITests t = do
       testAsyncServerOffline t
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
+    it "should restore confirmation after client restart" $
+      testAllowConnectionClientRestart t
   describe "Message delivery" $ do
     it "should deliver message after client restart" $
       testDeliverClientRestart t
@@ -475,6 +477,44 @@ testAsyncHelloTimeout = do
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
 
+testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO ()
+testAllowConnectionClientRestart t = do
+  let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]}
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServersSrv2 testDB2
+  withSmpServerStoreLogOn t testPort $ \_ -> do
+    (aliceId, bobId, confId) <-
+      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
+        runRight $ do
+          (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
+          aliceId <- joinConnection bob 1 True qInfo "bob's connInfo"
+          ("", _, CONF confId _ "bob's connInfo") <- get alice
+          pure (aliceId, bobId, confId)
+
+    ("", "", DOWN _ _) <- nGet bob
+
+    runRight_ $ do
+      allowConnectionAsync alice "1" bobId confId "alice's connInfo"
+      ("1", _, OK) <- get alice
+      pure ()
+
+    threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation)
+    disconnectAgentClient alice
+
+    alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+
+    withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
+      runRight $ do
+        ("", "", UP _ _) <- nGet bob
+
+        subscribeConnection alice2 bobId
+
+        get alice2 ##> ("", bobId, CON)
+        get bob ##> ("", aliceId, INFO "alice's connInfo")
+        get bob ##> ("", aliceId, CON)
+
+        exchangeGreetingsMsgId 4 alice2 bobId bob aliceId
+
 testDeliverClientRestart :: HasCallStack => ATransport -> IO ()
 testDeliverClientRestart t = do
   alice <- getSMPAgentClient' agentCfg initAgentServers testDB

From 8be2505fa044dd856321b14d0d2833ffc5b77a2d Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 30 Jun 2023 14:17:08 +0400
Subject: [PATCH 22/49] ratchet re-synchronization (#774)

* ratchet re-synchronization rfc wip

* additions

* additions, types

* fix tests

* re-sync implementation wip

* re-sync implementation 1st rev.

* test wip

* test passes

* doc

* wording

* improve doc schema

* single agreed state

* refactor (1 state variable)

* allowed -> required

* prohibit enqueue

* enqueue

* send via multiple queues

* test with server offline

* clarify errors

* rename

* more tests

* refactor

* rename AgentRKey

* rename AM_CONN_RATCHET_KEY

* more tests

* rename

* write encoded AgentRatchetInfo to AgentRatchetKey info

* move withConnLock

* refactor qDuplex

* re-create ratchet on receiving second key

* invert condition

* refactor

* simplify

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 rfcs/2023-06-08-resync-ratchets.md            | 366 ++++++++
 simplexmq.cabal                               |   1 +
 src/Simplex/Messaging/Agent.hs                | 848 +++++++++++-------
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |   2 +
 src/Simplex/Messaging/Agent/Protocol.hs       | 104 ++-
 src/Simplex/Messaging/Agent/Store.hs          |   4 +-
 src/Simplex/Messaging/Agent/Store/SQLite.hs   |  86 +-
 .../Agent/Store/SQLite/Migrations.hs          |   4 +-
 .../Migrations/M20230615_ratchet_sync.hs      |  41 +
 .../Store/SQLite/Migrations/agent_schema.sql  |  17 +-
 tests/AgentTests/FunctionalAPITests.hs        | 298 ++++--
 tests/AgentTests/SQLiteTests.hs               |   2 +-
 12 files changed, 1365 insertions(+), 408 deletions(-)
 create mode 100644 rfcs/2023-06-08-resync-ratchets.md
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230615_ratchet_sync.hs

diff --git a/rfcs/2023-06-08-resync-ratchets.md b/rfcs/2023-06-08-resync-ratchets.md
new file mode 100644
index 000000000..fc4572eec
--- /dev/null
+++ b/rfcs/2023-06-08-resync-ratchets.md
@@ -0,0 +1,366 @@
+# Re-sync encryption ratchets
+
+## Problem
+
+See https://github.com/simplex-chat/simplexmq/pull/743/files for problem and high-level solution.
+
+## Implementation
+
+### Diagnosing ratchet de-synchronization
+
+Message decryption happens in `agentClientMsg`, in `agentRatchetDecrypt`, which can return decryption result or error. Decryption error can be differentiated in `agentClientMsg` result pattern match, in Left cases, where we already differentiate duplicate error (`AGENT A_DUPLICATE`).
+
+Question: Which decryption errors can be diagnosed as ratchet de-synchronization?
+
+Possibly any `AGENT A_CRYPTO` error. Definitely on `RATCHET_HEADER`, TBC other. See `cryptoError :: C.CryptoError -> AgentErrorType` for conversion from decryption errors to `A_CRYPTO` or other agent errors. We're only interested in crypto errors, as other are either other client implementation errors, internal errors, or already processed duplicate error.
+
+Proposed classification of crypto errors, based on `AgentCryptoError`:
+
+`DECRYPT_AES` -> re-sync allowed (recommended/required?)
+
+`DECRYPT_CB` -> re-sync allowed (recommended/required?)
+
+`RATCHET_HEADER` -> **re-sync required**
+
+`RATCHET_EARLIER` -> re-sync allowed
+
+`RATCHET_SKIPPED` -> **re-sync required**
+
+Ratchet re-synchronization could be started automatically on diagnosing de-synchronization, based on these errors. As a potentially dangerous feature (e.g., implementation error could lead to infinite re-sync loop causing large traffic consumption), initially it will be available via agent functional api for client to call. Ratchet de-synchronization will instead produce an event prompting client to re-synchronize.
+
+Diagnosing possible ratchet de-synchronization also will be recorded as connection state - `ratchet_desync_state` field in `connections` table. Client should be prohibited to start ratchet re-synchronization unless `ratchet_desync_state` is set.
+
+Event should not be repeated for following received messages that can't be decrypted - based on `ratchet_desync_state`. If a received message can be decrypted, `ratchet_desync_state` should be set to NULL and a new event sent, indicating ratchet has healed.
+
+New event - `RDESYNC :: RatchetDesyncState -> ConnectionStats -> ACommand Agent AEConn`
+
+```haskell
+data RatchetDesyncState
+  = RDResyncAllowed
+  | RDResyncRequired
+  | RDHealed
+```
+
+New field should be added to `ConnectionStats` - `ratchetDesyncState :: Maybe RatchetDesyncState`, based on `ratchet_desync_state`.
+
+> On `RDESYNC` events chat should create chat item, prompting ratchet re-synchronization or notifying it has healed.
+> If connection has diagnosed ratchet de-sync, chat item should have a button to start ratchet re-sync.
+> We'd have to get `ConnectionStats` on chat level for this instead of chat info.
+> This wouldn't work for groups. One option is to add `ConnectionStats` to `GroupMember` type and update on events.
+> Same could be done for `Contact` then.
+
+To consider - allow to start ratchet re-synchronization at any time regardless of this field as an experimental feature. In chat it could be behind "Developer tools" + additional "Experimental" toggle. Agent api would have `force :: Bool` as parameter, allowing to bypass `ratchet_desync_state`. Should `ratchet_resync_state` (see below) still be honored in this case?
+
+### Re-synchronization process
+
+\*\*\*\*\*
+
+Basic idea is the following:
+
+Both agents send new ratchet keys and compute a new shared secret. Agent that starts re-synchronization should record this fact in the connection state. Agent that receives a new key should respond with a key of its own, unless it has recorded that it itself started re-synchronization in the connection state.
+
+It can happen that both agents start re-synchronizing simultaneously. In this case they both would record it in the connection state and would not respond with a new message - instead they would use each other's already sent keys.
+
+Agent has both keys if:
+
+- It initiates with the first key, and then receives the second key;
+- It receives the first key and then generates its own in response.
+
+After agent has both keys, it initiates new ratchet depending on keys ordering. The agent that sent the lower key should use `initRcvRatchet` function, the agent that sent the greater key should use `initSndRatchet` (or vice versa - but they should deterministically choose different sides).
+
+\*\*\*\*\*
+
+State whether the ratchet re-synchronization is in progress should be tracked in database via `connections` table new `ratchet_resync_state` field.
+
+New functional api:
+
+```haskell
+resyncConnectionRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
+```
+
+or if we want to allow re-synchronizing ratchet at any time even if de-synchronization wasn't diagnosed:
+
+```haskell
+resyncConnectionRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
+resyncConnectionRatchet c connId force = ...
+```
+
+Possibly client command?
+
+``` haskell
+data ACommand (p :: AParty) (e :: AEntity) where
+  ...
+  RESYNC_RATCHET :: Bool -> ACommand Client AEConn
+```
+
+New event - `RRESYNC :: RatchetResyncState -> ConnectionStats -> ACommand Agent AEConn`
+
+```haskell
+data RatchetResyncState
+  = RRStarted
+  | RRAgreedSnd
+  | RRAgreedRcv
+  | RRComplete
+```
+
+New `ConnectionStats` field - `ratchetResyncState :: Maybe RatchetResyncState`.
+
+When called, it should:
+
+- Generate new keys.
+- Update database connection state.
+  - Set `ratchet_desync_state` to NULL.
+  - Set `ratchet_resync_state` to `RRStarted`.
+  - Delete old ratchet from `ratchets` (is it safe?), create new ratchet.
+- Send `AgentRatchetKey` message.
+- Return updated `ConnectionStats` to client.
+
+> On `RRESYNC` events chat should create chat item, and reset connection verification.
+> Parameterized `RRESYNC` allows to distinguish: start and end of re-synchronization for initiating party; chat item direction - `RRESYNC RRStarted` is snd, `RRESYNC RRAgreedSnd/Rcv` and `RRESYNC RRComplete` are rcv (`RRESYNC RRAgreedSnd/Rcv` chat item could be omitted).
+
+AgentRatchetKey is a new message on the level of AgentMsgEnvelope - encrypted with queue level e2e encryption, but not with connection level e2e encryption (since ratchet de-synchronized).
+
+```haskell
+data AgentMsgEnvelope
+  = ...
+  | AgentRatchetKey
+      { agentVersion :: Version,
+        e2eEncryption :: E2ERatchetParams 'C.X448,
+        info :: ByteString -- for extension
+      }
+```
+
+On receiving `AgentRatchetKey`, if the receiving client hasn't started the ratchet re-synchronization itself (check `ratchet_resync_state`), it should:
+
+- Generate new keys and compute new shared secret, initializing ratchet based on keys comparison.
+- Update database connection state.
+  - Set `ratchet_resync_state` to `RRAgreedSnd/Rcv` (depending on whether ratchet was initialized as sending or receiving).
+  - Delete old ratchet from `ratchets`, create new ratchet.
+- Reply with its own `AgentRatchetKey`.
+- Notify client with `RRESYNC RRAgreedSnd/Rcv`.
+- If ratchet was initialized as sending, send `EREADY` message, notifying other agent ratchet is re-synced.
+
+New agent message:
+
+```haskell
+data AMessage
+  = ...
+  | -- ratchet re-synchronization is complete, with last decrypted sender message id
+    EREADY PrevExternalSndId
+```
+
+On receiving `AgentRatchetKey`, if the receiving client started re-sync:
+
+- Compute new shared secret, initializing ratchet based on keys comparison.
+- Update database connection state.
+  - Set `ratchet_resync_state` to `RRAgreedSnd/Rcv` (depending on whether ratchet was initialized as sending or receiving).
+  - Update ratchet.
+- Notify client with `RRESYNC RRAgreedSnd/Rcv`.
+- If ratchet was initialized as sending, send `EREADY` message.
+
+After agent receives `EREADY` (or any other message that successfully decrypts):
+
+- Reset `ratchet_resync_state` to NULL.
+- Notify client with `RRESYNC RRComplete`.
+- If ratchet was initialized as receiving, send reply `EREADY` message.
+
+### State transitions
+
+For initiating party:
+
+```
+    +------------+
+    | Ratchet ok |
+    +------------+
+          |
+          | message received, decryption error
+   * ---->|-----------------------------------+
+          |                                   |
+          V          new (clarifying)         V
+  +-----------------+     error      +------------------+
+  | Re-sync allowed |--------------->| Re-sync required |
+  +-----------------+                +------------------+
+          |                                   |
+          |-----------------------------------|
+          |                                   | alternative - message received,
+          | re-sync started by client         | successfully decrypted
+          V                                   V
+  +-----------------+                   +------------+
+  | Re-sync started |                   | Ratchet ok |
+  +-----------------+                   +------------+
+          |
+          | other party replied with new ratchet key
+          V
+  +----------------+
+  | Re-sync agreed |----> * message received, decryption error
+  |   snd / rcv    |        (should remember agreed state for reply EREADY?)
+  +----------------+
+          |
+          | message received, successfully decrypted
+          | (can be, but not necessarily, EREADY)
+          V
+    +------------+
+    | Ratchet ok |
+    +------------+
+```
+
+For replying party:
+
+```
+    +------------+
+    | Ratchet ok |
+    +------------+
+          |
+          | other party sent new ratchet key
+          V
+  +----------------+
+  | Re-sync agreed |
+  |   snd / rcv    |
+  +----------------+
+          |
+          | message received, successfully decrypted
+          | (can be, but not necessarily, EREADY)
+          V
+    +------------+
+    | Ratchet ok |
+    +------------+
+```
+
+### Ratchet state model
+
+#### 2 state variables
+
+Above we considered model with separate de-sync and re-sync state.
+
+| Desync \ Resync      | Nothing | RRStarted | RRAgreedSnd | RRAgreedRcv |
+| ---                  |  :---:  |   :---:   |    :---:    |    :---:    |
+| **Nothing**          | 1       | 3         | 4           | 4           |
+| **RDResyncAllowed**  | 2       |           | 5           | 5           |
+| **RDResyncRequired** | 2       |           | 5           | 5           |
+
+1: Ratchet is ok.
+
+2: Re-sync diagnosed, not in progress.
+
+3: Rs-sync started, diagnosing de-sync is prohibited.
+
+4: Re-sync agreed.
+
+5: Re-sync agreed, new de-sync is diagnosed.
+
+Combination 5 is possible in case de-sync was diagnosed before message that could be decrypted is received, for example if `EREADY` failed to deliver and no other decryptable message followed. We shouldn't prohibit diagnosing de-sync in this case, because agent may never exit "Agreed" state (if new decryptable message is never received). We also shouldn't overwrite/forget state of re-sync, even if we diagnose new possible de-sync, because if the decryptable `EREADY` is received and ratchet is in `RRAgreedRcv` state, it should respond with reply `EREADY`.
+
+Some combinations should be impossible:
+
+  - `RDResyncAllowed` with `RRStarted`.
+
+  - `RDResyncRequired` with `RRStarted`.
+
+`RDHealed` is equivalent to `Nothing` and only used for `RDESYNC` event, `Maybe RatchetDesyncState` can be replaced with `RatchetDesyncState`, with single new constructor `RDNoDesync` replacing `Nothing` and `RDHealed`.
+
+`RRComplete` is equivalent to `Nothing` and only used for `RRESYNC` event, `Maybe RatchetResyncState` can be replaced with `RatchetResyncState`, with single new constructor `RDNoResync` replacing `Nothing` and `RRComplete`.
+
+#### Single state variable
+
+Another option is two have a single state variable describing ratchet.
+
+```haskell
+data RatchetState
+  = RSOk
+  | RSResyncAllowed
+  | RSResyncRequired
+  | RSResyncStarted
+  | RRResyncAgreedSnd
+  | RRResyncAgreedRcv
+
+-- When `resyncConnectionRatchet` is not prohibited. Can override with `force`.
+-- Currently we check:`(isJust ratchetDesyncState || force) && ratchetResyncState /= Just RRStarted`.
+resyncConnectionRatchetAllowed :: RatchetState -> Bool
+resyncConnectionRatchetAllowed = \case
+  RSOk -> False
+  RSResyncAllowed -> True
+  RSResyncRequired -> True
+  RSResyncStarted -> False -- `force` shouldn't override
+  RRResyncAgreedSnd -> False
+  RRResyncAgreedRcv -> False
+
+-- When we register and notify about ratchet de-synchronization.
+-- Currently we check: `(isNothing ratchetDesyncState && ratchetResyncState /= Just RRStarted)`.
+-- We should also allow to update from Allowed to Required.
+shouldNotifyRDESYNC :: RatchetState -> Bool
+shouldNotifyRDESYNC = \case
+  RSOk -> True
+  RSResyncAllowed -> False -- only if new error implies Required
+  RSResyncRequired -> False
+  RSResyncStarted -> False
+  RRResyncAgreedSnd -> True
+  RRResyncAgreedRcv -> True
+
+-- When we prohibit connection switch, for `checkRatchetDesync`.
+-- Currently we check: `(ratchetDesyncState == Just RDResyncRequired || ratchetResyncState == Just RRStarted)`
+-- Also use in `runSmpQueueMsgDelivery` to pause delivery?
+ratchetDesynced :: RatchetState -> Bool
+ratchetDesynced = \case
+  RSOk -> False
+  RSResyncAllowed -> False
+  RSResyncRequired -> True
+  RSResyncStarted -> True
+  RRResyncAgreedSnd -> False
+  RRResyncAgreedRcv -> False
+```
+
+Having a single state variable limits differentiation described for combination 5 in matrix. It also limits possible differentiations in client between events when ratchet is healed on its own, and when ratchet re-sync is completed after agents negotiation. Overall, since matrix is not very sparse and allows for more fine-grained decision-making, having separate state variables for de-sync and re-sync seems preferred.
+
+#### Single state variable simplified (final version)
+
+```haskell
+data RatchetSyncState
+  = RSOk
+  | RSAllowed
+  | RSRequired
+  | RSStarted
+  | RSAgreed
+
+-- event
+RSYNC :: RatchetSyncState -> ConnectionStats -> ACommand Agent AEConn`
+
+-- ConnectionStats field
+ratchetSyncState :: RatchetSyncState
+```
+
+Updated design decisions:
+
+1. Single constructor for "Agreed" state. Differentiating `RRResyncAgreedSnd` and `RRResyncAgreedRcv` allowed for easier processing of `EREADY` by helping to determine whether reply `EREADY` has to be sent. However, it duplicated information already present in ratchet's state, and can be instead worked around by remembering and analyzing ratchet state pre decryption.
+
+2. Prohibit transition from "Agreed" state to "Desync" states. This would make possible edge-cases that leave ratchet in de-synchronized state without ability to progress (e.g. failed delivery of `AgentRatchetKey`), but would simplify state machine by removing dedicated "Desync" variable. Besides, there's still a recovery way with a `force` option.
+
+3. Treat "Agreed" as unfinished state - prohibit new messages to be enqueued, etc. Reception of any decryptable message transitions ratchet to "Ok" state.
+
+Possible improvements:
+
+- Repeatedly triggering re-synchronization while in "Started"/"Agreed" state re-sends same keys and EREADY.
+- Cooldown period, during which repeat re-synchronization is prohibited.
+
+### Skipped messages
+
+Options:
+
+1. Ignore skipped messages.
+2. Stop sending new messages while connection re-synchronizes (can use `ratchet_resync_state`).
+
+- Initiator shouldn't send new messages until receives `AgentRatchetKey` from second party.
+- Second party knows new shared secret immediately after processing first `AgentRatchetKey`, so it's not necessary to limit?
+
+3. 2 + Re-send skipped messages first.
+
+- Add `last_external_snd_msg_id` to `AgentRatchetKey`? + see link above
+
+4. Re-send only messages after the latest ratchet step. \*
+
+It may be okay to ignore skipped messages, or at most implement option 2, as ratchet de-synchronization is usually caused by misuse (human error) - the most common cause of ratchet de-sync seems to be sending and receiving messages after running agent with old database backup. In this case user has already seen most skipped messages, and it can be expected to not have them after switching to an old backup. So in this case the only "really skipped" messages are those that were sent during the latest ratchet step and failed to decrypt, triggering ratchet re-sync (\* another option is to only re-send those).
+
+Besides, depending on time of backup there may be an arbitrary large number of skipped messages, which may consume a lot of traffic and may halt delivery of up-to-date messages for some time.
+
+It may be better to have request for repeat delivery as a separate feature, that can be requested in necessary contexts - for example for group stability.
+
+Can servers delivery failure lead to de-sync? If message is lost on server and never delivered, ratchet wouldn't advance, so there's no room for de-sync? If yes, re-evaluate.
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 601e0a2e5..326f7433c 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -83,6 +83,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 9c1185ab2..f9f502ea6 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -64,6 +64,7 @@ module Simplex.Messaging.Agent
     ackMessage,
     switchConnection,
     abortConnectionSwitch,
+    synchronizeRatchet,
     suspendConnection,
     deleteConnection,
     deleteConnections,
@@ -115,7 +116,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)
+import Data.Maybe (isJust, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock
@@ -143,7 +144,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth)
+import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth)
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util
@@ -273,6 +274,10 @@ switchConnection c = withAgentEnv c . switchConnection' c
 abortConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
 abortConnectionSwitch c = withAgentEnv c . abortConnectionSwitch' c
 
+-- | Re-synchronize connection ratchet keys
+synchronizeRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
+synchronizeRatchet c = withAgentEnv c .: synchronizeRatchet' c
+
 -- | Suspend SMP agent connection (OFF command)
 suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 suspendConnection c = withAgentEnv c . suspendConnection' c
@@ -461,7 +466,8 @@ newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SC
 newConnNoQueues c userId connId enableNtfs cMode = do
   g <- asks idsDrg
   connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
-  let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, deleted = False} -- connection mode is determined by the accepting agent
+  -- connection mode is determined by the accepting agent
+  let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
   withStore c $ \db -> createNewConn db g cData cMode
 
 joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId
@@ -471,7 +477,7 @@ joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData
     Just (Compatible connAgentVersion) -> do
       g <- asks idsDrg
       let duplexHS = connAgentVersion /= 1
-          cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False}
+          cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
       connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation
       enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo
       pure connId
@@ -536,12 +542,18 @@ switchConnectionAsync' c corrId connId =
       SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs)
         | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
         | otherwise -> do
+          checkRatchetSync cData $ CMD PROHIBITED
           rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
           enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
           let rqs' = updatedQs rq1 rqs
           pure . connectionStats $ DuplexConnection cData rqs' sqs
       _ -> throwError $ CMD PROHIBITED
 
+checkRatchetSync :: AgentMonad m => ConnData -> AgentErrorType -> m ()
+checkRatchetSync ConnData {ratchetSyncState} err =
+  when (ratchetSyncState `elem` ([RSRequired, RSStarted, RSAgreed] :: [RatchetSyncState])) $
+    throwError err
+
 newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c)
 newConn c userId connId enableNtfs cMode clientData =
   getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData
@@ -589,7 +601,7 @@ joinConnSrv c userId connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData
       let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
       q <- newSndQueue userId "" qInfo
       let duplexHS = connAgentVersion /= 1
-          cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False}
+          cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
       connId' <- setUpConn asyncMode cData q rc
       let sq = (q :: SndQueue) {connId = connId'}
           cData' = (cData :: ConnData) {connId = connId'}
@@ -806,7 +818,9 @@ sendMessage' c connId msgFlags msg = withConnLock c connId "sendMessage" $ do
     _ -> throwError $ CONN SIMPLEX
   where
     enqueueMsgs :: ConnData -> NonEmpty SndQueue -> m AgentMsgId
-    enqueueMsgs cData sqs = enqueueMessages c cData sqs msgFlags $ A_MSG msg
+    enqueueMsgs cData sqs = do
+      checkRatchetSync cData $ CMD PROHIBITED
+      enqueueMessages c cData sqs msgFlags $ A_MSG msg
 
 -- / async command processing v v v
 
@@ -980,7 +994,12 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
 -- ^ ^ ^ async command processing /
 
 enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
-enqueueMessages c cData (sq :| sqs) msgFlags aMessage = do
+enqueueMessages c cData sqs msgFlags aMessage = do
+  checkRatchetSync cData $ INTERNAL "enqueueMessages: ratchet is not synchronized"
+  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
@@ -1079,6 +1098,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 SMP SMP.AUTH -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
+                  AM_RATCHET_INFO -> connError msgId NOT_AVAILABLE
                   AM_HELLO_
                     -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying,
                     -- because the queue must be secured by the time the confirmation or the first HELLO is received
@@ -1098,6 +1118,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                   AM_QKEY_ -> qError msgId "QKEY: AUTH"
                   AM_QUSE_ -> qError msgId "QUSE: AUTH"
                   AM_QTEST_ -> qError msgId "QTEST: AUTH"
+                  AM_EREADY_ -> notifyDel msgId err
                 _
                   -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
                   -- the message sending would be retried
@@ -1121,6 +1142,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                     when (isJust rq_) $ removeConfirmations db connId
                   unless (duplexHandshake == Just True) . void $ enqueueMessage c cData sq SMP.noMsgFlags HELLO
                 AM_CONN_INFO_REPLY -> pure ()
+                AM_RATCHET_INFO -> pure ()
                 AM_REPLY_ -> pure ()
                 AM_HELLO_ -> do
                   withStore' c $ \db -> setSndQueueStatus db sq Active
@@ -1178,6 +1200,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                             _ -> internalErr msgId "sent QTEST: there is only one queue in connection"
                         _ -> internalErr msgId "sent QTEST: queue not in connection or not replacing another queue"
                     _ -> internalErr msgId "QTEST sent not in duplex connection"
+                AM_EREADY_ -> pure ()
               delMsg msgId
   where
     delMsg :: InternalId -> m ()
@@ -1219,9 +1242,10 @@ switchConnection' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
 switchConnection' c connId =
   withConnLock c connId "switchConnection" $
     withStore c (`getConn` connId) >>= \case
-      SomeConn _ conn@(DuplexConnection _ rqs@(rq :| _rqs) _)
+      SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _)
         | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
         | otherwise -> do
+          checkRatchetSync cData $ CMD PROHIBITED
           rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
           switchDuplexConnection c conn rq'
       _ -> throwError $ CMD PROHIBITED
@@ -1249,6 +1273,7 @@ abortConnectionSwitch' c connId =
       SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
         Just rq
           | canAbortRcvSwitch rq -> do
+            checkRatchetSync cData $ CMD PROHIBITED
             -- multiple queues to which the connections switches were possible when repeating switch was allowed
             let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
             case L.nonEmpty keepRqs of
@@ -1265,6 +1290,24 @@ abortConnectionSwitch' c connId =
         _ -> throwError $ CMD PROHIBITED
       _ -> throwError $ CMD PROHIBITED
 
+synchronizeRatchet' :: AgentMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
+synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet" $ do
+  withStore c (`getConn` connId) >>= \case
+    SomeConn _ (DuplexConnection cData@ConnData {ratchetSyncState} rqs sqs)
+      | ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]) || 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
+        withStore' c $ \db -> do
+          setConnRatchetSync db connId RSStarted
+          setRatchetX3dhKeys db connId pk1 pk2 k1 k2
+        let cData' = cData {ratchetSyncState = RSStarted} :: ConnData
+            conn' = DuplexConnection cData' rqs sqs
+        pure $ connectionStats conn'
+      | otherwise -> throwError $ CMD PROHIBITED
+    _ -> throwError $ CMD PROHIBITED
+
 ackQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> SMP.MsgId -> m ()
 ackQueueMessage c rq srvMsgId =
   sendAck c rq srvMsgId `catchError` \case
@@ -1402,11 +1445,16 @@ getConnectionRatchetAdHash' c connId = do
 
 connectionStats :: Connection c -> ConnectionStats
 connectionStats = \case
-  RcvConnection _ rq -> ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = []}
-  SndConnection _ sq -> ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [sndQueueInfo sq]}
-  DuplexConnection _ rqs sqs -> ConnectionStats {rcvQueuesInfo = map rcvQueueInfo $ L.toList rqs, sndQueuesInfo = map sndQueueInfo $ L.toList sqs}
-  ContactConnection _ rq -> ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = []}
-  NewConnection _ -> ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = []}
+  RcvConnection ConnData {ratchetSyncState} rq ->
+    ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = [], ratchetSyncState}
+  SndConnection ConnData {ratchetSyncState} sq ->
+    ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [sndQueueInfo sq], ratchetSyncState}
+  DuplexConnection ConnData {ratchetSyncState} rqs sqs ->
+    ConnectionStats {rcvQueuesInfo = map rcvQueueInfo $ L.toList rqs, sndQueuesInfo = map sndQueueInfo $ L.toList sqs, ratchetSyncState}
+  ContactConnection ConnData {ratchetSyncState} rq ->
+    ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = [], ratchetSyncState}
+  NewConnection ConnData {ratchetSyncState} ->
+    ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [], ratchetSyncState}
 
 -- | Change servers to be used for creating new queues, in Reader monad
 setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
@@ -1673,6 +1721,7 @@ cleanupManager c@AgentClient {subQ} = do
     void . runExceptT $ do
       deleteConns `catchError` (notify "" . ERR)
       deleteRcvMsgHashes `catchError` (notify "" . ERR)
+      deleteProcessedRatchetKeyHashes `catchError` (notify "" . ERR)
       deleteRcvFilesExpired `catchError` (notify "" . RFERR)
       deleteRcvFilesDeleted `catchError` (notify "" . RFERR)
       deleteRcvFilesTmpPaths `catchError` (notify "" . RFERR)
@@ -1689,6 +1738,9 @@ cleanupManager c@AgentClient {subQ} = do
     deleteRcvMsgHashes = do
       rcvMsgHashesTTL <- asks $ rcvMsgHashesTTL . config
       withStore' c (`deleteRcvMsgHashesExpired` rcvMsgHashesTTL)
+    deleteProcessedRatchetKeyHashes = do
+      rkHashesTTL <- asks $ processedRatchetKeyHashesTTL . config
+      withStore' c (`deleteProcessedRatchetKeyHashesExpired` rkHashesTTL)
     deleteRcvFilesExpired = do
       rcvFilesTTL <- asks $ rcvFilesTTL . config
       rcvExpired <- withStore' c (`getRcvFilesExpired` rcvFilesTTL)
@@ -1735,339 +1787,425 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
   processSMP rq conn $ connData conn
   where
     processSMP :: RcvQueue -> Connection c -> ConnData -> m ()
-    processSMP rq@RcvQueue {e2ePrivKey, e2eDhSecret, status} conn cData@ConnData {userId, connId, duplexHandshake} = withConnLock c connId "processSMP" $
-      case cmd of
-        SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} ->
-          handleNotifyAck $
-            decryptSMPMessage v rq msg >>= \case
-              SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
-              SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
-          where
-            queueDrained = case conn of
-              DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ QCONT (sndAddress rq)
-              _ -> pure ()
-            processClientMsg srvTs msgFlags msgBody = do
-              clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
-                parseMessage msgBody
-              clientVRange <- asks $ smpClientVRange . config
-              unless (phVer `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
-              case (e2eDhSecret, e2ePubKey_) of
-                (Nothing, Just e2ePubKey) -> do
-                  let e2eDh = C.dh' e2ePubKey e2ePrivKey
-                  decryptClientMessage e2eDh clientMsg >>= \case
-                    (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption, encConnInfo, agentVersion}) ->
-                      smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion >> ack
-                    (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
-                      smpInvitation connReq connInfo >> ack
-                    _ -> prohibited >> ack
-                (Just e2eDh, Nothing) -> do
-                  decryptClientMessage e2eDh clientMsg >>= \case
-                    (SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do
-                      -- primary queue is set as Active in helloMsg, below is to set additional queues Active
-                      let RcvQueue {primary, dbReplaceQueueId} = rq
-                      unless (status == Active) . withStore' c $ \db -> setRcvQueueStatus db rq Active
-                      case (conn, dbReplaceQueueId) of
-                        (DuplexConnection _ rqs _, Just replacedId) -> do
-                          when primary . withStore' c $ \db -> setRcvQueuePrimary db connId rq
-                          case find ((replacedId ==) . dbQId) rqs of
-                            Just rq'@RcvQueue {server, rcvId} -> do
-                              checkRQSwchStatus rq' RSSendingQUSE
-                              void $ withStore' c $ \db -> setRcvSwitchStatus db rq' $ Just RSReceivedMessage
-                              enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICQDelete rcvId
-                            _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
-                        _ -> pure ()
-                      let encryptedMsgHash = C.sha256Hash encAgentMsg
-                      tryError (agentClientMsg encryptedMsgHash) >>= \case
-                        Right (Just (msgId, msgMeta, aMessage)) -> case aMessage of
-                          HELLO -> helloMsg >> ackDel msgId
-                          REPLY cReq -> replyMsg 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>"
-                            notify $ MSG msgMeta msgFlags body
-                          QCONT addr -> qDuplex "QCONT" $ continueSending addr
-                          QADD qs -> qDuplex "QADD" $ qAddMsg qs
-                          QKEY qs -> qDuplex "QKEY" $ qKeyMsg qs
-                          QUSE qs -> qDuplex "QUSE" $ qUseMsg qs
-                          -- no action needed for QTEST
-                          -- any message in the new queue will mark it active and trigger deletion of the old queue
-                          QTEST _ -> logServer "<--" c srv rId "MSG <QTEST>" >> ackDel msgId
-                          where
-                            qDuplex :: String -> (Connection 'CDuplex -> m ()) -> m ()
-                            qDuplex name a = case conn of
-                              DuplexConnection {} -> a conn >> ackDel msgId
-                              _ -> qError $ name <> ": message must be sent to duplex connection"
-                        Right _ -> prohibited >> ack
-                        Left e@(AGENT A_DUPLICATE) -> do
-                          withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
-                            Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
-                              | userAck -> ackDel internalId
-                              | otherwise -> do
-                                liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
-                                  AgentMessage _ (A_MSG body) -> do
-                                    logServer "<--" c srv rId "MSG <MSG>"
-                                    notify $ MSG msgMeta msgFlags body
-                                  _ -> pure ()
-                            _ -> checkDuplicateHash e encryptedMsgHash >> ack
-                        Left e -> checkDuplicateHash e encryptedMsgHash >> ack
-                      where
-                        checkDuplicateHash :: AgentErrorType -> ByteString -> m ()
-                        checkDuplicateHash e encryptedMsgHash =
-                          unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $
-                            throwError e
-                        agentClientMsg :: ByteString -> m (Maybe (InternalId, MsgMeta, AMessage))
-                        agentClientMsg encryptedMsgHash = withStore c $ \db -> runExceptT $ do
-                          agentMsgBody <- agentRatchetDecrypt db connId encAgentMsg
-                          liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
-                            agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
-                              let msgType = agentMessageType agentMsg
-                                  internalHash = C.sha256Hash agentMsgBody
-                              internalTs <- liftIO getCurrentTime
-                              (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- liftIO $ updateRcvIds db connId
-                              let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash prevMsgHash
-                                  recipient = (unId internalId, internalTs)
-                                  broker = (srvMsgId, systemToUTCTime srvTs)
-                                  msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
-                                  rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash, encryptedMsgHash}
-                              liftIO $ createRcvMsg db connId rq rcvMsg
-                              pure $ Just (internalId, msgMeta, aMessage)
-                            _ -> pure Nothing
-                    _ -> prohibited >> ack
-                _ -> prohibited >> ack
-            ack :: m ()
-            ack = enqueueCmd $ ICAck rId srvMsgId
-            ackDel :: InternalId -> m ()
-            ackDel = enqueueCmd . ICAckDel rId srvMsgId
-            handleNotifyAck :: m () -> m ()
-            handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack
-        SMP.END ->
-          atomically (TM.lookup tSess smpClients $>>= tryReadTMVar >>= processEND)
-            >>= logServer "<--" c srv rId
-          where
-            processEND = \case
-              Just (Right clnt)
-                | sessId == sessionId clnt -> do
-                  removeSubscription c connId
-                  notify' END
-                  pure "END"
-                | otherwise -> ignored
-              _ -> ignored
-            ignored = pure "END from disconnected client - ignored"
-        _ -> do
-          logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
-          notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED
-      where
-        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
-        notify = atomically . notify'
-
-        notify' :: forall e. AEntityI e => ACommand 'Agent e -> STM ()
-        notify' msg = writeTBQueue subQ ("", connId, APC (sAEntity @e) msg)
-
-        prohibited :: m ()
-        prohibited = notify . ERR $ AGENT A_PROHIBITED
-
-        enqueueCmd :: InternalCommand -> m ()
-        enqueueCmd = enqueueCommand c "" connId (Just srv) . AInternalCommand
-
-        decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> m (SMP.PrivHeader, AgentMsgEnvelope)
-        decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do
-          clientMsg <- agentCbDecrypt e2eDh cmNonce cmEncBody
-          SMP.ClientMessage privHeader clientBody <- parseMessage clientMsg
-          agentEnvelope <- parseMessage clientBody
-          -- Version check is removed here, because when connecting via v1 contact address the agent still sends v2 message,
-          -- to allow duplexHandshake mode, in case the receiving agent was updated to v2 after the address was created.
-          -- aVRange <- asks $ smpAgentVRange . config
-          -- if agentVersion agentEnvelope `isCompatible` aVRange
-          --   then pure (privHeader, agentEnvelope)
-          --   else throwError $ AGENT A_VERSION
-          pure (privHeader, agentEnvelope)
-
-        parseMessage :: Encoding a => ByteString -> m a
-        parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
-
-        smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
-        smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
-          logServer "<--" c srv rId "MSG <CONF>"
-          AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
-          unless
-            (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
-            (throwError $ AGENT A_VERSION)
-          case status of
-            New -> case (conn, e2eEncryption) of
-              -- party initiating connection
-              (RcvConnection {}, Just e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _)) -> do
-                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
-                case (agentMsgBody_, skipped) of
-                  (Right agentMsgBody, CR.SMDNoChange) ->
-                    parseMessage agentMsgBody >>= \case
-                      AgentConnInfo connInfo ->
-                        processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = [], smpClientVersion} False
-                      AgentConnInfoReply smpQueues connInfo ->
-                        processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion} True
-                      _ -> prohibited
-                    where
-                      processConf connInfo senderConf duplexHS = do
-                        let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
-                        g <- asks idsDrg
-                        confId <- withStore c $ \db -> do
-                          setHandshakeVersion db connId agentVersion duplexHS
-                          createConfirmation db g newConfirmation
-                        let srvs = map qServer $ smpReplyQueues senderConf
-                        notify $ CONF confId srvs connInfo
-                  _ -> prohibited
-              -- party accepting connection
-              (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
-                withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case
-                  AgentConnInfo connInfo -> do
-                    notify $ INFO connInfo
-                    let dhSecret = C.dh' e2ePubKey e2ePrivKey
-                    withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion
-                    enqueueCmd $ ICDuplexSecure rId senderKey
-                  _ -> prohibited
-              _ -> prohibited
-            _ -> prohibited
-
-        helloMsg :: m ()
-        helloMsg = do
-          logServer "<--" c srv rId "MSG <HELLO>"
-          case status of
-            Active -> prohibited
-            _ ->
-              case conn of
-                DuplexConnection _ _ (sq@SndQueue {status = sndStatus} :| _)
-                  -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
-                  -- this branch is executed by the accepting party in duplexHandshake mode (v2)
-                  -- and by the initiating party in v1
-                  -- Also see comment where HELLO is sent.
-                  | sndStatus == Active -> notify CON
-                  | duplexHandshake == Just True -> enqueueDuplexHello sq
-                  | otherwise -> pure ()
+    processSMP
+      rq@RcvQueue {e2ePrivKey, e2eDhSecret, status}
+      conn
+      cData@ConnData {userId, connId, duplexHandshake, ratchetSyncState = rss, lastExternalSndId} =
+        withConnLock c connId "processSMP" $ case cmd of
+          SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} ->
+            handleNotifyAck $
+              decryptSMPMessage v rq msg >>= \case
+                SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
+                SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
+            where
+              queueDrained = case conn of
+                DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ QCONT (sndAddress rq)
                 _ -> pure ()
+              processClientMsg srvTs msgFlags msgBody = do
+                clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
+                  parseMessage msgBody
+                clientVRange <- asks $ smpClientVRange . config
+                unless (phVer `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
+                case (e2eDhSecret, e2ePubKey_) of
+                  (Nothing, Just e2ePubKey) -> do
+                    let e2eDh = C.dh' e2ePubKey e2ePrivKey
+                    decryptClientMessage e2eDh clientMsg >>= \case
+                      (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) ->
+                        smpConfirmation senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
+                      (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
+                        smpInvitation connReq connInfo >> ack
+                      _ -> prohibited >> ack
+                  (Just e2eDh, Nothing) -> do
+                    decryptClientMessage e2eDh clientMsg >>= \case
+                      (SMP.PHEmpty, AgentRatchetKey {e2eEncryption}) ->
+                        qDuplex "AgentRatchetKey" (newRatchetKey e2eEncryption) >> ack
+                      (SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do
+                        -- primary queue is set as Active in helloMsg, below is to set additional queues Active
+                        let RcvQueue {primary, dbReplaceQueueId} = rq
+                        unless (status == Active) . withStore' c $ \db -> setRcvQueueStatus db rq Active
+                        case (conn, dbReplaceQueueId) of
+                          (DuplexConnection _ rqs _, Just replacedId) -> do
+                            when primary . withStore' c $ \db -> setRcvQueuePrimary db connId rq
+                            case find ((replacedId ==) . dbQId) rqs of
+                              Just rq'@RcvQueue {server, rcvId} -> do
+                                checkRQSwchStatus rq' RSSendingQUSE
+                                void $ withStore' c $ \db -> setRcvSwitchStatus db rq' $ Just RSReceivedMessage
+                                enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICQDelete rcvId
+                              _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
+                          _ -> pure ()
+                        let encryptedMsgHash = C.sha256Hash encAgentMsg
+                        tryError (agentClientMsg encryptedMsgHash) >>= \case
+                          Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do
+                            resetRatchetSync
+                            case aMessage of
+                              HELLO -> helloMsg >> ackDel msgId
+                              REPLY cReq -> replyMsg 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>"
+                                notify $ MSG msgMeta msgFlags body
+                              QCONT addr -> qDuplexAckDel "QCONT" $ continueSending addr
+                              QADD qs -> qDuplexAckDel "QADD" $ qAddMsg qs
+                              QKEY qs -> qDuplexAckDel "QKEY" $ qKeyMsg qs
+                              QUSE qs -> qDuplexAckDel "QUSE" $ qUseMsg qs
+                              -- no action needed for QTEST
+                              -- any message in the new queue will mark it active and trigger deletion of the old queue
+                              QTEST _ -> logServer "<--" c srv rId "MSG <QTEST>" >> ackDel msgId
+                              EREADY _ -> qDuplexAckDel "EREADY" $ ereadyMsg rcPrev
+                            where
+                              qDuplexAckDel :: String -> (Connection 'CDuplex -> m ()) -> m ()
+                              qDuplexAckDel name a = qDuplex name a >> ackDel msgId
+                              resetRatchetSync :: m ()
+                              resetRatchetSync = unless (rss `elem` ([RSOk, RSStarted] :: [RatchetSyncState])) $
+                                qDuplex "ratchet de-sync reset" $ \(DuplexConnection _ rqs sqs) -> do
+                                  let cData' = cData {ratchetSyncState = RSOk} :: ConnData
+                                      conn' = DuplexConnection cData' rqs sqs
+                                  notify . RSYNC RSOk $ connectionStats conn'
+                                  withStore' c $ \db -> setConnRatchetSync db connId RSOk
+                          Right _ -> prohibited >> ack
+                          Left e@(AGENT A_DUPLICATE) -> do
+                            withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
+                              Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
+                                | userAck -> ackDel internalId
+                                | otherwise -> do
+                                  liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
+                                    AgentMessage _ (A_MSG body) -> do
+                                      logServer "<--" c srv rId "MSG <MSG>"
+                                      notify $ MSG msgMeta msgFlags body
+                                    _ -> pure ()
+                              _ -> checkDuplicateHash e encryptedMsgHash >> ack
+                          Left (AGENT (A_CRYPTO e)) -> do
+                            exists <- withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash
+                            unless exists notifySync
+                            ack
+                            where
+                              notifySync :: m ()
+                              notifySync = qDuplex "AGENT A_CRYPTO error" $ \(DuplexConnection _ rqs sqs) -> do
+                                let rss' = cryptoErrToSyncState e
+                                when (rss == RSOk || (rss == RSAllowed && rss' == RSRequired)) $ do
+                                  let cData' = cData {ratchetSyncState = rss'} :: ConnData
+                                      conn' = DuplexConnection cData' rqs sqs
+                                  notify . RSYNC rss' $ connectionStats conn'
+                                  withStore' c $ \db -> setConnRatchetSync db connId rss'
+                          Left e -> checkDuplicateHash e encryptedMsgHash >> ack
+                        where
+                          checkDuplicateHash :: AgentErrorType -> ByteString -> m ()
+                          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
+                            rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY
+                            agentMsgBody <- agentRatchetDecrypt' db connId rc encAgentMsg
+                            liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
+                              agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
+                                let msgType = agentMessageType agentMsg
+                                    internalHash = C.sha256Hash agentMsgBody
+                                internalTs <- liftIO getCurrentTime
+                                (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- liftIO $ updateRcvIds db connId
+                                let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash prevMsgHash
+                                    recipient = (unId internalId, internalTs)
+                                    broker = (srvMsgId, systemToUTCTime srvTs)
+                                    msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
+                                    rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash, encryptedMsgHash}
+                                liftIO $ createRcvMsg db connId rq rcvMsg
+                                pure $ Just (internalId, msgMeta, aMessage, rc)
+                              _ -> pure Nothing
+                      _ -> prohibited >> ack
+                  _ -> prohibited >> ack
+              ack :: m ()
+              ack = enqueueCmd $ ICAck rId srvMsgId
+              ackDel :: InternalId -> m ()
+              ackDel = enqueueCmd . ICAckDel rId srvMsgId
+              handleNotifyAck :: m () -> m ()
+              handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack
+          SMP.END ->
+            atomically (TM.lookup tSess smpClients $>>= tryReadTMVar >>= processEND)
+              >>= logServer "<--" c srv rId
+            where
+              processEND = \case
+                Just (Right clnt)
+                  | sessId == sessionId clnt -> do
+                    removeSubscription c connId
+                    notify' END
+                    pure "END"
+                  | otherwise -> ignored
+                _ -> ignored
+              ignored = pure "END from disconnected client - ignored"
+          _ -> do
+            logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
+            notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED
+        where
+          notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+          notify = atomically . notify'
 
-        enqueueDuplexHello :: SndQueue -> m ()
-        enqueueDuplexHello sq = void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO
+          notify' :: forall e. AEntityI e => ACommand 'Agent e -> STM ()
+          notify' msg = writeTBQueue subQ ("", connId, APC (sAEntity @e) msg)
 
-        replyMsg :: NonEmpty SMPQueueInfo -> m ()
-        replyMsg smpQueues = do
-          logServer "<--" c srv rId "MSG <REPLY>"
-          case duplexHandshake of
-            Just True -> prohibited
-            _ -> case conn of
-              RcvConnection {} -> do
-                AcceptedConfirmation {ownConnInfo} <- withStore c (`getAcceptedConfirmation` connId)
-                connectReplyQueues c cData ownConnInfo smpQueues `catchError` (notify . ERR)
+          prohibited :: m ()
+          prohibited = notify . ERR $ AGENT A_PROHIBITED
+
+          enqueueCmd :: InternalCommand -> m ()
+          enqueueCmd = enqueueCommand c "" connId (Just srv) . AInternalCommand
+
+          decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> m (SMP.PrivHeader, AgentMsgEnvelope)
+          decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do
+            clientMsg <- agentCbDecrypt e2eDh cmNonce cmEncBody
+            SMP.ClientMessage privHeader clientBody <- parseMessage clientMsg
+            agentEnvelope <- parseMessage clientBody
+            -- Version check is removed here, because when connecting via v1 contact address the agent still sends v2 message,
+            -- to allow duplexHandshake mode, in case the receiving agent was updated to v2 after the address was created.
+            -- aVRange <- asks $ smpAgentVRange . config
+            -- if agentVersion agentEnvelope `isCompatible` aVRange
+            --   then pure (privHeader, agentEnvelope)
+            --   else throwError $ AGENT A_VERSION
+            pure (privHeader, agentEnvelope)
+
+          parseMessage :: Encoding a => ByteString -> m a
+          parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
+
+          smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
+          smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
+            logServer "<--" c srv rId "MSG <CONF>"
+            AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
+            unless
+              (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
+              (throwError $ AGENT A_VERSION)
+            case status of
+              New -> case (conn, e2eEncryption) of
+                -- party initiating connection
+                (RcvConnection {}, Just e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _)) -> do
+                  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
+                  case (agentMsgBody_, skipped) of
+                    (Right agentMsgBody, CR.SMDNoChange) ->
+                      parseMessage agentMsgBody >>= \case
+                        AgentConnInfo connInfo ->
+                          processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = [], smpClientVersion} False
+                        AgentConnInfoReply smpQueues connInfo ->
+                          processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion} True
+                        _ -> prohibited
+                      where
+                        processConf connInfo senderConf duplexHS = do
+                          let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
+                          g <- asks idsDrg
+                          confId <- withStore c $ \db -> do
+                            setHandshakeVersion db connId agentVersion duplexHS
+                            createConfirmation db g newConfirmation
+                          let srvs = map qServer $ smpReplyQueues senderConf
+                          notify $ CONF confId srvs connInfo
+                    _ -> prohibited
+                -- party accepting connection
+                (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
+                  withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case
+                    AgentConnInfo connInfo -> do
+                      notify $ INFO connInfo
+                      let dhSecret = C.dh' e2ePubKey e2ePrivKey
+                      withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion
+                      enqueueCmd $ ICDuplexSecure rId senderKey
+                    _ -> prohibited
+                _ -> prohibited
               _ -> prohibited
 
-        continueSending :: (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
-        continueSending addr (DuplexConnection _ _ sqs) =
-          case findQ addr sqs of
-            Just sq -> do
-              logServer "<--" c srv rId "MSG <QCONT>"
-              atomically $ do
-                (_, qLock) <- getPendingMsgQ c sq
-                void $ tryPutTMVar qLock ()
-            Nothing -> qError "QCONT: queue address not found"
+          helloMsg :: m ()
+          helloMsg = do
+            logServer "<--" c srv rId "MSG <HELLO>"
+            case status of
+              Active -> prohibited
+              _ ->
+                case conn of
+                  DuplexConnection _ _ (sq@SndQueue {status = sndStatus} :| _)
+                    -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
+                    -- this branch is executed by the accepting party in duplexHandshake mode (v2)
+                    -- and by the initiating party in v1
+                    -- Also see comment where HELLO is sent.
+                    | sndStatus == Active -> notify CON
+                    | duplexHandshake == Just True -> enqueueDuplexHello sq
+                    | otherwise -> pure ()
+                  _ -> pure ()
 
-        -- 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 _ rqs sqs) = do
-          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
-                  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}
-                      case (sndPublicKey, e2ePubKey) of
-                        (Just sndPubKey, Just dhPublicKey) -> do
-                          logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
-                          let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
-                          void . enqueueMessages c cData sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
-                          sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
-                          let sqs'' = updatedQs sq1 sqs' <> [sq2]
-                              conn' = DuplexConnection cData rqs sqs''
-                          notify . SWITCH QDSnd SPStarted $ connectionStats conn'
-                        _ -> qError "absent sender keys"
-                    _ -> qError "QADD: won't delete all snd queues in connection"
-                _ -> qError "QADD: replaced queue address is not found in connection"
-            _ -> throwError $ AGENT A_VERSION
+          enqueueDuplexHello :: SndQueue -> m ()
+          enqueueDuplexHello sq = void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO
 
-        -- processed by queue recipient
-        qKeyMsg :: NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
-        qKeyMsg ((qInfo, senderKey) :| _) (DuplexConnection _ rqs _) = do
-          clientVRange <- asks $ smpClientVRange . config
-          unless (qInfo `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
-          case findRQ (smpServer, senderId) rqs of
-            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
-                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
-                notify . SWITCH QDRcv SPConfirmed $ connectionStats conn
-              | otherwise -> qError "QKEY: queue already secured"
-            _ -> qError "QKEY: queue address not found in connection"
-          where
-            SMPQueueInfo cVer' SMPQueueAddress {smpServer, senderId, dhPublicKey} = qInfo
+          replyMsg :: NonEmpty SMPQueueInfo -> m ()
+          replyMsg smpQueues = do
+            logServer "<--" c srv rId "MSG <REPLY>"
+            case duplexHandshake of
+              Just True -> prohibited
+              _ -> case conn of
+                RcvConnection {} -> do
+                  AcceptedConfirmation {ownConnInfo} <- withStore c (`getAcceptedConfirmation` connId)
+                  connectReplyQueues c cData ownConnInfo smpQueues `catchError` (notify . ERR)
+                _ -> prohibited
 
-        -- processed by queue sender
-        -- mark queue as Secured and to start sending messages to it
-        qUseMsg :: 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 _ rqs sqs) =
-          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)
-                  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
-                  void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
-                  sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST
-                  let sqs' = updatedQs sq1' sqs
-                      conn' = DuplexConnection cData rqs sqs'
-                  notify . SWITCH QDSnd SPSecured $ connectionStats conn'
-                _ -> qError "QUSE: switching SndQueue not found in connection"
-            _ -> qError "QUSE: switched queue address not found in connection"
+          continueSending :: (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
+          continueSending addr (DuplexConnection _ _ sqs) =
+            case findQ addr sqs of
+              Just sq -> do
+                logServer "<--" c srv rId "MSG <QCONT>"
+                atomically $ do
+                  (_, qLock) <- getPendingMsgQ c sq
+                  void $ tryPutTMVar qLock ()
+              Nothing -> qError "QCONT: queue address not found"
 
-        qError :: String -> m ()
-        qError = throwError . AGENT . A_QUEUE
+          -- 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 _ rqs sqs) = do
+            checkRatchetSync cData $ 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
+                    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}
+                        case (sndPublicKey, e2ePubKey) of
+                          (Just sndPubKey, Just dhPublicKey) -> do
+                            logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
+                            let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
+                            void . enqueueMessages c cData sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
+                            sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
+                            let sqs'' = updatedQs sq1 sqs' <> [sq2]
+                                conn' = DuplexConnection cData rqs sqs''
+                            notify . SWITCH QDSnd SPStarted $ connectionStats conn'
+                          _ -> qError "absent sender keys"
+                      _ -> qError "QADD: won't delete all snd queues in connection"
+                  _ -> qError "QADD: replaced queue address is not found in connection"
+              _ -> throwError $ AGENT A_VERSION
 
-        smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-        smpInvitation connReq@(CRInvitationUri crData _) cInfo = do
-          logServer "<--" c srv rId "MSG <KEY>"
-          case conn of
-            ContactConnection {} -> do
-              g <- asks idsDrg
-              let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
-              invId <- withStore c $ \db -> createInvitation db g newInv
-              let srvs = L.map qServer $ crSmpQueues crData
-              notify $ REQ invId srvs cInfo
-            _ -> prohibited
+          -- processed by queue recipient
+          qKeyMsg :: NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
+          qKeyMsg ((qInfo, senderKey) :| _) (DuplexConnection _ rqs _) = do
+            checkRatchetSync cData $ AGENT (A_QUEUE "ratchet is not synchronized")
+            clientVRange <- asks $ smpClientVRange . config
+            unless (qInfo `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
+            case findRQ (smpServer, senderId) rqs of
+              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
+                  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
+                  notify . SWITCH QDRcv SPConfirmed $ connectionStats conn
+                | otherwise -> qError "QKEY: queue already secured"
+              _ -> qError "QKEY: queue address not found in connection"
+            where
+              SMPQueueInfo cVer' SMPQueueAddress {smpServer, senderId, dhPublicKey} = qInfo
 
-        checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
-        checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash
-          | extSndId == prevExtSndId + 1 && internalPrevMsgHash == receivedPrevMsgHash = MsgOk
-          | extSndId < prevExtSndId = MsgError $ MsgBadId extSndId
-          | extSndId == prevExtSndId = MsgError MsgDuplicate -- ? deduplicate
-          | extSndId > prevExtSndId + 1 = MsgError $ MsgSkipped (prevExtSndId + 1) (extSndId - 1)
-          | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
-          | otherwise = MsgError MsgDuplicate -- this case is not possible
+          -- processed by queue sender
+          -- mark queue as Secured and to start sending messages to it
+          qUseMsg :: 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 _ rqs sqs) = do
+            checkRatchetSync cData $ 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)
+                    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
+                    void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
+                    sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST
+                    let sqs' = updatedQs sq1' sqs
+                        conn' = DuplexConnection cData rqs sqs'
+                    notify . SWITCH QDSnd SPSecured $ connectionStats conn'
+                  _ -> qError "QUSE: switching SndQueue not found in connection"
+              _ -> qError "QUSE: switched queue address not found in connection"
+
+          qError :: String -> m ()
+          qError = throwError . AGENT . A_QUEUE
+
+          ereadyMsg :: CR.RatchetX448 -> Connection 'CDuplex -> m ()
+          ereadyMsg rcPrev (DuplexConnection cData' _ sqs) = do
+            let CR.Ratchet {rcSnd} = rcPrev
+            -- if ratchet was initialized as receiving, it means EREADY wasn't sent on key negotiation
+            when (isNothing rcSnd) $
+              void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
+
+          smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+          smpInvitation connReq@(CRInvitationUri crData _) cInfo = do
+            logServer "<--" c srv rId "MSG <KEY>"
+            case conn of
+              ContactConnection {} -> do
+                g <- asks idsDrg
+                let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
+                invId <- withStore c $ \db -> createInvitation db g newInv
+                let srvs = L.map qServer $ crSmpQueues crData
+                notify $ REQ invId srvs cInfo
+              _ -> prohibited
+
+          qDuplex :: String -> (Connection 'CDuplex -> m ()) -> m ()
+          qDuplex name a = case conn of
+            DuplexConnection {} -> a conn
+            _ -> qError $ name <> ": message must be sent to duplex connection"
+
+          newRatchetKey :: CR.E2ERatchetParams 'C.X448 -> Connection 'CDuplex -> m ()
+          newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv) (DuplexConnection cData' rqs sqs) =
+            unlessM ratchetExists $ do
+              AgentConfig {e2eEncryptVRange} <- asks config
+              unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
+              keys <- getSendRatchetKeys
+              initRatchet e2eEncryptVRange keys
+              notifyAgreed
+            where
+              rkHashRcv = rkHash k1Rcv k2Rcv
+              rkHash k1 k2 = C.sha256Hash $ C.pubKeyBytes k1 <> C.pubKeyBytes k2
+              ratchetExists :: m Bool
+              ratchetExists = withStore' c $ \db -> do
+                exists <- checkProcessedRatchetKeyHashExists db connId rkHashRcv
+                unless exists $ addProcessedRatchetKeyHash db connId rkHashRcv
+                pure exists
+              getSendRatchetKeys :: m (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448)
+              getSendRatchetKeys
+                | rss == RSStarted = withStore c (`getRatchetX3dhKeys'` connId)
+                | otherwise = do
+                  (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ version e2eOtherPartyParams
+                  void $ enqueueRatchetKeyMsgs c cData' sqs e2eParams
+                  pure (pk1, pk2, k1, k2)
+              notifyAgreed :: m ()
+              notifyAgreed = do
+                let cData'' = cData' {ratchetSyncState = RSAgreed} :: ConnData
+                    conn' = DuplexConnection cData'' rqs sqs
+                notify . RSYNC RSAgreed $ connectionStats conn'
+              recreateRatchet :: CR.Ratchet 'C.X448 -> m ()
+              recreateRatchet rc = withStore' c $ \db -> do
+                setConnRatchetSync db connId RSAgreed
+                deleteRatchet db connId
+                createRatchet db connId rc
+              -- compare public keys `k1` in AgentRatchetKey messages sent by self and other party
+              -- to determine ratchet initilization ordering
+              initRatchet :: VersionRange -> (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448) -> m ()
+              initRatchet e2eEncryptVRange (pk1, pk2, k1, k2)
+                | rkHash k1 k2 <= rkHashRcv = do
+                  recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 $ CR.x3dhRcv pk1 pk2 e2eOtherPartyParams
+                | otherwise = do
+                  (_, rcDHRs) <- liftIO C.generateKeyPair'
+                  recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams
+                  void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
+
+          checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
+          checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash
+            | extSndId == prevExtSndId + 1 && internalPrevMsgHash == receivedPrevMsgHash = MsgOk
+            | extSndId < prevExtSndId = MsgError $ MsgBadId extSndId
+            | extSndId == prevExtSndId = MsgError MsgDuplicate -- ? deduplicate
+            | extSndId > prevExtSndId + 1 = MsgError $ MsgSkipped (prevExtSndId + 1) (extSndId - 1)
+            | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
+            | otherwise = MsgError MsgDuplicate -- this case is not possible
 
 checkRQSwchStatus :: AgentMonad m => RcvQueue -> RcvSwitchStatus -> m ()
 checkRQSwchStatus rq@RcvQueue {rcvSwchStatus} expected =
@@ -2095,7 +2233,7 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) =
       enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing
 
 confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
-confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption = do
+confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption_ = do
   aMessage <- mkAgentMessage agentVersion
   msg <- mkConfirmation aMessage
   sendConfirmation c sq msg
@@ -2105,7 +2243,7 @@ confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo
     mkConfirmation aMessage = withStore c $ \db -> runExceptT $ do
       void . liftIO $ updateSndIds db connId
       encConnInfo <- agentRatchetEncrypt db connId (smpEncode aMessage) e2eEncConnInfoLength
-      pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption, encConnInfo}
+      pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo}
     mkAgentMessage :: Version -> m AgentMessage
     mkAgentMessage 1 = pure $ AgentConnInfo connInfo
     mkAgentMessage _ = do
@@ -2113,7 +2251,7 @@ confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo
       pure $ AgentConnInfoReply (qInfo :| []) connInfo
 
 enqueueConfirmation :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
-enqueueConfirmation c cData@ConnData {connId, connAgentVersion} sq connInfo e2eEncryption = do
+enqueueConfirmation c cData@ConnData {connId, connAgentVersion} sq connInfo e2eEncryption_ = do
   resumeMsgDelivery c cData sq
   msgId <- storeConfirmation
   queuePendingMsgs c sq [msgId]
@@ -2126,7 +2264,35 @@ enqueueConfirmation c cData@ConnData {connId, connAgentVersion} sq connInfo e2eE
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr
       encConnInfo <- agentRatchetEncrypt db connId agentMsgStr e2eEncConnInfoLength
-      let msgBody = smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption, encConnInfo}
+      let msgBody = smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo}
+          msgType = agentMessageType agentMsg
+          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 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
+
+enqueueRatchetKey :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> CR.E2ERatchetParams 'C.X448 -> m AgentMsgId
+enqueueRatchetKey c cData@ConnData {connId, connAgentVersion} sq e2eEncryption = do
+  resumeMsgDelivery c cData sq
+  msgId <- storeRatchetKey
+  queuePendingMsgs c sq [msgId]
+  pure $ unId msgId
+  where
+    storeRatchetKey :: m InternalId
+    storeRatchetKey = withStore c $ \db -> runExceptT $ do
+      internalTs <- liftIO getCurrentTime
+      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
+      let agentMsg = AgentRatchetInfo ""
+          agentMsgStr = smpEncode agentMsg
+          internalHash = C.sha256Hash agentMsgStr
+      let msgBody = smpEncode $ AgentRatchetKey {agentVersion = connAgentVersion, e2eEncryption, info = agentMsgStr}
           msgType = agentMessageType agentMsg
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
       liftIO $ createSndMsg db connId msgData
@@ -2145,6 +2311,10 @@ agentRatchetEncrypt db connId msg paddedLen = do
 agentRatchetDecrypt :: DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
 agentRatchetDecrypt db connId encAgentMsg = do
   rc <- ExceptT $ getRatchet db connId
+  agentRatchetDecrypt' db connId rc encAgentMsg
+
+agentRatchetDecrypt' :: DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString
+agentRatchetDecrypt' db connId rc encAgentMsg = do
   skipped <- liftIO $ getSkippedMsgKeys db connId
   (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg
   liftIO $ updateRatchet db connId rc' skippedDiff
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index 3664cbb5b..e199f0b79 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -83,6 +83,7 @@ data AgentConfig = AgentConfig
     initialCleanupDelay :: Int64,
     cleanupInterval :: Int64,
     rcvMsgHashesTTL :: NominalDiffTime,
+    processedRatchetKeyHashesTTL :: NominalDiffTime,
     rcvFilesTTL :: NominalDiffTime,
     sndFilesTTL :: NominalDiffTime,
     xftpNotifyErrsOnRetry :: Bool,
@@ -147,6 +148,7 @@ defaultAgentConfig =
       initialCleanupDelay = 30 * 1000000, -- 30 seconds
       cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
       rcvMsgHashesTTL = 30 * nominalDay,
+      processedRatchetKeyHashesTTL = 30 * nominalDay,
       rcvFilesTTL = 2 * nominalDay,
       sndFilesTTL = nominalDay,
       xftpNotifyErrsOnRetry = True,
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 1a4f1f83f..98a4cad5b 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -62,6 +62,7 @@ module Simplex.Messaging.Agent.Protocol
     RcvSwitchStatus (..),
     SndSwitchStatus (..),
     QueueDirection (..),
+    RatchetSyncState (..),
     SMPConfirmation (..),
     AgentMsgEnvelope (..),
     AgentMessage (..),
@@ -98,6 +99,7 @@ module Simplex.Messaging.Agent.Protocol
     BrokerErrorType (..),
     SMPAgentError (..),
     AgentCryptoError (..),
+    cryptoErrToSyncState,
     ATransmission,
     ATransmissionOrError,
     ARawTransmission,
@@ -324,6 +326,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone
   UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
   SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
+  RSYNC :: RatchetSyncState -> ConnectionStats -> ACommand Agent AEConn
   SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
   MID :: AgentMsgId -> ACommand Agent AEConn
   SENT :: AgentMsgId -> ACommand Agent AEConn
@@ -382,6 +385,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   DOWN_ :: ACommandTag Agent AENone
   UP_ :: ACommandTag Agent AENone
   SWITCH_ :: ACommandTag Agent AEConn
+  RSYNC_ :: ACommandTag Agent AEConn
   SEND_ :: ACommandTag Client AEConn
   MID_ :: ACommandTag Agent AEConn
   SENT_ :: ACommandTag Agent AEConn
@@ -433,6 +437,7 @@ aCommandTag = \case
   DOWN {} -> DOWN_
   UP {} -> UP_
   SWITCH {} -> SWITCH_
+  RSYNC {} -> RSYNC_
   SEND {} -> SEND_
   MID _ -> MID_
   SENT _ -> SENT_
@@ -559,6 +564,41 @@ instance ToJSON SndSwitchStatus where
 instance FromJSON SndSwitchStatus where
   parseJSON = strParseJSON "SndSwitchStatus"
 
+data RatchetSyncState
+  = RSOk
+  | RSAllowed
+  | RSRequired
+  | RSStarted
+  | RSAgreed
+  deriving (Eq, Show)
+
+instance StrEncoding RatchetSyncState where
+  strEncode = \case
+    RSOk -> "ok"
+    RSAllowed -> "allowed"
+    RSRequired -> "required"
+    RSStarted -> "started"
+    RSAgreed -> "agreed"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "ok" -> pure RSOk
+      "allowed" -> pure RSAllowed
+      "required" -> pure RSRequired
+      "started" -> pure RSStarted
+      "agreed" -> pure RSAgreed
+      _ -> fail "bad RatchetSyncState"
+
+instance FromField RatchetSyncState where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField RatchetSyncState where toField = toField . decodeLatin1 . strEncode
+
+instance ToJSON RatchetSyncState where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance FromJSON RatchetSyncState where
+  parseJSON = strParseJSON "RatchetSyncState"
+
 data RcvQueueInfo = RcvQueueInfo
   { rcvServer :: SMPServer,
     rcvSwitchStatus :: Maybe RcvSwitchStatus,
@@ -597,17 +637,21 @@ instance StrEncoding SndQueueInfo where
 
 data ConnectionStats = ConnectionStats
   { rcvQueuesInfo :: [RcvQueueInfo],
-    sndQueuesInfo :: [SndQueueInfo]
+    sndQueuesInfo :: [SndQueueInfo],
+    ratchetSyncState :: RatchetSyncState
   }
   deriving (Eq, Show, Generic)
 
 instance StrEncoding ConnectionStats where
-  strEncode ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
-    "rcv=" <> strEncodeList rcvQueuesInfo <> " snd=" <> strEncodeList sndQueuesInfo
+  strEncode ConnectionStats {rcvQueuesInfo, sndQueuesInfo, ratchetSyncState} =
+    "rcv=" <> strEncodeList rcvQueuesInfo
+      <> (" snd=" <> strEncodeList sndQueuesInfo)
+      <> (" sync=" <> strEncode ratchetSyncState)
   strP = do
     rcvQueuesInfo <- "rcv=" *> strListP
     sndQueuesInfo <- " snd=" *> strListP
-    pure ConnectionStats {rcvQueuesInfo, sndQueuesInfo}
+    ratchetSyncState <- " sync=" *> strP
+    pure ConnectionStats {rcvQueuesInfo, sndQueuesInfo, ratchetSyncState}
 
 instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
 
@@ -710,7 +754,7 @@ data SMPConfirmation = SMPConfirmation
 data AgentMsgEnvelope
   = AgentConfirmation
       { agentVersion :: Version,
-        e2eEncryption :: Maybe (E2ERatchetParams 'C.X448),
+        e2eEncryption_ :: Maybe (E2ERatchetParams 'C.X448),
         encConnInfo :: ByteString
       }
   | AgentMsgEnvelope
@@ -722,22 +766,29 @@ data AgentMsgEnvelope
         connReq :: ConnectionRequestUri 'CMInvitation,
         connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet,
       }
+  | AgentRatchetKey
+      { agentVersion :: Version,
+        e2eEncryption :: E2ERatchetParams 'C.X448,
+        info :: ByteString
+      }
   deriving (Show)
 
 instance Encoding AgentMsgEnvelope where
   smpEncode = \case
-    AgentConfirmation {agentVersion, e2eEncryption, encConnInfo} ->
-      smpEncode (agentVersion, 'C', e2eEncryption, Tail encConnInfo)
+    AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo} ->
+      smpEncode (agentVersion, 'C', e2eEncryption_, Tail encConnInfo)
     AgentMsgEnvelope {agentVersion, encAgentMessage} ->
       smpEncode (agentVersion, 'M', Tail encAgentMessage)
     AgentInvitation {agentVersion, connReq, connInfo} ->
       smpEncode (agentVersion, 'I', Large $ strEncode connReq, Tail connInfo)
+    AgentRatchetKey {agentVersion, e2eEncryption, info} ->
+      smpEncode (agentVersion, 'R', e2eEncryption, Tail info)
   smpP = do
     agentVersion <- smpP
     smpP >>= \case
       'C' -> do
-        (e2eEncryption, Tail encConnInfo) <- smpP
-        pure AgentConfirmation {agentVersion, e2eEncryption, encConnInfo}
+        (e2eEncryption_, Tail encConnInfo) <- smpP
+        pure AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo}
       'M' -> do
         Tail encAgentMessage <- smpP
         pure AgentMsgEnvelope {agentVersion, encAgentMessage}
@@ -745,15 +796,21 @@ instance Encoding AgentMsgEnvelope where
         connReq <- strDecode . unLarge <$?> smpP
         Tail connInfo <- smpP
         pure AgentInvitation {agentVersion, connReq, connInfo}
+      'R' -> do
+        e2eEncryption <- smpP
+        Tail info <- smpP
+        pure AgentRatchetKey {agentVersion, e2eEncryption, info}
       _ -> fail "bad AgentMsgEnvelope"
 
 -- SMP agent message formats (after double ratchet decryption,
 -- or in case of AgentInvitation - in plain text body)
+-- AgentRatchetInfo is not encrypted with double ratchet, but with per-queue E2E encryption
 data AgentMessage
   = AgentConnInfo ConnInfo
   | -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
     -- It makes REPLY message unnecessary.
     AgentConnInfoReply (L.NonEmpty SMPQueueInfo) ConnInfo
+  | AgentRatchetInfo ByteString
   | AgentMessage APrivHeader AMessage
   deriving (Show)
 
@@ -761,17 +818,20 @@ instance Encoding AgentMessage where
   smpEncode = \case
     AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
     AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
+    AgentRatchetInfo info -> smpEncode ('R', Tail info)
     AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
   smpP =
     smpP >>= \case
       'I' -> AgentConnInfo . unTail <$> smpP
       'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
+      'R' -> AgentRatchetInfo . unTail <$> smpP
       'M' -> AgentMessage <$> smpP <*> smpP
       _ -> fail "bad AgentMessage"
 
 data AgentMessageType
   = AM_CONN_INFO
   | AM_CONN_INFO_REPLY
+  | AM_RATCHET_INFO
   | AM_HELLO_
   | AM_REPLY_
   | AM_A_MSG_
@@ -780,12 +840,14 @@ data AgentMessageType
   | AM_QKEY_
   | AM_QUSE_
   | AM_QTEST_
+  | AM_EREADY_
   deriving (Eq, Show)
 
 instance Encoding AgentMessageType where
   smpEncode = \case
     AM_CONN_INFO -> "C"
     AM_CONN_INFO_REPLY -> "D"
+    AM_RATCHET_INFO -> "S"
     AM_HELLO_ -> "H"
     AM_REPLY_ -> "R"
     AM_A_MSG_ -> "M"
@@ -794,10 +856,12 @@ instance Encoding AgentMessageType where
     AM_QKEY_ -> "QK"
     AM_QUSE_ -> "QU"
     AM_QTEST_ -> "QT"
+    AM_EREADY_ -> "E"
   smpP =
     A.anyChar >>= \case
       'C' -> pure AM_CONN_INFO
       'D' -> pure AM_CONN_INFO_REPLY
+      'S' -> pure AM_RATCHET_INFO
       'H' -> pure AM_HELLO_
       'R' -> pure AM_REPLY_
       'M' -> pure AM_A_MSG_
@@ -809,12 +873,14 @@ instance Encoding AgentMessageType where
           'U' -> pure AM_QUSE_
           'T' -> pure AM_QTEST_
           _ -> fail "bad AgentMessageType"
+      'E' -> pure AM_EREADY_
       _ -> fail "bad AgentMessageType"
 
 agentMessageType :: AgentMessage -> AgentMessageType
 agentMessageType = \case
   AgentConnInfo _ -> AM_CONN_INFO
   AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
+  AgentRatchetInfo _ -> AM_RATCHET_INFO
   AgentMessage _ aMsg -> case aMsg of
     -- HELLO is used both in v1 and in v2, but differently.
     -- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
@@ -829,6 +895,7 @@ agentMessageType = \case
     QKEY _ -> AM_QKEY_
     QUSE _ -> AM_QUSE_
     QTEST _ -> AM_QTEST_
+    EREADY _ -> AM_EREADY_
 
 data APrivHeader = APrivHeader
   { -- | sequential ID assigned by the sending agent
@@ -852,6 +919,7 @@ data AMsgType
   | QKEY_
   | QUSE_
   | QTEST_
+  | EREADY_
   deriving (Eq)
 
 instance Encoding AMsgType where
@@ -864,6 +932,7 @@ instance Encoding AMsgType where
     QKEY_ -> "QK"
     QUSE_ -> "QU"
     QTEST_ -> "QT"
+    EREADY_ -> "E"
   smpP =
     A.anyChar >>= \case
       'H' -> pure HELLO_
@@ -877,6 +946,7 @@ instance Encoding AMsgType where
           'U' -> pure QUSE_
           'T' -> pure QTEST_
           _ -> fail "bad AMsgType"
+      'E' -> pure EREADY_
       _ -> fail "bad AMsgType"
 
 -- | Messages sent between SMP agents once SMP queue is secured.
@@ -899,6 +969,8 @@ data AMessage
     QUSE (L.NonEmpty (SndQAddr, Bool))
   | -- sent by the sender to test new queues and to complete switching
     QTEST (L.NonEmpty SndQAddr)
+  | -- ratchet re-synchronization is complete, with last decrypted sender message id (recipient's `last_external_snd_msg_id`)
+    EREADY Int64
   deriving (Show)
 
 type SndQAddr = (SMPServer, SMP.SenderId)
@@ -913,6 +985,7 @@ instance Encoding AMessage where
     QKEY qs -> smpEncode (QKEY_, qs)
     QUSE qs -> smpEncode (QUSE_, qs)
     QTEST qs -> smpEncode (QTEST_, qs)
+    EREADY lastDecryptedMsgId -> smpEncode (EREADY_, lastDecryptedMsgId)
   smpP =
     smpP
       >>= \case
@@ -924,6 +997,7 @@ instance Encoding AMessage where
         QKEY_ -> QKEY <$> smpP
         QUSE_ -> QUSE <$> smpP
         QTEST_ -> QTEST <$> smpP
+        EREADY_ -> EREADY <$> smpP
 
 instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
   strEncode = \case
@@ -1419,6 +1493,14 @@ instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
 
 instance Arbitrary AgentCryptoError where arbitrary = genericArbitraryU
 
+cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState
+cryptoErrToSyncState = \case
+  DECRYPT_AES -> RSAllowed
+  DECRYPT_CB -> RSAllowed
+  RATCHET_HEADER -> RSRequired
+  RATCHET_EARLIER _ -> RSAllowed
+  RATCHET_SKIPPED _ -> RSRequired
+
 -- | SMP agent command and response parser for commands passed via network (only parses binary length)
 networkCommandP :: Parser ACmd
 networkCommandP = commandP A.takeByteString
@@ -1448,6 +1530,7 @@ instance StrEncoding ACmdTag where
       "DOWN" -> nt DOWN_
       "UP" -> nt UP_
       "SWITCH" -> ct SWITCH_
+      "RSYNC" -> ct RSYNC_
       "SEND" -> t SEND_
       "MID" -> ct MID_
       "SENT" -> ct SENT_
@@ -1501,6 +1584,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     DOWN_ -> "DOWN"
     UP_ -> "UP"
     SWITCH_ -> "SWITCH"
+    RSYNC_ -> "RSYNC"
     SEND_ -> "SEND"
     MID_ -> "MID"
     SENT_ -> "SENT"
@@ -1568,6 +1652,7 @@ commandP binaryP =
           DOWN_ -> s (DOWN <$> strP_ <*> connections)
           UP_ -> s (UP <$> strP_ <*> connections)
           SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
+          RSYNC_ -> s (RSYNC <$> strP_ <*> strP)
           MID_ -> s (MID <$> A.decimal)
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
@@ -1626,6 +1711,7 @@ serializeCommand = \case
   DOWN srv conns -> B.unwords [s DOWN_, s srv, connections conns]
   UP srv conns -> B.unwords [s UP_, s srv, connections conns]
   SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
+  RSYNC rrState cstats -> s (RSYNC_, rrState, cstats)
   SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
   MID mId -> s (MID_, Str $ bshow mId)
   SENT mId -> s (SENT_, Str $ bshow mId)
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index 7fbe9dfe2..871a82563 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -293,7 +293,9 @@ data ConnData = ConnData
     connAgentVersion :: Version,
     enableNtfs :: Bool,
     duplexHandshake :: Maybe Bool, -- added in agent protocol v2
-    deleted :: Bool
+    lastExternalSndId :: PrevExternalSndId,
+    deleted :: Bool,
+    ratchetSyncState :: RatchetSyncState
   }
   deriving (Eq, Show)
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 6a9341b74..eec4169dd 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -53,6 +53,10 @@ module Simplex.Messaging.Agent.Store.SQLite
     getConnData,
     setConnDeleted,
     getDeletedConnIds,
+    setConnRatchetSync,
+    addProcessedRatchetKeyHash,
+    checkProcessedRatchetKeyHashExists,
+    deleteProcessedRatchetKeyHashesExpired,
     getRcvConn,
     getRcvQueueById,
     getSndQueueById,
@@ -107,7 +111,11 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- Double ratchet persistence
     createRatchetX3dhKeys,
     getRatchetX3dhKeys,
+    createRatchetX3dhKeys',
+    getRatchetX3dhKeys',
+    setRatchetX3dhKeys,
     createRatchet,
+    deleteRatchet,
     getRatchet,
     getSkippedMsgKeys,
     updateRatchet,
@@ -1029,6 +1037,35 @@ getRatchetX3dhKeys db connId =
       Right (Just k1, Just k2) -> Right (k1, k2)
       _ -> Left SEX3dhKeysNotFound
 
+createRatchetX3dhKeys' :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> C.PublicKeyX448 -> C.PublicKeyX448 -> IO ()
+createRatchetX3dhKeys' db connId x3dhPrivKey1 x3dhPrivKey2 x3dhPubKey1 x3dhPubKey2 =
+  DB.execute
+    db
+    "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, x3dh_pub_key_1, x3dh_pub_key_2) VALUES (?,?,?,?,?)"
+    (connId, x3dhPrivKey1, x3dhPrivKey2, x3dhPubKey1, x3dhPubKey2)
+
+getRatchetX3dhKeys' :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448))
+getRatchetX3dhKeys' db connId =
+  fmap hasKeys $
+    firstRow id SEX3dhKeysNotFound $
+      DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, x3dh_pub_key_1, x3dh_pub_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
+  where
+    hasKeys = \case
+      Right (Just pk1, Just pk2, Just k1, Just k2) -> Right (pk1, pk2, k1, k2)
+      _ -> Left SEX3dhKeysNotFound
+
+-- used to remember new keys when starting ratchet re-synchronization
+setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> C.PublicKeyX448 -> C.PublicKeyX448 -> IO ()
+setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 x3dhPubKey1 x3dhPubKey2 =
+  DB.execute
+    db
+    [sql|
+      UPDATE ratchets
+      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?
+      WHERE conn_id = ?
+    |]
+    (x3dhPrivKey1, x3dhPrivKey2, x3dhPubKey1, x3dhPubKey2, connId)
+
 createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO ()
 createRatchet db connId rc =
   DB.executeNamed
@@ -1039,10 +1076,16 @@ createRatchet db connId rc =
       ON CONFLICT (conn_id) DO UPDATE SET
         ratchet_state = :ratchet_state,
         x3dh_priv_key_1 = NULL,
-        x3dh_priv_key_2 = NULL
+        x3dh_priv_key_2 = NULL,
+        x3dh_pub_key_1 = NULL,
+        x3dh_pub_key_2 = NULL
     |]
     [":conn_id" := connId, ":ratchet_state" := rc]
 
+deleteRatchet :: DB.Connection -> ConnId -> IO ()
+deleteRatchet db connId =
+  DB.execute db "DELETE FROM ratchets WHERE conn_id = ?" (Only connId)
+
 getRatchet :: DB.Connection -> ConnId -> IO (Either StoreError RatchetX448)
 getRatchet db connId =
   firstRow' ratchet SERatchetNotFound $ DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId)
@@ -1643,10 +1686,21 @@ getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAn
     handleDBError = pure . Left . SEInternal . bshow
 
 getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
-getConnData dbConn connId' =
-  maybeFirstRow cData $ DB.query dbConn "SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId')
+getConnData db connId' =
+  maybeFirstRow cData $
+    DB.query
+      db
+      [sql|
+        SELECT
+          user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake,
+          last_external_snd_msg_id, deleted, ratchet_sync_state
+        FROM connections
+        WHERE conn_id = ?
+      |]
+      (Only connId')
   where
-    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode)
+    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, lastExternalSndId, deleted, ratchetSyncState) =
+      (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, lastExternalSndId, deleted, ratchetSyncState}, cMode)
 
 setConnDeleted :: DB.Connection -> ConnId -> IO ()
 setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
@@ -1654,6 +1708,30 @@ setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHE
 getDeletedConnIds :: DB.Connection -> IO [ConnId]
 getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
 
+setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO ()
+setConnRatchetSync db connId ratchetSyncState =
+  DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId)
+
+addProcessedRatchetKeyHash :: DB.Connection -> ConnId -> ByteString -> IO ()
+addProcessedRatchetKeyHash db connId hash =
+  DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, hash)
+
+checkProcessedRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
+checkProcessedRatchetKeyHashExists db connId hash = do
+  fromMaybe False
+    <$> maybeFirstRow
+      fromOnly
+      ( DB.query
+          db
+          "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
+          (connId, hash)
+      )
+
+deleteProcessedRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
+deleteProcessedRatchetKeyHashesExpired db ttl = do
+  cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
+  DB.execute db "DELETE FROM processed_ratchet_key_hashes WHERE created_at < ?" (Only cutoffTs)
+
 -- | returns all connection queues, the first queue is the primary one
 getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
 getRcvQueuesByConnId_ db connId =
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index 4e03c4e1a..bc91cd8f0 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
@@ -61,6 +61,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -88,7 +89,8 @@ schemaMigrations =
     ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
     ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
     ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
-    ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status)
+    ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
+    ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync)
   ]
 
 -- | The list of migrations in ascending order by date
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230615_ratchet_sync.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230615_ratchet_sync.hs
new file mode 100644
index 000000000..38db93060
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230615_ratchet_sync.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+-- Ratchet public keys are saved when ratchet re-synchronization is started - upon receiving other party's public keys,
+-- keys are compared to determine ratchet initialization ordering for both parties.
+-- This solves a possible race when both parties start ratchet re-synchronization at the same time.
+m20230615_ratchet_sync :: Query
+m20230615_ratchet_sync =
+  [sql|
+ALTER TABLE connections ADD COLUMN ratchet_sync_state TEXT NOT NULL DEFAULT 'ok';
+
+ALTER TABLE ratchets ADD COLUMN x3dh_pub_key_1 BLOB;
+ALTER TABLE ratchets ADD COLUMN x3dh_pub_key_2 BLOB;
+
+CREATE TABLE processed_ratchet_key_hashes(
+  processed_ratchet_key_hash_id INTEGER PRIMARY KEY,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  hash BLOB NOT NULL,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
+|]
+
+down_m20230615_ratchet_sync :: Query
+down_m20230615_ratchet_sync =
+  [sql|
+DROP INDEX idx_processed_ratchet_key_hashes_hash;
+
+DROP TABLE processed_ratchet_key_hashes;
+
+ALTER TABLE ratchets DROP COLUMN x3dh_pub_key_2;
+ALTER TABLE ratchets DROP COLUMN x3dh_pub_key_1;
+
+ALTER TABLE connections DROP COLUMN ratchet_sync_state;
+|]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index c391e484c..ca07c8244 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -25,7 +25,8 @@ CREATE TABLE connections(
   enable_ntfs INTEGER,
   deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL),
   user_id INTEGER CHECK(user_id NOT NULL)
-  REFERENCES users ON DELETE CASCADE
+  REFERENCES users ON DELETE CASCADE,
+  ratchet_sync_state TEXT NOT NULL DEFAULT 'ok'
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -154,6 +155,9 @@ CREATE TABLE ratchets(
   -- ratchet is initially empty on the receiving side(the side offering the connection)
   ratchet_state BLOB,
   e2e_version INTEGER NOT NULL DEFAULT 1
+  ,
+  x3dh_pub_key_1 BLOB,
+  x3dh_pub_key_2 BLOB
 ) WITHOUT ROWID;
 CREATE TABLE skipped_messages(
   skipped_message_id INTEGER PRIMARY KEY,
@@ -356,6 +360,13 @@ CREATE TABLE encrypted_rcv_message_hashes(
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
+CREATE TABLE processed_ratchet_key_hashes(
+  processed_ratchet_key_hash_id INTEGER PRIMARY KEY,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  hash BLOB NOT NULL,
+  created_at TEXT NOT NULL DEFAULT(datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT(datetime('now'))
+);
 CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
 CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
 CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
@@ -446,3 +457,7 @@ CREATE INDEX idx_encrypted_rcv_message_hashes_hash ON encrypted_rcv_message_hash
   conn_id,
   hash
 );
+CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(
+  conn_id,
+  hash
+);
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index c95d8f304..c1a70dec8 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -125,16 +125,16 @@ runRight action =
     Right x -> pure x
     Left e -> error $ "Unexpected error: " <> show e
 
-getInAnyOrder :: HasCallStack => AgentClient -> [AEntityTransmission 'AEConn -> Bool] -> Expectation
+getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation
 getInAnyOrder _ [] = pure ()
 getInAnyOrder c rs = do
-  r <- get c
+  r <- pGet c
   let rest = filter (not . expected r) rs
   if length rest < length rs
     then getInAnyOrder c rest
     else error $ "unexpected event: " <> show r
   where
-    expected :: AEntityTransmission 'AEConn -> (AEntityTransmission 'AEConn -> Bool) -> Bool
+    expected :: ATransmission 'Agent -> (ATransmission 'Agent -> Bool) -> Bool
     expected r rp = rp r
 
 functionalAPITests :: ATransport -> Spec
@@ -169,8 +169,17 @@ functionalAPITests t = do
       testDuplicateMessage t
     it "should report error via msg integrity on skipped messages" $
       testSkippedMessages t
-    it "should report decryption error on ratchet becoming out of sync" $
-      testDecryptionError t
+    describe "Ratchet synchronization" $ do
+      it "should report ratchet de-synchronization, synchronize ratchets" $
+        testRatchetSync t
+      it "should synchronize ratchets after server being offline" $
+        testRatchetSyncServerOffline t
+      it "should synchronize ratchets after client restart" $
+        testRatchetSyncClientRestart t
+      it "should synchronize ratchets after suspend/foreground" $
+        testRatchetSyncSuspendForeground t
+      it "should synchronize ratchets when clients start synchronization simultaneously" $
+        testRatchetSyncSimultaneous t
   describe "Inactive client disconnection" $ do
     it "should disconnect clients if it was inactive longer than TTL" $
       testInactiveClientDisconnected t
@@ -639,53 +648,222 @@ testSkippedMessages t = do
       get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False
       ackMessage bob2 aliceId 6
 
-testDecryptionError :: HasCallStack => ATransport -> IO ()
-testDecryptionError t = do
+testRatchetSync :: HasCallStack => ATransport -> IO ()
+testRatchetSync t = do
   alice <- getSMPAgentClient' agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
-    (aliceId, bobId) <- runRight $ makeConnection alice bob
+    (aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob
+    runRight $ do
+      ConnectionStats {ratchetSyncState} <- synchronizeRatchet bob2 aliceId False
+      liftIO $ ratchetSyncState `shouldBe` RSStarted
+
+      get alice =##> ratchetSyncP bobId RSAgreed
+
+      get bob2 =##> ratchetSyncP aliceId RSAgreed
+
+      get alice =##> ratchetSyncP bobId RSOk
+
+      get bob2 =##> ratchetSyncP aliceId RSOk
+
+      exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
+
+setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient)
+setupDesynchronizedRatchet alice bob = do
+  (aliceId, bobId) <- runRight $ makeConnection alice bob
+  runRight_ $ do
+    4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+    get alice ##> ("", bobId, SENT 4)
+    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+    ackMessage bob aliceId 4
+
+    5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2"
+    get bob ##> ("", aliceId, SENT 5)
+    get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False
+    ackMessage alice bobId 5
+
+    liftIO $ copyFile testDB2 (testDB2 <> ".bak")
+
+    6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
+    get alice ##> ("", bobId, SENT 6)
+    get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
+    ackMessage bob aliceId 6
+
+    7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4"
+    get bob ##> ("", aliceId, SENT 7)
+    get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False
+    ackMessage alice bobId 7
+
+  disconnectAgentClient bob
+
+  -- importing database backup after progressing ratchet de-synchronizes ratchet
+  liftIO $ renameFile (testDB2 <> ".bak") testDB2
+
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
+
+  runRight_ $ do
+    subscribeConnection bob2 aliceId
+
+    Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ synchronizeRatchet bob2 aliceId False
+
+    8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5"
+    get alice ##> ("", bobId, SENT 8)
+    get bob2 =##> ratchetSyncP aliceId RSRequired
+
+    Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ sendMessage bob2 aliceId SMP.noMsgFlags "hello 6"
+    pure ()
+
+  pure (aliceId, bobId, bob2)
+
+ratchetSyncP :: ConnId -> RatchetSyncState -> AEntityTransmission 'AEConn -> Bool
+ratchetSyncP cId rrs = \case
+  (_, cId', RSYNC rrs' ConnectionStats {ratchetSyncState}) ->
+    cId' == cId && rrs' == rrs && ratchetSyncState == rrs
+  _ -> False
+
+ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission 'Agent -> Bool
+ratchetSyncP' cId rrs = \case
+  (_, cId', APC SAEConn (RSYNC rrs' ConnectionStats {ratchetSyncState})) ->
+    cId' == cId && rrs' == rrs && ratchetSyncState == rrs
+  _ -> False
+
+testRatchetSyncServerOffline :: HasCallStack => ATransport -> IO ()
+testRatchetSyncServerOffline t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
+    setupDesynchronizedRatchet alice bob
+
+  ("", "", DOWN _ _) <- nGet alice
+  ("", "", DOWN _ _) <- nGet bob2
+
+  ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId False
+  liftIO $ ratchetSyncState `shouldBe` RSStarted
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight_ $ do
-      4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
-      get alice ##> ("", bobId, SENT 4)
-      get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-      ackMessage bob aliceId 4
+      liftIO . getInAnyOrder alice $
+        [ ratchetSyncP' bobId RSAgreed,
+          serverUpP
+        ]
 
-      5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2"
-      get bob ##> ("", aliceId, SENT 5)
-      get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False
-      ackMessage alice bobId 5
+      liftIO . getInAnyOrder bob2 $
+        [ ratchetSyncP' aliceId RSAgreed,
+          serverUpP
+        ]
 
-      liftIO $ copyFile testDB2 (testDB2 <> ".bak")
+      get alice =##> ratchetSyncP bobId RSOk
 
-      6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
-      get alice ##> ("", bobId, SENT 6)
-      get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
-      ackMessage bob aliceId 6
+      get bob2 =##> ratchetSyncP aliceId RSOk
 
-      7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4"
-      get bob ##> ("", aliceId, SENT 7)
-      get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False
-      ackMessage alice bobId 7
+      exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
 
-    disconnectAgentClient bob
+serverUpP :: ATransmission 'Agent -> Bool
+serverUpP = \case
+  ("", "", APC SAENone (UP _ _)) -> True
+  _ -> False
 
-    -- importing database backup after progressing ratchet de-synchronizes ratchet,
-    -- this will be fixed by ratchet re-negotiation
-    liftIO $ renameFile (testDB2 <> ".bak") testDB2
+testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO ()
+testRatchetSyncClientRestart t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
+    setupDesynchronizedRatchet alice bob
 
-    bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  ("", "", DOWN _ _) <- nGet alice
+  ("", "", DOWN _ _) <- nGet bob2
 
+  ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId False
+  liftIO $ ratchetSyncState `shouldBe` RSStarted
+
+  disconnectAgentClient bob2
+
+  bob3 <- getSMPAgentClient' agentCfg initAgentServers testDB2
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight_ $ do
-      subscribeConnection bob2 aliceId
+      ("", "", UP _ _) <- nGet alice
 
-      8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5"
-      get alice ##> ("", bobId, SENT 8)
-      get bob2 =##> \case ("", c, ERR AGENT {agentErr = A_CRYPTO {cryptoErr = RATCHET_HEADER}}) -> c == aliceId; _ -> False
+      subscribeConnection bob3 aliceId
 
-      6 <- sendMessage bob2 aliceId SMP.noMsgFlags "hello 6"
-      get bob2 ##> ("", aliceId, SENT 6)
-      get alice =##> \case ("", c, ERR AGENT {agentErr = A_CRYPTO {cryptoErr = RATCHET_HEADER}}) -> c == bobId; _ -> False
+      get alice =##> ratchetSyncP bobId RSAgreed
+
+      get bob3 =##> ratchetSyncP aliceId RSAgreed
+
+      get alice =##> ratchetSyncP bobId RSOk
+
+      get bob3 =##> ratchetSyncP aliceId RSOk
+
+      exchangeGreetingsMsgIds alice bobId 12 bob3 aliceId 9
+
+testRatchetSyncSuspendForeground :: HasCallStack => ATransport -> IO ()
+testRatchetSyncSuspendForeground t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
+    setupDesynchronizedRatchet alice bob
+
+  ("", "", DOWN _ _) <- nGet alice
+  ("", "", DOWN _ _) <- nGet bob2
+
+  ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId False
+  liftIO $ ratchetSyncState `shouldBe` RSStarted
+
+  suspendAgent bob2 0
+  threadDelay 100000
+  foregroundAgent bob2
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    runRight_ $ do
+      liftIO . getInAnyOrder alice $
+        [ ratchetSyncP' bobId RSAgreed,
+          serverUpP
+        ]
+
+      liftIO . getInAnyOrder bob2 $
+        [ ratchetSyncP' aliceId RSAgreed,
+          serverUpP
+        ]
+
+      get alice =##> ratchetSyncP bobId RSOk
+
+      get bob2 =##> ratchetSyncP aliceId RSOk
+
+      exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
+
+testRatchetSyncSimultaneous :: HasCallStack => ATransport -> IO ()
+testRatchetSyncSimultaneous t = do
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ ->
+    setupDesynchronizedRatchet alice bob
+
+  ("", "", DOWN _ _) <- nGet alice
+  ("", "", DOWN _ _) <- nGet bob2
+
+  ConnectionStats {ratchetSyncState = bRSS} <- runRight $ synchronizeRatchet bob2 aliceId False
+  liftIO $ bRSS `shouldBe` RSStarted
+
+  ConnectionStats {ratchetSyncState = aRSS} <- runRight $ synchronizeRatchet alice bobId True
+  liftIO $ aRSS `shouldBe` RSStarted
+
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    runRight_ $ do
+      liftIO . getInAnyOrder alice $
+        [ ratchetSyncP' bobId RSAgreed,
+          serverUpP
+        ]
+
+      liftIO . getInAnyOrder bob2 $
+        [ ratchetSyncP' aliceId RSAgreed,
+          serverUpP
+        ]
+
+      get alice =##> ratchetSyncP bobId RSOk
+
+      get bob2 =##> ratchetSyncP aliceId RSOk
+
+      exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection alice bob = makeConnectionForUsers alice 1 bob 1
@@ -1265,20 +1443,20 @@ testAbortSwitchStartedReinitiate servers = do
     withB :: (AgentClient -> IO a) -> IO a
     withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
-switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> AEntityTransmission 'AEConn -> Bool
+switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission 'Agent -> Bool
 switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
 
-switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> AEntityTransmission 'AEConn -> Bool
+switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission 'Agent -> Bool
 switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses)
 
-switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> AEntityTransmission 'AEConn -> Bool
+switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission 'Agent -> Bool
 switchPhaseP cId qd sphase statsP = \case
-  (_, cId', SWITCH qd' sphase' stats) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
+  (_, cId', APC SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
   _ -> False
 
-errQueueNotFoundP :: ConnId -> AEntityTransmission 'AEConn -> Bool
+errQueueNotFoundP :: ConnId -> ATransmission 'Agent -> Bool
 errQueueNotFoundP cId = \case
-  (_, cId', ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}) -> cId' == cId
+  (_, cId', APC SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId
   _ -> False
 
 testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
@@ -1327,43 +1505,44 @@ testSwitch2Connections servers = do
     (aId2, bId2) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId2 b aId2
     pure (aId1, bId1, aId2, bId2)
-  withA $ \a -> runRight_ $ do
-    void $ subscribeConnections a [bId1, bId2]
+  let withA' = sessionSubscribe withA [bId1, bId2]
+      withB' = sessionSubscribe withB [aId1, aId2]
+  withA' $ \a -> do
     stats1 <- switchConnectionAsync a "" bId1
     liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
     stats2 <- switchConnectionAsync a "" bId2
     liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
-  withA $ \a -> withB $ \b -> runRight_ $ do
-    void $ subscribeConnections a [bId1, bId2]
-    void $ subscribeConnections b [aId1, aId2]
-
+  withB' $ \b -> do
     liftIO . getInAnyOrder b $
       [ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
         switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
         switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
         switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
       ]
-
+  withA' $ \a -> do
     liftIO . getInAnyOrder a $
       [ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
         switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
         switchPhaseRcvP bId2 SPConfirmed [Just RSSendingQADD, Nothing],
         switchPhaseRcvP bId2 SPSecured [Just RSSendingQUSE, Nothing]
       ]
-
+  withB' $ \b -> do
     liftIO . getInAnyOrder b $
       [ switchPhaseSndP aId1 SPSecured [Just SSSendingQTEST, Nothing],
         switchPhaseSndP aId1 SPCompleted [Nothing],
         switchPhaseSndP aId2 SPSecured [Just SSSendingQTEST, Nothing],
         switchPhaseSndP aId2 SPCompleted [Nothing]
       ]
-
+  withA' $ \a -> do
     liftIO . getInAnyOrder a $
       [ switchPhaseRcvP bId1 SPCompleted [Nothing],
         switchPhaseRcvP bId2 SPCompleted [Nothing]
       ]
+  withA $ \a -> withB $ \b -> runRight_ $ do
+    void $ subscribeConnections a [bId1, bId2]
+    void $ subscribeConnections b [aId1, aId2]
 
     exchangeGreetingsMsgId 10 a bId1 b aId1
     exchangeGreetingsMsgId 10 a bId2 b aId2
@@ -1594,3 +1773,18 @@ exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
   get bob ##> ("", aliceId, SENT msgId')
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
   ackMessage alice bobId msgId'
+
+exchangeGreetingsMsgIds :: HasCallStack => AgentClient -> ConnId -> Int64 -> AgentClient -> ConnId -> Int64 -> ExceptT AgentErrorType IO ()
+exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
+  msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
+  liftIO $ msgId1 `shouldBe` aliceMsgId
+  get alice ##> ("", bobId, SENT aliceMsgId)
+  get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+  ackMessage bob aliceId bobMsgId
+  msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
+  let aliceMsgId' = aliceMsgId + 1
+      bobMsgId' = bobMsgId + 1
+  liftIO $ msgId2 `shouldBe` bobMsgId'
+  get bob ##> ("", aliceId, SENT bobMsgId')
+  get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
+  ackMessage alice bobId aliceMsgId'
diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs
index 89b54face..3aa0721d4 100644
--- a/tests/AgentTests/SQLiteTests.hs
+++ b/tests/AgentTests/SQLiteTests.hs
@@ -140,7 +140,7 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False}
+cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
 
 testPrivateSignKey :: C.APrivateSignKey
 testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"

From 16367fcb3ba56546f3f7a405850640c2137790cc Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 30 Jun 2023 12:26:09 +0100
Subject: [PATCH 23/49] make timeouts for batched functions dependent on the
 number of batches (#786)

* make timeouts for batched functions dependent on the number of batches

* fix

* refactor

* refactor

* change import

* refactor

* rename function

* rename

* refactor

* remove space
---
 src/Simplex/Messaging/Client.hs | 70 ++++++++++++++++++++++++++-------
 src/Simplex/Messaging/Crypto.hs |  3 ++
 2 files changed, 58 insertions(+), 15 deletions(-)

diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index 957bd3bad..c83083d8e 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TupleSections #-}
 
 -- |
 -- Module      : Simplex.Messaging.Client
@@ -82,10 +83,11 @@ import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (rights)
+import Data.Foldable (foldl')
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (find)
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Data.Time.Clock (UTCTime, getCurrentTime)
@@ -114,6 +116,9 @@ data ProtocolClient err msg = ProtocolClient
     sessionId :: SessionId,
     sessionTs :: UTCTime,
     thVersion :: Version,
+    timeoutPerBlock :: Int,
+    blockSize :: Int,
+    batch :: Bool,
     client_ :: PClient err msg
   }
 
@@ -122,6 +127,7 @@ data PClient err msg = PClient
     transportSession :: TransportSession msg,
     transportHost :: TransportHost,
     tcpTimeout :: Int,
+    batchDelay :: Maybe Int,
     pingErrorCount :: TVar Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TMap CorrId (Request err msg),
@@ -168,6 +174,8 @@ data NetworkConfig = NetworkConfig
     tcpConnectTimeout :: Int,
     -- | timeout of protocol commands (microseconds)
     tcpTimeout :: Int,
+    -- | additional timeout per kilobyte (1024 bytes) to be sent
+    tcpTimeoutPerKb :: Int,
     -- | TCP keep-alive options, Nothing to skip enabling keep-alive
     tcpKeepAlive :: Maybe KeepAliveOpts,
     -- | period for SMP ping commands (microseconds, 0 to disable)
@@ -201,6 +209,7 @@ defaultNetworkConfig =
       sessionMode = TSMUser,
       tcpConnectTimeout = 7_500_000,
       tcpTimeout = 5_000_000,
+      tcpTimeoutPerKb = 10_000, -- 10ms, should be less than 130ms to avoid Int overflow on 32 bit systems
       tcpKeepAlive = Just defaultKeepAliveOpts,
       smpPingInterval = 600_000_000, -- 10min
       smpPingCount = 3,
@@ -286,7 +295,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
         `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
     Left e -> pure $ Left e
   where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb, smpPingInterval} = networkConfig
     mkProtocolClient :: TransportHost -> STM (PClient err msg)
     mkProtocolClient transportHost = do
       connected <- newTVar False
@@ -301,6 +310,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
             transportSession,
             transportHost,
             tcpTimeout,
+            batchDelay,
             pingErrorCount,
             clientCorrId,
             sentCommands,
@@ -334,9 +344,10 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
     client _ c cVar h =
       runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
-        Right th@THandle {sessionId, thVersion} -> do
+        Right th@THandle {sessionId, thVersion, blockSize, batch} -> do
           sessionTs <- getCurrentTime
-          let c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs}
+          let timeoutPerBlock = (blockSize * tcpTimeoutPerKb) `div` 1024
+              c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs, timeoutPerBlock, blockSize, batch}
           atomically $ do
             writeTVar (connected c) True
             putTMVar cVar $ Right c'
@@ -586,32 +597,61 @@ okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs
 sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
 sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
+type PCTransmission err msg = (SentRawTransmission, TMVar (Response err msg))
+
 -- | Send multiple commands with batching and collect responses
+-- It will result in Int overflow on 32 bit platform for a large number of blocks (~13.4k blocks / ~1.2m subscriptions)
+-- TODO switch to timeout or TimeManager that supports Int64
 sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either (ProtocolClientError err) msg))
-sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ}} cs = do
-  ts <- mapM (runExceptT . mkTransmission c) cs
-  mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
-  forConcurrently ts $ \case
-    Right (_, r) -> withTimeout c $ atomically $ takeTMVar r
+sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout, batchDelay}, batch, blockSize, timeoutPerBlock} cs = do
+  (h :| ts) <- mapM (runExceptT . mkTransmission c) cs
+  let h' :: Either (ProtocolClientError err) (PCTransmission err msg, Int) = (,timeoutPerBlock) <$> h
+      batchSz = if batch then either (const 0) tSize h else 0
+      ts' :: NonEmpty (Either (ProtocolClientError err) (PCTransmission err msg, Int)) =
+        L.reverse . fst3 $ foldl' batchTimeouts ([h'], timeoutPerBlock, batchSz) ts
+      ts_ :: (Maybe (NonEmpty SentRawTransmission)) =
+        L.nonEmpty . map (fst . fst) . rights $ L.toList ts'
+  mapM_ (atomically . writeTBQueue sndQ) ts_
+  forConcurrently ts' $ \case
+    Right ((_t, r), bt) -> withTimeout c (tcpTimeout + bt) (atomically $ takeTMVar r)
     Left e -> pure $ Left e
+  where
+    fst3 (x, _, _) = x
+    -- tSize calculation matches the batching logic in tPut that does actual breaking of transmissions into blocks
+    tSize :: PCTransmission err msg -> Int
+    tSize ((sig, t), _) = maybe 0 C.signatureSize sig + B.length t + 3 -- 1 byte for signature size + 2 bytes for transmission size
+    batchTimeouts :: (NonEmpty (Either (ProtocolClientError err) (PCTransmission err msg, Int)), Int, Int) -> Either (ProtocolClientError err) (PCTransmission err msg) -> (NonEmpty (Either (ProtocolClientError err) (PCTransmission err msg, Int)), Int, Int)
+    batchTimeouts (ts, bt, batchSz) = \case
+      Left e -> (Left e <| ts, bt, batchSz)
+      Right t
+        | not batch ->
+          (Right (t, bt') <| ts, bt', 0)
+        | batchSz' + 1 > blockSize ->
+          (Right (t, bt') <| ts, bt', tSz)
+        | otherwise -> -- same block in the batch
+          (Right (t, bt) <| ts, bt, batchSz') -- 1 byte for the number of transmissions in the batch
+        where
+          batchSz' = batchSz + tSz
+          bt' = bt + timeoutPerBlock + fromMaybe 0 batchDelay
+          tSz = tSize t
 
 -- | Send Protocol command
 sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
-sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}} pKey qId cmd = do
+sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} pKey qId cmd = do
   (t, r) <- mkTransmission c (pKey, qId, cmd)
   ExceptT $ sendRecv t r
   where
     -- two separate "atomically" needed to avoid blocking
     sendRecv :: SentRawTransmission -> TMVar (Response err msg) -> IO (Response err msg)
-    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c (atomically $ takeTMVar r)
+    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c tcpTimeout (atomically $ takeTMVar r)
 
-withTimeout :: ProtocolClient err msg -> IO (Either (ProtocolClientError err) msg) -> IO (Either (ProtocolClientError err) msg)
-withTimeout ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} a =
-  timeout tcpTimeout a >>= \case
+withTimeout :: ProtocolClient err msg -> Int -> IO (Either (ProtocolClientError err) msg) -> IO (Either (ProtocolClientError err) msg)
+withTimeout ProtocolClient {client_ = PClient {pingErrorCount}} t a = do
+  timeout t a >>= \case
     Just r -> atomically (writeTVar pingErrorCount 0) >> pure r
     _ -> pure $ Left PCEResponseTimeout
 
-mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> ExceptT (ProtocolClientError err) IO (SentRawTransmission, TMVar (Response err msg))
+mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> ExceptT (ProtocolClientError err) IO (PCTransmission err msg)
 mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do
   corrId <- liftIO $ atomically getNextCorrId
   let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index db058e662..5d20bdb4e 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -680,6 +680,9 @@ instance SignatureSize (Signature a) where
     SignatureEd25519 _ -> Ed25519.signatureSize
     SignatureEd448 _ -> Ed448.signatureSize
 
+instance SignatureSize ASignature where
+  signatureSize (ASignature _ s) = signatureSize s
+
 instance SignatureSize APrivateSignKey where
   signatureSize (APrivateSignKey _ k) = signatureSize k
 

From 94540a2c71f09c5a0c27894ef41fe2dd59b2dd48 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 30 Jun 2023 16:22:01 +0100
Subject: [PATCH 24/49] servers: add TCP timeouts to avoid memory leaks (#776)

* servers: add TCP timeouts to avoid memory leaks

* fix tests

* only use RecvTimeOut

* servers: simple timeout for TCP transport

* revert dependency change

* simplify

* simplify

* simplify 2
---
 src/Simplex/FileTransfer/Server.hs            |  4 +--
 src/Simplex/FileTransfer/Server/Env.hs        |  4 +--
 src/Simplex/FileTransfer/Server/Main.hs       |  6 +++-
 src/Simplex/Messaging/Agent/Server.hs         |  4 +--
 src/Simplex/Messaging/Notifications/Server.hs |  4 +--
 .../Messaging/Notifications/Server/Env.hs     |  4 +--
 .../Messaging/Notifications/Server/Main.hs    |  6 +++-
 src/Simplex/Messaging/Server.hs               |  4 +--
 src/Simplex/Messaging/Server/Env/STM.hs       |  5 +--
 src/Simplex/Messaging/Server/Main.hs          |  6 +++-
 src/Simplex/Messaging/Transport.hs            | 36 ++++++++++++-------
 src/Simplex/Messaging/Transport/Buffer.hs     | 27 ++++++++++----
 src/Simplex/Messaging/Transport/Client.hs     | 10 ++++--
 src/Simplex/Messaging/Transport/HTTP2.hs      |  2 +-
 .../Messaging/Transport/HTTP2/Server.hs       | 14 ++++----
 src/Simplex/Messaging/Transport/Server.hs     | 25 +++++++++++--
 src/Simplex/Messaging/Transport/WebSockets.hs | 17 +++++----
 tests/NtfClient.hs                            |  5 +--
 tests/SMPClient.hs                            |  3 +-
 tests/XFTPClient.hs                           |  3 +-
 20 files changed, 130 insertions(+), 59 deletions(-)

diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 7b94738b0..34dbcf34a 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -70,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, logTLSErrors} started = do
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig} started = do
   restoreServerStats
   raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer
   where
@@ -79,7 +79,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
       serverParams <- asks tlsServerParams
       env <- ask
       liftIO $
-        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams logTLSErrors $ \sessionId r sendResponse -> do
+        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig $ \sessionId r sendResponse -> do
           reqBody <- getHTTP2Body r xftpBlockSize
           processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
 
diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs
index 5ca6ddcc7..584594e96 100644
--- a/src/Simplex/FileTransfer/Server/Env.hs
+++ b/src/Simplex/FileTransfer/Server/Env.hs
@@ -26,7 +26,7 @@ import Simplex.FileTransfer.Server.StoreLog
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey)
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
 import UnliftIO.STM
@@ -55,7 +55,7 @@ data XFTPServerConfig = XFTPServerConfig
     logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
-    logTLSErrors :: Bool
+    transportConfig :: TransportServerConfig
   }
 
 data XFTPEnv = XFTPEnv
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
index 0a5d0290e..9f496e330 100644
--- a/src/Simplex/FileTransfer/Server/Main.hs
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -25,6 +25,7 @@ import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
 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)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -151,7 +152,10 @@ xftpServerCLI cfgPath logPath = do
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "file-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
-              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+              transportConfig =
+                defaultTransportServerConfig
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+                  }
             }
 
 data CliCommand
diff --git a/src/Simplex/Messaging/Agent/Server.hs b/src/Simplex/Messaging/Agent/Server.hs
index b51903c43..ef1bf5edc 100644
--- a/src/Simplex/Messaging/Agent/Server.hs
+++ b/src/Simplex/Messaging/Agent/Server.hs
@@ -23,7 +23,7 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
 import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
-import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer)
+import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer, defaultTransportServerConfig)
 import Simplex.Messaging.Util (bshow)
 import UnliftIO.Async (race_)
 import qualified UnliftIO.Exception as E
@@ -48,7 +48,7 @@ runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile,
     smpAgent _ = do
       -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
       tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-      runTransportServer started tcpPort tlsServerParams True $ \(h :: c) -> do
+      runTransportServer started tcpPort tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
         liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
         c <- getAgentClient initServers
         logConnection c True
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 8c6c6bc03..7a1abd20f 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -72,7 +72,7 @@ runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtf
 type M a = ReaderT NtfEnv IO a
 
 ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
-ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
+ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
   restoreServerStats
   s <- asks subscriber
   ps <- asks pushServer
@@ -83,7 +83,7 @@ ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
     runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
+      runTransportServer started tcpPort serverParams tCfg (runClient t)
 
     runClient :: Transport c => TProxy c -> c -> M ()
     runClient _ h = do
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index f9f3926c5..fa3f40cab 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -32,7 +32,7 @@ import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport)
-import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
@@ -57,7 +57,7 @@ data NtfServerConfig = NtfServerConfig
     logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
-    logTLSErrors :: Bool
+    transportConfig :: TransportServerConfig
   }
 
 defaultInactiveClientExpiration :: ExpirationConfig
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index efe6aeb2a..cd456fc55 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -23,6 +23,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientCo
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -123,7 +124,10 @@ ntfServerCLI cfgPath logPath =
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
-              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+              transportConfig =
+                defaultTransportServerConfig
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+                  }
             }
 
 data CliCommand
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index fa30520ff..dcd02ca5e 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -103,7 +103,7 @@ runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started
 type M a = ReaderT Env IO a
 
 smpServer :: TMVar Bool -> ServerConfig -> M ()
-smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
+smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
   s <- asks server
   restoreServerMessages
   restoreServerStats
@@ -117,7 +117,7 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
     runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
+      runTransportServer started tcpPort serverParams tCfg (runClient t)
 
     serverThread ::
       forall s.
diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs
index 27291540e..609438848 100644
--- a/src/Simplex/Messaging/Server/Env/STM.hs
+++ b/src/Simplex/Messaging/Server/Env/STM.hs
@@ -30,7 +30,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 (loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
 import Simplex.Messaging.Version
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
@@ -69,7 +69,8 @@ data ServerConfig = ServerConfig
     certificateFile :: FilePath,
     -- | SMP client-server protocol version range
     smpServerVRange :: VersionRange,
-    logTLSErrors :: Bool
+    -- | TCP transport config
+    transportConfig :: TransportServerConfig
   }
 
 defMsgExpirationDays :: Int64
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index 004f72971..df15cebda 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -28,6 +28,7 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClien
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
@@ -198,7 +199,10 @@ smpServerCLI cfgPath logPath =
               serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
               smpServerVRange = supportedSMPServerVRange,
-              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+              transportConfig =
+                defaultTransportServerConfig
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+                  }
             }
 
 data CliCommand
diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs
index 3344a8197..3c44e0989 100644
--- a/src/Simplex/Messaging/Transport.hs
+++ b/src/Simplex/Messaging/Transport.hs
@@ -29,6 +29,7 @@ module Simplex.Messaging.Transport
     supportedSMPServerVRange,
     simplexMQVersion,
     smpBlockSize,
+    TransportConfig (..),
 
     -- * Transport connection class
     Transport (..),
@@ -104,6 +105,11 @@ simplexMQVersion = showVersion SMQ.version
 
 -- * Transport connection class
 
+data TransportConfig = TransportConfig
+  { logTLSErrors :: Bool,
+    transportTimeout :: Maybe Int
+  }
+
 class Transport c where
   transport :: ATransport
   transport = ATransport (TProxy @c)
@@ -112,11 +118,13 @@ class Transport c where
 
   transportPeer :: c -> TransportPeer
 
+  transportConfig :: c -> TransportConfig
+
   -- | Upgrade server TLS context to connection (used in the server)
-  getServerConnection :: T.Context -> IO c
+  getServerConnection :: TransportConfig -> T.Context -> IO c
 
   -- | Upgrade client TLS context to connection (used in the client)
-  getClientConnection :: T.Context -> IO c
+  getClientConnection :: TransportConfig -> T.Context -> IO c
 
   -- | tls-unique channel binding per RFC5929
   tlsUnique :: c -> SessionId
@@ -150,24 +158,25 @@ data TLS = TLS
   { tlsContext :: T.Context,
     tlsPeer :: TransportPeer,
     tlsUniq :: ByteString,
-    tlsBuffer :: TBuffer
+    tlsBuffer :: TBuffer,
+    tlsTransportConfig :: TransportConfig
   }
 
-connectTLS :: T.TLSParams p => Maybe HostName -> Bool -> p -> Socket -> IO T.Context
-connectTLS host_ logErrors params sock =
+connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context
+connectTLS host_ TransportConfig {logTLSErrors} params sock =
   E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
     logHandshakeErrors (T.handshake ctx) $> ctx
   where
-    logHandshakeErrors = if logErrors then (`catchAll` logThrow) else id
+    logHandshakeErrors = if logTLSErrors then (`catchAll` logThrow) else id
     logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
     host = maybe "" (\h -> " (" <> h <> ")") host_
 
-getTLS :: TransportPeer -> T.Context -> IO TLS
-getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS
+getTLS :: TransportPeer -> TransportConfig -> T.Context -> IO TLS
+getTLS tlsPeer cfg cxt = withTlsUnique tlsPeer cxt newTLS
   where
     newTLS tlsUniq = do
       tlsBuffer <- atomically newTBuffer
-      pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, tlsBuffer}
+      pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsPeer, tlsUniq, tlsBuffer}
 
 withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
 withTlsUnique peer cxt f =
@@ -199,6 +208,7 @@ supportedParameters =
 instance Transport TLS where
   transportName _ = "TLS"
   transportPeer = tlsPeer
+  transportConfig = tlsTransportConfig
   getServerConnection = getTLS TServer
   getClientConnection = getTLS TClient
   tlsUnique = tlsUniq
@@ -207,10 +217,12 @@ instance Transport TLS where
   -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
   -- this function may return less than requested number of bytes
   cGet :: TLS -> Int -> IO ByteString
-  cGet TLS {tlsContext, tlsBuffer} n = getBuffered tlsBuffer n (T.recvData tlsContext)
-
+  cGet TLS {tlsContext, tlsBuffer, tlsTransportConfig = TransportConfig {transportTimeout = t_}} n =
+    getBuffered tlsBuffer n t_ (T.recvData tlsContext)
+      
   cPut :: TLS -> ByteString -> IO ()
-  cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
+  cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} s =
+    withTimedErr t_ . T.sendData tlsContext $ BL.fromStrict s
 
   getLn :: TLS -> IO ByteString
   getLn TLS {tlsContext, tlsBuffer} = do
diff --git a/src/Simplex/Messaging/Transport/Buffer.hs b/src/Simplex/Messaging/Transport/Buffer.hs
index 7d09d6819..141690386 100644
--- a/src/Simplex/Messaging/Transport/Buffer.hs
+++ b/src/Simplex/Messaging/Transport/Buffer.hs
@@ -8,6 +8,8 @@ import Control.Concurrent.STM
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import System.Timeout (timeout)
+import GHC.IO.Exception (ioException, IOException (..), IOErrorType (..))
 
 data TBuffer = TBuffer
   { buffer :: TVar ByteString,
@@ -26,22 +28,33 @@ withBufferLock TBuffer {getLock} =
     (atomically $ takeTMVar getLock)
     (atomically $ putTMVar getLock ())
 
-getBuffered :: TBuffer -> Int -> IO ByteString -> IO ByteString
-getBuffered tb@TBuffer {buffer} n getChunk = withBufferLock tb $ do
-  b <- readChunks =<< readTVarIO buffer
+getBuffered :: TBuffer -> Int -> Maybe Int -> IO ByteString -> IO ByteString
+getBuffered tb@TBuffer {buffer} n t_ getChunk = withBufferLock tb $ do
+  b <- readChunks True =<< readTVarIO buffer
   let (s, b') = B.splitAt n b
   atomically $ writeTVar buffer $! b'
   -- This would prevent the need to pad auth tag in HTTP2
   -- threadDelay 150
   pure s
   where
-    readChunks :: ByteString -> IO ByteString
-    readChunks b
+    readChunks :: Bool -> ByteString -> IO ByteString
+    readChunks firstChunk b
       | B.length b >= n = pure b
       | otherwise =
-        getChunk >>= \case
+        get >>= \case
           "" -> pure b
-          s -> readChunks $ b <> s
+          s -> readChunks False $ b <> s
+      where
+        get
+          | firstChunk = getChunk
+          | otherwise = withTimedErr t_ getChunk
+
+withTimedErr :: Maybe Int -> IO a -> IO a
+withTimedErr t_ a = case t_ of
+  Just t -> timeout t a >>= maybe err pure
+  Nothing -> a
+  where
+    err = ioException (IOError Nothing TimeExpired "" "get timeout" Nothing Nothing)
 
 -- This function is only used in test and needs to be improved before it can be used in production,
 -- it will never complete if TLS connection is closed before there is newline.
diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs
index 464d3230e..1f7fd44a8 100644
--- a/src/Simplex/Messaging/Transport/Client.hs
+++ b/src/Simplex/Messaging/Transport/Client.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -114,12 +115,16 @@ data TransportClientConfig = TransportClientConfig
 defaultTransportClientConfig :: TransportClientConfig
 defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
 
+clientTransportConfig :: TransportClientConfig -> TransportConfig
+clientTransportConfig TransportClientConfig {logTLSErrors} =
+  TransportConfig {logTLSErrors, transportTimeout = Nothing}
+
 -- | Connect to passed TCP host:port and pass handle to the client.
 runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
 runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} proxyUsername host port keyHash client = do
+runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive} proxyUsername host port keyHash client = do
   let hostName = B.unpack $ strEncode host
       clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
       connectTCP = case socksProxy of
@@ -128,7 +133,8 @@ runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpK
   c <- liftIO $ do
     sock <- connectTCP port
     mapM_ (setSocketKeepAlive sock) tcpKeepAlive
-    connectTLS (Just hostName) logTLSErrors clientParams sock >>= getClientConnection
+    let tCfg = clientTransportConfig cfg
+    connectTLS (Just hostName) tCfg clientParams sock >>= getClientConnection tCfg
   client c `E.finally` liftIO (closeConnection c)
   where
     hostAddr = \case
diff --git a/src/Simplex/Messaging/Transport/HTTP2.hs b/src/Simplex/Messaging/Transport/HTTP2.hs
index f258f9dc9..1feccce88 100644
--- a/src/Simplex/Messaging/Transport/HTTP2.hs
+++ b/src/Simplex/Messaging/Transport/HTTP2.hs
@@ -73,7 +73,7 @@ instance HTTP2BodyChunk HS.Request where
 getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
 getHTTP2Body r n = do
   bodyBuffer <- atomically newTBuffer
-  let getPart n' = getBuffered bodyBuffer n' $ getBodyChunk r
+  let getPart n' = getBuffered bodyBuffer n' Nothing $ getBodyChunk r
   bodyHead <- getPart n
   let bodySize = fromMaybe 0 $ getBodySize r
       -- TODO check bodySize once it is set
diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs
index 9a305ed8a..650026ef4 100644
--- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs
+++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs
@@ -14,7 +14,7 @@ import qualified Network.TLS as T
 import Numeric.Natural (Natural)
 import Simplex.Messaging.Transport (SessionId)
 import Simplex.Messaging.Transport.HTTP2
-import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
+import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer)
 
 type HTTP2ServerFunc = SessionId -> Request -> (Response -> IO ()) -> IO ()
 
@@ -27,7 +27,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
-    logTLSErrors :: Bool
+    transportConfig :: TransportServerConfig
   }
   deriving (Show)
 
@@ -45,12 +45,12 @@ data HTTP2Server = HTTP2Server
 
 -- This server is for testing only, it processes all requests in a single queue.
 getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, logTLSErrors} = do
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
   tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port bufferSize tlsServerParams logTLSErrors $ \sessionId r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig $ \sessionId r sendResponse -> do
       reqBody <- getHTTP2Body r bodyHeadSize
       atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
@@ -59,8 +59,8 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port bufferSize serverParams logTLSErrors http2Server =
-  runTransportServer started port serverParams logTLSErrors $ withHTTP2 bufferSize run
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port bufferSize serverParams transportConfig http2Server =
+  runTransportServer started port serverParams transportConfig $ withHTTP2 bufferSize run
   where
     run cfg sessId = H.run cfg $ \req _aux sendResp -> http2Server sessId req (`sendResp` [])
diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs
index 536ebb0db..02d163079 100644
--- a/src/Simplex/Messaging/Transport/Server.hs
+++ b/src/Simplex/Messaging/Transport/Server.hs
@@ -7,6 +7,8 @@
 module Simplex.Messaging.Transport.Server
   ( runTransportServer,
     runTCPServer,
+    TransportServerConfig (..),
+    defaultTransportServerConfig,
     loadSupportedTLSServerParams,
     loadTLSServerParams,
     loadFingerprint,
@@ -38,15 +40,32 @@ import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
+data TransportServerConfig = TransportServerConfig
+  { logTLSErrors :: Bool,
+    transportTimeout :: Int
+  }
+  deriving (Eq, Show)
+
+defaultTransportServerConfig :: TransportServerConfig
+defaultTransportServerConfig = TransportServerConfig
+  { logTLSErrors = True,
+    transportTimeout = 40000000
+  }
+
+serverTransportConfig :: TransportServerConfig -> TransportConfig
+serverTransportConfig TransportServerConfig {logTLSErrors, transportTimeout} =
+  TransportConfig {logTLSErrors, transportTimeout = Just transportTimeout}
+
 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --
 -- All accepted connections are passed to the passed function.
-runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> (c -> m ()) -> m ()
-runTransportServer started port serverParams logTLSErrors server = do
+runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> m ()) -> m ()
+runTransportServer started port serverParams cfg server = do
   u <- askUnliftIO
+  let tCfg = serverTransportConfig cfg
   liftIO . runTCPServer started port $ \conn ->
     E.bracket
-      (connectTLS Nothing logTLSErrors serverParams conn >>= getServerConnection)
+      (connectTLS Nothing tCfg serverParams conn >>= getServerConnection tCfg)
       closeConnection
       (unliftIO u . server)
 
diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs
index c6b1a2610..a0633e09e 100644
--- a/src/Simplex/Messaging/Transport/WebSockets.hs
+++ b/src/Simplex/Messaging/Transport/WebSockets.hs
@@ -17,6 +17,7 @@ import Simplex.Messaging.Transport
     Transport (..),
     TransportError (..),
     TransportPeer (..),
+    TransportConfig (..),
     closeTLS,
     smpBlockSize,
     withTlsUnique,
@@ -27,7 +28,8 @@ data WS = WS
   { wsPeer :: TransportPeer,
     tlsUniq :: ByteString,
     wsStream :: Stream,
-    wsConnection :: Connection
+    wsConnection :: Connection,
+    wsTransportConfig :: TransportConfig
   }
 
 websocketsOpts :: ConnectionOptions
@@ -45,10 +47,13 @@ instance Transport WS where
   transportPeer :: WS -> TransportPeer
   transportPeer = wsPeer
 
-  getServerConnection :: T.Context -> IO WS
+  transportConfig :: WS -> TransportConfig
+  transportConfig = wsTransportConfig
+
+  getServerConnection :: TransportConfig -> T.Context -> IO WS
   getServerConnection = getWS TServer
 
-  getClientConnection :: T.Context -> IO WS
+  getClientConnection :: TransportConfig -> T.Context -> IO WS
   getClientConnection = getWS TClient
 
   tlsUnique :: WS -> ByteString
@@ -74,13 +79,13 @@ instance Transport WS where
       then E.throwIO TEBadBlock
       else pure $ B.init s
 
-getWS :: TransportPeer -> T.Context -> IO WS
-getWS wsPeer cxt = withTlsUnique wsPeer cxt connectWS
+getWS :: TransportPeer -> TransportConfig -> T.Context -> IO WS
+getWS wsPeer cfg cxt = withTlsUnique wsPeer cxt connectWS
   where
     connectWS tlsUniq = do
       s <- makeTLSContextStream cxt
       wsConnection <- connectPeer wsPeer s
-      pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection}
+      pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg}
     connectPeer :: TransportPeer -> Stream -> IO Connection
     connectPeer TServer = acceptClientRequest
     connectPeer TClient = sendClientRequest
diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs
index 3984ff881..184d184d6 100644
--- a/tests/NtfClient.hs
+++ b/tests/NtfClient.hs
@@ -44,6 +44,7 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Server
+import Simplex.Messaging.Transport.Server
 import Test.Hspec
 import UnliftIO.Async
 import UnliftIO.Concurrent
@@ -99,7 +100,7 @@ ntfServerCfg =
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/ntf-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
-      logTLSErrors = True
+      transportConfig = defaultTransportServerConfig
     }
 
 withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
@@ -166,7 +167,7 @@ apnsMockServerConfig =
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
-      logTLSErrors = True
+      transportConfig = defaultTransportServerConfig
     }
 
 withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()
diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs
index 3e60b9061..c49b65ee6 100644
--- a/tests/SMPClient.hs
+++ b/tests/SMPClient.hs
@@ -24,6 +24,7 @@ import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
+import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Version
 import System.Environment (lookupEnv)
 import System.Info (os)
@@ -99,7 +100,7 @@ cfg =
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
       smpServerVRange = supportedSMPServerVRange,
-      logTLSErrors = True
+      transportConfig = defaultTransportServerConfig
     }
 
 withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index 4bd91997a..658344aed 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -14,6 +14,7 @@ import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Server (runXFTPServerBlocking)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
 import Simplex.Messaging.Protocol (XFTPServer)
+import Simplex.Messaging.Transport.Server
 import Test.Hspec
 
 xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
@@ -111,7 +112,7 @@ testXFTPServerConfig =
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
-      logTLSErrors = True
+      transportConfig = defaultTransportServerConfig
     }
 
 testXFTPClientConfig :: XFTPClientConfig

From 0e1562deae1233d1e04ed523a32730203b431122 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 30 Jun 2023 20:19:10 +0400
Subject: [PATCH 25/49]  increase connection agent version according to
 received messages; add version and flags to connection stats, bump
 currentSMPAgentVersion (#789)

---
 src/Simplex/Messaging/Agent.hs              | 224 +++++++++++---------
 src/Simplex/Messaging/Agent/Protocol.hs     |  20 +-
 src/Simplex/Messaging/Agent/Store.hs        |  25 ++-
 src/Simplex/Messaging/Agent/Store/SQLite.hs |   5 +
 tests/AgentTests/ConnectionRequestTests.hs  |  12 +-
 tests/AgentTests/FunctionalAPITests.hs      | 176 +++++++++++++--
 6 files changed, 326 insertions(+), 136 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index f9f502ea6..e899d6a12 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -116,7 +116,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, isNothing)
+import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock
@@ -542,18 +542,13 @@ switchConnectionAsync' c corrId connId =
       SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs)
         | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
         | otherwise -> do
-          checkRatchetSync cData $ CMD PROHIBITED
+          when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
           rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
           enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
           let rqs' = updatedQs rq1 rqs
           pure . connectionStats $ DuplexConnection cData rqs' sqs
       _ -> throwError $ CMD PROHIBITED
 
-checkRatchetSync :: AgentMonad m => ConnData -> AgentErrorType -> m ()
-checkRatchetSync ConnData {ratchetSyncState} err =
-  when (ratchetSyncState `elem` ([RSRequired, RSStarted, RSAgreed] :: [RatchetSyncState])) $
-    throwError err
-
 newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c)
 newConn c userId connId enableNtfs cMode clientData =
   getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData
@@ -743,7 +738,7 @@ subscribeConnections' c connIds = do
       forM_ (M.assocs rcvRs) $ \case
         (connId, Right _) -> forM_ (M.lookup connId conns) $ \case
           Right (SomeConn _ conn) -> do
-            let cmd = if enableNtfs $ connData conn then NSCCreate else NSCDelete
+            let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete
             atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
           _ -> pure ()
         _ -> pure ()
@@ -819,7 +814,7 @@ sendMessage' c connId msgFlags msg = withConnLock c connId "sendMessage" $ do
   where
     enqueueMsgs :: ConnData -> NonEmpty SndQueue -> m AgentMsgId
     enqueueMsgs cData sqs = do
-      checkRatchetSync cData $ CMD PROHIBITED
+      when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
       enqueueMessages c cData sqs msgFlags $ A_MSG msg
 
 -- / async command processing v v v
@@ -995,7 +990,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
 
 enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
 enqueueMessages c cData sqs msgFlags aMessage = do
-  checkRatchetSync cData $ INTERNAL "enqueueMessages: ratchet is not synchronized"
+  when (ratchetSyncSendProhibited cData) $ throwError $ INTERNAL "enqueueMessages: ratchet is not synchronized"
   enqueueMessages' c cData sqs msgFlags aMessage
 
 enqueueMessages' :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
@@ -1006,14 +1001,15 @@ enqueueMessages' c cData (sq :| sqs) msgFlags aMessage = do
   pure msgId
 
 enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
-enqueueMessage c cData@ConnData {connId, connAgentVersion} sq msgFlags aMessage = do
+enqueueMessage c cData@ConnData {connId} sq msgFlags aMessage = do
   resumeMsgDelivery c cData sq
-  msgId <- storeSentMsg
+  aVRange <- asks $ smpAgentVRange . config
+  msgId <- storeSentMsg $ maxVersion aVRange
   queuePendingMsgs c sq [msgId]
   pure $ unId msgId
   where
-    storeSentMsg :: m InternalId
-    storeSentMsg = withStore c $ \db -> runExceptT $ do
+    storeSentMsg :: Version -> m InternalId
+    storeSentMsg agentVersion = withStore c $ \db -> runExceptT $ do
       internalTs <- liftIO getCurrentTime
       (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
@@ -1021,7 +1017,7 @@ enqueueMessage c cData@ConnData {connId, connAgentVersion} sq msgFlags aMessage
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr
       encAgentMessage <- agentRatchetEncrypt db connId agentMsgStr e2eEncUserMsgLength
-      let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = connAgentVersion, encAgentMessage}
+      let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage}
           msgType = agentMessageType agentMsg
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, internalHash, prevMsgHash}
       liftIO $ createSndMsg db connId msgData
@@ -1245,7 +1241,7 @@ switchConnection' c connId =
       SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _)
         | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
         | otherwise -> do
-          checkRatchetSync cData $ CMD PROHIBITED
+          when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
           rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
           switchDuplexConnection c conn rq'
       _ -> throwError $ CMD PROHIBITED
@@ -1273,7 +1269,7 @@ abortConnectionSwitch' c connId =
       SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
         Just rq
           | canAbortRcvSwitch rq -> do
-            checkRatchetSync cData $ CMD PROHIBITED
+            when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
             -- multiple queues to which the connections switches were possible when repeating switch was allowed
             let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
             case L.nonEmpty keepRqs of
@@ -1293,8 +1289,8 @@ abortConnectionSwitch' c connId =
 synchronizeRatchet' :: AgentMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
 synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet" $ do
   withStore c (`getConn` connId) >>= \case
-    SomeConn _ (DuplexConnection cData@ConnData {ratchetSyncState} rqs sqs)
-      | ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]) || force -> do
+    SomeConn _ (DuplexConnection cData rqs sqs)
+      | 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
@@ -1445,16 +1441,25 @@ getConnectionRatchetAdHash' c connId = do
 
 connectionStats :: Connection c -> ConnectionStats
 connectionStats = \case
-  RcvConnection ConnData {ratchetSyncState} rq ->
-    ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = [], ratchetSyncState}
-  SndConnection ConnData {ratchetSyncState} sq ->
-    ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [sndQueueInfo sq], ratchetSyncState}
-  DuplexConnection ConnData {ratchetSyncState} rqs sqs ->
-    ConnectionStats {rcvQueuesInfo = map rcvQueueInfo $ L.toList rqs, sndQueuesInfo = map sndQueueInfo $ L.toList sqs, ratchetSyncState}
-  ContactConnection ConnData {ratchetSyncState} rq ->
-    ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = [], ratchetSyncState}
-  NewConnection ConnData {ratchetSyncState} ->
-    ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [], ratchetSyncState}
+  RcvConnection cData rq ->
+    (stats cData) {rcvQueuesInfo = [rcvQueueInfo rq]}
+  SndConnection cData sq ->
+    (stats cData) {sndQueuesInfo = [sndQueueInfo sq]}
+  DuplexConnection cData rqs sqs ->
+    (stats cData) {rcvQueuesInfo = map rcvQueueInfo $ L.toList rqs, sndQueuesInfo = map sndQueueInfo $ L.toList sqs}
+  ContactConnection cData rq ->
+    (stats cData) {rcvQueuesInfo = [rcvQueueInfo rq]}
+  NewConnection cData ->
+    stats cData
+  where
+    stats cData@ConnData {connAgentVersion, ratchetSyncState} =
+      ConnectionStats
+        { connAgentVersion,
+          rcvQueuesInfo = [],
+          sndQueuesInfo = [],
+          ratchetSyncState,
+          ratchetSyncSupported = ratchetSyncSupported' cData
+        }
 
 -- | Change servers to be used for creating new queues, in Reader monad
 setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
@@ -1784,13 +1789,13 @@ cleanupManager c@AgentClient {subQ} = do
 processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
 processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do
   (rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId)
-  processSMP rq conn $ connData conn
+  processSMP rq conn $ toConnData conn
   where
-    processSMP :: RcvQueue -> Connection c -> ConnData -> m ()
+    processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> m ()
     processSMP
       rq@RcvQueue {e2ePrivKey, e2eDhSecret, status}
       conn
-      cData@ConnData {userId, connId, duplexHandshake, ratchetSyncState = rss, lastExternalSndId} =
+      cData@ConnData {userId, connId, duplexHandshake, connAgentVersion, ratchetSyncState = rss} =
         withConnLock c connId "processSMP" $ case cmd of
           SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} ->
             handleNotifyAck $
@@ -1811,19 +1816,22 @@ 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 senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
+                        smpConfirmation conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
                       (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
-                        smpInvitation connReq connInfo >> ack
+                        smpInvitation conn connReq connInfo >> ack
                       _ -> prohibited >> ack
                   (Just e2eDh, Nothing) -> do
                     decryptClientMessage e2eDh clientMsg >>= \case
-                      (SMP.PHEmpty, AgentRatchetKey {e2eEncryption}) ->
-                        qDuplex "AgentRatchetKey" (newRatchetKey e2eEncryption) >> ack
-                      (SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do
+                      (SMP.PHEmpty, AgentRatchetKey {agentVersion, e2eEncryption}) -> do
+                        conn' <- updateConnVersion conn cData agentVersion
+                        qDuplex conn' "AgentRatchetKey" $ newRatchetKey e2eEncryption
+                        ack
+                      (SMP.PHEmpty, AgentMsgEnvelope {agentVersion, encAgentMessage}) -> do
+                        conn' <- updateConnVersion conn cData agentVersion
                         -- primary queue is set as Active in helloMsg, below is to set additional queues Active
                         let RcvQueue {primary, dbReplaceQueueId} = rq
                         unless (status == Active) . withStore' c $ \db -> setRcvQueueStatus db rq Active
-                        case (conn, dbReplaceQueueId) of
+                        case (conn', dbReplaceQueueId) of
                           (DuplexConnection _ rqs _, Just replacedId) -> do
                             when primary . withStore' c $ \db -> setRcvQueuePrimary db connId rq
                             case find ((replacedId ==) . dbQId) rqs of
@@ -1833,35 +1841,37 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                                 enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICQDelete rcvId
                               _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
                           _ -> pure ()
-                        let encryptedMsgHash = C.sha256Hash encAgentMsg
+                        let encryptedMsgHash = C.sha256Hash encAgentMessage
                         tryError (agentClientMsg encryptedMsgHash) >>= \case
                           Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do
-                            resetRatchetSync
+                            conn'' <- resetRatchetSync
                             case aMessage of
-                              HELLO -> helloMsg >> ackDel msgId
-                              REPLY cReq -> replyMsg cReq >> ackDel msgId
+                              HELLO -> helloMsg conn'' >> ackDel msgId
+                              REPLY cReq -> replyMsg conn'' cReq >> ackDel msgId
                               -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
                               A_MSG body -> do
                                 logServer "<--" c srv rId "MSG <MSG>"
                                 notify $ MSG msgMeta msgFlags body
-                              QCONT addr -> qDuplexAckDel "QCONT" $ continueSending addr
-                              QADD qs -> qDuplexAckDel "QADD" $ qAddMsg qs
-                              QKEY qs -> qDuplexAckDel "QKEY" $ qKeyMsg qs
-                              QUSE qs -> qDuplexAckDel "QUSE" $ qUseMsg qs
+                              QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending addr
+                              QADD qs -> qDuplexAckDel conn'' "QADD" $ qAddMsg qs
+                              QKEY qs -> qDuplexAckDel conn'' "QKEY" $ qKeyMsg qs
+                              QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg qs
                               -- no action needed for QTEST
                               -- any message in the new queue will mark it active and trigger deletion of the old queue
                               QTEST _ -> logServer "<--" c srv rId "MSG <QTEST>" >> ackDel msgId
-                              EREADY _ -> qDuplexAckDel "EREADY" $ ereadyMsg rcPrev
+                              EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev
                             where
-                              qDuplexAckDel :: String -> (Connection 'CDuplex -> m ()) -> m ()
-                              qDuplexAckDel name a = qDuplex name a >> ackDel msgId
-                              resetRatchetSync :: m ()
-                              resetRatchetSync = unless (rss `elem` ([RSOk, RSStarted] :: [RatchetSyncState])) $
-                                qDuplex "ratchet de-sync reset" $ \(DuplexConnection _ rqs sqs) -> do
-                                  let cData' = cData {ratchetSyncState = RSOk} :: ConnData
-                                      conn' = DuplexConnection cData' rqs sqs
-                                  notify . RSYNC RSOk $ connectionStats conn'
+                              qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> m ()) -> m ()
+                              qDuplexAckDel conn'' name a = qDuplex conn'' name a >> ackDel msgId
+                              resetRatchetSync :: m (Connection c)
+                              resetRatchetSync
+                                | rss `notElem` ([RSOk, RSStarted] :: [RatchetSyncState]) = do
+                                  let cData'' = (toConnData conn') {ratchetSyncState = RSOk} :: ConnData
+                                      conn'' = updateConnection cData'' conn'
+                                  notify . RSYNC RSOk $ connectionStats conn''
                                   withStore' c $ \db -> setConnRatchetSync db connId RSOk
+                                  pure conn''
+                                | otherwise = pure conn'
                           Right _ -> prohibited >> ack
                           Left e@(AGENT A_DUPLICATE) -> do
                             withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
@@ -1880,12 +1890,12 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                             ack
                             where
                               notifySync :: m ()
-                              notifySync = qDuplex "AGENT A_CRYPTO error" $ \(DuplexConnection _ rqs sqs) -> do
+                              notifySync = qDuplex conn' "AGENT A_CRYPTO error" $ \connDuplex -> do
                                 let rss' = cryptoErrToSyncState e
                                 when (rss == RSOk || (rss == RSAllowed && rss' == RSRequired)) $ do
-                                  let cData' = cData {ratchetSyncState = rss'} :: ConnData
-                                      conn' = DuplexConnection cData' rqs sqs
-                                  notify . RSYNC rss' $ connectionStats conn'
+                                  let cData'' = (toConnData conn') {ratchetSyncState = rss'} :: ConnData
+                                      conn'' = updateConnection cData'' connDuplex
+                                  notify . RSYNC rss' $ connectionStats conn''
                                   withStore' c $ \db -> setConnRatchetSync db connId rss'
                           Left e -> checkDuplicateHash e encryptedMsgHash >> ack
                         where
@@ -1896,7 +1906,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                           agentClientMsg :: ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
                           agentClientMsg encryptedMsgHash = withStore c $ \db -> runExceptT $ do
                             rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY
-                            agentMsgBody <- agentRatchetDecrypt' db connId rc encAgentMsg
+                            agentMsgBody <- agentRatchetDecrypt' db connId rc encAgentMessage
                             liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
                               agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
                                 let msgType = agentMessageType agentMsg
@@ -1913,6 +1923,18 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                               _ -> pure Nothing
                       _ -> prohibited >> ack
                   _ -> prohibited >> ack
+              updateConnVersion :: Connection c -> ConnData -> Version -> m (Connection c)
+              updateConnVersion conn' cData' msgAgentVersion = do
+                aVRange <- asks $ smpAgentVRange . config
+                let msgAVRange = fromMaybe (versionToRange msgAgentVersion) $ safeVersionRange (minVersion aVRange) msgAgentVersion
+                case msgAVRange `compatibleVersion` aVRange of
+                  Just (Compatible av)
+                    | av > connAgentVersion -> do
+                      withStore' c $ \db -> setConnAgentVersion db connId av
+                      let cData'' = cData' {connAgentVersion = av} :: ConnData
+                      pure $ updateConnection cData'' conn'
+                    | otherwise -> pure conn'
+                  Nothing -> pure conn'
               ack :: m ()
               ack = enqueueCmd $ ICAck rId srvMsgId
               ackDel :: InternalId -> m ()
@@ -1964,15 +1986,15 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           parseMessage :: Encoding a => ByteString -> m a
           parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
 
-          smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
-          smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
+          smpConfirmation :: Connection c -> C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
+          smpConfirmation conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
             logServer "<--" c srv rId "MSG <CONF>"
             AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
             unless
               (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
               (throwError $ AGENT A_VERSION)
             case status of
-              New -> case (conn, e2eEncryption) of
+              New -> case (conn', e2eEncryption) of
                 -- party initiating connection
                 (RcvConnection {}, Just e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _)) -> do
                   unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
@@ -2009,13 +2031,13 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 _ -> prohibited
               _ -> prohibited
 
-          helloMsg :: m ()
-          helloMsg = do
+          helloMsg :: Connection c -> m ()
+          helloMsg conn' = do
             logServer "<--" c srv rId "MSG <HELLO>"
             case status of
               Active -> prohibited
               _ ->
-                case conn of
+                case conn' of
                   DuplexConnection _ _ (sq@SndQueue {status = sndStatus} :| _)
                     -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
                     -- this branch is executed by the accepting party in duplexHandshake mode (v2)
@@ -2025,19 +2047,22 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                     | duplexHandshake == Just True -> enqueueDuplexHello sq
                     | otherwise -> pure ()
                   _ -> pure ()
+            where
+              enqueueDuplexHello :: SndQueue -> m ()
+              enqueueDuplexHello sq = do
+                let cData' = toConnData conn'
+                void $ enqueueMessage c cData' sq SMP.MsgFlags {notification = True} HELLO
 
-          enqueueDuplexHello :: SndQueue -> m ()
-          enqueueDuplexHello sq = void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO
-
-          replyMsg :: NonEmpty SMPQueueInfo -> m ()
-          replyMsg smpQueues = do
+          replyMsg :: Connection c -> NonEmpty SMPQueueInfo -> m ()
+          replyMsg conn' smpQueues = do
             logServer "<--" c srv rId "MSG <REPLY>"
             case duplexHandshake of
               Just True -> prohibited
-              _ -> case conn of
+              _ -> case conn' of
                 RcvConnection {} -> do
                   AcceptedConfirmation {ownConnInfo} <- withStore c (`getAcceptedConfirmation` connId)
-                  connectReplyQueues c cData ownConnInfo smpQueues `catchError` (notify . ERR)
+                  let cData' = toConnData conn'
+                  connectReplyQueues c cData' ownConnInfo smpQueues `catchError` (notify . ERR)
                 _ -> prohibited
 
           continueSending :: (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
@@ -2053,8 +2078,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           -- 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 _ rqs sqs) = do
-            checkRatchetSync cData $ AGENT (A_QUEUE "ratchet is not synchronized")
+          qAddMsg ((qUri, Just addr) :| _) (DuplexConnection cData' rqs sqs) = do
+            when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized")
             clientVRange <- asks $ smpClientVRange . config
             case qUri `compatibleVersion` clientVRange of
               Just qInfo@(Compatible sqInfo@SMPQueueInfo {queueAddress}) ->
@@ -2074,10 +2099,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                           (Just sndPubKey, Just dhPublicKey) -> do
                             logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
                             let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
-                            void . enqueueMessages c cData sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
+                            void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
                             sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
                             let sqs'' = updatedQs sq1 sqs' <> [sq2]
-                                conn' = DuplexConnection cData rqs sqs''
+                                conn' = DuplexConnection cData' rqs sqs''
                             notify . SWITCH QDSnd SPStarted $ connectionStats conn'
                           _ -> qError "absent sender keys"
                       _ -> qError "QADD: won't delete all snd queues in connection"
@@ -2086,8 +2111,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
 
           -- processed by queue recipient
           qKeyMsg :: NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m ()
-          qKeyMsg ((qInfo, senderKey) :| _) (DuplexConnection _ rqs _) = do
-            checkRatchetSync cData $ AGENT (A_QUEUE "ratchet is not synchronized")
+          qKeyMsg ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do
+            when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized")
             clientVRange <- asks $ smpClientVRange . config
             unless (qInfo `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
             case findRQ (smpServer, senderId) rqs of
@@ -2098,7 +2123,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   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
-                  notify . SWITCH QDRcv SPConfirmed $ connectionStats conn
+                  notify . SWITCH QDRcv SPConfirmed $ connectionStats conn'
                 | otherwise -> qError "QKEY: queue already secured"
               _ -> qError "QKEY: queue address not found in connection"
             where
@@ -2108,8 +2133,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           -- mark queue as Secured and to start sending messages to it
           qUseMsg :: 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 _ rqs sqs) = do
-            checkRatchetSync cData $ AGENT (A_QUEUE "ratchet is not synchronized")
+          qUseMsg ((addr, _primary) :| _) (DuplexConnection cData' rqs sqs) = do
+            when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized")
             case findQ addr sqs of
               Just sq'@SndQueue {dbReplaceQueueId = Just replaceQId} -> do
                 case find ((replaceQId ==) . dbQId) sqs of
@@ -2119,10 +2144,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                     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
-                    void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
+                    void $ enqueueMessages c cData' [sq''] SMP.noMsgFlags $ QTEST [addr]
                     sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST
                     let sqs' = updatedQs sq1' sqs
-                        conn' = DuplexConnection cData rqs sqs'
+                        conn' = DuplexConnection cData' rqs sqs'
                     notify . SWITCH QDSnd SPSecured $ connectionStats conn'
                   _ -> qError "QUSE: switching SndQueue not found in connection"
               _ -> qError "QUSE: switched queue address not found in connection"
@@ -2131,16 +2156,16 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           qError = throwError . AGENT . A_QUEUE
 
           ereadyMsg :: CR.RatchetX448 -> Connection 'CDuplex -> m ()
-          ereadyMsg rcPrev (DuplexConnection cData' _ sqs) = do
+          ereadyMsg rcPrev (DuplexConnection cData'@ConnData {lastExternalSndId} _ sqs) = do
             let CR.Ratchet {rcSnd} = rcPrev
             -- if ratchet was initialized as receiving, it means EREADY wasn't sent on key negotiation
             when (isNothing rcSnd) $
               void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
 
-          smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-          smpInvitation connReq@(CRInvitationUri crData _) cInfo = do
+          smpInvitation :: Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+          smpInvitation conn' connReq@(CRInvitationUri crData _) cInfo = do
             logServer "<--" c srv rId "MSG <KEY>"
-            case conn of
+            case conn' of
               ContactConnection {} -> do
                 g <- asks idsDrg
                 let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
@@ -2149,13 +2174,13 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 notify $ REQ invId srvs cInfo
               _ -> prohibited
 
-          qDuplex :: String -> (Connection 'CDuplex -> m ()) -> m ()
-          qDuplex name a = case conn of
-            DuplexConnection {} -> a conn
+          qDuplex :: Connection c -> String -> (Connection 'CDuplex -> m ()) -> m ()
+          qDuplex conn' name action = case conn' of
+            DuplexConnection {} -> action conn'
             _ -> qError $ name <> ": message must be sent to duplex connection"
 
           newRatchetKey :: CR.E2ERatchetParams 'C.X448 -> Connection 'CDuplex -> m ()
-          newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv) (DuplexConnection cData' rqs sqs) =
+          newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv) conn'@(DuplexConnection cData'@ConnData {lastExternalSndId} _ sqs) =
             unlessM ratchetExists $ do
               AgentConfig {e2eEncryptVRange} <- asks config
               unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
@@ -2180,8 +2205,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               notifyAgreed :: m ()
               notifyAgreed = do
                 let cData'' = cData' {ratchetSyncState = RSAgreed} :: ConnData
-                    conn' = DuplexConnection cData'' rqs sqs
-                notify . RSYNC RSAgreed $ connectionStats conn'
+                    conn'' = updateConnection cData'' conn'
+                notify . RSYNC RSAgreed $ connectionStats conn''
               recreateRatchet :: CR.Ratchet 'C.X448 -> m ()
               recreateRatchet rc = withStore' c $ \db -> do
                 setConnRatchetSync db connId RSAgreed
@@ -2279,20 +2304,21 @@ enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do
   pure msgId
 
 enqueueRatchetKey :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> CR.E2ERatchetParams 'C.X448 -> m AgentMsgId
-enqueueRatchetKey c cData@ConnData {connId, connAgentVersion} sq e2eEncryption = do
+enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
   resumeMsgDelivery c cData sq
-  msgId <- storeRatchetKey
+  aVRange <- asks $ smpAgentVRange . config
+  msgId <- storeRatchetKey $ maxVersion aVRange
   queuePendingMsgs c sq [msgId]
   pure $ unId msgId
   where
-    storeRatchetKey :: m InternalId
-    storeRatchetKey = withStore c $ \db -> runExceptT $ do
+    storeRatchetKey :: Version -> m InternalId
+    storeRatchetKey agentVersion = withStore c $ \db -> runExceptT $ do
       internalTs <- liftIO getCurrentTime
       (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let agentMsg = AgentRatchetInfo ""
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr
-      let msgBody = smpEncode $ AgentRatchetKey {agentVersion = connAgentVersion, e2eEncryption, info = agentMsgStr}
+      let msgBody = smpEncode $ AgentRatchetKey {agentVersion, e2eEncryption, info = agentMsgStr}
           msgType = agentMessageType agentMsg
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
       liftIO $ createSndMsg db connId msgData
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 98a4cad5b..31e65f842 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -211,7 +211,7 @@ import Text.Read
 import UnliftIO.Exception (Exception)
 
 currentSMPAgentVersion :: Version
-currentSMPAgentVersion = 2
+currentSMPAgentVersion = 3
 
 supportedSMPAgentVRange :: VersionRange
 supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
@@ -636,22 +636,28 @@ instance StrEncoding SndQueueInfo where
     pure SndQueueInfo {sndServer, sndSwitchStatus}
 
 data ConnectionStats = ConnectionStats
-  { rcvQueuesInfo :: [RcvQueueInfo],
+  { connAgentVersion :: Version,
+    rcvQueuesInfo :: [RcvQueueInfo],
     sndQueuesInfo :: [SndQueueInfo],
-    ratchetSyncState :: RatchetSyncState
+    ratchetSyncState :: RatchetSyncState,
+    ratchetSyncSupported :: Bool
   }
   deriving (Eq, Show, Generic)
 
 instance StrEncoding ConnectionStats where
-  strEncode ConnectionStats {rcvQueuesInfo, sndQueuesInfo, ratchetSyncState} =
-    "rcv=" <> strEncodeList rcvQueuesInfo
+  strEncode ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} =
+    "agent_version=" <> strEncode connAgentVersion
+      <> (" rcv=" <> strEncodeList rcvQueuesInfo)
       <> (" snd=" <> strEncodeList sndQueuesInfo)
       <> (" sync=" <> strEncode ratchetSyncState)
+      <> (" sync_supported=" <> strEncode ratchetSyncSupported)
   strP = do
-    rcvQueuesInfo <- "rcv=" *> strListP
+    connAgentVersion <- "agent_version=" *> strP
+    rcvQueuesInfo <- " rcv=" *> strListP
     sndQueuesInfo <- " snd=" *> strListP
     ratchetSyncState <- " sync=" *> strP
-    pure ConnectionStats {rcvQueuesInfo, sndQueuesInfo, ratchetSyncState}
+    ratchetSyncSupported <- " sync_supported=" *> strP
+    pure ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported}
 
 instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
 
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index 871a82563..2a51e7f9f 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -243,14 +243,22 @@ deriving instance Eq (Connection d)
 
 deriving instance Show (Connection d)
 
-connData :: Connection d -> ConnData
-connData = \case
+toConnData :: Connection d -> ConnData
+toConnData = \case
   NewConnection cData -> cData
   RcvConnection cData _ -> cData
   SndConnection cData _ -> cData
   DuplexConnection cData _ _ -> cData
   ContactConnection cData _ -> cData
 
+updateConnection :: ConnData -> Connection d -> Connection d
+updateConnection cData = \case
+  NewConnection _ -> NewConnection cData
+  RcvConnection _ rq -> RcvConnection cData rq
+  SndConnection _ sq -> SndConnection cData sq
+  DuplexConnection _ rqs sqs -> DuplexConnection cData rqs sqs
+  ContactConnection _ rq -> ContactConnection cData rq
+
 data SConnType :: ConnType -> Type where
   SCNew :: SConnType CNew
   SCRcv :: SConnType CRcv
@@ -299,6 +307,19 @@ data ConnData = ConnData
   }
   deriving (Eq, Show)
 
+-- this function should be mirrored in the clients
+ratchetSyncAllowed :: ConnData -> Bool
+ratchetSyncAllowed cData@ConnData {ratchetSyncState} =
+  ratchetSyncSupported' cData && (ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]))
+
+ratchetSyncSupported' :: ConnData -> Bool
+ratchetSyncSupported' ConnData {connAgentVersion} = connAgentVersion >= 3
+
+-- this function should be mirrored in the clients
+ratchetSyncSendProhibited :: ConnData -> Bool
+ratchetSyncSendProhibited ConnData {ratchetSyncState} =
+  ratchetSyncState `elem` ([RSRequired, RSStarted, RSAgreed] :: [RatchetSyncState])
+
 data PendingCommand = PendingCommand
   { corrId :: ACorrId,
     userId :: UserId,
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index eec4169dd..442445359 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -52,6 +52,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     getDeletedConns,
     getConnData,
     setConnDeleted,
+    setConnAgentVersion,
     getDeletedConnIds,
     setConnRatchetSync,
     addProcessedRatchetKeyHash,
@@ -1705,6 +1706,10 @@ getConnData db connId' =
 setConnDeleted :: DB.Connection -> ConnId -> IO ()
 setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
 
+setConnAgentVersion :: DB.Connection -> ConnId -> Version -> IO ()
+setConnAgentVersion db connId aVersion =
+  DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId)
+
 getDeletedConnIds :: DB.Connection -> IO [ConnId]
 getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
 
diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs
index ea50834fd..ea457d0bc 100644
--- a/tests/AgentTests/ConnectionRequestTests.hs
+++ b/tests/AgentTests/ConnectionRequestTests.hs
@@ -70,8 +70,8 @@ connectionRequest =
   ACR SCMInvitation $
     CRInvitationUri connReqData testE2ERatchetParams
 
-connectionRequest12 :: AConnectionRequestUri
-connectionRequest12 =
+connectionRequestCurrentRange :: AConnectionRequestUri
+connectionRequestCurrentRange =
   ACR SCMInvitation $
     CRInvitationUri
       connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
@@ -113,8 +113,8 @@ connectionRequestTests =
         `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
         <> urlEncode True testDhKeyStrUri
         <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
-      strEncode connectionRequest12
-        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+      strEncode connectionRequestCurrentRange
+        `shouldBe` "https://simplex.chat/invitation#/?v=1-3&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
         <> urlEncode True testDhKeyStrUri
         <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
         <> urlEncode True testDhKeyStrUri
@@ -158,9 +158,9 @@ connectionRequestTests =
             <> testDhKeyStrUri
             <> "&e2e=extra_key%3Dnew%26v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
             <> "&some_new_param=abc"
-            <> "&v=1-2"
+            <> "&v=1-3"
         )
-        `shouldBe` Right connectionRequest12
+        `shouldBe` Right connectionRequestCurrentRange
       strDecode
         ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
             <> testDhKeyStrUri
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index c1a70dec8..f16961222 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -104,17 +104,31 @@ pGet c = do
 pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
-smpCfgV1 :: ProtocolClientConfig
-smpCfgV1 = (smpCfg agentCfg) {serverVRange = vr11}
+smpCfgVPrev :: ProtocolClientConfig
+smpCfgVPrev = (smpCfg agentCfg) {serverVRange = serverVRangePrev}
+  where
+    serverVRangePrev = prevRange $ serverVRange $ smpCfg agentCfg
 
-agentCfgV1 :: AgentConfig
-agentCfgV1 = agentCfg {smpAgentVRange = vr11, smpClientVRange = vr11, e2eEncryptVRange = vr11, smpCfg = smpCfgV1}
+agentCfgVPrev :: AgentConfig
+agentCfgVPrev =
+  agentCfg
+    { smpAgentVRange = smpAgentVRangePrev,
+      smpClientVRange = smpClientVRangePrev,
+      e2eEncryptVRange = e2eEncryptVRangePrev,
+      smpCfg = smpCfgVPrev
+    }
+  where
+    smpAgentVRangePrev = prevRange $ smpAgentVRange agentCfg
+    smpClientVRangePrev = prevRange $ smpClientVRange agentCfg
+    e2eEncryptVRangePrev = prevRange $ e2eEncryptVRange agentCfg
 
-agentCfgRatchetV1 :: AgentConfig
-agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11}
+agentCfgRatchetVPrev :: AgentConfig
+agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = e2eEncryptVRangePrev}
+  where
+    e2eEncryptVRangePrev = prevRange $ e2eEncryptVRange agentCfg
 
-vr11 :: VersionRange
-vr11 = mkVersionRange 1 1
+prevRange :: VersionRange -> VersionRange
+prevRange vr = vr {maxVersion = maxVersion vr - 1}
 
 runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation
 runRight_ action = runExceptT action `shouldReturn` Right ()
@@ -163,6 +177,13 @@ functionalAPITests t = do
     it "should restore confirmation after client restart" $
       testAllowConnectionClientRestart t
   describe "Message delivery" $ do
+    describe "update connection agent version on received messages" $ do
+      it "should increase if compatible, shouldn't decrease" $
+        testIncreaseConnAgentVersion t
+      it "should increase to max compatible version" $
+        testIncreaseConnAgentVersionMaxCompatible t
+      it "should increase when connection was negotiated on different versions" $
+        testIncreaseConnAgentVersionStartDifferentVersion t
     it "should deliver message after client restart" $
       testDeliverClientRestart t
     it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
@@ -292,17 +313,17 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
 
 testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2 t runTest = do
-  it "v2" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
-  it "v1" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfgV1 4 runTest
-  it "v1 to v2" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfg 4 runTest
-  it "v2 to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgV1 4 runTest
+  it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
+  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
 
 testRatchetMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testRatchetMatrix2 t runTest = do
-  it "ratchet v2" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
-  it "ratchet v1" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfgRatchetV1 3 runTest
-  it "ratchets v1 to v2" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfg 3 runTest
-  it "ratchets v2 to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetV1 3 runTest
+  it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
+  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
 
 testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
 testServerMatrix2 t runTest = do
@@ -478,6 +499,9 @@ testAsyncServerOffline t = 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}
   alice <- getSMPAgentClient' agentCfgV1 initAgentServers testDB
   bob <- getSMPAgentClient' agentCfg {helloTimeout = 1} initAgentServers testDB2
   runRight_ $ do
@@ -524,6 +548,114 @@ testAllowConnectionClientRestart t = do
 
         exchangeGreetingsMsgId 4 alice2 bobId bob aliceId
 
+testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO ()
+testIncreaseConnAgentVersion t = do
+  alice <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    (aliceId, bobId) <- runRight $ do
+      (aliceId, bobId) <- makeConnection alice bob
+      exchangeGreetingsMsgId 4 alice bobId bob aliceId
+      checkVersion alice bobId 2
+      checkVersion bob aliceId 2
+      pure (aliceId, bobId)
+
+    -- version doesn't increase if incompatible
+
+    disconnectAgentClient alice
+    alice2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+
+    runRight_ $ do
+      subscribeConnection alice2 bobId
+      exchangeGreetingsMsgId 6 alice2 bobId bob aliceId
+      checkVersion alice2 bobId 2
+      checkVersion bob aliceId 2
+
+    -- version increases if compatible
+
+    disconnectAgentClient bob
+    bob2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
+
+    runRight_ $ do
+      subscribeConnection bob2 aliceId
+      exchangeGreetingsMsgId 8 alice2 bobId bob2 aliceId
+      checkVersion alice2 bobId 3
+      checkVersion bob2 aliceId 3
+
+    -- version doesn't decrease, even if incompatible
+
+    disconnectAgentClient alice2
+    alice3 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB
+
+    runRight_ $ do
+      subscribeConnection alice3 bobId
+      exchangeGreetingsMsgId 10 alice3 bobId bob2 aliceId
+      checkVersion alice3 bobId 3
+      checkVersion bob2 aliceId 3
+
+    disconnectAgentClient bob2
+    bob3 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2
+
+    runRight_ $ do
+      subscribeConnection bob3 aliceId
+      exchangeGreetingsMsgId 12 alice3 bobId bob3 aliceId
+      checkVersion alice3 bobId 3
+      checkVersion bob3 aliceId 3
+
+checkVersion :: AgentClient -> ConnId -> Version -> ExceptT AgentErrorType IO ()
+checkVersion c connId v = do
+  ConnectionStats {connAgentVersion} <- getConnectionServers c connId
+  liftIO $ connAgentVersion `shouldBe` v
+
+testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO ()
+testIncreaseConnAgentVersionMaxCompatible t = do
+  alice <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    (aliceId, bobId) <- runRight $ do
+      (aliceId, bobId) <- makeConnection alice bob
+      exchangeGreetingsMsgId 4 alice bobId bob aliceId
+      checkVersion alice bobId 2
+      checkVersion bob aliceId 2
+      pure (aliceId, bobId)
+
+    -- version increases to max compatible
+
+    disconnectAgentClient alice
+    alice2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+    disconnectAgentClient bob
+    bob2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB2
+
+    runRight_ $ do
+      subscribeConnection alice2 bobId
+      subscribeConnection bob2 aliceId
+      exchangeGreetingsMsgId 6 alice2 bobId bob2 aliceId
+      checkVersion alice2 bobId 3
+      checkVersion bob2 aliceId 3
+
+testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO ()
+testIncreaseConnAgentVersionStartDifferentVersion t = do
+  alice <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    (aliceId, bobId) <- runRight $ do
+      (aliceId, bobId) <- makeConnection alice bob
+      exchangeGreetingsMsgId 4 alice bobId bob aliceId
+      checkVersion alice bobId 2
+      checkVersion bob aliceId 2
+      pure (aliceId, bobId)
+
+    -- version increases to max compatible
+
+    disconnectAgentClient alice
+    alice2 <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+
+    runRight_ $ do
+      subscribeConnection alice2 bobId
+      exchangeGreetingsMsgId 6 alice2 bobId bob aliceId
+      checkVersion alice2 bobId 3
+      checkVersion bob aliceId 3
+
 testDeliverClientRestart :: HasCallStack => ATransport -> IO ()
 testDeliverClientRestart t = do
   alice <- getSMPAgentClient' agentCfg initAgentServers testDB
@@ -716,15 +848,15 @@ setupDesynchronizedRatchet alice bob = do
   pure (aliceId, bobId, bob2)
 
 ratchetSyncP :: ConnId -> RatchetSyncState -> AEntityTransmission 'AEConn -> Bool
-ratchetSyncP cId rrs = \case
-  (_, cId', RSYNC rrs' ConnectionStats {ratchetSyncState}) ->
-    cId' == cId && rrs' == rrs && ratchetSyncState == rrs
+ratchetSyncP cId rss = \case
+  (_, cId', RSYNC rss' ConnectionStats {ratchetSyncState}) ->
+    cId' == cId && rss' == rss && ratchetSyncState == rss
   _ -> False
 
 ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission 'Agent -> Bool
-ratchetSyncP' cId rrs = \case
-  (_, cId', APC SAEConn (RSYNC rrs' ConnectionStats {ratchetSyncState})) ->
-    cId' == cId && rrs' == rrs && ratchetSyncState == rrs
+ratchetSyncP' cId rss = \case
+  (_, cId', APC SAEConn (RSYNC rss' ConnectionStats {ratchetSyncState})) ->
+    cId' == cId && rss' == rss && ratchetSyncState == rss
   _ -> False
 
 testRatchetSyncServerOffline :: HasCallStack => ATransport -> IO ()

From 54dc8d42e7594632daeadf0a0f115936b17165af Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 3 Jul 2023 13:32:58 +0100
Subject: [PATCH 26/49] 5.2.0, ntf server 1.5.0 (#790)

---
 CHANGELOG.md                                  | 44 +++++++++++++++++++
 package.yaml                                  |  2 +-
 simplexmq.cabal                               |  2 +-
 .../Messaging/Notifications/Server/Main.hs    |  2 +-
 4 files changed, 47 insertions(+), 3 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index d3741a28e..e188931b1 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,47 @@
+# 5.2.0 (NTF server 1.5.0)
+
+Agent:
+- treat agent INACTIVE error as temporary - fixes failed message delivery in some race conditions.
+- restore connection confirmations after client restart - fixes failed connections.
+- ratchet resynchronization protocol and API.
+- increase connection version to mutually supported by both peers on each received message.
+
+Client:
+- make timeout for batched functions dependent on the number of batches - fixes expiry on large batches.
+
+Servers:
+- add timeout in case of sending TCP traffic and in case of partial delivery of requested blocks to avoid resource leaks.
+
+# 5.1.2, 5.1.3 (NTF server 1.4.1, 1.4.2)
+
+Agent:
+- ACK message on decryption error (fixes stuck message delivery bug)
+- more robust connection switching logic, API to abort switching the address
+
+Notification server:
+- batch subscriptions to SMP servers
+
+# 5.1.1 (NTF server 1.4.0)
+
+Agent:
+- store and check hashes of previous encrypted messages to differentiate between duplicates and decryption errors
+
+Server:
+- larger processing queues
+- expire messages when restoring them
+
+# 5.1.0
+
+XFTP client:
+- check encrypted file exists when uploading
+- remove user ID from deletion API
+
+Agent:
+- vacuum database on migrations
+
+SMP server:
+- configure message expiration time in INI file
+
 # 5.0.0
 
 SimpleX File Transfer Protocol (XFTP):
diff --git a/package.yaml b/package.yaml
index 8a9b664db..c1bdd937b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.1.3
+version: 5.2.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 326f7433c..c9506f994 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.1.3
+version:        5.2.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index cd456fc55..c9467a09f 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -30,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.4.2"
+ntfServerVersion = "1.5.0"
 
 defaultSMPBatchDelay :: Int
 defaultSMPBatchDelay = 10000

From 75fe28a8a665167e69734c7cf1d63071b65b7b80 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 3 Jul 2023 17:43:56 +0100
Subject: [PATCH 27/49] lint

---
 src/Simplex/Messaging/Agent/Protocol.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 31e65f842..b8241d4af 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -1467,7 +1467,7 @@ instance StrEncoding AgentErrorType where
       <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
       <|> "AGENT " *> (AGENT <$> parseRead1)
       <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
-      <|> "INACTIVE" *> pure INACTIVE
+      <|> "INACTIVE" $> INACTIVE
     where
       textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
   strEncode = \case

From fe22d9b299f106fc4a3d167e90499ddb4d3bfa26 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 4 Jul 2023 22:54:45 +0100
Subject: [PATCH 28/49] agent api to reconnect all servers (#792)

---
 src/Simplex/Messaging/Agent.hs | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index e899d6a12..623fcc1f1 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -75,6 +75,7 @@ module Simplex.Messaging.Agent
     setNtfServers,
     setNetworkConfig,
     getNetworkConfig,
+    reconnectAllServers,
     registerNtfToken,
     verifyNtfToken,
     checkNtfToken,
@@ -316,13 +317,16 @@ setNetworkConfig :: MonadUnliftIO m => AgentClient -> NetworkConfig -> m ()
 setNetworkConfig c cfg' = do
   cfg <- atomically $ do
     swapTVar (useNetworkConfig c) cfg'
-  liftIO . when (cfg /= cfg') $ do
-    closeProtocolServerClients c smpClients
-    closeProtocolServerClients c ntfClients
+  when (cfg /= cfg') $ reconnectAllServers c
 
 getNetworkConfig :: AgentErrorMonad m => AgentClient -> m NetworkConfig
 getNetworkConfig = readTVarIO . useNetworkConfig
 
+reconnectAllServers :: MonadUnliftIO m => AgentClient -> m ()
+reconnectAllServers c = liftIO $ do
+  closeProtocolServerClients c smpClients
+  closeProtocolServerClients c ntfClients
+
 -- | Register device notifications token
 registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
 registerNtfToken c = withAgentEnv c .: registerNtfToken' c

From f2657f9c0b954f952aaf381bb9b55ac34ea59ed7 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Wed, 5 Jul 2023 18:14:51 +0400
Subject: [PATCH 29/49] add crypto error to RSYNC event (#794)

---
 src/Simplex/Messaging/Agent.hs          |  8 ++++----
 src/Simplex/Messaging/Agent/Protocol.hs | 20 +++++++++++++++++---
 tests/AgentTests/FunctionalAPITests.hs  |  4 ++--
 3 files changed, 23 insertions(+), 9 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 623fcc1f1..7c0419e0a 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -1872,7 +1872,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                                 | rss `notElem` ([RSOk, RSStarted] :: [RatchetSyncState]) = do
                                   let cData'' = (toConnData conn') {ratchetSyncState = RSOk} :: ConnData
                                       conn'' = updateConnection cData'' conn'
-                                  notify . RSYNC RSOk $ connectionStats conn''
+                                  notify . RSYNC RSOk Nothing $ connectionStats conn''
                                   withStore' c $ \db -> setConnRatchetSync db connId RSOk
                                   pure conn''
                                 | otherwise = pure conn'
@@ -1896,10 +1896,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                               notifySync :: m ()
                               notifySync = qDuplex conn' "AGENT A_CRYPTO error" $ \connDuplex -> do
                                 let rss' = cryptoErrToSyncState e
-                                when (rss == RSOk || (rss == RSAllowed && rss' == RSRequired)) $ do
+                                when (rss `elem` ([RSOk, RSAllowed, RSRequired] :: [RatchetSyncState])) $ do
                                   let cData'' = (toConnData conn') {ratchetSyncState = rss'} :: ConnData
                                       conn'' = updateConnection cData'' connDuplex
-                                  notify . RSYNC rss' $ connectionStats conn''
+                                  notify . RSYNC rss' (Just e) $ connectionStats conn''
                                   withStore' c $ \db -> setConnRatchetSync db connId rss'
                           Left e -> checkDuplicateHash e encryptedMsgHash >> ack
                         where
@@ -2210,7 +2210,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               notifyAgreed = do
                 let cData'' = cData' {ratchetSyncState = RSAgreed} :: ConnData
                     conn'' = updateConnection cData'' conn'
-                notify . RSYNC RSAgreed $ connectionStats conn''
+                notify . RSYNC RSAgreed Nothing $ connectionStats conn''
               recreateRatchet :: CR.Ratchet 'C.X448 -> m ()
               recreateRatchet rc = withStore' c $ \db -> do
                 setConnRatchetSync db connId RSAgreed
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index b8241d4af..5ab875757 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -326,7 +326,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone
   UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
   SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
-  RSYNC :: RatchetSyncState -> ConnectionStats -> ACommand Agent AEConn
+  RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn
   SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
   MID :: AgentMsgId -> ACommand Agent AEConn
   SENT :: AgentMsgId -> ACommand Agent AEConn
@@ -1449,6 +1449,20 @@ instance ToJSON AgentCryptoError where
   toJSON = J.genericToJSON $ sumTypeJSON id
   toEncoding = J.genericToEncoding $ sumTypeJSON id
 
+instance StrEncoding AgentCryptoError where
+  strP =
+    "DECRYPT_AES" $> DECRYPT_AES
+      <|> "DECRYPT_CB" $> DECRYPT_CB
+      <|> "RATCHET_HEADER" $> RATCHET_HEADER
+      <|> "RATCHET_EARLIER " *> (RATCHET_EARLIER <$> strP)
+      <|> "RATCHET_SKIPPED " *> (RATCHET_SKIPPED <$> strP)
+  strEncode = \case
+    DECRYPT_AES -> "DECRYPT_AES"
+    DECRYPT_CB -> "DECRYPT_CB"
+    RATCHET_HEADER -> "RATCHET_HEADER"
+    RATCHET_EARLIER n -> "RATCHET_EARLIER " <> strEncode n
+    RATCHET_SKIPPED n -> "RATCHET_SKIPPED " <> strEncode n
+
 instance ToJSON SMPAgentError where
   toJSON = J.genericToJSON $ sumTypeJSON id
   toEncoding = J.genericToEncoding $ sumTypeJSON id
@@ -1658,7 +1672,7 @@ commandP binaryP =
           DOWN_ -> s (DOWN <$> strP_ <*> connections)
           UP_ -> s (UP <$> strP_ <*> connections)
           SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
-          RSYNC_ -> s (RSYNC <$> strP_ <*> strP)
+          RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP)
           MID_ -> s (MID <$> A.decimal)
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
@@ -1717,7 +1731,7 @@ serializeCommand = \case
   DOWN srv conns -> B.unwords [s DOWN_, s srv, connections conns]
   UP srv conns -> B.unwords [s UP_, s srv, connections conns]
   SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
-  RSYNC rrState cstats -> s (RSYNC_, rrState, cstats)
+  RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
   SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
   MID mId -> s (MID_, Str $ bshow mId)
   SENT mId -> s (SENT_, Str $ bshow mId)
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index f16961222..9aac75b63 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -849,13 +849,13 @@ setupDesynchronizedRatchet alice bob = do
 
 ratchetSyncP :: ConnId -> RatchetSyncState -> AEntityTransmission 'AEConn -> Bool
 ratchetSyncP cId rss = \case
-  (_, cId', RSYNC rss' ConnectionStats {ratchetSyncState}) ->
+  (_, cId', RSYNC rss' _ ConnectionStats {ratchetSyncState}) ->
     cId' == cId && rss' == rss && ratchetSyncState == rss
   _ -> False
 
 ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission 'Agent -> Bool
 ratchetSyncP' cId rss = \case
-  (_, cId', APC SAEConn (RSYNC rss' ConnectionStats {ratchetSyncState})) ->
+  (_, cId', APC SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) ->
     cId' == cId && rss' == rss && ratchetSyncState == rss
   _ -> False
 

From f76a5ca5b6be8bf0ba1323c3e6b90b17737dba76 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sun, 9 Jul 2023 18:04:45 +0100
Subject: [PATCH 30/49] agent: catch IO errors correctly in MonadError (#795)

* agent: catch IO errors correctly in MonadError

* correction

* correction

* utils

* agentFinally to catch IO exceptions in ExceptT

* rename

* remove, inline

* rename utils

* utils unit test

* test to show catch and finally problems

* tryAllErrors

* enable all tests
---
 simplexmq.cabal                               |   1 +
 src/Simplex/FileTransfer/Agent.hs             |  29 +++--
 src/Simplex/Messaging/Agent.hs                |  59 +++++-----
 src/Simplex/Messaging/Agent/Client.hs         |   4 +-
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |  23 +++-
 .../Messaging/Agent/NtfSubSupervisor.hs       |  10 +-
 src/Simplex/Messaging/Util.hs                 |  31 +++--
 tests/CoreTests/UtilTests.hs                  | 110 ++++++++++++++++++
 tests/Test.hs                                 |   2 +
 9 files changed, 209 insertions(+), 60 deletions(-)
 create mode 100644 tests/CoreTests/UtilTests.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index c9506f994..3c20ea9ed 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -533,6 +533,7 @@ test-suite simplexmq-test
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
       CoreTests.RetryIntervalTests
+      CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
       NtfClient
diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index b50031f96..7ca1e5a4f 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -71,7 +71,6 @@ import System.FilePath (takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Concurrent
 import UnliftIO.Directory
-import qualified UnliftIO.Exception as E
 
 startWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
 startWorkers c workDir = do
@@ -162,7 +161,7 @@ addWorker c wsSel runWorker runWorkerNoSrv srv_ = do
       let runWorker' = case srv_ of
             Just srv -> runWorker c srv doWork
             Nothing -> runWorkerNoSrv c doWork
-      worker <- async $ runWorker' `E.finally` atomically (TM.delete srv_ ws)
+      worker <- async $ runWorker' `agentFinally` atomically (TM.delete srv_ ws)
       atomically $ TM.insert srv_ (doWork, worker) ws
     Just (doWork, _) ->
       void . atomically $ tryPutTMVar doWork ()
@@ -187,10 +186,10 @@ runXFTPRcvWorker c srv doWork = do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryInterval ri' $ \delay' loop ->
             downloadFileChunk fc replica
-              `catchError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchError (\_ -> pure ()) $ do
+              flip catchAgentError (\_ -> pure ()) $ do
                 notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
                 when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e
                 closeXFTPServerClient c userId server digest
@@ -249,7 +248,7 @@ runXFTPRcvLocalWorker c doWork = do
       case nextFile of
         Nothing -> noWorkToDo
         Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
-          decryptFile f `catchError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
+          decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, status, chunks} = do
@@ -300,7 +299,7 @@ sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients =
       createDirectory outputDir
       let tempPath = workPath </> "snd"
       createDirectoryIfMissing False tempPath
-      runSend fileName outputDir tempPath `catchError` \e -> do
+      runSend fileName outputDir tempPath `catchAgentError` \e -> do
         cleanup outputDir tempPath
         notify c sndFileId $ SFERR e
       where
@@ -370,7 +369,7 @@ runXFTPSndPrepareWorker c doWork = do
       case nextFile of
         Nothing -> noWorkToDo
         Just f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
-          prepareFile f `catchError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
+          prepareFile f `catchAgentError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     prepareFile :: SndFile -> m ()
     prepareFile SndFile {prefixPath = Nothing} =
@@ -424,7 +423,7 @@ runXFTPSndPrepareWorker c doWork = do
               usedSrvs <- newTVarIO ([] :: [XFTPServer])
               withRetryInterval (riFast ri) $ \_ loop ->
                 createWithNextSrv usedSrvs
-                  `catchError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
+                  `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
               where
                 retryLoop loop = atomically (assertAgentForeground c) >> loop
             createWithNextSrv usedSrvs = do
@@ -460,10 +459,10 @@ runXFTPSndWorker c srv doWork = do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryInterval ri' $ \delay' loop ->
             uploadFileChunk fc replica
-              `catchError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchError (\_ -> pure ()) $ do
+              flip catchAgentError (\_ -> pure ()) $ do
                 notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
                 when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
                 closeXFTPServerClient c userId server digest
@@ -579,8 +578,8 @@ deleteSndFileInternal c sndFileEntityId = do
 
 deleteSndFileRemote :: forall m. AgentMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
 deleteSndFileRemote c userId sndFileEntityId (ValidFileDescription FileDescription {chunks}) = do
-  deleteSndFileInternal c sndFileEntityId `catchError` (notify c sndFileEntityId . SFERR)
-  forM_ chunks $ \ch -> deleteFileChunk ch `catchError` (notify c sndFileEntityId . SFERR)
+  deleteSndFileInternal c sndFileEntityId `catchAgentError` (notify c sndFileEntityId . SFERR)
+  forM_ chunks $ \ch -> deleteFileChunk ch `catchAgentError` (notify c sndFileEntityId . SFERR)
   where
     deleteFileChunk :: FileChunk -> m ()
     deleteFileChunk FileChunk {digest, replicas = replica@FileChunkReplica {server} : _} = do
@@ -594,7 +593,7 @@ addXFTPDelWorker c srv = do
   atomically (TM.lookup srv ws) >>= \case
     Nothing -> do
       doWork <- newTMVarIO ()
-      worker <- async $ runXFTPDelWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
+      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 ()
@@ -619,10 +618,10 @@ runXFTPDelWorker c srv doWork = do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryInterval ri' $ \delay' loop ->
             deleteChunkReplica replica
-              `catchError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchError (\_ -> pure ()) $ do
+              flip catchAgentError (\_ -> pure ()) $ do
                 notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
                 when notifyOnRetry $ notify c "" $ SFERR e
                 closeXFTPServerClient c userId server chunkDigest
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 7c0419e0a..ab09a3a14 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -502,7 +502,7 @@ acceptContactAsync' c corrId enableNtfs invId ownConnInfo = do
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
-      joinConnAsync c userId corrId enableNtfs connReq ownConnInfo `catchError` \err -> do
+      joinConnAsync c userId corrId enableNtfs connReq ownConnInfo `catchAgentError` \err -> do
         withStore' c (`unacceptInvitation` invId)
         throwError err
     _ -> throwError $ CMD PROHIBITED
@@ -565,7 +565,7 @@ newConnSrv c userId connId enableNtfs cMode clientData srv = do
 newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
 newRcvConnSrv c userId connId enableNtfs cMode clientData srv = do
   AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
-  (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange `catchError` \e -> liftIO (print e) >> throwError e
+  (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange `catchAgentError` \e -> liftIO (print e) >> throwError e
   void . withStore c $ \db -> updateNewConnRcv db connId rq
   addSubscription c rq
   when enableNtfs $ do
@@ -671,7 +671,7 @@ acceptContact' c connId enableNtfs invId ownConnInfo = withConnLock c connId "ac
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
-      joinConn c userId connId False enableNtfs connReq ownConnInfo `catchError` \err -> do
+      joinConn c userId connId False enableNtfs connReq ownConnInfo `catchAgentError` \err -> do
         withStore' c (`unacceptInvitation` invId)
         throwError err
     _ -> throwError $ CMD PROHIBITED
@@ -787,7 +787,7 @@ getNotificationMessage' c nonce encNtfInfo = do
       ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo
       PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} <- liftEither (parse strP (INTERNAL "error parsing PNMessageData") ntfData)
       (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
-      ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchError` \_ -> pure Nothing
+      ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
       maxMsgs <- asks $ ntfMaxMessages . config
       (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId maxMsgs ntfMsgMeta []
     _ -> throwError $ CMD PROHIBITED
@@ -872,8 +872,8 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
     atomically $ throwWhenInactive c
     cmdId <- atomically $ readTQueue cq
     atomically $ beginAgentOperation c AOSndNetwork
-    E.try (withStore c $ \db -> getPendingCommand db cmdId) >>= \case
-      Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ INTERNAL $ show e)
+    tryAgentError (withStore c $ \db -> getPendingCommand db cmdId) >>= \case
+      Left e -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR e)
       Right cmd -> processCmd (riFast ri) cmdId cmd
   where
     processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m ()
@@ -1078,9 +1078,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
     atomically $ beginAgentOperation c AOSndNetwork
     atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in queuePendingMsgs
     let mId = unId msgId
-    E.try (withStore c $ \db -> getPendingMsgData db connId msgId) >>= \case
-      Left (e :: E.SomeException) ->
-        notify $ MERR mId (INTERNAL $ show e)
+    tryAgentError (withStore c $ \db -> getPendingMsgData db connId msgId) >>= \case
+      Left e -> notify $ MERR mId e
       Right (rq_, PendingMsgData {msgType, msgBody, msgFlags, msgRetryState, internalTs}) -> do
         let ri' = maybe id updateRetryInterval2 msgRetryState ri
         withRetryLock2 ri' qLock $ \riState loop -> do
@@ -1310,7 +1309,7 @@ synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet"
 
 ackQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> SMP.MsgId -> m ()
 ackQueueMessage c rq srvMsgId =
-  sendAck c rq srvMsgId `catchError` \case
+  sendAck c rq srvMsgId `catchAgentError` \case
     SMP SMP.NO_MSG -> pure ()
     e -> throwError e
 
@@ -1511,7 +1510,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
         replaceToken :: NtfTokenId -> m NtfTknStatus
         replaceToken tknId = do
           ns <- asks ntfSupervisor
-          tryReplace ns `catchError` \e ->
+          tryReplace ns `catchAgentError` \e ->
             if temporaryOrHostError e
               then throwError e
               else do
@@ -1618,7 +1617,7 @@ deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
     let ntfTknAction = Just NTADelete
     withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction
     atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction}
-    agentNtfDeleteToken c tknId tkn `catchError` \case
+    agentNtfDeleteToken c tknId tkn `catchAgentError` \case
       NTF AUTH -> pure ()
       e -> throwError e
   withStore' c $ \db -> removeNtfToken db tkn
@@ -1728,16 +1727,16 @@ cleanupManager c@AgentClient {subQ} = do
   int <- asks (cleanupInterval . config)
   forever $ do
     void . runExceptT $ do
-      deleteConns `catchError` (notify "" . ERR)
-      deleteRcvMsgHashes `catchError` (notify "" . ERR)
-      deleteProcessedRatchetKeyHashes `catchError` (notify "" . ERR)
-      deleteRcvFilesExpired `catchError` (notify "" . RFERR)
-      deleteRcvFilesDeleted `catchError` (notify "" . RFERR)
-      deleteRcvFilesTmpPaths `catchError` (notify "" . RFERR)
-      deleteSndFilesExpired `catchError` (notify "" . SFERR)
-      deleteSndFilesDeleted `catchError` (notify "" . SFERR)
-      deleteSndFilesPrefixPaths `catchError` (notify "" . SFERR)
-      deleteExpiredReplicasForDeletion `catchError` (notify "" . SFERR)
+      deleteConns `catchAgentError` (notify "" . ERR)
+      deleteRcvMsgHashes `catchAgentError` (notify "" . ERR)
+      deleteProcessedRatchetKeyHashes `catchAgentError` (notify "" . ERR)
+      deleteRcvFilesExpired `catchAgentError` (notify "" . RFERR)
+      deleteRcvFilesDeleted `catchAgentError` (notify "" . RFERR)
+      deleteRcvFilesTmpPaths `catchAgentError` (notify "" . RFERR)
+      deleteSndFilesExpired `catchAgentError` (notify "" . SFERR)
+      deleteSndFilesDeleted `catchAgentError` (notify "" . SFERR)
+      deleteSndFilesPrefixPaths `catchAgentError` (notify "" . SFERR)
+      deleteExpiredReplicasForDeletion `catchAgentError` (notify "" . SFERR)
     liftIO $ threadDelay' int
   where
     deleteConns =
@@ -1753,33 +1752,33 @@ cleanupManager c@AgentClient {subQ} = do
     deleteRcvFilesExpired = do
       rcvFilesTTL <- asks $ rcvFilesTTL . config
       rcvExpired <- withStore' c (`getRcvFilesExpired` rcvFilesTTL)
-      forM_ rcvExpired $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
+      forM_ rcvExpired $ \(dbId, entId, p) -> flip catchAgentError (notify entId . RFERR) $ do
         removePath =<< toFSFilePath p
         withStore' c (`deleteRcvFile'` dbId)
     deleteRcvFilesDeleted = do
       rcvDeleted <- withStore' c getCleanupRcvFilesDeleted
-      forM_ rcvDeleted $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
+      forM_ rcvDeleted $ \(dbId, entId, p) -> flip catchAgentError (notify entId . RFERR) $ do
         removePath =<< toFSFilePath p
         withStore' c (`deleteRcvFile'` dbId)
     deleteRcvFilesTmpPaths = do
       rcvTmpPaths <- withStore' c getCleanupRcvFilesTmpPaths
-      forM_ rcvTmpPaths $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
+      forM_ rcvTmpPaths $ \(dbId, entId, p) -> flip catchAgentError (notify entId . RFERR) $ do
         removePath =<< toFSFilePath p
         withStore' c (`updateRcvFileNoTmpPath` dbId)
     deleteSndFilesExpired = do
       sndFilesTTL <- asks $ sndFilesTTL . config
       sndExpired <- withStore' c (`getSndFilesExpired` sndFilesTTL)
-      forM_ sndExpired $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+      forM_ sndExpired $ \(dbId, entId, p) -> flip catchAgentError (notify entId . SFERR) $ do
         forM_ p $ removePath <=< toFSFilePath
         withStore' c (`deleteSndFile'` dbId)
     deleteSndFilesDeleted = do
       sndDeleted <- withStore' c getCleanupSndFilesDeleted
-      forM_ sndDeleted $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+      forM_ sndDeleted $ \(dbId, entId, p) -> flip catchAgentError (notify entId . SFERR) $ do
         forM_ p $ removePath <=< toFSFilePath
         withStore' c (`deleteSndFile'` dbId)
     deleteSndFilesPrefixPaths = do
       sndPrefixPaths <- withStore' c getCleanupSndFilesPrefixPaths
-      forM_ sndPrefixPaths $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+      forM_ sndPrefixPaths $ \(dbId, entId, p) -> flip catchAgentError (notify entId . SFERR) $ do
         removePath =<< toFSFilePath p
         withStore' c (`updateSndFileNoPrefixPath` dbId)
     deleteExpiredReplicasForDeletion = do
@@ -1944,7 +1943,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               ackDel :: InternalId -> m ()
               ackDel = enqueueCmd . ICAckDel rId srvMsgId
               handleNotifyAck :: m () -> m ()
-              handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack
+              handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack
           SMP.END ->
             atomically (TM.lookup tSess smpClients $>>= tryReadTMVar >>= processEND)
               >>= logServer "<--" c srv rId
@@ -2066,7 +2065,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                 RcvConnection {} -> do
                   AcceptedConfirmation {ownConnInfo} <- withStore c (`getAcceptedConfirmation` connId)
                   let cData' = toConnData conn'
-                  connectReplyQueues c cData' ownConnInfo smpQueues `catchError` (notify . ERR)
+                  connectReplyQueues c cData' ownConnInfo smpQueues `catchAgentError` (notify . ERR)
                 _ -> prohibited
 
           continueSending :: (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index d4289749b..1d33fa1bc 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -443,7 +443,7 @@ reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c
     tryReconnectSMPClient aId = do
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \_ loop ->
-        reconnectSMPClient c tSess `catchError` const loop
+        reconnectSMPClient c tSess `catchAgentError` const loop
       atomically . removeAsyncAction aId $ reconnections c
 
 reconnectSMPClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m ()
@@ -640,7 +640,7 @@ withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pur
 withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a
 withClient_ c tSess@(userId, srv, _) statCmd action = do
   cl <- getProtocolServerClient c tSess
-  (action cl <* stat cl "OK") `catchError` logServerError cl
+  (action cl <* stat cl "OK") `catchAgentError` logServerError cl
   where
     stat cl = liftIO . incClientStat c userId cl statCmd
     logServerError :: Client msg -> AgentErrorType -> m a
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index e199f0b79..ad1d882bb 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
@@ -17,6 +18,9 @@ module Simplex.Messaging.Agent.Env.SQLite
     NetworkConfig (..),
     defaultAgentConfig,
     defaultReconnectInterval,
+    tryAgentError,
+    catchAgentError,
+    agentFinally,
     Env (..),
     newSMPAgentEnv,
     createAgentStore,
@@ -52,9 +56,10 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
 import Simplex.Messaging.Transport.Client (defaultSMPPort)
+import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors)
 import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
-import UnliftIO (Async)
+import UnliftIO (Async, SomeException)
 import UnliftIO.STM
 
 type AgentMonad' m = (MonadUnliftIO m, MonadReader Env m)
@@ -225,3 +230,19 @@ newXFTPAgent = do
   xftpSndWorkers <- TM.empty
   xftpDelWorkers <- TM.empty
   pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}
+
+tryAgentError :: AgentMonad m => m a -> m (Either AgentErrorType a)
+tryAgentError = tryAllErrors mkInternal
+{-# INLINE tryAgentError #-}
+
+catchAgentError :: AgentMonad m => m a -> (AgentErrorType -> m a) -> m a
+catchAgentError = catchAllErrors mkInternal
+{-# INLINE catchAgentError #-}
+
+agentFinally :: AgentMonad m => m a -> m a -> m a
+agentFinally = allFinally mkInternal
+{-# INLINE agentFinally #-}
+
+mkInternal :: SomeException -> AgentErrorType
+mkInternal = INTERNAL . show
+{-# INLINE mkInternal #-}
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 186b2cbb0..8e4603683 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
@@ -147,7 +147,7 @@ processNtfSub c (connId, cmd) = do
       atomically (TM.lookup srv ws) >>= \case
         Nothing -> do
           doWork <- newTMVarIO ()
-          worker <- async $ runWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
+          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 ()
@@ -173,7 +173,7 @@ runNtfWorker c srv doWork = do
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop ->
             processAction a
-              `catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
+              `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
@@ -213,7 +213,7 @@ runNtfWorker c srv doWork = do
           NSADelete -> case ntfSubId of
             Just nSubId ->
               (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
-                `E.finally` continueDeletion
+                `agentFinally` continueDeletion
             _ -> continueDeletion
             where
               continueDeletion = do
@@ -224,7 +224,7 @@ runNtfWorker c srv doWork = do
           NSARotate -> case ntfSubId of
             Just nSubId ->
               (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
-                `E.finally` deleteCreate
+                `agentFinally` deleteCreate
             _ -> deleteCreate
             where
               deleteCreate = do
@@ -257,7 +257,7 @@ runNtfSMPWorker c srv doWork = do
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop ->
             processAction a
-              `catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
+              `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
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index ec3678b39..aecb59aa3 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -13,12 +12,13 @@ import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
+import Data.List (groupBy, sortOn)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Time (NominalDiffTime)
 import UnliftIO.Async
-import Data.List (groupBy, sortOn)
+import qualified UnliftIO.Exception as UE
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
 raceAny_ = r []
@@ -99,17 +99,34 @@ catchAll_ :: IO a -> IO a -> IO a
 catchAll_ a = catchAll a . const
 {-# INLINE catchAll_ #-}
 
+tryAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m (Either e a)
+tryAllErrors err action = tryError action `UE.catch` (pure . Left . err)
+{-# INLINE tryAllErrors #-}
+
+catchAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> (e -> m a) -> m a
+catchAllErrors err action handle = tryAllErrors err action >>= either handle pure
+{-# INLINE catchAllErrors #-}
+
+catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a
+catchThrow action err  = catchAllErrors err action throwError
+{-# INLINE catchThrow #-}
+
+allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m a -> m a
+allFinally err action final = tryAllErrors err action >>= either (\e -> final >> throwError e) (const final)
+{-# INLINE allFinally #-}
+
 eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
 
 groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
 groupOn = groupBy . eqOn
-    -- it is equivalent to groupBy ((==) `on` f),
-    -- but it redefines `on` to avoid duplicate computation for most values.
-    -- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
-    -- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
-    where eqOn f = \x -> let fx = f x in \y -> fx == f y
+  -- it is equivalent to groupBy ((==) `on` f),
+  -- but it redefines `on` to avoid duplicate computation for most values.
+  -- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
+  -- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
+  where
+    eqOn f = \x -> let fx = f x in \y -> fx == f y
 
 groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
 groupAllOn f = groupOn f . sortOn f
diff --git a/tests/CoreTests/UtilTests.hs b/tests/CoreTests/UtilTests.hs
new file mode 100644
index 000000000..3da316ecc
--- /dev/null
+++ b/tests/CoreTests/UtilTests.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CoreTests.UtilTests where
+
+import Control.Exception (Exception, SomeException, throwIO)
+import Control.Monad.Except
+import Data.IORef
+import Simplex.Messaging.Util
+import Simplex.Messaging.Client.Agent ()
+import Test.Hspec
+import qualified UnliftIO.Exception as UE
+
+utilTests :: Spec
+utilTests = do
+  describe "lifted try, catch and finally problems" $ do
+    describe "try" $ do
+      it "lifted try does not catch errors" $ do
+        runExceptT (UE.try throwTestError >>= either handleCatch pure) `shouldReturn` Left (TestError "error")
+        runExceptT (UE.try throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
+      it "lifted try with SomeException catches all errors but wraps ExceptT errors" $ do
+        runExceptT (UE.try throwTestError >>= either handleException pure) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
+        runExceptT (UE.try throwTestException >>= either handleException pure) `shouldReturn` Right "caught user error (error)"
+    describe "catch" $ do
+      it "lifted catch does not catch" $ do
+        runExceptT (throwTestError `UE.catch` handleCatch) `shouldReturn` Left (TestError "error")
+        runExceptT (throwTestException `UE.catch` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
+      it "lifted catch of SomeException catches all errors but wraps ExceptT errors" $ do
+        runExceptT (throwTestError `UE.catch` handleException) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
+        runExceptT (throwTestException `UE.catch` handleException) `shouldReturn` Right "caught user error (error)"
+    describe "finally" $ do
+      it "lifted finally executes final action and stays in ExceptT monad" $ withFinal $ \final ->
+        runExceptT (throwTestError `UE.finally` final) `shouldReturn` Left (TestError "error")
+      it "lifted finally executes final action but throws exception" $ withFinal $ \final ->
+        runExceptT (throwTestException `UE.finally` final) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
+  describe "tryAllErrors" $ do
+    it "should return ExceptT error as Left" $
+      runExceptT (tryAllErrors testErr throwTestError) `shouldReturn` Right (Left (TestError "error"))
+    it "should return SomeException as Left" $
+      runExceptT (tryAllErrors testErr throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
+    it "should return no errors as Right" $
+      runExceptT (tryAllErrors testErr noErrors) `shouldReturn` Right (Right "no errors")
+  describe "tryAllErrors specialized as tryTestError" $ do
+    let tryTestError = tryAllErrors testErr
+    it "should return ExceptT error as Left" $
+      runExceptT (tryTestError throwTestError) `shouldReturn` Right (Left (TestError "error"))
+    it "should return SomeException as Left" $
+      runExceptT (tryTestError throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
+    it "should return no errors as Right" $
+      runExceptT (tryTestError noErrors) `shouldReturn` Right (Right "no errors")
+  describe "catchAllErrors" $ do
+    it "should catch ExceptT error" $
+      runExceptT (catchAllErrors testErr throwTestError handleCatch) `shouldReturn` Right "caught TestError \"error\""
+    it "should catch SomeException" $
+      runExceptT (catchAllErrors testErr throwTestException handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
+    it "should not throw if there are no errors" $
+      runExceptT (catchAllErrors testErr noErrors throwError) `shouldReturn` Right "no errors"
+  describe "catchAllErrors specialized as catchTestError" $ do
+    let catchTestError = catchAllErrors testErr
+    it "should catch ExceptT error" $
+      runExceptT (throwTestError `catchTestError` handleCatch) `shouldReturn` Right "caught TestError \"error\""
+    it "should catch SomeException" $
+      runExceptT (throwTestException `catchTestError` handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
+    it "should not throw if there are no errors" $
+      runExceptT (noErrors `catchTestError` throwError) `shouldReturn` Right "no errors"
+  describe "catchThrow" $ do
+    it "should re-throw ExceptT error" $
+      runExceptT (throwTestError `catchThrow` testErr) `shouldReturn` Left (TestError "error")
+    it "should catch SomeException and throw as ExceptT error" $
+      runExceptT (throwTestException `catchThrow` testErr) `shouldReturn` Left (TestException "user error (error)")
+    it "should not throw if there are no exceptions" $
+      runExceptT (noErrors `catchThrow` testErr) `shouldReturn` Right "no errors"
+  describe "allFinally should run final action" $ do
+    it "then throw ExceptT error" $ withFinal $ \final ->
+      runExceptT (allFinally testErr throwTestError final) `shouldReturn` Left (TestError "error")
+    it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
+      runExceptT (allFinally testErr throwTestException final) `shouldReturn` Left (TestException "user error (error)")
+    it "and should not throw if there are no exceptions" $ withFinal $ \final ->
+      runExceptT (allFinally testErr noErrors final) `shouldReturn` Right "final"
+  describe "allFinally specialized as testFinally should run final action" $ do
+    let testFinally = allFinally testErr
+    it "then throw ExceptT error" $ withFinal $ \final ->
+      runExceptT (throwTestError `testFinally` final) `shouldReturn` Left (TestError "error")
+    it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
+      runExceptT (throwTestException `testFinally` final) `shouldReturn` Left (TestException "user error (error)")
+    it "and should not throw if there are no exceptions" $ withFinal $ \final ->
+      runExceptT (noErrors `testFinally` final) `shouldReturn` Right "final"
+  where
+    throwTestError :: ExceptT TestError IO String
+    throwTestError = throwError $ TestError "error"
+    throwTestException :: ExceptT TestError IO String
+    throwTestException = liftIO $ throwIO $ userError "error"
+    noErrors :: ExceptT TestError IO String
+    noErrors = pure "no errors"
+    testErr :: SomeException -> TestError
+    testErr = TestException . show
+    handleCatch :: TestError -> ExceptT TestError IO String
+    handleCatch e = pure $ "caught " <> show e
+    handleException :: SomeException -> ExceptT TestError IO String
+    handleException e = pure $ "caught " <> show e
+    withFinal :: (ExceptT TestError IO String -> IO ()) -> IO ()
+    withFinal test = do
+      r <- newIORef False
+      let final = liftIO $ writeIORef r True >> pure "final"
+      test final
+      readIORef r `shouldReturn` True
+
+data TestError = TestError String | TestException String
+  deriving (Eq, Show)
+
+instance Exception TestError
diff --git a/tests/Test.hs b/tests/Test.hs
index d76357be4..259c3c3cb 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -7,6 +7,7 @@ import CoreTests.CryptoTests
 import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
 import CoreTests.RetryIntervalTests
+import CoreTests.UtilTests
 import CoreTests.VersionRangeTests
 import FileDescriptionTests (fileDescriptionTests)
 import NtfServerTests (ntfServerTests)
@@ -39,6 +40,7 @@ main = do
           describe "Version range" versionRangeTests
           describe "Encryption tests" cryptoTests
           describe "Retry interval tests" retryIntervalTests
+          describe "Util tests" utilTests
         describe "SMP server via TLS" $ serverTests (transport @TLS)
         describe "SMP server via WebSockets" $ serverTests (transport @WS)
         describe "Notifications server" $ ntfServerTests (transport @TLS)

From 2f5c646e55f48d112a9fea11b36ea548cdc0bec3 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sun, 9 Jul 2023 18:38:44 +0100
Subject: [PATCH 31/49] test with catchError/tryError

---
 tests/CoreTests/UtilTests.hs | 29 +++++++++++++++++++----------
 1 file changed, 19 insertions(+), 10 deletions(-)

diff --git a/tests/CoreTests/UtilTests.hs b/tests/CoreTests/UtilTests.hs
index 3da316ecc..f3c78c07b 100644
--- a/tests/CoreTests/UtilTests.hs
+++ b/tests/CoreTests/UtilTests.hs
@@ -12,26 +12,35 @@ import qualified UnliftIO.Exception as UE
 
 utilTests :: Spec
 utilTests = do
-  describe "lifted try, catch and finally problems" $ do
-    describe "try" $ do
-      it "lifted try does not catch errors" $ do
+  describe "problems of lifted try, catch and finally (don't use them)" $ do
+    describe "lifted try" $ do
+      it "does not catch errors" $ do
         runExceptT (UE.try throwTestError >>= either handleCatch pure) `shouldReturn` Left (TestError "error")
         runExceptT (UE.try throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
-      it "lifted try with SomeException catches all errors but wraps ExceptT errors" $ do
+      it "with SomeException catches all errors but wraps ExceptT errors" $ do
         runExceptT (UE.try throwTestError >>= either handleException pure) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
         runExceptT (UE.try throwTestException >>= either handleException pure) `shouldReturn` Right "caught user error (error)"
-    describe "catch" $ do
-      it "lifted catch does not catch" $ do
+    describe "lifted catch" $ do
+      it "does not catch" $ do
         runExceptT (throwTestError `UE.catch` handleCatch) `shouldReturn` Left (TestError "error")
         runExceptT (throwTestException `UE.catch` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
-      it "lifted catch of SomeException catches all errors but wraps ExceptT errors" $ do
+      it "with SomeException catches all errors but wraps ExceptT errors" $ do
         runExceptT (throwTestError `UE.catch` handleException) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
         runExceptT (throwTestException `UE.catch` handleException) `shouldReturn` Right "caught user error (error)"
-    describe "finally" $ do
-      it "lifted finally executes final action and stays in ExceptT monad" $ withFinal $ \final ->
+    describe "lifted finally" $ do
+      it "with ExceptT error executes final action and stays in ExceptT monad" $ withFinal $ \final ->
         runExceptT (throwTestError `UE.finally` final) `shouldReturn` Left (TestError "error")
-      it "lifted finally executes final action but throws exception" $ withFinal $ \final ->
+      it "with exception executes final action (not always - race condition?) and throws exception" $ withFinal $ \final ->
         runExceptT (throwTestException `UE.finally` final) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
+  describe "problems of tryError and catchError (don't use them)" $ do
+    describe "tryError" $ do
+      it "catches ExceptT errors but not Exceptions" $ do
+        runExceptT (tryError throwTestError >>= either handleCatch pure) `shouldReturn` Right "caught TestError \"error\""
+        runExceptT (tryError throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
+    describe "catchError" $ do
+      it "catches ExceptT errors but not Exceptions" $ do
+        runExceptT (throwTestError `catchError` handleCatch) `shouldReturn` Right "caught TestError \"error\""
+        runExceptT (throwTestException `catchError` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
   describe "tryAllErrors" $ do
     it "should return ExceptT error as Left" $
       runExceptT (tryAllErrors testErr throwTestError) `shouldReturn` Right (Left (TestError "error"))

From 532cd2f39c7c22da19a47424eaefa7eafb0aeff8 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sun, 9 Jul 2023 21:36:23 +0100
Subject: [PATCH 32/49] fix allFinally

---
 src/Simplex/Messaging/Agent/Env/SQLite.hs | 2 +-
 src/Simplex/Messaging/Util.hs             | 4 ++--
 tests/CoreTests/UtilTests.hs              | 4 ++--
 3 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index ad1d882bb..5e779cc22 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -239,7 +239,7 @@ catchAgentError :: AgentMonad m => m a -> (AgentErrorType -> m a) -> m a
 catchAgentError = catchAllErrors mkInternal
 {-# INLINE catchAgentError #-}
 
-agentFinally :: AgentMonad m => m a -> m a -> m a
+agentFinally :: AgentMonad m => m a -> m b -> m a
 agentFinally = allFinally mkInternal
 {-# INLINE agentFinally #-}
 
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index aecb59aa3..3a0113b71 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -111,8 +111,8 @@ catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e)
 catchThrow action err  = catchAllErrors err action throwError
 {-# INLINE catchThrow #-}
 
-allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m a -> m a
-allFinally err action final = tryAllErrors err action >>= either (\e -> final >> throwError e) (const final)
+allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a
+allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwError pure r
 {-# INLINE allFinally #-}
 
 eitherToMaybe :: Either a b -> Maybe b
diff --git a/tests/CoreTests/UtilTests.hs b/tests/CoreTests/UtilTests.hs
index f3c78c07b..ded4d9aad 100644
--- a/tests/CoreTests/UtilTests.hs
+++ b/tests/CoreTests/UtilTests.hs
@@ -84,7 +84,7 @@ utilTests = do
     it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
       runExceptT (allFinally testErr throwTestException final) `shouldReturn` Left (TestException "user error (error)")
     it "and should not throw if there are no exceptions" $ withFinal $ \final ->
-      runExceptT (allFinally testErr noErrors final) `shouldReturn` Right "final"
+      runExceptT (allFinally testErr noErrors final) `shouldReturn` Right "no errors"
   describe "allFinally specialized as testFinally should run final action" $ do
     let testFinally = allFinally testErr
     it "then throw ExceptT error" $ withFinal $ \final ->
@@ -92,7 +92,7 @@ utilTests = do
     it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
       runExceptT (throwTestException `testFinally` final) `shouldReturn` Left (TestException "user error (error)")
     it "and should not throw if there are no exceptions" $ withFinal $ \final ->
-      runExceptT (noErrors `testFinally` final) `shouldReturn` Right "final"
+      runExceptT (noErrors `testFinally` final) `shouldReturn` Right "no errors"
   where
     throwTestError :: ExceptT TestError IO String
     throwTestError = throwError $ TestError "error"

From 1afcefa5e7cf7c4a5e5732104105d14259be16b6 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Tue, 11 Jul 2023 20:19:20 +0400
Subject: [PATCH 33/49] db error busy treatments (#796)

---
 simplexmq.cabal                               |  1 +
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 85 +++++--------------
 .../Messaging/Agent/Store/SQLite/Common.hs    | 61 +++++++++++++
 .../Agent/Store/SQLite/Migrations.hs          | 43 +++++-----
 tests/AgentTests/SchemaDump.hs                |  6 +-
 5 files changed, 109 insertions(+), 87 deletions(-)
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Common.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 3c20ea9ed..89f57d40a 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -63,6 +63,7 @@ library
       Simplex.Messaging.Agent.Server
       Simplex.Messaging.Agent.Store
       Simplex.Messaging.Agent.Store.SQLite
+      Simplex.Messaging.Agent.Store.SQLite.Common
       Simplex.Messaging.Agent.Store.SQLite.Migrations
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 442445359..9cda785a3 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -206,7 +206,6 @@ module Simplex.Messaging.Agent.Store.SQLite
   )
 where
 
-import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
@@ -229,7 +228,7 @@ import Data.Ord (Down (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
 import Data.Word (Word32)
 import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..))
 import qualified Database.SQLite.Simple as DB
@@ -246,6 +245,7 @@ import Simplex.FileTransfer.Types
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
 import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.SQLite.Common
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRError, Migration (..), MigrationsToRun (..), mtrErrorDescription)
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import qualified Simplex.Messaging.Crypto as C
@@ -258,25 +258,18 @@ import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, s
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, groupOn, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (takeDirectory)
 import System.IO (hFlush, stdout)
-import UnliftIO.Exception (bracket, onException)
+import UnliftIO.Exception (onException)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
 -- * SQLite Store implementation
 
-data SQLiteStore = SQLiteStore
-  { dbFilePath :: FilePath,
-    dbEncrypted :: TVar Bool,
-    dbConnection :: TMVar DB.Connection,
-    dbNew :: Bool
-  }
-
 data MigrationError
   = MEUpgrade {upMigrations :: [UpMigration]}
   | MEDowngrade {downMigrations :: [String]}
@@ -333,35 +326,35 @@ createSQLiteStore dbFilePath dbKey migrations confirmMigrations = do
     Left e -> closeSQLiteStore st $> Left e
 
 migrateSchema :: SQLiteStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
-migrateSchema st migrations confirmMigrations = withConnection st $ \db -> do
-  Migrations.initialize db
-  Migrations.get db migrations >>= \case
+migrateSchema st migrations confirmMigrations = do
+  Migrations.initialize st
+  Migrations.get st migrations >>= \case
     Left e -> do
       when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
       pure . Left $ MigrationError e
     Right MTRNone -> pure $ Right ()
     Right ms@(MTRUp ums)
-      | dbNew st -> Migrations.run db ms $> Right ()
+      | dbNew st -> Migrations.run st ms $> Right ()
       | otherwise -> case confirmMigrations of
-        MCYesUp -> run db ms
-        MCYesUpDown -> run db ms
-        MCConsole -> confirm err >> run db ms
+        MCYesUp -> run ms
+        MCYesUpDown -> run ms
+        MCConsole -> confirm err >> run ms
         MCError -> pure $ Left err
       where
         err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
     Right ms@(MTRDown dms) -> case confirmMigrations of
-      MCYesUpDown -> run db ms
-      MCConsole -> confirm err >> run db ms
+      MCYesUpDown -> run ms
+      MCConsole -> confirm err >> run ms
       MCYesUp -> pure $ Left err
       MCError -> pure $ Left err
       where
         err = MEDowngrade $ map downName dms
   where
     confirm err = confirmOrExit $ migrationErrorDescription err
-    run db ms = do
+    run ms = do
       let f = dbFilePath st
       copyFile f (f <> ".bak")
-      Migrations.run db ms
+      Migrations.run st ms
       pure $ Right ()
 
 confirmOrExit :: String -> IO ()
@@ -375,9 +368,10 @@ confirmOrExit s = do
 connectSQLiteStore :: FilePath -> String -> IO SQLiteStore
 connectSQLiteStore dbFilePath dbKey = do
   dbNew <- not <$> doesFileExist dbFilePath
-  dbConnection <- newTMVarIO =<< connectDB dbFilePath dbKey
+  dbConn <- dbBusyLoop $ connectDB dbFilePath dbKey
+  dbConnVar <- newTMVarIO dbConn
   dbEncrypted <- newTVarIO . not $ null dbKey
-  pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection, dbNew}
+  pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection = dbConnVar, dbNew}
 
 connectDB :: FilePath -> String -> IO DB.Connection
 connectDB path key = do
@@ -389,13 +383,11 @@ connectDB path key = do
     prepare db = do
       let exec = SQLite3.exec $ DB.connectionHandle db
       unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";"
-      exec . fromQuery $
-        [sql|
-          PRAGMA foreign_keys = ON;
-          -- PRAGMA trusted_schema = OFF;
-          PRAGMA secure_delete = ON;
-          PRAGMA auto_vacuum = FULL;
-        |]
+      exec "PRAGMA busy_timeout = 100;"
+      exec "PRAGMA foreign_keys = ON;"
+      -- exec "PRAGMA trusted_schema = OFF;"
+      exec "PRAGMA secure_delete = ON;"
+      exec "PRAGMA auto_vacuum = FULL;"
 
 closeSQLiteStore :: SQLiteStore -> IO ()
 closeSQLiteStore st = atomically (takeTMVar $ dbConnection st) >>= DB.close
@@ -438,37 +430,6 @@ handleSQLError err e
   | DB.sqlError e == DB.ErrorConstraint = err
   | otherwise = SEInternal $ bshow e
 
-withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withConnection SQLiteStore {dbConnection} =
-  bracket
-    (atomically $ takeTMVar dbConnection)
-    (atomically . putTMVar dbConnection)
-
-withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withTransaction = withTransactionCtx Nothing
-
-withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withTransactionCtx ctx_ st action = withConnection st $ loop 500 3_000_000
-  where
-    loop :: Int -> Int -> DB.Connection -> IO a
-    loop t tLim db =
-      transactionWithCtx `E.catch` \(e :: SQLError) ->
-        if tLim > t && DB.sqlError e == DB.ErrorBusy
-          then do
-            threadDelay t
-            loop (t * 9 `div` 8) (tLim - t) db
-          else E.throwIO e
-      where
-        transactionWithCtx = case ctx_ of
-          Nothing -> DB.withImmediateTransaction db (action db)
-          Just ctx -> do
-            t1 <- getCurrentTime
-            r <- DB.withImmediateTransaction db (action db)
-            t2 <- getCurrentTime
-            putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
-            putStrLn $ "withTransactionCtx end   :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
-            pure r
-
 createUserRecord :: DB.Connection -> IO UserId
 createUserRecord db = do
   DB.execute_ db "INSERT INTO users DEFAULT VALUES"
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs
new file mode 100644
index 000000000..89efa7810
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Common
+  ( SQLiteStore (..),
+    withConnection,
+    withTransaction,
+    withTransactionCtx,
+    dbBusyLoop,
+  )
+where
+
+import Control.Concurrent (threadDelay)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import Database.SQLite.Simple (SQLError)
+import qualified Database.SQLite.Simple as DB
+import Simplex.Messaging.Util (diffToMilliseconds)
+import UnliftIO.Exception (bracket)
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM
+
+data SQLiteStore = SQLiteStore
+  { dbFilePath :: FilePath,
+    dbEncrypted :: TVar Bool,
+    dbConnection :: TMVar DB.Connection,
+    dbNew :: Bool
+  }
+
+withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withConnection SQLiteStore {dbConnection} =
+  bracket
+    (atomically $ takeTMVar dbConnection)
+    (atomically . putTMVar dbConnection)
+
+withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withTransaction = withTransactionCtx Nothing
+
+withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withTransactionCtx ctx_ st action = withConnection st $ \db -> dbBusyLoop (transactionWithCtx db)
+  where
+    transactionWithCtx db = case ctx_ of
+      Nothing -> DB.withImmediateTransaction db (action db)
+      Just ctx -> do
+        t1 <- getCurrentTime
+        r <- DB.withImmediateTransaction db (action db)
+        t2 <- getCurrentTime
+        putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
+        putStrLn $ "withTransactionCtx end   :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
+        pure r
+
+dbBusyLoop :: forall a. IO a -> IO a
+dbBusyLoop action = loop 500 3000000
+  where
+    loop :: Int -> Int -> IO a
+    loop t tLim =
+      action `E.catch` \(e :: SQLError) ->
+        if tLim > t && DB.sqlError e == DB.ErrorBusy
+          then do
+            threadDelay t
+            loop (t * 9 `div` 8) (tLim - t)
+          else E.throwIO e
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index bc91cd8f0..737edda95 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
@@ -42,6 +42,7 @@ import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
 import GHC.Generics (Generic)
 import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
+import Simplex.Messaging.Agent.Store.SQLite.Common
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
@@ -99,44 +100,42 @@ app = sortOn name $ map migration schemaMigrations
   where
     migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
 
-get :: Connection -> [Migration] -> IO (Either MTRError MigrationsToRun)
-get db migrations = migrationsToRun migrations <$> getCurrent db
+get :: SQLiteStore -> [Migration] -> IO (Either MTRError MigrationsToRun)
+get st migrations = migrationsToRun migrations <$> withTransaction st getCurrent
 
 getCurrent :: Connection -> IO [Migration]
 getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
   where
     toMigration (name, down) = Migration {name, up = "", down}
 
-run :: Connection -> MigrationsToRun -> IO ()
-run db = \case
+run :: SQLiteStore -> MigrationsToRun -> IO ()
+run st = \case
   MTRUp [] -> pure ()
-  MTRUp ms -> mapM_ runUp ms >> execSQL "VACUUM;"
+  MTRUp ms -> mapM_ runUp ms >> withConnection st (`execSQL` "VACUUM;")
   MTRDown ms -> mapM_ runDown $ reverse ms
   MTRNone -> pure ()
   where
-    runUp Migration {name, up, down} = do
-      when (name == "m20220811_onion_hosts") updateServers
-      DB.withImmediateTransaction db $ insert >> execSQL up
+    runUp Migration {name, up, down} = withTransaction st $ \db -> do
+      when (name == "m20220811_onion_hosts") $ updateServers db
+      insert db >> execSQL db up
       where
-        insert = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
-        updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
-          DB.withImmediateTransaction db $
-            let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
-             in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
-    runDown DownMigration {downName, downQuery} = do
-      DB.withImmediateTransaction db $ do
-        execSQL downQuery
-        DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
-    execSQL = SQLite3.exec $ DB.connectionHandle db
+        insert db = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
+        updateServers db = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
+          let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
+           in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
+    runDown DownMigration {downName, downQuery} = withTransaction st $ \db -> do
+      execSQL db downQuery
+      DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
+    execSQL db = SQLite3.exec $ DB.connectionHandle db
 
-initialize :: Connection -> IO ()
-initialize db = do
+initialize :: SQLiteStore -> IO ()
+initialize st = withTransaction st $ \db -> do
   cs :: [Text] <- map fromOnly <$> DB.query_ db "SELECT name FROM pragma_table_info('migrations')"
   case cs of
-    [] -> createMigrations
+    [] -> createMigrations db
     _ -> when ("down" `notElem` cs) $ DB.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
   where
-    createMigrations =
+    createMigrations db =
       DB.execute_
         db
         [sql|
diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs
index 8154e3c01..097482c07 100644
--- a/tests/AgentTests/SchemaDump.hs
+++ b/tests/AgentTests/SchemaDump.hs
@@ -50,13 +50,13 @@ testSchemaMigrations = do
       putStrLn $ "down migration " <> name m
       let downMigr = fromJust $ toDownMigration m
       schema <- getSchema testDB testSchema
-      withConnection st (`Migrations.run` MTRUp [m])
+      Migrations.run st $ MTRUp [m]
       schema' <- getSchema testDB testSchema
       schema' `shouldNotBe` schema
-      withConnection st (`Migrations.run` MTRDown [downMigr])
+      Migrations.run st $ MTRDown [downMigr]
       schema'' <- getSchema testDB testSchema
       schema'' `shouldBe` schema
-      withConnection st (`Migrations.run` MTRUp [m])
+      Migrations.run st $ MTRUp [m]
       schema''' <- getSchema testDB testSchema
       schema''' `shouldBe` schema'
 

From 58dbc197ce4a2e3698325c14294dc3c30401b984 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 11 Jul 2023 18:54:14 +0100
Subject: [PATCH 34/49] increase TCP timeout for clients (#797)

---
 src/Simplex/Messaging/Client.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index c83083d8e..cbd7be42f 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -207,9 +207,9 @@ defaultNetworkConfig =
       hostMode = HMOnionViaSocks,
       requiredHostMode = False,
       sessionMode = TSMUser,
-      tcpConnectTimeout = 7_500_000,
-      tcpTimeout = 5_000_000,
-      tcpTimeoutPerKb = 10_000, -- 10ms, should be less than 130ms to avoid Int overflow on 32 bit systems
+      tcpConnectTimeout = 15_000_000,
+      tcpTimeout = 10_000_000,
+      tcpTimeoutPerKb = 20_000, -- 20ms, should be less than 130ms to avoid Int overflow on 32 bit systems
       tcpKeepAlive = Just defaultKeepAliveOpts,
       smpPingInterval = 600_000_000, -- 10min
       smpPingCount = 3,

From b61e3b5f95f5d9fde8ba365e9b18bf9b64fb0880 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 11 Jul 2023 19:43:31 +0100
Subject: [PATCH 35/49] server: disable transport timeout (#793)

---
 src/Simplex/Messaging/Transport/Server.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs
index 02d163079..d5155ce6d 100644
--- a/src/Simplex/Messaging/Transport/Server.hs
+++ b/src/Simplex/Messaging/Transport/Server.hs
@@ -53,8 +53,9 @@ defaultTransportServerConfig = TransportServerConfig
   }
 
 serverTransportConfig :: TransportServerConfig -> TransportConfig
-serverTransportConfig TransportServerConfig {logTLSErrors, transportTimeout} =
-  TransportConfig {logTLSErrors, transportTimeout = Just transportTimeout}
+serverTransportConfig TransportServerConfig {logTLSErrors} =
+  -- TransportConfig {logTLSErrors, transportTimeout = Just transportTimeout}
+  TransportConfig {logTLSErrors, transportTimeout = Nothing}
 
 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --

From 4c6c436e7f5b677e4c34900874c650acc584ae84 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 12 Jul 2023 07:35:38 +0100
Subject: [PATCH 36/49] resubscribe in batches in Client.Agent (#798)

* resubscribe in batches in Client.Agent

* fix test
---
 src/Simplex/Messaging/Client/Agent.hs           | 17 +++++++++--------
 src/Simplex/Messaging/Notifications/Server.hs   |  9 ++-------
 .../Messaging/Notifications/Server/Env.hs       |  1 +
 .../Messaging/Notifications/Server/Main.hs      |  1 +
 src/Simplex/Messaging/Util.hs                   |  8 ++++++++
 tests/NtfClient.hs                              |  1 +
 6 files changed, 22 insertions(+), 15 deletions(-)

diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index a59424f24..df96bce05 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -39,7 +39,7 @@ import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPS
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, tryE, ($>>=))
+import Simplex.Messaging.Util (catchAll_, tryE, ($>>=), toChunks)
 import System.Timeout (timeout)
 import UnliftIO (async)
 import UnliftIO.Exception (Exception)
@@ -66,7 +66,8 @@ data SMPClientAgentConfig = SMPClientAgentConfig
   { smpCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
     msgQSize :: Natural,
-    agentQSize :: Natural
+    agentQSize :: Natural,
+    agentSubsBatchSize :: Int
   }
 
 defaultSMPClientAgentConfig :: SMPClientAgentConfig
@@ -79,8 +80,9 @@ defaultSMPClientAgentConfig =
             increaseAfter = 10 * second,
             maxInterval = 10 * second
           },
-      msgQSize = 64,
-      agentQSize = 64
+      msgQSize = 256,
+      agentQSize = 256,
+      agentSubsBatchSize = 900
     }
   where
     second = 1000000
@@ -222,9 +224,9 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
           SPRecipient -> False
 
         subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> ExceptT SMPClientError IO ()
-        subscribe_ smp party subs =
-          case L.nonEmpty subs of
-            Just subs' -> do
+        subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
+          where
+            subscribeBatch subs' = do
               let subs'' :: (NonEmpty (QueueId, C.APrivateSignKey)) = L.map (first snd) subs'
               rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
               let rs' :: (NonEmpty ((SMPSub, C.APrivateSignKey), Either SMPClientError ())) =
@@ -238,7 +240,6 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
               mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs 
               mapM_ (liftIO . notify . CASubError srv) $ L.nonEmpty finalErrs
               mapM_ (throwE . snd) $ listToMaybe tempErrs
-            Nothing -> pure ()
 
     notify :: SMPClientAgentEvent -> IO ()
     notify evt = atomically $ writeTBQueue (agentQ ca) evt
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 7a1abd20f..1daeea8ab 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -158,18 +158,13 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
     subscribe = forever $ do
       subs <- atomically (readTBQueue newSubQ)
       let ss = L.groupAllWith server subs
+      batchSize <- asks $ subsBatchSize . config
       forM_ ss $ \serverSubs -> do
         let srv = server $ L.head serverSubs
-            batches = toChunks 900 $ L.toList serverSubs
+            batches = toChunks batchSize $ L.toList serverSubs
         SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber srv
         mapM_ (atomically . writeTQueue subscriberSubQ) batches
 
-    toChunks :: Int -> [a] -> [NonEmpty a]
-    toChunks _ [] = []
-    toChunks n xs =
-      let (ys, xs') = splitAt n xs
-      in maybe id (:) (L.nonEmpty ys) (toChunks n xs')
-
     server :: NtfEntityRec 'Subscription -> SMPServer
     server (NtfSub sub) = ntfSubServer sub
 
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index fa3f40cab..38604b62b 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -46,6 +46,7 @@ data NtfServerConfig = NtfServerConfig
     pushQSize :: Natural,
     smpAgentCfg :: SMPClientAgentConfig,
     apnsConfig :: APNSPushClientConfig,
+    subsBatchSize :: Int,
     inactiveClientExpiration :: Maybe ExpirationConfig,
     storeLogFile :: Maybe FilePath,
     -- CA certificate private key is not needed for initialization
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index c9467a09f..19f4a6e73 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -115,6 +115,7 @@ ntfServerCLI cfgPath logPath =
               pushQSize = 1048,
               smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
               apnsConfig = defaultAPNSPushClientConfig,
+              subsBatchSize = 900,
               inactiveClientExpiration = Nothing,
               storeLogFile = enableStoreLog $> storeLogFilePath,
               caCertificateFile = c caCrtFile,
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index 3a0113b71..63617bc9d 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -13,6 +13,8 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import Data.List (groupBy, sortOn)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
@@ -131,6 +133,12 @@ groupOn = groupBy . eqOn
 groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
 groupAllOn f = groupOn f . sortOn f
 
+toChunks :: Int -> [a] -> [NonEmpty a]
+toChunks _ [] = []
+toChunks n xs =
+  let (ys, xs') = splitAt n xs
+  in maybe id (:) (L.nonEmpty ys) (toChunks n xs')
+
 safeDecodeUtf8 :: ByteString -> Text
 safeDecodeUtf8 = decodeUtf8With onError
   where
diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs
index 184d184d6..1bd46e4b9 100644
--- a/tests/NtfClient.hs
+++ b/tests/NtfClient.hs
@@ -89,6 +89,7 @@ ntfServerCfg =
           { apnsPort = apnsTestPort,
             caStoreFile = "tests/fixtures/ca.crt"
           },
+      subsBatchSize = 900,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       storeLogFile = Nothing,
       -- CA certificate private key is not needed for initialization

From 745a144e0c75acb2dc8c685f127ebaeb32ce813f Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 13 Jul 2023 19:23:06 +0100
Subject: [PATCH 37/49] 5.2.1 (ntf 1.5.1, xftp 1.0.1) (#799)

---
 package.yaml                                       | 2 +-
 simplexmq.cabal                                    | 2 +-
 src/Simplex/FileTransfer/Client/Main.hs            | 2 +-
 src/Simplex/FileTransfer/Server/Main.hs            | 2 +-
 src/Simplex/Messaging/Notifications/Server/Main.hs | 2 +-
 5 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/package.yaml b/package.yaml
index c1bdd937b..a6e2ef8e0 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.2.0
+version: 5.2.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 89f57d40a..f9f40392a 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.2.0
+version:        5.2.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 20b6d177d..4d7f99e85 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -74,7 +74,7 @@ import UnliftIO
 import UnliftIO.Directory
 
 xftpClientVersion :: String
-xftpClientVersion = "0.1.0"
+xftpClientVersion = "1.0.1"
 
 chunkSize1 :: Word32
 chunkSize1 = kb 256
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
index 9f496e330..5da183437 100644
--- a/src/Simplex/FileTransfer/Server/Main.hs
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -32,7 +32,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 xftpServerVersion :: String
-xftpServerVersion = "1.0.0"
+xftpServerVersion = "1.0.1"
 
 xftpServerCLI :: FilePath -> FilePath -> IO ()
 xftpServerCLI cfgPath logPath = do
diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs
index 19f4a6e73..46544af17 100644
--- a/src/Simplex/Messaging/Notifications/Server/Main.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Main.hs
@@ -30,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.5.0"
+ntfServerVersion = "1.5.1"
 
 defaultSMPBatchDelay :: Int
 defaultSMPBatchDelay = 10000

From 58cb2855d23ac970a619a61d088ed2a08dfb3d81 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 13 Jul 2023 22:33:48 +0100
Subject: [PATCH 38/49] agent: delivery receipts (#752)

* rfc: delivery receipts

* update doc

* update rfc

* implementation plan, types, schema

* migration, update types

* update types

* rename migration

* export MsgReceiptStatus, JSON encoding

* update rfc, schema

* correction

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* skeleton of the implementation

* more implementation (some tests fail)

* more code, 1 test fails

* fix encoding

* refactor

* refactor

* test, fix

* only send receipts in v3+, test

* flip condition

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* flip condition

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* agent version 4 required to send receipts

* fix test

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 rfcs/2023-05-03-delivery-receipts.md          | 170 ++++++++++++++++++
 simplexmq.cabal                               |   2 +-
 src/Simplex/FileTransfer.hs                   |  14 --
 src/Simplex/Messaging/Agent.hs                | 123 +++++++++----
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |   8 +-
 src/Simplex/Messaging/Agent/Protocol.hs       | 144 +++++++++++----
 src/Simplex/Messaging/Agent/Store.hs          |  14 ++
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 128 ++++++++++---
 .../Agent/Store/SQLite/Migrations.hs          |   4 +-
 .../Migrations/M20230701_delivery_receipts.hs |  24 +++
 .../Store/SQLite/Migrations/agent_schema.sql  |   6 +
 tests/AgentTests/ConnectionRequestTests.hs    |   4 +-
 tests/AgentTests/FunctionalAPITests.hs        | 147 +++++++++++----
 tests/AgentTests/NotificationTests.hs         |  28 +--
 14 files changed, 649 insertions(+), 167 deletions(-)
 create mode 100644 rfcs/2023-05-03-delivery-receipts.md
 delete mode 100644 src/Simplex/FileTransfer.hs
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230701_delivery_receipts.hs

diff --git a/rfcs/2023-05-03-delivery-receipts.md b/rfcs/2023-05-03-delivery-receipts.md
new file mode 100644
index 000000000..bc5658f96
--- /dev/null
+++ b/rfcs/2023-05-03-delivery-receipts.md
@@ -0,0 +1,170 @@
+# Delivery receipts
+
+## Problems
+
+User experience - users need to know that the messages are delivered to the recipient, as this confirms that the system is functioning.
+
+The downside of communicating message delivery as it confirms that the recipient was online, and, unless there is a delay in confirming, can be used to track the location via the variation in network latency. So delivery receipts should be delayed with a randomized interval and should be opt in or opt out.
+
+Another problem of message receipts is that they increase network traffic and server load. This could be avoided if delivery receipts are communicated as part of normal message delivery flow.
+
+Some other existing and planned features implicitely confirm message delivery and, possibly, should depend on message delivery being enabled:
+- agent message to resume delivery when quota was exceeded (implemented, [rfc](./2022-12-27-queue-quota.md))
+- agent message to re-deliver skipped messages or to re-negotiate double ratchet.
+
+## Solution
+
+There are three layers where delivery receipts can be implemented:
+- chat protocol. Pro: logic of when to deliver it is decoupled from the message flow, Con: extra traffic, can only work in duplex connections.
+- agent client protocol. Pro: can be automated and combined with the protocol to re-deliver skipped messages. Con: extra traffic.
+- SMP protocol. Pro: minimal extra traffic, Con: complicates server design as it would require pushing receipts when there is no next message.
+
+The last approach seems the most promising for avoiding additional traffic:
+- modify client ACK command to include whether delivery receipt should be provided to sender, and, possibly, any e2e encrypted data that should be included in the receipt (e.g., that the receiving client already saw this message in case we use "feedback" variant of roumor-mongering protocol for groups).
+- server would manage delaying of the receipts, by randomizing the time after which the receipt will be available to the sender, and by combining the receipts when possible.
+- modify response to SEND command to include any available delivery receipts.
+- add a separate delivery receipt that will be pushed to the sender in the connection where the message was received by the server.
+
+## SMP protocol changes
+
+```haskell
+data Command (p :: Party) where
+  -- ...
+  ACK :: MsgId -> Maybe ByteString -> Command Recipient
+  -- the presense of ByteString in ACK indicates that the delivery needs to be confirmed.
+  -- the protocol does not define the format of this confirmation, it is application specific, and can be -- an empty string.
+  -- And open question is how to e2e encrypt information in this string - this probably can be handled on Agent client protocol level, and could be the same ratchet key that was used to encrypt and decrypt the message. The downside of this approach is that this key currently is not stored, and storing it requires additional logic to clear these keys if unused after some time.
+  -- TODO consider what could be a better approach.
+  SENT :: MsgId -> [(MsgId, UTCTime, ByteString)] -> Command Sender
+  -- or
+  -- SENT :: MsgId -> Command Sender
+  -- in case we just batch
+  -- this response will be sent to SEND command and will include a sender's message ID generated by the server (currently it does not exist), and posibly an empty list of delivery receipts with the same message IDs as in responses to SEND, timestamps when these receipts became available, and e2e encrypted ByteString passed in ACK command.
+  -- The ID in this response should be different from the ID used in MSG, to keep the promise of not having shared identifiers in sent/received traffic even inside TLS tunnel.
+  -- Keeping the quality of shared ciphertext also requires adding additional encryption layer between the server and the sender, this can be achieved in one of two ways:
+  -- 1) passing a separate DH key in each SEND command, and server including additional DH key in each SENT response, with computed DH secret per message later used to encrypt and decrypt the delivery receipt payloads. This is probably a bad idea as it would increase a cryptographic load on both the server and the client.
+  -- 2) agree a key per queue, in the same way it is done for the recipient. Possibly, it requires additional DH key in confirmation message that the recipient then uses to secure the queue, and passing this key in KEY (secure queue) command. The response to this secure command would the include server's DH key returned to the recipient that would be passed to the sender in HELLO message. Even though recipient could observe both public DH keys, they won't know the computed shared secret. Recipient that controls the server could perform MITM attack on this key exchange, but it doesn't give any benefit over what recipient can do when they have access to the server - the threat model remains the same. The downside of this approach is that it also requires additional changes in client protocol level (confirmation message format and HELLO message).
+  -- 3) also agree on a key per queue, but via separate commands between the sender and the server, once the sender was notified that the queue is secured. This approach is probably better, and the server would simply delay the delivery of delivery receipts until the shared secret is agreed.
+  SKEY :: C.PublicKeyX25519 -> Command Sender
+  SBKEY :: C.PublicKeyX25519 -> BrokerMsg
+  -- these are the command and response to agree secret to encrypt delivery receipt payloads for option 3
+  SSUB :: Command Sender
+  -- subscribe to receive delivery receipts for a given queue - will be sent when the conversation is opened (unless there is an active subscription already), not all queues at once, and won't be re-subscribed on losing the server connection (TBC).
+  RCVD :: MsgId -> UTCTime -> ByteString -> Command Recipient
+  -- delivery receipt. UTCTime is the time when it became available, not the time when ACK was sent by the recipient, to avoid leaking location via network latency.
+```
+
+Possibly, there is no need to include delivery receipts into SENT response and instead just use batching of responses that is already supported. As server responses are not signed, there is no per-response overhead that is substantial, and a lot of receipts that are available can be packed into one block (depending on the size of payload that has to be fixed not to leak metadata).
+
+This all seems rather complicated for SMP protocol, and the approach of doing it on a higher level seems more attractive than initially. Possibly we should reconsider, and reduce traffic by reducing block sizes... Reducing block sizes unfortunately requires supporting variable block sizes, and would leak some metadata during the transition period.
+
+## Another approach
+
+Above represents substantial complexity, and at least doubles server code complexity for the feature that is definitely not doubling the value of server software. Moving to variable block size is simpler, but also has a lot of complexity, reduces metadata privacy (at least for the duration of migration period), reduces image preview quality, and requires postponing this feature for multiple releases, until all clients migrate.
+
+Given that the main traffic is generated by the groups, and direct messages do not create a lot of traffic, a much simpler and better solution is to simply send delivery receipts as the message, in direct conversations only, either as chat protocol message or as agent client protocol message (either on the message or on the envelope layer).
+
+### Comparison of these two approaches:
+
+**Chat protocol message**
+
+Pros:
+- simpler, more contained change - SMP layer is not aware of this feature
+- easier to extend protocol with additional application specific payload, e.g. references to group DAG
+Cons:
+- ?
+
+```json
+  // ...
+  "x.msg.delivered": {
+    "properties": {
+      "msgId": {"ref": "base64url"},
+      "params": {
+        "properties": {
+          "msgId": {"ref": "base64url"},
+        },
+        "optionalProperties": {
+          "data": {} // possibly the initial protocol does not need it, with JSON can be added later
+        }
+      }
+    }
+  },
+  // ...
+```
+
+**Agent client protocol envelope**
+
+Pros:
+- possibility of using it in a wider range of the applications
+- possibility to include received message hash to increase communication integrity - the sending client would be then notified, and it can be exposed in the UI, that the received message is not the same as sent.
+
+Cons:
+- additional implementation complexity - requires additional events to communicate between chat and agent.
+
+```haskell
+data AMessage =
+  -- ...
+  | A_RCVD AgentMsgId MsgHash ByteString -- references to the received message
+  -- ...
+```
+
+The weirdness of the above design is that it refers to the data present in the header of another message, the alternative would be to have a separate envelope for delivery receipt:
+
+```haskell
+data AgentMessage =
+  -- ...
+  AgentMessageRcvd APrivHeader AgentMsgId MsgHash ByteString -- references to the received message
+  -- ...
+```
+
+But probably the first one is a bit better, TBC.
+
+In any case there should be an additional event to notify chat client:
+
+```haskell
+data ACommand (p :: AParty) (e :: AEntity) where
+  -- ...
+  RCVD AgentMsgId MsgMeta ByteString -> ACommand Agent AEConn
+  -- ...
+```
+
+On the balance of things, implementing on the level of Agent Client protocol seems better, as the additional complexity is marginal, but it allows for wider range of applications, and also allows for additional delivery integrity validation. The format for payload still requires chat protocol message encoding once we want to add it, but initially it could be just an empty string.
+
+## Implementation plan
+
+Currently, we delete sent messages once delivered to the server. It would be helpful if we could keep the records in snd_messages table, and then use them to process delivery receipts, although it may be insufficient (we could add fields). Probably it is not possible to keep them as there is a foreign key constraint with `on delete cascade`.
+
+The new table will be used to track sent message hashes to correlate their IDs with delivery receipts (that will also be stored in messages/rcv_messages). Receipts need to be processed in chat in the same way as normal messages, so they would be sent to chat with MsgMeta, and the chat will need to ack them once processed.
+
+Agent ackMessage function will be also used to automatically schedule sending delivery receipts if they are enabled for connection, only for normal messages - no sending receipts to receipts.
+
+There can be receipt re-delivery to the chat in the same cases as when normal message can be re-delivered (in case of AGENT A_DUPLICATE when it was not ack'd by the user).
+
+## Other considerations
+
+### How clients decide whether to send delivery receipts
+
+Two options are possible - local settings per conversation or chat preferences framework, that allows to have mutual on/off. The latter seems preferable as without knowing whether the other party is sending receipts, it is not possible to uderstand what the absense of the receipt means - network malfunction or receipts disabled.
+
+Groups are a special case, as while some groups may enable sending the delivery receipts, the group members should be able to disable it locally. This should probably be done via a separate conversation setting in the same way as enabling notifications or favourites. In this case the receipt would only be sent to the group if it is enabled in the group and not disabled by the member. The toggle may be located in the same page as chat preferences, but it should be a separate setting. We might want though to communicate somehow whether a given member sends delivery receipts so that other members know whether to expect them or not.
+
+### How this functionality is released
+
+5.2:
+- support for sending and receiving delivery receipts preference, both in direct messages and in groups (for forward compatibility).
+- support for sending and receiving delivery receipts in direct chats only, but disable sending them
+
+5.3:
+- show receipt preferences in the UI
+- enable sending receipts in direct chats where they are enabled
+
+A separate question is how to enable this functionality for the existing contacts. Possible options are:
+
+1. Enable (as per default) for all contacts, show notification to the user when they open the app for update that delivery notifications are now sent by default to all contacts. Pro: no extra logic to implement. Con: may be perceived as a privacy violation, as to some contacts the delivery receipts will be sent before the user had chance to disable them.
+2. Ask the user when the new version first runs whether they want to use delivery receipts and offer these options:
+  1) keep enabled for all profiles (and for all contacts)
+  2) enable for all profiles in ~12 or in ~24 hours giving users the chance to review all contacts / profiles and disable some of them. The problem here is also in possibility of the correlation in case they all start sending receipts at the same time. Possibly the option could be to set a random time in 12-15 or 24-30 hours range to avoid the possibility of such correlation.
+  3) disable for all profiles – it will require sending profile updates to all contacts, so the delivery receipts should be kept disabled and profile updates should be sent after random intervals, one by one (not scheduled all at once, as the time may pass while the app is off).
+3. Offer an option to enable globally later - we could keep it as a one-off option, available only to existing users, and visible on the top level of the Settings - once enabled, the option will disappear and it won't be possible to disable again. The downside here is that the new contacts would be receiving the profile with enabled notifications but they still won't be delivered...
+4. Another option is to have all new contacts decided based on a global user default (that can be set in the settings and in the dialog on first start), but for the existing contacts keep in unset state that is not interpreted as either on or off, but interpreted as unknown until the user makes a choice... That might be an optimal solution for the users but it would probably require changing the preferences framework or some ad-hoc hacks. That still keeps the question open how to avoid correlation between profiles.
+5. That might be the case for version agreement too - the availability of the option per contact will depend on the version. It doesn't answer the question what to do with global defaults though...
diff --git a/simplexmq.cabal b/simplexmq.cabal
index f9f40392a..a3d6af40b 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -34,7 +34,6 @@ flag swift
 
 library
   exposed-modules:
-      Simplex.FileTransfer
       Simplex.FileTransfer.Agent
       Simplex.FileTransfer.Client
       Simplex.FileTransfer.Client.Agent
@@ -85,6 +84,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/FileTransfer.hs b/src/Simplex/FileTransfer.hs
deleted file mode 100644
index 9f648d7ff..000000000
--- a/src/Simplex/FileTransfer.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Simplex.FileTransfer where
-
--- TODO
--- Protocol
--- Store (in memory storage)
--- StoreLog (append only log)
--- FileDescription
--- Server
--- Client
--- Server/Main (server CLI)
--- Client/Main (client CLI)
---
--- Transport for HTTP2 ?
--- streaming Crypto
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index ab09a3a14..9b2499c44 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -117,7 +117,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 (fromMaybe, isJust, isNothing)
+import Data.Maybe (fromMaybe, isJust, isNothing, catMaybes)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock
@@ -152,7 +152,6 @@ import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import UnliftIO.Async (async, race_)
 import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
-import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
 -- import GHC.Conc (unsafeIOToSTM)
@@ -203,8 +202,8 @@ acceptContactAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> Con
 acceptContactAsync c corrId enableNtfs = withAgentEnv c .: acceptContactAsync' c corrId enableNtfs
 
 -- | Acknowledge message (ACK command) asynchronously, no synchronous response
-ackMessageAsync :: forall m. AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> AgentMsgId -> m ()
-ackMessageAsync c = withAgentEnv c .:. ackMessageAsync' c
+ackMessageAsync :: forall m. AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
+ackMessageAsync c = withAgentEnv c .:: ackMessageAsync' c
 
 -- | Switch connection to the new receive queue
 switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> m ConnectionStats
@@ -264,8 +263,8 @@ resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
 sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
 sendMessage c = withAgentEnv c .:. sendMessage' c
 
-ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
-ackMessage c = withAgentEnv c .: ackMessage' c
+ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
+ackMessage c = withAgentEnv c .:. ackMessage' c
 
 -- | Switch connection to the new receive queue
 switchConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
@@ -432,7 +431,7 @@ processCommand c (connId, APC e cmd) =
     RJCT invId -> rejectContact' c connId invId $> (connId, OK)
     SUB -> subscribeConnection' c connId $> (connId, OK)
     SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody
-    ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
+    ACK msgId rcptInfo_ -> ackMessage' c connId msgId rcptInfo_ $> (connId, OK)
     SWCH -> switchConnection' c connId $> (connId, OK)
     OFF -> suspendConnection' c connId $> (connId, OK)
     DEL -> deleteConnection' c connId $> (connId, OK)
@@ -507,8 +506,8 @@ acceptContactAsync' c corrId enableNtfs invId ownConnInfo = do
         throwError err
     _ -> throwError $ CMD PROHIBITED
 
-ackMessageAsync' :: forall m. AgentMonad m => AgentClient -> ACorrId -> ConnId -> AgentMsgId -> m ()
-ackMessageAsync' c corrId connId msgId = do
+ackMessageAsync' :: forall m. AgentMonad m => AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
+ackMessageAsync' c corrId connId msgId rcptInfo_ = do
   SomeConn cType _ <- withStore c (`getConn` connId)
   case cType of
     SCDuplex -> enqueueAck
@@ -519,8 +518,11 @@ ackMessageAsync' c corrId connId msgId = do
   where
     enqueueAck :: m ()
     enqueueAck = do
-      (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId
-      enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId
+      let mId = InternalId msgId
+      RcvMsg {msgType} <- withStore c $ \db -> getRcvMsg db connId mId
+      when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwError $ CMD PROHIBITED
+      (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId mId
+      enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId rcptInfo_
 
 deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
 deleteConnectionAsync' c connId = deleteConnectionsAsync' c [connId]
@@ -891,7 +893,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
             void $ joinConnSrv c userId connId True enableNtfs cReq connInfo srv
             notify OK
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
-        ACK msgId -> withServer' . tryCommand $ ackMessage' c connId msgId >> notify OK
+        ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK
         SWCH ->
           noServer . tryCommand . withConnLock c connId "switchConnection" $
             withStore c (`getConn` connId) >>= \case
@@ -1112,6 +1114,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                         _ -> connError msgId NOT_ACCEPTED
                   AM_REPLY_ -> notifyDel msgId err
                   AM_A_MSG_ -> notifyDel msgId err
+                  AM_A_RCVD_ -> notifyDel msgId err
                   AM_QCONT_ -> notifyDel msgId err
                   AM_QADD_ -> qError msgId "QADD: AUTH"
                   AM_QKEY_ -> qError msgId "QKEY: AUTH"
@@ -1166,6 +1169,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                       qInfo <- createReplyQueue c cData sq srv
                       void . enqueueMessage c cData sq SMP.noMsgFlags $ REPLY [qInfo]
                 AM_A_MSG_ -> notify $ SENT mId
+                AM_A_RCVD_ -> pure ()
                 AM_QCONT_ -> pure ()
                 AM_QADD_ -> pure ()
                 AM_QKEY_ -> do
@@ -1200,10 +1204,12 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                         _ -> internalErr msgId "sent QTEST: queue not in connection or not replacing another queue"
                     _ -> internalErr msgId "QTEST sent not in duplex connection"
                 AM_EREADY_ -> pure ()
-              delMsg msgId
+              delMsgKeep (msgType == AM_A_MSG_) msgId
   where
     delMsg :: InternalId -> m ()
-    delMsg msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId
+    delMsg = delMsgKeep False
+    delMsgKeep :: Bool -> InternalId -> m ()
+    delMsgKeep keepForReceipt msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId keepForReceipt
     notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
     notify cmd = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) cmd)
     notifyDel :: AEntityI e => InternalId -> ACommand 'Agent e -> m ()
@@ -1220,22 +1226,38 @@ retrySndOp c loop = do
   atomically $ beginAgentOperation c AOSndNetwork
   loop
 
-ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
-ackMessage' c connId msgId = withConnLock c connId "ackMessage" $ do
+ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
+ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do
   SomeConn _ conn <- withStore c (`getConn` connId)
   case conn of
-    DuplexConnection {} -> ack
-    RcvConnection {} -> ack
+    DuplexConnection {} -> ack >> sendRcpt conn >> del
+    RcvConnection {} -> ack >> del
     SndConnection {} -> throwError $ CONN SIMPLEX
     ContactConnection {} -> throwError $ CMD PROHIBITED
     NewConnection _ -> throwError $ CMD PROHIBITED
   where
     ack :: m ()
     ack = do
-      let mId = InternalId msgId
-      (rq, srvMsgId) <- withStore c $ \db -> setMsgUserAck db connId mId
+      -- the stored message was delivered via a specific queue, the rest failed to decrypt and were already acknowledged
+      (rq, srvMsgId) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId
       ackQueueMessage c rq srvMsgId
-      withStore' c $ \db -> deleteMsg db connId mId
+    del :: m ()
+    del = withStore' c $ \db -> deleteMsg db connId $ InternalId msgId
+    sendRcpt :: Connection 'CDuplex -> m ()
+    sendRcpt (DuplexConnection cData _ sqs) = do
+      msg@RcvMsg {msgType, msgReceipt} <- withStore c $ \db -> getRcvMsg db connId $ InternalId msgId
+      case rcptInfo_ of
+        Just rcptInfo -> do
+          unless (msgType == AM_A_MSG_) $ throwError (CMD PROHIBITED)
+          when (messageRcptsSupported cData) $ do
+            let RcvMsg {msgMeta = MsgMeta {sndMsgId}, internalHash} = msg
+                rcpt = A_RCVD [AMessageReceipt {agentMsgId = sndMsgId, msgHash = internalHash, rcptInfo}]
+            void $ enqueueMessages c cData sqs SMP.MsgFlags {notification = False} rcpt
+        Nothing -> case (msgType, msgReceipt) of
+          -- only remove sent message if receipt hash was Ok, both to debug and for future redundancy
+          (AM_A_RCVD_, Just MsgReceipt {agentMsgId = sndMsgId, msgRcptStatus = MROk}) ->
+            withStore' c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId
+          _ -> pure ()
 
 switchConnection' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
 switchConnection' c connId =
@@ -1725,30 +1747,30 @@ cleanupManager c@AgentClient {subQ} = do
   delay <- asks (initialCleanupDelay . config)
   liftIO $ threadDelay' delay
   int <- asks (cleanupInterval . config)
+  ttl <- asks $ storedMsgDataTTL . config
   forever $ do
-    void . runExceptT $ do
-      deleteConns `catchAgentError` (notify "" . ERR)
-      deleteRcvMsgHashes `catchAgentError` (notify "" . ERR)
-      deleteProcessedRatchetKeyHashes `catchAgentError` (notify "" . ERR)
-      deleteRcvFilesExpired `catchAgentError` (notify "" . RFERR)
-      deleteRcvFilesDeleted `catchAgentError` (notify "" . RFERR)
-      deleteRcvFilesTmpPaths `catchAgentError` (notify "" . RFERR)
-      deleteSndFilesExpired `catchAgentError` (notify "" . SFERR)
-      deleteSndFilesDeleted `catchAgentError` (notify "" . SFERR)
-      deleteSndFilesPrefixPaths `catchAgentError` (notify "" . SFERR)
-      deleteExpiredReplicasForDeletion `catchAgentError` (notify "" . SFERR)
+    run ERR deleteConns
+    run ERR $ withStore' c (`deleteRcvMsgHashesExpired` ttl)
+    run ERR $ withStore' c (`deleteSndMsgsExpired` ttl)
+    run ERR $ withStore' c (`deleteRatchetKeyHashesExpired` ttl)
+    run RFERR deleteRcvFilesExpired
+    run RFERR deleteRcvFilesDeleted
+    run RFERR deleteRcvFilesTmpPaths
+    run SFERR deleteSndFilesExpired
+    run SFERR deleteSndFilesDeleted
+    run SFERR deleteSndFilesPrefixPaths
+    run SFERR deleteExpiredReplicasForDeletion
     liftIO $ threadDelay' int
   where
+    run :: forall e. AEntityI e => (AgentErrorType -> ACommand 'Agent e) -> ExceptT AgentErrorType m () -> m ()
+    run err a = do
+      void . runExceptT $ a `catchAgentError` (notify "" . err)
+      step <- asks $ cleanupStepInterval . config
+      liftIO $ threadDelay step
     deleteConns =
       withLock (deleteLock c) "cleanupManager" $ do
         void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
         withStore' c deleteUsersWithoutConns >>= mapM_ (notify "" . DEL_USER)
-    deleteRcvMsgHashes = do
-      rcvMsgHashesTTL <- asks $ rcvMsgHashesTTL . config
-      withStore' c (`deleteRcvMsgHashesExpired` rcvMsgHashesTTL)
-    deleteProcessedRatchetKeyHashes = do
-      rkHashesTTL <- asks $ processedRatchetKeyHashesTTL . config
-      withStore' c (`deleteProcessedRatchetKeyHashesExpired` rkHashesTTL)
     deleteRcvFilesExpired = do
       rcvFilesTTL <- asks $ rcvFilesTTL . config
       rcvExpired <- withStore' c (`getRcvFilesExpired` rcvFilesTTL)
@@ -1855,6 +1877,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                               A_MSG body -> do
                                 logServer "<--" c srv rId "MSG <MSG>"
                                 notify $ MSG msgMeta msgFlags body
+                              A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta
                               QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending addr
                               QADD qs -> qDuplexAckDel conn'' "QADD" $ qAddMsg qs
                               QKEY qs -> qDuplexAckDel conn'' "QKEY" $ qKeyMsg qs
@@ -2078,6 +2101,28 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   void $ tryPutTMVar qLock ()
               Nothing -> qError "QCONT: queue address not found"
 
+          messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> m ()
+          messagesRcvd rcpts msgMeta@MsgMeta {broker = (srvMsgId, _)} _ = do
+            logServer "<--" c srv rId "MSG <RCPT>"
+            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
+              Nothing -> enqueueCmd $ ICAck rId srvMsgId
+            where
+              clientReceipt :: AMessageReceipt -> m (Maybe MsgReceipt)
+              clientReceipt AMessageReceipt {agentMsgId, msgHash} = do
+                let sndMsgId = InternalSndId agentMsgId
+                SndMsg {internalId = InternalId msgId, msgType, internalHash, msgReceipt} <- withStore c $ \db -> getSndMsgViaRcpt db connId sndMsgId
+                if msgType /= AM_A_MSG_
+                  then notify (ERR $ AGENT A_PROHIBITED) $> Nothing -- unexpected message type for receipt
+                  else case msgReceipt of
+                    Just MsgReceipt {msgRcptStatus = MROk} -> pure Nothing -- already notified with MROk status
+                    _ -> do
+                      let msgRcptStatus = if msgHash == internalHash then MROk else MRBadMsgHash
+                          rcpt = MsgReceipt {agentMsgId = msgId, msgRcptStatus}
+                      withStore' c $ \db -> updateSndMsgRcpt db connId sndMsgId rcpt
+                      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"
@@ -2195,7 +2240,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               rkHash k1 k2 = C.sha256Hash $ C.pubKeyBytes k1 <> C.pubKeyBytes k2
               ratchetExists :: m Bool
               ratchetExists = withStore' c $ \db -> do
-                exists <- checkProcessedRatchetKeyHashExists db connId rkHashRcv
+                exists <- checkRatchetKeyHashExists db connId rkHashRcv
                 unless exists $ addProcessedRatchetKeyHash db connId rkHashRcv
                 pure exists
               getSendRatchetKeys :: m (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448)
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index 5e779cc22..3a818f250 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -87,8 +87,8 @@ data AgentConfig = AgentConfig
     helloTimeout :: NominalDiffTime,
     initialCleanupDelay :: Int64,
     cleanupInterval :: Int64,
-    rcvMsgHashesTTL :: NominalDiffTime,
-    processedRatchetKeyHashesTTL :: NominalDiffTime,
+    cleanupStepInterval :: Int,
+    storedMsgDataTTL :: NominalDiffTime,
     rcvFilesTTL :: NominalDiffTime,
     sndFilesTTL :: NominalDiffTime,
     xftpNotifyErrsOnRetry :: Bool,
@@ -152,8 +152,8 @@ defaultAgentConfig =
       helloTimeout = 2 * nominalDay,
       initialCleanupDelay = 30 * 1000000, -- 30 seconds
       cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
-      rcvMsgHashesTTL = 30 * nominalDay,
-      processedRatchetKeyHashesTTL = 30 * nominalDay,
+      cleanupStepInterval = 200000, -- 200ms
+      storedMsgDataTTL = 21 * nominalDay,
       rcvFilesTTL = 2 * nominalDay,
       sndFilesTTL = nominalDay,
       xftpNotifyErrsOnRetry = True,
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 5ab875757..e4c720aef 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -69,6 +69,10 @@ module Simplex.Messaging.Agent.Protocol
     AgentMessageType (..),
     APrivHeader (..),
     AMessage (..),
+    AMessageReceipt (..),
+    MsgReceipt (..),
+    MsgReceiptInfo,
+    MsgReceiptStatus (..),
     SndQAddr,
     SMPServer,
     pattern SMPServer,
@@ -211,7 +215,7 @@ import Text.Read
 import UnliftIO.Exception (Exception)
 
 currentSMPAgentVersion :: Version
-currentSMPAgentVersion = 3
+currentSMPAgentVersion = 4
 
 supportedSMPAgentVRange :: VersionRange
 supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
@@ -314,7 +318,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client AEConn -- response OK
   CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
   LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
-  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
+  REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
   ACPT :: InvitationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
   RJCT :: InvitationId -> ACommand Client AEConn
   INFO :: ConnInfo -> ACommand Agent AEConn
@@ -332,7 +336,8 @@ data ACommand (p :: AParty) (e :: AEntity) where
   SENT :: AgentMsgId -> ACommand Agent AEConn
   MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
   MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn
-  ACK :: AgentMsgId -> ACommand Client AEConn
+  ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn
+  RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn 
   SWCH :: ACommand Client AEConn
   OFF :: ACommand Client AEConn
   DEL :: ACommand Client AEConn
@@ -392,6 +397,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   MERR_ :: ACommandTag Agent AEConn
   MSG_ :: ACommandTag Agent AEConn
   ACK_ :: ACommandTag Client AEConn
+  RCVD_ :: ACommandTag Agent AEConn
   SWCH_ :: ACommandTag Client AEConn
   OFF_ :: ACommandTag Client AEConn
   DEL_ :: ACommandTag Client AEConn
@@ -443,7 +449,8 @@ aCommandTag = \case
   SENT _ -> SENT_
   MERR {} -> MERR_
   MSG {} -> MSG_
-  ACK _ -> ACK_
+  ACK {} -> ACK_
+  RCVD {} -> RCVD_
   SWCH -> SWCH_
   OFF -> OFF_
   DEL -> DEL_
@@ -743,6 +750,25 @@ data MsgMeta = MsgMeta
   }
   deriving (Eq, Show)
 
+instance StrEncoding MsgMeta where
+  strEncode MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
+    B.unwords
+      [ strEncode integrity,
+        "R=" <> bshow rmId <> "," <> showTs rTs,
+        "B=" <> encode bmId <> "," <> showTs bTs,
+        "S=" <> bshow sndMsgId
+      ]
+    where
+      showTs = B.pack . formatISO8601Millis
+  strP = do
+    integrity <- strP
+    recipient <- " R=" *> partyMeta A.decimal
+    broker <- " B=" *> partyMeta base64P
+    sndMsgId <- " S=" *> A.decimal
+    pure MsgMeta {integrity, recipient, broker, sndMsgId}
+    where
+      partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P
+
 data SMPConfirmation = SMPConfirmation
   { -- | sender's public key to use for authentication of sender's commands at the recepient's server
     senderKey :: SndPublicVerifyKey,
@@ -815,7 +841,7 @@ data AgentMessage
   = AgentConnInfo ConnInfo
   | -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
     -- It makes REPLY message unnecessary.
-    AgentConnInfoReply (L.NonEmpty SMPQueueInfo) ConnInfo
+    AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo
   | AgentRatchetInfo ByteString
   | AgentMessage APrivHeader AMessage
   deriving (Show)
@@ -841,6 +867,7 @@ data AgentMessageType
   | AM_HELLO_
   | AM_REPLY_
   | AM_A_MSG_
+  | AM_A_RCVD_
   | AM_QCONT_
   | AM_QADD_
   | AM_QKEY_
@@ -857,6 +884,7 @@ instance Encoding AgentMessageType where
     AM_HELLO_ -> "H"
     AM_REPLY_ -> "R"
     AM_A_MSG_ -> "M"
+    AM_A_RCVD_ -> "V"
     AM_QCONT_ -> "QC"
     AM_QADD_ -> "QA"
     AM_QKEY_ -> "QK"
@@ -871,6 +899,7 @@ instance Encoding AgentMessageType where
       'H' -> pure AM_HELLO_
       'R' -> pure AM_REPLY_
       'M' -> pure AM_A_MSG_
+      'V' -> pure AM_A_RCVD_
       'Q' ->
         A.anyChar >>= \case
           'C' -> pure AM_QCONT_
@@ -896,6 +925,7 @@ agentMessageType = \case
     -- REPLY is only used in v1
     REPLY _ -> AM_REPLY_
     A_MSG _ -> AM_A_MSG_
+    A_RCVD {} -> AM_A_RCVD_
     QCONT _ -> AM_QCONT_
     QADD _ -> AM_QADD_
     QKEY _ -> AM_QKEY_
@@ -920,6 +950,7 @@ data AMsgType
   = HELLO_
   | REPLY_
   | A_MSG_
+  | A_RCVD_
   | QCONT_
   | QADD_
   | QKEY_
@@ -933,6 +964,7 @@ instance Encoding AMsgType where
     HELLO_ -> "H"
     REPLY_ -> "R"
     A_MSG_ -> "M"
+    A_RCVD_ -> "V"
     QCONT_ -> "QC"
     QADD_ -> "QA"
     QKEY_ -> "QK"
@@ -944,6 +976,7 @@ instance Encoding AMsgType where
       'H' -> pure HELLO_
       'R' -> pure REPLY_
       'M' -> pure A_MSG_
+      'V' -> pure A_RCVD_
       'Q' ->
         A.anyChar >>= \case
           'C' -> pure QCONT_
@@ -962,23 +995,60 @@ data AMessage
   = -- | the first message in the queue to validate it is secured
     HELLO
   | -- | reply queues information
-    REPLY (L.NonEmpty SMPQueueInfo)
+    REPLY (NonEmpty SMPQueueInfo)
   | -- | agent envelope for the client message
     A_MSG MsgBody
+  | -- | agent envelope for delivery receipt 
+    A_RCVD (NonEmpty AMessageReceipt)
   | -- | the message instructing the client to continue sending messages (after ERR QUOTA)
     QCONT SndQAddr
   | -- add queue to connection (sent by recipient), with optional address of the replaced queue
-    QADD (L.NonEmpty (SMPQueueUri, Maybe SndQAddr))
+    QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr))
   | -- key to secure the added queues and agree e2e encryption key (sent by sender)
-    QKEY (L.NonEmpty (SMPQueueInfo, SndPublicVerifyKey))
+    QKEY (NonEmpty (SMPQueueInfo, SndPublicVerifyKey))
   | -- inform that the queues are ready to use (sent by recipient)
-    QUSE (L.NonEmpty (SndQAddr, Bool))
+    QUSE (NonEmpty (SndQAddr, Bool))
   | -- sent by the sender to test new queues and to complete switching
-    QTEST (L.NonEmpty SndQAddr)
+    QTEST (NonEmpty SndQAddr)
   | -- ratchet re-synchronization is complete, with last decrypted sender message id (recipient's `last_external_snd_msg_id`)
-    EREADY Int64
+    EREADY AgentMsgId
   deriving (Show)
 
+-- | this type is used to send as part of the protocol between different clients
+-- TODO possibly, rename fields and types referring to external and internal IDs to make them different
+data AMessageReceipt = AMessageReceipt
+  { agentMsgId :: AgentMsgId, -- this is an external snd message ID referenced by the message recipient
+    msgHash :: MsgHash,
+    rcptInfo :: MsgReceiptInfo
+  }
+  deriving (Show)
+
+-- | this type is used as part of agent protocol to communicate with the user application
+data MsgReceipt = MsgReceipt
+  { agentMsgId :: AgentMsgId, -- this is an internal agent message ID of received message
+    msgRcptStatus :: MsgReceiptStatus
+  }
+  deriving (Eq, Show)
+
+data MsgReceiptStatus = MROk | MRBadMsgHash
+  deriving (Eq, Show)
+
+instance StrEncoding MsgReceiptStatus where
+  strEncode = \case
+    MROk -> "ok"
+    MRBadMsgHash -> "badMsgHash"
+  strP =
+    A.takeWhile1 (/= ' ') >>= \ case
+      "ok" -> pure MROk
+      "badMsgHash" -> pure MRBadMsgHash
+      _ -> fail "bad MsgReceiptStatus"
+
+instance ToJSON MsgReceiptStatus where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+type MsgReceiptInfo = ByteString
+
 type SndQAddr = (SMPServer, SMP.SenderId)
 
 instance Encoding AMessage where
@@ -986,6 +1056,7 @@ instance Encoding AMessage where
     HELLO -> smpEncode HELLO_
     REPLY smpQueues -> smpEncode (REPLY_, smpQueues)
     A_MSG body -> smpEncode (A_MSG_, Tail body)
+    A_RCVD mrs -> smpEncode (A_RCVD_, mrs)
     QCONT addr -> smpEncode (QCONT_, addr)
     QADD qs -> smpEncode (QADD_, qs)
     QKEY qs -> smpEncode (QKEY_, qs)
@@ -998,6 +1069,7 @@ instance Encoding AMessage where
         HELLO_ -> pure HELLO
         REPLY_ -> REPLY <$> smpP
         A_MSG_ -> A_MSG . unTail <$> smpP
+        A_RCVD_ -> A_RCVD <$> smpP
         QCONT_ -> QCONT <$> smpP
         QADD_ -> QADD <$> smpP
         QKEY_ -> QKEY <$> smpP
@@ -1005,6 +1077,21 @@ instance Encoding AMessage where
         QTEST_ -> QTEST <$> smpP
         EREADY_ -> EREADY <$> smpP
 
+instance Encoding AMessageReceipt where
+  smpEncode AMessageReceipt {agentMsgId, msgHash, rcptInfo} =
+    smpEncode (agentMsgId, msgHash, Large rcptInfo)
+  smpP = do
+    (agentMsgId, msgHash, Large rcptInfo) <- smpP
+    pure AMessageReceipt {agentMsgId, msgHash, rcptInfo}
+
+instance StrEncoding MsgReceipt where
+  strEncode MsgReceipt {agentMsgId, msgRcptStatus} =
+    strEncode agentMsgId <> ":" <> strEncode msgRcptStatus
+  strP = do
+    agentMsgId <- strP <* A.char ':'
+    msgRcptStatus <- strP
+    pure MsgReceipt {agentMsgId, msgRcptStatus}
+
 instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
   strEncode = \case
     CRInvitationUri crData e2eParams -> crEncode "invitation" crData (Just e2eParams)
@@ -1234,7 +1321,7 @@ deriving instance Show AConnectionRequestUri
 data ConnReqUriData = ConnReqUriData
   { crScheme :: ConnReqScheme,
     crAgentVRange :: VersionRange,
-    crSmpQueues :: L.NonEmpty SMPQueueUri,
+    crSmpQueues :: NonEmpty SMPQueueUri,
     crClientData :: Maybe CRClientData
   }
   deriving (Eq, Show)
@@ -1296,7 +1383,7 @@ instance StrEncoding MsgIntegrity where
   strP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> strP)
   strEncode = \case
     MsgOk -> "OK"
-    MsgError e -> "ERR" <> strEncode e
+    MsgError e -> "ERR " <> strEncode e
 
 instance ToJSON MsgIntegrity where
   toJSON = J.genericToJSON $ sumTypeJSON fstToLower
@@ -1316,7 +1403,7 @@ data MsgErrorType
 instance StrEncoding MsgErrorType where
   strP =
     "ID " *> (MsgBadId <$> A.decimal)
-      <|> "IDS " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
+      <|> "NO_ID " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
       <|> "HASH" $> MsgBadHash
       <|> "DUPLICATE" $> MsgDuplicate
   strEncode = \case
@@ -1557,6 +1644,7 @@ instance StrEncoding ACmdTag where
       "MERR" -> ct MERR_
       "MSG" -> ct MSG_
       "ACK" -> t ACK_
+      "RCVD" -> ct RCVD_
       "SWCH" -> t SWCH_
       "OFF" -> t OFF_
       "DEL" -> t DEL_
@@ -1611,6 +1699,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     MERR_ -> "MERR"
     MSG_ -> "MSG"
     ACK_ -> "ACK"
+    RCVD_ -> "RCVD"
     SWCH_ -> "SWCH"
     OFF_ -> "OFF"
     DEL_ -> "DEL"
@@ -1654,7 +1743,7 @@ commandP binaryP =
           RJCT_ -> s (RJCT <$> A.takeByteString)
           SUB_ -> pure SUB
           SEND_ -> s (SEND <$> smpP <* A.space <*> binaryP)
-          ACK_ -> s (ACK <$> A.decimal)
+          ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP))
           SWCH_ -> pure SWCH
           OFF_ -> pure OFF
           DEL_ -> pure DEL
@@ -1676,7 +1765,8 @@ commandP binaryP =
           MID_ -> s (MID <$> A.decimal)
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
-          MSG_ -> s (MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> binaryP)
+          MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP)
+          RCVD_ -> s (RCVD <$> strP <* A.space <*> strP)
           DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP)
           DEL_CONN_ -> pure DEL_CONN
           DEL_USER_ -> s (DEL_USER <$> strP)
@@ -1701,13 +1791,6 @@ commandP binaryP =
        in case ds of
             [] -> Left "no sender file description"
             sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds
-    msgMetaP = do
-      integrity <- strP
-      recipient <- " R=" *> partyMeta A.decimal
-      broker <- " B=" *> partyMeta base64P
-      sndMsgId <- " S=" *> A.decimal
-      pure MsgMeta {integrity, recipient, broker, sndMsgId}
-    partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P
 
 parseCommand :: ByteString -> Either AgentErrorType ACmd
 parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
@@ -1736,8 +1819,9 @@ serializeCommand = \case
   MID mId -> s (MID_, Str $ bshow mId)
   SENT mId -> s (SENT_, Str $ bshow mId)
   MERR mId e -> s (MERR_, Str $ bshow mId, e)
-  MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, serializeMsgMeta msgMeta, smpEncode msgFlags, serializeBinary msgBody]
-  ACK mId -> s (ACK_, Str $ bshow mId)
+  MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, s msgMeta, smpEncode msgFlags, serializeBinary msgBody]
+  ACK mId rcptInfo_ -> s (ACK_, Str $ bshow mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_
+  RCVD msgMeta rcpts -> s (RCVD_, msgMeta, rcpts)
   SWCH -> s SWCH_
   OFF -> s OFF_
   DEL -> s DEL_
@@ -1759,19 +1843,9 @@ serializeCommand = \case
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
-    showTs :: UTCTime -> ByteString
-    showTs = B.pack . formatISO8601Millis
     connections :: [ConnId] -> ByteString
     connections = B.intercalate "," . map strEncode
     sfDone sd rds = B.intercalate fdSeparator $ strEncode sd : map strEncode rds
-    serializeMsgMeta :: MsgMeta -> ByteString
-    serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
-      B.unwords
-        [ strEncode integrity,
-          "R=" <> bshow rmId <> "," <> showTs rTs,
-          "B=" <> encode bmId <> "," <> showTs bTs,
-          "S=" <> bshow sndMsgId
-        ]
 
 serializeBinary :: ByteString -> ByteString
 serializeBinary body = bshow (B.length body) <> "\n" <> body
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index 2a51e7f9f..e190c171d 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -315,6 +315,9 @@ ratchetSyncAllowed cData@ConnData {ratchetSyncState} =
 ratchetSyncSupported' :: ConnData -> Bool
 ratchetSyncSupported' ConnData {connAgentVersion} = connAgentVersion >= 3
 
+messageRcptsSupported :: ConnData -> Bool
+messageRcptsSupported ConnData {connAgentVersion} = connAgentVersion >= 4
+
 -- this function should be mirrored in the clients
 ratchetSyncSendProhibited :: ConnData -> Bool
 ratchetSyncSendProhibited ConnData {ratchetSyncState} =
@@ -506,7 +509,10 @@ data RcvMsgData = RcvMsgData
 data RcvMsg = RcvMsg
   { internalId :: InternalId,
     msgMeta :: MsgMeta,
+    msgType :: AgentMessageType,
     msgBody :: MsgBody,
+    internalHash :: MsgHash,
+    msgReceipt :: Maybe MsgReceipt, -- if this message is a delivery receipt
     userAck :: Bool
   }
 
@@ -521,6 +527,14 @@ data SndMsgData = SndMsgData
     prevMsgHash :: MsgHash
   }
 
+data SndMsg = SndMsg
+  { internalId :: InternalId,
+    internalSndId :: InternalSndId,
+    msgType :: AgentMessageType,
+    internalHash :: MsgHash,
+    msgReceipt :: Maybe MsgReceipt
+  }
+
 data PendingMsgData = PendingMsgData
   { msgId :: InternalId,
     msgType :: AgentMessageType,
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 9cda785a3..0d9e4df9f 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -56,8 +56,8 @@ module Simplex.Messaging.Agent.Store.SQLite
     getDeletedConnIds,
     setConnRatchetSync,
     addProcessedRatchetKeyHash,
-    checkProcessedRatchetKeyHashExists,
-    deleteProcessedRatchetKeyHashesExpired,
+    checkRatchetKeyHashExists,
+    deleteRatchetKeyHashesExpired,
     getRcvConn,
     getRcvQueueById,
     getSndQueueById,
@@ -99,16 +99,21 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateSndIds,
     createSndMsg,
     createSndMsgDelivery,
+    getSndMsgViaRcpt,
+    updateSndMsgRcpt,
     getPendingMsgData,
     updatePendingMsgRIState,
     getPendingMsgs,
     deletePendingMsgs,
     setMsgUserAck,
+    getRcvMsg,
     getLastMsg,
     checkRcvMsgHashExists,
     deleteMsg,
+    deleteDeliveredSndMsg,
     deleteSndMsgDelivery,
     deleteRcvMsgHashesExpired,
+    deleteSndMsgsExpired,
     -- Double ratchet persistence
     createRatchetX3dhKeys,
     getRatchetX3dhKeys,
@@ -893,6 +898,31 @@ createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO
 createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
   DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId)
 
+getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
+getSndMsgViaRcpt db connId sndMsgId =
+  firstRow toSndMsg SEMsgNotFound $
+    DB.query
+      db
+      [sql|
+        SELECT s.internal_id, m.msg_type, s.internal_hash, s.rcpt_internal_id, s.rcpt_status
+        FROM snd_messages s
+        JOIN messages m ON s.internal_id = m.internal_id
+        WHERE s.conn_id = ? AND s.internal_snd_id = ?
+      |]
+      (connId, sndMsgId)
+  where
+    toSndMsg :: (InternalId, AgentMessageType, MsgHash, Maybe AgentMsgId, Maybe MsgReceiptStatus) -> SndMsg
+    toSndMsg (internalId, msgType, internalHash, rcptInternalId_, rcptStatus_) =
+      let msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_
+       in SndMsg {internalId, internalSndId = sndMsgId, msgType, internalHash, msgReceipt}
+
+updateSndMsgRcpt :: DB.Connection -> ConnId -> InternalSndId -> MsgReceipt -> IO ()
+updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} =
+  DB.execute
+    db
+    "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
@@ -929,32 +959,51 @@ deletePendingMsgs db connId SndQueue {dbQueueId} =
 
 setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId))
 setMsgUserAck db connId agentMsgId = runExceptT $ do
-  liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId)
   (dbRcvId, srvMsgId) <-
     ExceptT . firstRow id SEMsgNotFound $
       DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
   rq <- ExceptT $ getRcvQueueById db connId dbRcvId
+  liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId)
   pure (rq, srvMsgId)
 
-getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg)
-getLastMsg db connId msgId =
-  maybeFirstRow rcvMsg $
+getRcvMsg :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg)
+getRcvMsg db connId agentMsgId =
+  firstRow toRcvMsg SEMsgNotFound $
     DB.query
       db
       [sql|
         SELECT
-          r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity,
-          m.msg_body, r.user_ack
+          r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
+          m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
+        FROM rcv_messages r
+        JOIN messages m ON r.internal_id = m.internal_id
+        LEFT JOIN snd_messages s ON s.rcpt_internal_id = r.internal_id
+        WHERE r.conn_id = ? AND r.internal_id = ?
+      |]
+      (connId, agentMsgId)
+
+getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg)
+getLastMsg db connId msgId =
+  maybeFirstRow toRcvMsg $
+    DB.query
+      db
+      [sql|
+        SELECT
+          r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
+          m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
         FROM rcv_messages r
         JOIN messages m ON r.internal_id = m.internal_id
         JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id
+        LEFT JOIN snd_messages s ON s.rcpt_internal_id = r.internal_id
         WHERE r.conn_id = ? AND r.broker_id = ?
       |]
       (connId, msgId)
-  where
-    rcvMsg (agentMsgId, internalTs, brokerId, brokerTs, sndMsgId, integrity, msgBody, userAck) =
-      let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity}
-       in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgBody, userAck}
+
+toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs, AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg    
+toRcvMsg (agentMsgId, internalTs, brokerId, brokerTs, sndMsgId, integrity, internalHash, msgType, msgBody, rcptInternalId_, rcptStatus_, userAck) =
+  let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity}
+      msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_
+    in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck}
 
 checkRcvMsgHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
 checkRcvMsgHashExists db connId hash = do
@@ -971,20 +1020,55 @@ deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
 deleteMsg db connId msgId =
   DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
 
-deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO ()
-deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId = do
+deleteMsgContent :: DB.Connection -> ConnId -> InternalId -> IO ()
+deleteMsgContent db connId msgId =
+  DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
+
+deleteDeliveredSndMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
+deleteDeliveredSndMsg db connId msgId = do
+  cnt <- countPendingSndDeliveries_ db connId msgId
+  when (cnt == 0) $ deleteMsg db connId msgId
+
+deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO ()
+deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do
   DB.execute
     db
     "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND internal_id = ?"
     (connId, dbQueueId, msgId)
-  (Only (cnt :: Int) : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
-  when (cnt == 0) $ deleteMsg db connId msgId
+  cnt <- countPendingSndDeliveries_ db connId msgId
+  when (cnt == 0) $ do
+    del <-
+      maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case
+        Just (Just (_ :: Int64), Just MROk) -> pure deleteMsg
+        _ -> pure $ if keepForReceipt then deleteMsgContent else deleteMsg
+    del db connId msgId
+
+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)
+  pure cnt
 
 deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
 deleteRcvMsgHashesExpired db ttl = do
   cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
   DB.execute db "DELETE FROM encrypted_rcv_message_hashes WHERE created_at < ?" (Only cutoffTs)
 
+deleteSndMsgsExpired :: DB.Connection -> NominalDiffTime -> IO ()
+deleteSndMsgsExpired db ttl = do
+  cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
+  DB.execute
+    db
+    [sql|
+      DELETE FROM messages
+      WHERE internal_id IN (
+        SELECT s.internal_id
+        FROM snd_messages s
+        JOIN messages m USING (internal_id)
+        WHERE m.internal_ts < ?
+      )
+    |]
+    (Only cutoffTs)
+
 createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
 createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 =
   DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
@@ -1504,6 +1588,10 @@ instance ToField AgentCommandTag where toField = toField . strEncode
 
 instance FromField AgentCommandTag where fromField = blobFieldParser strP
 
+instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEncode
+
+instance FromField MsgReceiptStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -1682,8 +1770,8 @@ addProcessedRatchetKeyHash :: DB.Connection -> ConnId -> ByteString -> IO ()
 addProcessedRatchetKeyHash db connId hash =
   DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, hash)
 
-checkProcessedRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
-checkProcessedRatchetKeyHashExists db connId hash = do
+checkRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
+checkRatchetKeyHashExists db connId hash = do
   fromMaybe False
     <$> maybeFirstRow
       fromOnly
@@ -1693,8 +1781,8 @@ checkProcessedRatchetKeyHashExists db connId hash = do
           (connId, hash)
       )
 
-deleteProcessedRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
-deleteProcessedRatchetKeyHashesExpired db ttl = do
+deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
+deleteRatchetKeyHashesExpired db ttl = do
   cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
   DB.execute db "DELETE FROM processed_ratchet_key_hashes WHERE created_at < ?" (Only cutoffTs)
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index 737edda95..810bebd3c 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
@@ -63,6 +63,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_r
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -91,7 +92,8 @@ schemaMigrations =
     ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
     ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
     ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
-    ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync)
+    ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
+    ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts)
   ]
 
 -- | The list of migrations in ascending order by date
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230701_delivery_receipts.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230701_delivery_receipts.hs
new file mode 100644
index 000000000..1dab82674
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230701_delivery_receipts.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230701_delivery_receipts :: Query
+m20230701_delivery_receipts =
+  [sql|
+ALTER TABLE snd_messages ADD COLUMN rcpt_internal_id INTEGER;
+ALTER TABLE snd_messages ADD COLUMN rcpt_status TEXT;
+
+CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages(conn_id, rcpt_internal_id);
+|]
+
+down_m20230701_delivery_receipts :: Query
+down_m20230701_delivery_receipts =
+  [sql|
+DROP INDEX idx_snd_messages_rcpt_internal_id;
+
+ALTER TABLE snd_messages DROP COLUMN rcpt_internal_id;
+ALTER TABLE snd_messages DROP COLUMN rcpt_status;
+|]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index ca07c8244..10e3148b0 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -119,6 +119,8 @@ CREATE TABLE snd_messages(
   previous_msg_hash BLOB NOT NULL DEFAULT x'',
   retry_int_slow INTEGER,
   retry_int_fast INTEGER,
+  rcpt_internal_id INTEGER,
+  rcpt_status TEXT,
   PRIMARY KEY(conn_id, internal_snd_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -461,3 +463,7 @@ CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hash
   conn_id,
   hash
 );
+CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages(
+  conn_id,
+  rcpt_internal_id
+);
diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs
index ea457d0bc..d603a0f40 100644
--- a/tests/AgentTests/ConnectionRequestTests.hs
+++ b/tests/AgentTests/ConnectionRequestTests.hs
@@ -114,7 +114,7 @@ connectionRequestTests =
         <> urlEncode True testDhKeyStrUri
         <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
       strEncode connectionRequestCurrentRange
-        `shouldBe` "https://simplex.chat/invitation#/?v=1-3&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        `shouldBe` "https://simplex.chat/invitation#/?v=1-4&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
         <> urlEncode True testDhKeyStrUri
         <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
         <> urlEncode True testDhKeyStrUri
@@ -158,7 +158,7 @@ connectionRequestTests =
             <> testDhKeyStrUri
             <> "&e2e=extra_key%3Dnew%26v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
             <> "&some_new_param=abc"
-            <> "&v=1-3"
+            <> "&v=1-4"
         )
         `shouldBe` Right connectionRequestCurrentRange
       strDecode
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index 9aac75b63..f9e8b4c71 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -104,6 +104,9 @@ pGet c = do
 pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
+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
@@ -293,6 +296,9 @@ functionalAPITests t = do
   describe "getRatchetAdHash" $
     it "should return the same data for both peers" $
       withSmpServer t testRatchetAdHash
+  describe "Delivery receipts" $ do
+    it "should send and receive delivery receipt" $ withSmpServer t testDeliveryReceipts
+    it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion t
 
 testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
 testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do
@@ -352,17 +358,17 @@ runAgentClientTest alice bob baseId = do
     2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
     get alice ##> ("", bobId, SENT $ baseId + 2)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 1
+    ackMessage bob aliceId (baseId + 1) Nothing
     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 2
+    ackMessage bob aliceId (baseId + 2) Nothing
     3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
     4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
     get bob ##> ("", aliceId, SENT $ baseId + 4)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 3
+    ackMessage alice bobId (baseId + 3) Nothing
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 4
+    ackMessage alice bobId (baseId + 4) Nothing
     suspendConnection alice bobId
     5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
@@ -389,17 +395,17 @@ runAgentClientContactTest alice bob baseId = do
     2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
     get alice ##> ("", bobId, SENT $ baseId + 2)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 1
+    ackMessage bob aliceId (baseId + 1) Nothing
     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 2
+    ackMessage bob aliceId (baseId + 2) Nothing
     3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
     4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
     get bob ##> ("", aliceId, SENT $ baseId + 4)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 3
+    ackMessage alice bobId (baseId + 3) Nothing
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 4
+    ackMessage alice bobId (baseId + 4) Nothing
     suspendConnection alice bobId
     5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
@@ -702,7 +708,7 @@ testDuplicateMessage t = do
     runRight_ $ do
       subscribeConnection bob1 aliceId
       get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-      ackMessage bob1 aliceId 4
+      ackMessage bob1 aliceId 4 Nothing
       5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
       get alice ##> ("", bobId, SENT 5)
       get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
@@ -714,7 +720,7 @@ testDuplicateMessage t = do
   -- commenting two lines below and uncommenting further two lines would also runRight_,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
-  Left (BROKER _ TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
+  Left (BROKER _ TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5 Nothing
 
   disconnectAgentClient alice
   disconnectAgentClient bob1
@@ -727,7 +733,7 @@ testDuplicateMessage t = do
       subscribeConnection bob2 aliceId
       subscribeConnection alice2 bobId
       -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
-      -- ackMessage bob2 aliceId 5
+      -- ackMessage bob2 aliceId 5 Nothing
       -- message 2 is not delivered again, even though it was delivered to the agent
       6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3"
       get alice2 ##> ("", bobId, SENT 6)
@@ -743,7 +749,7 @@ testSkippedMessages t = do
       4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
       get alice ##> ("", bobId, SENT 4)
       get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-      ackMessage bob aliceId 4
+      ackMessage bob aliceId 4 Nothing
 
     disconnectAgentClient bob
 
@@ -773,12 +779,12 @@ testSkippedMessages t = do
       8 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5"
       get alice2 ##> ("", bobId, SENT 8)
       get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 4, toMsgId = 6}}} _ "hello 5") -> c == aliceId; _ -> False
-      ackMessage bob2 aliceId 5
+      ackMessage bob2 aliceId 5 Nothing
 
       9 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6"
       get alice2 ##> ("", bobId, SENT 9)
       get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False
-      ackMessage bob2 aliceId 6
+      ackMessage bob2 aliceId 6 Nothing
 
 testRatchetSync :: HasCallStack => ATransport -> IO ()
 testRatchetSync t = do
@@ -807,24 +813,24 @@ setupDesynchronizedRatchet alice bob = do
     4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
     get alice ##> ("", bobId, SENT 4)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId 4
+    ackMessage bob aliceId 4 Nothing
 
     5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2"
     get bob ##> ("", aliceId, SENT 5)
     get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False
-    ackMessage alice bobId 5
+    ackMessage alice bobId 5 Nothing
 
     liftIO $ copyFile testDB2 (testDB2 <> ".bak")
 
     6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
     get alice ##> ("", bobId, SENT 6)
     get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
-    ackMessage bob aliceId 6
+    ackMessage bob aliceId 6 Nothing
 
     7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4"
     get bob ##> ("", aliceId, SENT 7)
     get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False
-    ackMessage alice bobId 7
+    ackMessage alice bobId 7 Nothing
 
   disconnectAgentClient bob
 
@@ -1056,7 +1062,7 @@ testSuspendingAgent = do
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
     get a ##> ("", bId, SENT 4)
     get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
-    ackMessage b aId 4
+    ackMessage b aId 4 Nothing
     suspendAgent b 1000000
     get' b ##> ("", "", SUSPENDED)
     5 <- sendMessage a bId SMP.noMsgFlags "hello 2"
@@ -1074,7 +1080,7 @@ testSuspendingAgentCompleteSending t = do
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
     get a ##> ("", bId, SENT 4)
     get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
-    ackMessage b aId 4
+    ackMessage b aId 4 Nothing
     pure (aId, bId)
 
   runRight_ $ do
@@ -1093,9 +1099,9 @@ testSuspendingAgentCompleteSending t = do
 
     pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
     pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
-    ackMessage a bId 5
+    ackMessage a bId 5 Nothing
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
-    ackMessage a bId 6
+    ackMessage a bId 6 Nothing
 
 testSuspendingAgentTimeout :: ATransport -> IO ()
 testSuspendingAgentTimeout t = do
@@ -1106,7 +1112,7 @@ testSuspendingAgentTimeout t = do
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
     get a ##> ("", bId, SENT 4)
     get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
-    ackMessage b aId 4
+    ackMessage b aId 4 Nothing
     pure (aId, bId)
 
   runRight_ $ do
@@ -1205,20 +1211,20 @@ testAsyncCommands = do
     2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
     get alice ##> ("", bobId, SENT $ baseId + 2)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessageAsync bob "4" aliceId $ baseId + 1
+    ackMessageAsync bob "4" aliceId (baseId + 1) Nothing
     ("4", _, OK) <- get bob
     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessageAsync bob "5" aliceId $ baseId + 2
+    ackMessageAsync bob "5" aliceId (baseId + 2) Nothing
     ("5", _, OK) <- get bob
     3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
     4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
     get bob ##> ("", aliceId, SENT $ baseId + 4)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessageAsync alice "6" bobId $ baseId + 3
+    ackMessageAsync alice "6" bobId (baseId + 3) Nothing
     ("6", _, OK) <- get alice
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessageAsync alice "7" bobId $ baseId + 4
+    ackMessageAsync alice "7" bobId (baseId + 4) Nothing
     ("7", _, OK) <- get alice
     deleteConnectionAsync alice bobId
     get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False
@@ -1263,17 +1269,17 @@ testAcceptContactAsync = do
     2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
     get alice ##> ("", bobId, SENT $ baseId + 2)
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 1
+    ackMessage bob aliceId (baseId + 1) Nothing
     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 2
+    ackMessage bob aliceId (baseId + 2) Nothing
     3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
     4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
     get bob ##> ("", aliceId, SENT $ baseId + 4)
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 3
+    ackMessage alice bobId (baseId + 3) Nothing
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 4
+    ackMessage alice bobId (baseId + 4) Nothing
     suspendConnection alice bobId
     5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
@@ -1740,7 +1746,7 @@ testSwitch2ConnectionsAbort1 servers = do
     withB :: (AgentClient -> IO a) -> IO a
     withB = withAgent agentCfg {initialClientId = 1} servers testDB2
 
-testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
+testCreateQueueAuth :: HasCallStack => (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
 testCreateQueueAuth clnt1 clnt2 = do
   a <- getClient clnt1
   b <- getClient clnt2
@@ -1772,7 +1778,7 @@ testSMPServerConnectionTest t newQueueBasicAuth srv =
     a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
     runRight $ testProtocolServer a 1 srv
 
-testRatchetAdHash :: IO ()
+testRatchetAdHash :: HasCallStack => IO ()
 testRatchetAdHash = do
   a <- getSMPAgentClient' agentCfg initAgentServers testDB
   b <- getSMPAgentClient' agentCfg initAgentServers testDB2
@@ -1782,6 +1788,73 @@ testRatchetAdHash = do
     ad2 <- getConnectionRatchetAdHash b aId
     liftIO $ ad1 `shouldBe` ad2
 
+testDeliveryReceipts :: HasCallStack => IO ()
+testDeliveryReceipts = do
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
+  runRight_ $ do
+    (aId, bId) <- makeConnection a b
+    -- a sends, b receives and sends delivery receipt
+    4 <- sendMessage a bId SMP.noMsgFlags "hello"
+    get a ##> ("", bId, SENT 4)
+    get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
+    ackMessage b aId 4 $ Just ""
+    get a =##> \case ("", c, Rcvd 4) -> c == bId; _ -> False
+    ackMessage a bId 5 Nothing
+    -- b sends, a receives and sends delivery receipt
+    6 <- sendMessage b aId SMP.noMsgFlags "hello too"
+    get b ##> ("", aId, SENT 6)
+    get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
+    ackMessage a bId 6 $ Just ""
+    get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False
+    ackMessage b aId 7 (Just "") `catchError` \e -> liftIO $ e `shouldBe` Agent.CMD PROHIBITED
+    ackMessage b aId 7 Nothing
+
+testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO ()
+testDeliveryReceiptsVersion t = do
+  a <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
+  withSmpServerStoreMsgLogOn t testPort $ \_ -> do
+    (aId, bId) <- runRight $ do
+      (aId, bId) <- makeConnection a b
+      checkVersion a bId 3
+      checkVersion b aId 3
+      4 <- sendMessage a bId SMP.noMsgFlags "hello"
+      get a ##> ("", bId, SENT 4)
+      get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
+      ackMessage b aId 4 $ Just ""
+      liftIO $ noMessages a "no delivery receipt (unsupported version)"
+      5 <- sendMessage b aId SMP.noMsgFlags "hello too"
+      get b ##> ("", aId, SENT 5)
+      get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
+      ackMessage a bId 5 $ Just ""
+      liftIO $ noMessages b "no delivery receipt (unsupported version)"
+      pure (aId, bId)
+
+    disconnectAgentClient a
+    disconnectAgentClient b
+    a' <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB
+    b' <- getSMPAgentClient' agentCfg {smpAgentVRange = mkVersionRange 1 4} initAgentServers testDB2
+
+    runRight_ $ do
+      subscribeConnection a' bId
+      subscribeConnection b' aId
+      exchangeGreetingsMsgId 6 a' bId b' aId
+      checkVersion a' bId 4
+      checkVersion b' aId 4
+      8 <- sendMessage a' bId SMP.noMsgFlags "hello"
+      get a' ##> ("", bId, SENT 8)
+      get b' =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
+      ackMessage b' aId 8 $ Just ""
+      get a' =##> \case ("", c, Rcvd 8) -> c == bId; _ -> False
+      ackMessage a' bId 9 Nothing
+      10 <- sendMessage b' aId SMP.noMsgFlags "hello too"
+      get b' ##> ("", aId, SENT 10)
+      get a' =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
+      ackMessage a' bId 10 $ Just ""
+      get b' =##> \case ("", c, Rcvd 10) -> c == aId; _ -> False
+      ackMessage b' aId 11 Nothing
+
 testTwoUsers :: HasCallStack => IO ()
 testTwoUsers = do
   let nc = netCfg initAgentServers
@@ -1898,13 +1971,13 @@ exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
   liftIO $ msgId1 `shouldBe` msgId
   get alice ##> ("", bobId, SENT msgId)
   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-  ackMessage bob aliceId msgId
+  ackMessage bob aliceId msgId Nothing
   msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
   let msgId' = msgId + 1
   liftIO $ msgId2 `shouldBe` msgId'
   get bob ##> ("", aliceId, SENT msgId')
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-  ackMessage alice bobId msgId'
+  ackMessage alice bobId msgId' Nothing
 
 exchangeGreetingsMsgIds :: HasCallStack => AgentClient -> ConnId -> Int64 -> AgentClient -> ConnId -> Int64 -> ExceptT AgentErrorType IO ()
 exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
@@ -1912,11 +1985,11 @@ exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
   liftIO $ msgId1 `shouldBe` aliceMsgId
   get alice ##> ("", bobId, SENT aliceMsgId)
   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-  ackMessage bob aliceId bobMsgId
+  ackMessage bob aliceId bobMsgId Nothing
   msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
   let aliceMsgId' = aliceMsgId + 1
       bobMsgId' = bobMsgId + 1
   liftIO $ msgId2 `shouldBe` bobMsgId'
   get bob ##> ("", aliceId, SENT bobMsgId')
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-  ackMessage alice bobId aliceMsgId'
+  ackMessage alice bobId aliceMsgId' Nothing
diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs
index 36eaf8f7c..1891193d1 100644
--- a/tests/AgentTests/NotificationTests.hs
+++ b/tests/AgentTests/NotificationTests.hs
@@ -253,7 +253,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
 
   runRight_ $ do
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 1
+    ackMessage alice bobId (baseId + 1) Nothing
     -- delete notification subscription
     toggleConnectionNtfs alice bobId False
     liftIO $ threadDelay 250000
@@ -296,13 +296,13 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 1)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 1
+    ackMessage alice bobId (baseId + 1) Nothing
     -- alice sends message
     2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
     get alice ##> ("", bobId, SENT $ baseId + 2)
     void $ messageNotification apnsQ
     get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
-    ackMessage bob aliceId $ baseId + 2
+    ackMessage bob aliceId (baseId + 2) Nothing
     -- no unexpected notifications should follow
     noNotification apnsQ
   where
@@ -343,7 +343,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 1)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 1
+    ackMessage alice bobId (baseId + 1) Nothing
     -- set mode to NMPeriodic
     NTActive <- registerNtfToken alice tkn NMPeriodic
     -- send message, no notification
@@ -352,7 +352,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     noNotification apnsQ
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 2
+    ackMessage alice bobId (baseId + 2) Nothing
     -- set mode to NMInstant
     NTActive <- registerNtfToken alice tkn NMInstant
     -- send message, receive notification
@@ -361,7 +361,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 3)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 3
+    ackMessage alice bobId (baseId + 3) Nothing
     -- turn off notifications
     deleteNtfToken alice tkn
     -- send message, no notification
@@ -370,7 +370,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 4)
     noNotification apnsQ
     get alice =##> \case ("", c, Msg "why hello there") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 4
+    ackMessage alice bobId (baseId + 4) Nothing
     -- turn on notifications, set mode to NMInstant
     void $ registerTestToken alice "abcd" NMInstant apnsQ
     -- send message, receive notification
@@ -379,7 +379,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 5)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 5
+    ackMessage alice bobId (baseId + 5) Nothing
     -- no notifications should follow
     noNotification apnsQ
   where
@@ -407,7 +407,7 @@ testChangeToken APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 1)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId $ baseId + 1
+    ackMessage alice bobId (baseId + 1) Nothing
     pure (aliceId, bobId)
   disconnectAgentClient alice
 
@@ -422,7 +422,7 @@ testChangeToken APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     void $ messageNotification apnsQ
     get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
-    ackMessage alice1 bobId $ baseId + 2
+    ackMessage alice1 bobId (baseId + 2) Nothing
     -- no notifications should follow
     noNotification apnsQ
   where
@@ -441,7 +441,7 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT 4)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId 4
+    ackMessage alice bobId 4 Nothing
     liftIO $ killThread threadId
     pure (aliceId, bobId)
 
@@ -467,7 +467,7 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT 4)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-    ackMessage alice bobId 4
+    ackMessage alice bobId 4 Nothing
     liftIO $ killThread threadId
     pure (aliceId, bobId)
 
@@ -498,7 +498,7 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
       get b ##> ("", aliceId, SENT msgId)
       void $ messageNotification apnsQ
       get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-      ackMessage a bobId msgId
+      ackMessage a bobId msgId Nothing
     pure conns
 
   runRight_ @AgentErrorType $ do
@@ -545,7 +545,7 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
           get b ##> ("", aId, SENT msgId)
           void $ messageNotification apnsQ
           get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
-          ackMessage a bId msgId
+          ackMessage a bId msgId Nothing
     testMessage "hello"
     _ <- switchConnectionAsync a "" bId
     switchComplete a bId b aId

From 3fee468051f5b28ccfc588306684e5f7f1170ed5 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 14 Jul 2023 18:13:54 +0100
Subject: [PATCH 39/49] agent: expire messages on quota errors (#801)

---
 src/Simplex/Messaging/Agent.hs | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 9b2499c44..bf34f4df4 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -1095,7 +1095,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 SMP SMP.QUOTA -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
-                  _ -> retrySndMsg RISlow
+                  _ -> retryIfNotExpired RISlow err
                 SMP SMP.AUTH -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -1124,11 +1124,12 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 _
                   -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
                   -- the message sending would be retried
-                  | temporaryOrHostError e -> do
-                    let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
-                    ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg RIFast)
+                  | temporaryOrHostError e -> retryIfNotExpired RIFast err
                   | otherwise -> notifyDel msgId err
               where
+                retryIfNotExpired riMode err = do
+                  let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
+                  ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg riMode)
                 msgExpired timeoutSel = do
                   msgTimeout <- asks $ timeoutSel . config
                   currentTime <- liftIO getCurrentTime

From 1901e96ecceabe2c01ad5f79aa4518dbb9c550ce Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 14 Jul 2023 21:07:45 +0100
Subject: [PATCH 40/49] server: make main SMP server queues unbounded (#802)

---
 src/Simplex/Messaging/Server.hs         |  8 ++++----
 src/Simplex/Messaging/Server/Env/STM.hs | 16 ++++++++--------
 src/Simplex/Messaging/Server/Main.hs    |  2 +-
 tests/SMPClient.hs                      |  2 +-
 4 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index dcd02ca5e..4a8eb1467 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -122,7 +122,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
     serverThread ::
       forall s.
       Server ->
-      (Server -> TBQueue (QueueId, Client)) ->
+      (Server -> TQueue (QueueId, Client)) ->
       (Server -> TMap QueueId Client) ->
       (Client -> TMap QueueId s) ->
       (s -> IO ()) ->
@@ -134,7 +134,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
         updateSubscribers = do
-          (qId, clnt) <- readTBQueue $ subQ s
+          (qId, clnt) <- readTQueue $ subQ s
           let clientToBeNotified = \c' ->
                 if sameClientSession clnt c'
                   then pure Nothing
@@ -477,7 +477,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
           where
             newSub :: m (TVar Sub)
             newSub = time "SUB newSub" . atomically $ do
-              writeTBQueue subscribedQ (rId, clnt)
+              writeTQueue subscribedQ (rId, clnt)
               sub <- newTVar =<< newSubscription NoSub
               TM.insert rId sub subscriptions
               pure sub
@@ -522,7 +522,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
         subscribeNotifications :: m (Transmission BrokerMsg)
         subscribeNotifications = time "NSUB" . atomically $ do
           unlessM (TM.member queueId ntfSubscriptions) $ do
-            writeTBQueue ntfSubscribedQ (queueId, clnt)
+            writeTQueue ntfSubscribedQ (queueId, clnt)
             TM.insert queueId () ntfSubscriptions
           pure ok
 
diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs
index 609438848..812bb462b 100644
--- a/src/Simplex/Messaging/Server/Env/STM.hs
+++ b/src/Simplex/Messaging/Server/Env/STM.hs
@@ -39,7 +39,7 @@ import UnliftIO.STM
 data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport)],
     tbqSize :: Natural,
-    serverTbqSize :: Natural,
+    -- serverTbqSize :: Natural,
     msgQueueQuota :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
@@ -103,9 +103,9 @@ data Env = Env
   }
 
 data Server = Server
-  { subscribedQ :: TBQueue (RecipientId, Client),
+  { subscribedQ :: TQueue (RecipientId, Client),
     subscribers :: TMap RecipientId Client,
-    ntfSubscribedQ :: TBQueue (NotifierId, Client),
+    ntfSubscribedQ :: TQueue (NotifierId, Client),
     notifiers :: TMap NotifierId Client
   }
 
@@ -127,11 +127,11 @@ data Sub = Sub
     delivered :: TMVar MsgId
   }
 
-newServer :: Natural -> STM Server
-newServer qSize = do
-  subscribedQ <- newTBQueue qSize
+newServer :: STM Server
+newServer = do
+  subscribedQ <- newTQueue
   subscribers <- TM.empty
-  ntfSubscribedQ <- newTBQueue qSize
+  ntfSubscribedQ <- newTQueue
   notifiers <- TM.empty
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
 
@@ -152,7 +152,7 @@ newSubscription subThread = do
 
 newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
 newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
-  server <- atomically $ newServer (serverTbqSize config)
+  server <- atomically newServer
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index df15cebda..b1d92991b 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -166,7 +166,7 @@ smpServerCLI cfgPath logPath =
           ServerConfig
             { transports = iniTransports ini,
               tbqSize = 64,
-              serverTbqSize = 1024,
+              -- serverTbqSize = 1024,
               msgQueueQuota = 128,
               queueIdBytes = 24,
               msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs
index c49b65ee6..470fcf215 100644
--- a/tests/SMPClient.hs
+++ b/tests/SMPClient.hs
@@ -82,7 +82,7 @@ cfg =
   ServerConfig
     { transports = undefined,
       tbqSize = 1,
-      serverTbqSize = 1,
+      -- serverTbqSize = 1,
       msgQueueQuota = 4,
       queueIdBytes = 24,
       msgIdBytes = 24,

From d989d114785e9a490b8fb61d77ba33c82c6e56f5 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 15 Jul 2023 10:37:08 +0100
Subject: [PATCH 41/49] server: refactor restoring store log (#803)

---
 src/Simplex/Messaging/Server/Env/STM.hs  | 13 +++---
 src/Simplex/Messaging/Server/StoreLog.hs | 59 +++++++++++-------------
 2 files changed, 32 insertions(+), 40 deletions(-)

diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs
index 812bb462b..165e4d330 100644
--- a/src/Simplex/Messaging/Server/Env/STM.hs
+++ b/src/Simplex/Messaging/Server/Env/STM.hs
@@ -156,22 +156,21 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile
-  s' <- restoreQueues queueStore `mapM` storeLog
+  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 = s', tlsServerParams, serverStats}
+  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog, tlsServerParams, serverStats}
   where
-    restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)
-    restoreQueues QueueStore {queues, senders, notifiers} s = do
-      (qs, s') <- liftIO $ readWriteStoreLog s
+    restoreQueues :: QueueStore -> FilePath -> m (StoreLog 'WriteMode)
+    restoreQueues QueueStore {queues, senders, notifiers} f = do
+      (qs, s) <- liftIO $ readWriteStoreLog f
       atomically $ do
         writeTVar queues =<< mapM newTVar qs
         writeTVar senders $! M.foldr' addSender M.empty qs
         writeTVar notifiers $! M.foldr' addNotifier M.empty qs
-      pure s'
+      pure s
     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
     addSender q = M.insert (senderId q) (recipientId q)
     addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs
index c6b276283..fceae16f4 100644
--- a/src/Simplex/Messaging/Server/StoreLog.hs
+++ b/src/Simplex/Messaging/Server/StoreLog.hs
@@ -25,20 +25,17 @@ module Simplex.Messaging.Server.StoreLog
 where
 
 import Control.Applicative (optional, (<|>))
-import Control.Monad (unless)
-import Data.Bifunctor (first, second)
+import Control.Monad (foldM, unless, when)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Either (partitionEithers)
 import Data.Functor (($>))
-import Data.List (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
 import Simplex.Messaging.Transport.Buffer (trimCR)
+import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist)
 import System.IO
 
@@ -139,37 +136,33 @@ logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 
-readWriteStoreLog :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
-readWriteStoreLog s@(ReadStoreLog f _) = do
-  qs <- readQueues s
-  closeStoreLog s
-  s' <- openWriteStoreLog f
-  writeQueues s' qs
-  pure (qs, s')
+readWriteStoreLog :: FilePath -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
+readWriteStoreLog f = do
+  qs <- ifM (doesFileExist f) (readQueues f) (pure M.empty)
+  s <- openWriteStoreLog f
+  writeQueues s qs
+  pure (qs, s)
 
 writeQueues :: StoreLog 'WriteMode -> Map RecipientId QueueRec -> IO ()
-writeQueues s = mapM_ (writeStoreLogRecord s . CreateQueue) . M.filter active
+writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q
   where
     active QueueRec {status} = status == QueueActive
 
-type LogParsingError = (String, ByteString)
-
-readQueues :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec)
-readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLog
+readQueues :: FilePath -> IO (Map RecipientId QueueRec)
+readQueues f = foldM processLine M.empty . B.lines =<< B.readFile f
   where
-    procStoreLog :: LB.ByteString -> ([LogParsingError], Map RecipientId QueueRec)
-    procStoreLog = second (foldl' procLogRecord M.empty) . partitionEithers . map parseLogRecord . LB.lines
-    returnResult :: ([LogParsingError], Map RecipientId QueueRec) -> IO (Map RecipientId QueueRec)
-    returnResult (errs, res) = mapM_ printError errs $> res
-    parseLogRecord :: LB.ByteString -> Either LogParsingError StoreLogRecord
-    parseLogRecord = (\s -> first (,s) $ strDecode s) . trimCR . LB.toStrict
-    procLogRecord :: Map RecipientId QueueRec -> StoreLogRecord -> Map RecipientId QueueRec
-    procLogRecord m = \case
-      CreateQueue q -> M.insert (recipientId q) q m
-      SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
-      AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
-      SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
-      DeleteQueue qId -> M.delete qId m
-      DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
-    printError :: LogParsingError -> IO ()
-    printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
+    processLine :: Map RecipientId QueueRec -> ByteString -> IO (Map RecipientId QueueRec)
+    processLine m s = case strDecode $ trimCR s of
+      Right r -> pure $ procLogRecord r
+      Left e -> printError e $> m
+      where
+        procLogRecord :: StoreLogRecord -> Map RecipientId QueueRec
+        procLogRecord = \case
+          CreateQueue q -> M.insert (recipientId q) q m
+          SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
+          AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
+          SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
+          DeleteQueue qId -> M.delete qId m
+          DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
+        printError :: String -> IO ()
+        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

From 4fae7dcaeeabe14ec244686484ca1ab6c1bf140f Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 15 Jul 2023 13:33:00 +0100
Subject: [PATCH 42/49] server: control port (#804)

* server: control port

* do not remove messages when saving via control port

* remove unused record fields

* fix tests
---
 simplexmq.cabal                              |  1 +
 src/Simplex/Messaging/Server.hs              | 72 ++++++++++++++++++--
 src/Simplex/Messaging/Server/Control.hs      | 36 ++++++++++
 src/Simplex/Messaging/Server/Env/STM.hs      | 11 ++-
 src/Simplex/Messaging/Server/Main.hs         |  6 +-
 src/Simplex/Messaging/Server/MsgStore/STM.hs |  9 +++
 src/Simplex/Messaging/Server/Stats.hs        |  2 +-
 tests/SMPClient.hs                           |  3 +-
 8 files changed, 126 insertions(+), 14 deletions(-)
 create mode 100644 src/Simplex/Messaging/Server/Control.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index a3d6af40b..b70cd513f 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -109,6 +109,7 @@ library
       Simplex.Messaging.Protocol
       Simplex.Messaging.Server
       Simplex.Messaging.Server.CLI
+      Simplex.Messaging.Server.Control
       Simplex.Messaging.Server.Env.STM
       Simplex.Messaging.Server.Expiration
       Simplex.Messaging.Server.Main
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 4a8eb1467..5826bcf7b 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -58,11 +58,13 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
 import GHC.TypeLits (KnownNat)
-import Network.Socket (ServiceName)
+import Network.Socket (ServiceName, Socket, socketToHandle)
+import Simplex.Messaging.Agent.Lock
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding (Encoding (smpEncode))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.Control
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
@@ -74,10 +76,11 @@ import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
-import System.IO (hPutStrLn)
+import System.IO (hPutStrLn, hSetNewlineMode, universalNewlineMode)
 import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
@@ -110,15 +113,18 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
       serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
-      map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
+      map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
     )
-    `finally` (withLog closeStoreLog >> saveServerMessages >> saveServerStats)
+    `finally` withLock (savingLock s) "final" (saveServer False)
   where
     runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
       runTransportServer started tcpPort serverParams tCfg (runClient t)
 
+    saveServer :: Bool -> M ()
+    saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
+
     serverThread ::
       forall s.
       Server ->
@@ -223,6 +229,57 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
         Right th -> runClientTransport th
         Left _ -> pure ()
 
+    controlPortThread_ :: ServerConfig -> [M ()]
+    controlPortThread_ ServerConfig {controlPort = Just port} = [runCPServer port]
+    controlPortThread_ _ = []
+
+    runCPServer :: ServiceName -> M ()
+    runCPServer port = do
+      srv <- asks server
+      cpStarted <- newEmptyTMVarIO
+      u <- askUnliftIO
+      liftIO $ runTCPServer cpStarted port $ runCPClient u srv
+      where
+        runCPClient :: UnliftIO (ReaderT Env IO) -> Server -> Socket -> IO ()
+        runCPClient u srv sock = do
+          h <- socketToHandle sock ReadWriteMode
+          hSetBuffering h LineBuffering
+          hSetNewlineMode h universalNewlineMode
+          hPutStrLn h "SMP server control port\n'help' for supported commands"
+          cpLoop h
+          where
+            cpLoop h = do
+              s <- B.hGetLine h
+              case strDecode $ trimCR s of
+                Right CPQuit -> hClose h
+                Right cmd -> processCP h cmd >> cpLoop h
+                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h
+            processCP h = \case
+              CPSuspend -> hPutStrLn h "suspend not implemented"
+              CPResume -> hPutStrLn h "resume not implemented"
+              CPClients -> hPutStrLn h "clients not implemented"
+              CPStats -> do
+                ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
+                putStat "fromTime" fromTime
+                putStat "qCreated" qCreated
+                putStat "qSecured" qSecured
+                putStat "qDeleted" qDeleted
+                putStat "msgSent" msgSent
+                putStat "msgRecv" msgRecv
+                putStat "msgSentNtf" msgSentNtf
+                putStat "msgRecvNtf" msgRecvNtf
+                putStat "qCount" qCount
+                putStat "msgCount" msgCount
+                where
+                  putStat :: Show a => String -> TVar a -> IO ()
+                  putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v
+              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, save, help, quit"
+              CPQuit -> pure ()
+
 runClientTransport :: Transport c => THandle c -> M ()
 runClientTransport th@THandle {thVersion, sessionId} = do
   q <- asks $ tbqSize . config
@@ -720,8 +777,8 @@ randomId n = do
   gVar <- asks idsDrg
   atomically (C.pseudoRandomBytes n gVar)
 
-saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => m ()
-saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
+saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => Bool -> m ()
+saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages
   where
     saveMessages f = do
       logInfo $ "saving messages to file " <> T.pack f
@@ -730,8 +787,9 @@ saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
         readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
       logInfo "messages saved"
       where
+        getMessages = if keepMsgs then snapshotMsgQueue else flushMsgQueue
         saveQueueMsgs ms h rId =
-          atomically (flushMsgQueue ms rId)
+          atomically (getMessages ms rId)
             >>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
 
 restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
diff --git a/src/Simplex/Messaging/Server/Control.hs b/src/Simplex/Messaging/Server/Control.hs
new file mode 100644
index 000000000..184e94775
--- /dev/null
+++ b/src/Simplex/Messaging/Server/Control.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Server.Control where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Simplex.Messaging.Encoding.String
+
+data ControlProtocol
+  = CPSuspend
+  | CPResume
+  | CPClients
+  | CPStats
+  | CPSave
+  | CPHelp
+  | CPQuit
+
+instance StrEncoding ControlProtocol where
+  strEncode = \case
+    CPSuspend -> "suspend"
+    CPResume -> "resume"
+    CPClients -> "clients"
+    CPStats -> "stats"
+    CPSave -> "save"
+    CPHelp -> "help"
+    CPQuit -> "quit"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "suspend" -> pure CPSuspend
+      "resume" -> pure CPResume
+      "clients" -> pure CPClients
+      "stats" -> pure CPStats
+      "save" -> pure CPSave
+      "help" -> pure CPHelp
+      "quit" -> pure CPQuit
+      _ -> fail "bad ControlProtocol command"
diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs
index 165e4d330..386355e80 100644
--- a/src/Simplex/Messaging/Server/Env/STM.hs
+++ b/src/Simplex/Messaging/Server/Env/STM.hs
@@ -19,6 +19,7 @@ import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural
+import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Crypto (KeyHash (..))
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
@@ -70,7 +71,9 @@ data ServerConfig = ServerConfig
     -- | SMP client-server protocol version range
     smpServerVRange :: VersionRange,
     -- | TCP transport config
-    transportConfig :: TransportServerConfig
+    transportConfig :: TransportServerConfig,
+    -- | run listener on control port
+    controlPort :: Maybe ServiceName
   }
 
 defMsgExpirationDays :: Int64
@@ -106,7 +109,8 @@ data Server = Server
   { subscribedQ :: TQueue (RecipientId, Client),
     subscribers :: TMap RecipientId Client,
     ntfSubscribedQ :: TQueue (NotifierId, Client),
-    notifiers :: TMap NotifierId Client
+    notifiers :: TMap NotifierId Client,
+    savingLock :: Lock
   }
 
 data Client = Client
@@ -133,7 +137,8 @@ newServer = do
   subscribers <- TM.empty
   ntfSubscribedQ <- newTQueue
   notifiers <- TM.empty
-  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
+  savingLock <- createLock
+  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
 
 newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
 newClient qSize thVersion sessionId ts = do
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index b1d92991b..749a8d6ba 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -130,7 +130,8 @@ smpServerCLI cfgPath logPath =
                 <> ("host: " <> host <> "\n")
                 <> ("port: " <> defaultServerPort <> "\n")
                 <> "log_tls_errors: off\n\
-                   \websockets: off\n\n\
+                   \websockets: off\n\
+                   \# control_port: 5224\n\n\
                    \[INACTIVE_CLIENTS]\n\
                    \# TTL and interval to check inactive clients\n\
                    \disconnect: off\n"
@@ -202,7 +203,8 @@ smpServerCLI cfgPath logPath =
               transportConfig =
                 defaultTransportServerConfig
                   { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  }
+                  },
+              controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini
             }
 
 data CliCommand
diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs
index e9dd95eec..95e425d8e 100644
--- a/src/Simplex/Messaging/Server/MsgStore/STM.hs
+++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs
@@ -13,6 +13,7 @@ module Simplex.Messaging.Server.MsgStore.STM
     getMsgQueue,
     delMsgQueue,
     flushMsgQueue,
+    snapshotMsgQueue,
     writeMsg,
     tryPeekMsg,
     peekMsg,
@@ -62,6 +63,14 @@ delMsgQueue st rId = TM.delete rId st
 flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
 flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
 
+snapshotMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+snapshotMsgQueue st rId  = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . msgQueue)
+  where
+    snapshotTQueue q = do
+      msgs <- flushTQueue q
+      mapM_ (writeTQueue q) msgs
+      pure msgs
+
 writeMsg :: MsgQueue -> Message -> STM (Maybe Message)
 writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do
   canWrt <- readTVar canWrite
diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs
index b462eaffa..493bd5ac1 100644
--- a/src/Simplex/Messaging/Server/Stats.hs
+++ b/src/Simplex/Messaging/Server/Stats.hs
@@ -94,7 +94,7 @@ setServerStats s d = do
   writeTVar (msgRecvNtf s) $! _msgRecvNtf d
   setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
   writeTVar (qCount s) $! _qCount d
-  writeTVar (msgCount s) $! _qCount d
+  writeTVar (msgCount s) $! _msgCount d
 
 instance StrEncoding ServerStatsData where
   strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf} =
diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs
index 470fcf215..639f254d0 100644
--- a/tests/SMPClient.hs
+++ b/tests/SMPClient.hs
@@ -100,7 +100,8 @@ cfg =
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
       smpServerVRange = supportedSMPServerVRange,
-      transportConfig = defaultTransportServerConfig
+      transportConfig = defaultTransportServerConfig,
+      controlPort = Nothing
     }
 
 withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a

From de95119ca600965ed29a7c0cf18867ccc576ec2c Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 15 Jul 2023 13:35:09 +0100
Subject: [PATCH 43/49] 5.3.0.0

---
 package.yaml    | 2 +-
 simplexmq.cabal | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/package.yaml b/package.yaml
index a6e2ef8e0..9b432d30e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.2.1
+version: 5.3.0.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index b70cd513f..e61491639 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.2.1
+version:        5.3.0.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and

From 4ed40fa5d50fbfa99f6b1c7c6d635ffeb00f6e77 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Mon, 17 Jul 2023 20:33:25 +0400
Subject: [PATCH 44/49] enable a test in CI ("should resume sending file after
 restart") (#800)

---
 tests/XFTPAgent.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 9eaa0f23e..b2b97e3cb 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -37,7 +37,7 @@ xftpAgentTests = around_ testBracket . describe "Functional API" $ do
   it "should send and receive file" testXFTPAgentSendReceive
   it "should resume receiving file after restart" testXFTPAgentReceiveRestore
   it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup
-  xit'' "should resume sending file after restart" testXFTPAgentSendRestore
+  it "should resume sending file after restart" testXFTPAgentSendRestore
   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
@@ -255,6 +255,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
     liftIO $ sfId' `shouldBe` sfId
 
     -- prefix path should be removed after sending file
+    threadDelay 100000
     doesDirectoryExist prefixPath `shouldReturn` False
     doesFileExist encPath `shouldReturn` False
 

From 7e2b30945009e0cbe02a6b11a585595d3e4858b0 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 20 Jul 2023 16:15:33 +0400
Subject: [PATCH 45/49] migration to delete expired messages (#801 is suspected
 to have caused temporary traffic increase due to flood of non expired
 messages) (#806)

---
 simplexmq.cabal                               |  1 +
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 10 +---------
 .../Agent/Store/SQLite/Migrations.hs          |  4 +++-
 .../M20230720_delete_expired_messages.hs      | 20 +++++++++++++++++++
 .../Store/SQLite/Migrations/agent_schema.sql  |  4 ++++
 tests/XFTPAgent.hs                            |  1 -
 6 files changed, 29 insertions(+), 11 deletions(-)
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230720_delete_expired_messages.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index e61491639..237e66e89 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -85,6 +85,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 0d9e4df9f..87c342836 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -1058,15 +1058,7 @@ deleteSndMsgsExpired db ttl = do
   cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
   DB.execute
     db
-    [sql|
-      DELETE FROM messages
-      WHERE internal_id IN (
-        SELECT s.internal_id
-        FROM snd_messages s
-        JOIN messages m USING (internal_id)
-        WHERE m.internal_ts < ?
-      )
-    |]
+    "DELETE FROM messages WHERE internal_snd_id IS NOT NULL AND internal_ts < ?"
     (Only cutoffTs)
 
 createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index 810bebd3c..704a645ee 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
@@ -64,6 +64,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_m
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -93,7 +94,8 @@ schemaMigrations =
     ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
     ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
     ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
-    ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts)
+    ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
+    ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages)
   ]
 
 -- | The list of migrations in ascending order by date
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230720_delete_expired_messages.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230720_delete_expired_messages.hs
new file mode 100644
index 000000000..3cfdb688d
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230720_delete_expired_messages.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230720_delete_expired_messages :: Query
+m20230720_delete_expired_messages =
+  [sql|
+CREATE INDEX idx_messages_internal_snd_id_ts ON messages(internal_snd_id, internal_ts);
+
+DELETE FROM messages WHERE internal_snd_id IS NOT NULL AND internal_ts < datetime('now', '-3 days');
+|]
+
+down_m20230720_delete_expired_messages :: Query
+down_m20230720_delete_expired_messages =
+  [sql|
+DROP INDEX idx_messages_internal_snd_id_ts;
+|]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 10e3148b0..898be9721 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -467,3 +467,7 @@ CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages(
   conn_id,
   rcpt_internal_id
 );
+CREATE INDEX idx_messages_internal_snd_id_ts ON messages(
+  internal_snd_id,
+  internal_ts
+);
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index b2b97e3cb..53a0184f3 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -16,7 +16,6 @@ import Data.Int (Int64)
 import Data.List (find, isSuffixOf)
 import Data.Maybe (fromJust)
 import SMPAgentClient (agentCfg, initAgentServers, testDB)
-import SMPClient (xit'')
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType (AUTH))
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))

From c54be32135ccd79e9bf2c82b30955c1e2fa8d822 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 22 Jul 2023 09:16:06 +0100
Subject: [PATCH 46/49] Revert "agent: expire messages on quota errors (#801)"
 (#807)

This reverts commit 3fee468051f5b28ccfc588306684e5f7f1170ed5.
---
 src/Simplex/Messaging/Agent.hs | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index bf34f4df4..9b2499c44 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -1095,7 +1095,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 SMP SMP.QUOTA -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
-                  _ -> retryIfNotExpired RISlow err
+                  _ -> retrySndMsg RISlow
                 SMP SMP.AUTH -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -1124,12 +1124,11 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 _
                   -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
                   -- the message sending would be retried
-                  | temporaryOrHostError e -> retryIfNotExpired RIFast err
+                  | temporaryOrHostError e -> do
+                    let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
+                    ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg RIFast)
                   | otherwise -> notifyDel msgId err
               where
-                retryIfNotExpired riMode err = do
-                  let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
-                  ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg riMode)
                 msgExpired timeoutSel = do
                   msgTimeout <- asks $ timeoutSel . config
                   currentTime <- liftIO getCurrentTime

From 6314bb17066a379446eed73c6a1fb9c4e9944517 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 22 Jul 2023 13:00:25 +0100
Subject: [PATCH 47/49] agent: partially fix message queries, debug message
 times (#810)

* agent: partially fix message queries, debug message times

* fix more joins
---
 src/Simplex/Messaging/Agent.hs              | 16 ++++-----
 src/Simplex/Messaging/Agent/Client.hs       | 36 +++++++++++++++++----
 src/Simplex/Messaging/Agent/Store/SQLite.hs | 10 +++---
 3 files changed, 43 insertions(+), 19 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 9b2499c44..38d444b95 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -519,9 +519,9 @@ ackMessageAsync' c corrId connId msgId rcptInfo_ = do
     enqueueAck :: m ()
     enqueueAck = do
       let mId = InternalId msgId
-      RcvMsg {msgType} <- withStore c $ \db -> getRcvMsg db connId mId
+      RcvMsg {msgType} <- withStoreCtx "ackMessageAsync': getRcvMsg" c $ \db -> getRcvMsg db connId mId
       when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwError $ CMD PROHIBITED
-      (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId mId
+      (RcvQueue {server}, _) <- withStoreCtx "ackMessageAsync': setMsgUserAck" c $ \db -> setMsgUserAck db connId mId
       enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId rcptInfo_
 
 deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
@@ -1239,13 +1239,13 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do
     ack :: m ()
     ack = do
       -- the stored message was delivered via a specific queue, the rest failed to decrypt and were already acknowledged
-      (rq, srvMsgId) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId
+      (rq, srvMsgId) <- withStoreCtx "ackMessage': setMsgUserAck" c $ \db -> setMsgUserAck db connId $ InternalId msgId
       ackQueueMessage c rq srvMsgId
     del :: m ()
-    del = withStore' c $ \db -> deleteMsg db connId $ InternalId msgId
+    del = withStoreCtx' "ackMessage': deleteMsg" c $ \db -> deleteMsg db connId $ InternalId msgId
     sendRcpt :: Connection 'CDuplex -> m ()
     sendRcpt (DuplexConnection cData _ sqs) = do
-      msg@RcvMsg {msgType, msgReceipt} <- withStore c $ \db -> getRcvMsg db connId $ InternalId msgId
+      msg@RcvMsg {msgType, msgReceipt} <- withStoreCtx "ackMessage': getRcvMsg" c $ \db -> getRcvMsg db connId $ InternalId msgId
       case rcptInfo_ of
         Just rcptInfo -> do
           unless (msgType == AM_A_MSG_) $ throwError (CMD PROHIBITED)
@@ -1256,7 +1256,7 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do
         Nothing -> case (msgType, msgReceipt) of
           -- only remove sent message if receipt hash was Ok, both to debug and for future redundancy
           (AM_A_RCVD_, Just MsgReceipt {agentMsgId = sndMsgId, msgRcptStatus = MROk}) ->
-            withStore' c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId
+            withStoreCtx' "ackMessage': deleteDeliveredSndMsg" c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId
           _ -> pure ()
 
 switchConnection' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
@@ -1900,7 +1900,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                                 | otherwise = pure conn'
                           Right _ -> prohibited >> ack
                           Left e@(AGENT A_DUPLICATE) -> do
-                            withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
+                            withStoreCtx' "processSMP: getLastMsg" c (\db -> getLastMsg db connId srvMsgId) >>= \case
                               Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
                                 | userAck -> ackDel internalId
                                 | otherwise -> do
@@ -2112,7 +2112,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               clientReceipt :: AMessageReceipt -> m (Maybe MsgReceipt)
               clientReceipt AMessageReceipt {agentMsgId, msgHash} = do
                 let sndMsgId = InternalSndId agentMsgId
-                SndMsg {internalId = InternalId msgId, msgType, internalHash, msgReceipt} <- withStore c $ \db -> getSndMsgViaRcpt db connId sndMsgId
+                SndMsg {internalId = InternalId msgId, msgType, internalHash, msgReceipt} <- withStoreCtx "messagesRcvd: getSndMsgViaRcpt" c $ \db -> getSndMsgViaRcpt db connId sndMsgId
                 if msgType /= AM_A_MSG_
                   then notify (ERR $ AGENT A_PROHIBITED) $> Nothing -- unexpected message type for receipt
                   else case msgReceipt of
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 1d33fa1bc..bc65b4a96 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -90,6 +90,8 @@ module Simplex.Messaging.Agent.Client
     whenSuspending,
     withStore,
     withStore',
+    withStoreCtx,
+    withStoreCtx',
     storeError,
     userServers,
     pickServer,
@@ -127,6 +129,7 @@ import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text.Encoding
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
+import Data.Time.Clock (diffUTCTime)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
 import GHC.Generics (Generic)
@@ -1236,16 +1239,37 @@ waitUntilForeground :: AgentClient -> STM ()
 waitUntilForeground c = unlessM ((ASForeground ==) <$> readTVar (agentState c)) retry
 
 withStore' :: AgentMonad m => AgentClient -> (DB.Connection -> IO a) -> m a
-withStore' c action = withStore c $ fmap Right . action
+withStore' = withStoreCtx_' Nothing
 
 withStore :: AgentMonad m => AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
-withStore c action = do
+withStore = withStoreCtx_ Nothing
+
+withStoreCtx' :: AgentMonad m => String -> AgentClient -> (DB.Connection -> IO a) -> m a
+withStoreCtx' = withStoreCtx_' . Just
+
+withStoreCtx :: AgentMonad m => String -> AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
+withStoreCtx = withStoreCtx_ . Just
+
+withStoreCtx_' :: AgentMonad m => Maybe String -> AgentClient -> (DB.Connection -> IO a) -> m a
+withStoreCtx_' ctx_ c action = withStoreCtx_ ctx_ c $ fmap Right . action
+
+withStoreCtx_ :: AgentMonad m => Maybe String -> AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
+withStoreCtx_ ctx_ c action = do
   st <- asks store
-  liftEitherError storeError . agentOperationBracket c AODatabase (\_ -> pure ()) $
-    withTransaction st action `E.catch` handleInternal
+  liftEitherError storeError . agentOperationBracket c AODatabase (\_ -> pure ()) $ case ctx_ of
+    Nothing -> withTransaction st action `E.catch` handleInternal ""
+    -- uncomment to debug store performance
+    -- Just ctx -> do
+    --   t1 <- liftIO getCurrentTime
+    --   putStrLn $ "agent withStoreCtx start       :: " <> show t1 <> " :: " <> ctx
+    --   r <- withTransaction st action `E.catch` handleInternal (" (" <> ctx <> ")")
+    --   t2 <- liftIO getCurrentTime
+    --   putStrLn $ "agent withStoreCtx end         :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
+    --   pure r
+    Just _ -> withTransaction st action `E.catch` handleInternal ""
   where
-    handleInternal :: E.SomeException -> IO (Either StoreError a)
-    handleInternal = pure . Left . SEInternal . bshow
+    handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
+    handleInternal ctxStr e = pure . Left . SEInternal . B.pack $ show e <> ctxStr
 
 storeError :: StoreError -> AgentErrorType
 storeError = \case
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 87c342836..cfd572755 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -906,7 +906,7 @@ getSndMsgViaRcpt db connId sndMsgId =
       [sql|
         SELECT s.internal_id, m.msg_type, s.internal_hash, s.rcpt_internal_id, s.rcpt_status
         FROM snd_messages s
-        JOIN messages m ON s.internal_id = m.internal_id
+        JOIN messages m ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
         WHERE s.conn_id = ? AND s.internal_snd_id = ?
       |]
       (connId, sndMsgId)
@@ -976,8 +976,8 @@ getRcvMsg db connId agentMsgId =
           r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
           m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
         FROM rcv_messages r
-        JOIN messages m ON r.internal_id = m.internal_id
-        LEFT JOIN snd_messages s ON s.rcpt_internal_id = r.internal_id
+        JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id
+        LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id
         WHERE r.conn_id = ? AND r.internal_id = ?
       |]
       (connId, agentMsgId)
@@ -992,9 +992,9 @@ getLastMsg db connId msgId =
           r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
           m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
         FROM rcv_messages r
-        JOIN messages m ON r.internal_id = m.internal_id
+        JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id
         JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id
-        LEFT JOIN snd_messages s ON s.rcpt_internal_id = r.internal_id
+        LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id
         WHERE r.conn_id = ? AND r.broker_id = ?
       |]
       (connId, msgId)

From e81f3b5529748bfeb3f22dbfedfb2cc8f3a63de3 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Sat, 22 Jul 2023 16:20:49 +0400
Subject: [PATCH 48/49] add indexes (#809)

---
 simplexmq.cabal                               |  1 +
 .../Agent/Store/SQLite/Migrations.hs          |  4 +++-
 .../SQLite/Migrations/M20230722_indexes.hs    | 20 +++++++++++++++++++
 .../Store/SQLite/Migrations/agent_schema.sql  |  6 ++++++
 4 files changed, 30 insertions(+), 1 deletion(-)
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230722_indexes.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 237e66e89..b1c19bfdf 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -86,6 +86,7 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index 704a645ee..e3715c4c9 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
@@ -65,6 +65,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -95,7 +96,8 @@ schemaMigrations =
     ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
     ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
     ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
-    ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages)
+    ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
+    ("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes)
   ]
 
 -- | The list of migrations in ascending order by date
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230722_indexes.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230722_indexes.hs
new file mode 100644
index 000000000..5c41a5f20
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230722_indexes.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230722_indexes :: Query
+m20230722_indexes =
+  [sql|
+CREATE INDEX idx_processed_ratchet_key_hashes_created_at ON processed_ratchet_key_hashes(created_at);
+CREATE INDEX idx_encrypted_rcv_message_hashes_created_at ON encrypted_rcv_message_hashes(created_at);
+|]
+
+down_m20230722_indexes :: Query
+down_m20230722_indexes =
+  [sql|
+DROP INDEX idx_encrypted_rcv_message_hashes_created_at;
+DROP INDEX idx_processed_ratchet_key_hashes_created_at;
+|]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 898be9721..000f6812b 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -471,3 +471,9 @@ CREATE INDEX idx_messages_internal_snd_id_ts ON messages(
   internal_snd_id,
   internal_ts
 );
+CREATE INDEX idx_processed_ratchet_key_hashes_created_at ON processed_ratchet_key_hashes(
+  created_at
+);
+CREATE INDEX idx_encrypted_rcv_message_hashes_created_at ON encrypted_rcv_message_hashes(
+  created_at
+);

From fdbfe0e8d159f394f6eb0f5168620da8694033cd Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 22 Jul 2023 13:21:53 +0100
Subject: [PATCH 49/49] 5.3.0.1

---
 package.yaml    | 2 +-
 simplexmq.cabal | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/package.yaml b/package.yaml
index 9b432d30e..fad82be22 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.3.0.0
+version: 5.3.0.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index b1c19bfdf..f93b29271 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.3.0.0
+version:        5.3.0.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and