deduplicate connections for locking

* agent: notify about polled message processing (for iOS notifications)

* optionally keep key and support re-opening database

* exports

* test that cannot reopen when created with keepKey: false

* set max number of messages to receive for a notification to 3

Dockerfile

@@ -5,7 +5,7 @@ FROM ubuntu:${TAG} AS build
 ### Build stage
 
 # Install curl and git and simplexmq dependencies
-RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-12 llvm-12-dev libnuma-dev
+RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-12 llvm-12-dev libnuma-dev libssl-dev
 
 # Specify bootstrap Haskell versions
 ENV BOOTSTRAP_HASKELL_GHC_VERSION=9.6.3

apps/smp-agent/Main.hs

@@ -5,6 +5,7 @@
 module Main where
 
 import Control.Logger.Simple
+import Data.ByteArray (ScrubbedBytes)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Agent.Env.SQLite
@@ -19,7 +20,7 @@ cfg = defaultAgentConfig
 agentDbFile :: String
 agentDbFile = "smp-agent.db"
 
-agentDbKey :: String
+agentDbKey :: ScrubbedBytes
 agentDbKey = ""
 
 servers :: InitialAgentServers
@@ -38,5 +39,5 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  Right st <- createAgentStore agentDbFile agentDbKey MCConsole
+  Right st <- createAgentStore agentDbFile agentDbKey False MCConsole
   withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers st

cabal.project

@@ -4,7 +4,10 @@ packages: .
 -- packages: . ../http2
 -- packages: . ../network-transport
 
-with-compiler: ghc-9.6.3
+index-state: 2023-12-12T00:00:00Z
+
+package cryptostore
+    flags: +use_crypton
 
 source-repository-package
     type: git
@@ -16,11 +19,6 @@ source-repository-package
     location: https://github.com/simplex-chat/hs-socks.git
     tag: a30cc7a79a08d8108316094f8f2f82a0c5e1ac51
 
-source-repository-package
-    type: git
-    location: https://github.com/kazu-yamamoto/http2.git
-    tag: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb
-
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/direct-sqlcipher.git
@@ -30,8 +28,3 @@ source-repository-package
     type: git
     location: https://github.com/simplex-chat/sqlcipher-simple.git
     tag: a46bd361a19376c5211f1058908fc0ae6bf42446
-
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/network-transport.git
-    tag: 0013798272a683e35ca38d2fdaf480942311fba8

package.yaml

@@ -32,13 +32,15 @@ dependencies:
   - attoparsec == 0.14.*
   - base >= 4.14 && < 5
   - base64-bytestring >= 1.0 && < 1.3
-  - bytestring == 0.11.*
   - case-insensitive == 1.2.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
   - containers == 0.6.*
-  - cryptonite == 0.30.*
-  - cryptostore == 0.2.*
+  - crypton == 0.34.*
+  - crypton-x509 == 1.7.*
+  - crypton-x509-store == 1.6.*
+  - crypton-x509-validation == 1.6.*
+  - cryptostore == 0.3.*
   - data-default == 0.7.*
   - direct-sqlcipher == 2.3.*
   - directory == 1.3.*
@@ -50,7 +52,7 @@ dependencies:
   - iproute == 1.7.*
   - iso8601-time == 0.1.*
   - memory == 0.18.*
-  - mtl == 2.3.*
+  - mtl >= 2.3.1 && < 3.0
   - network >= 3.1.2.7 && < 3.2
   - network-info >= 0.2 && < 0.3
   - network-transport == 0.5.6
@@ -62,20 +64,14 @@ dependencies:
   - socks == 0.6.*
   - sqlcipher-simple == 0.4.*
   - stm == 2.5.*
-  - template-haskell >= 2.16 && < 2.21
   - temporary == 1.3.*
-  - text == 2.0.*
-  - time == 1.9.*
-  - time-compat == 1.9.*
+  - time == 1.12.*
   - time-manager == 0.0.*
-  - tls >= 1.6.0 && < 1.7
+  - tls >= 1.7.0 && < 1.8
   - transformers == 0.6.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
   - websockets == 0.12.*
-  - x509 == 1.7.*
-  - x509-store == 1.6.*
-  - x509-validation == 1.6.*
   - yaml == 0.11.*
 
 flags:
@@ -83,11 +79,25 @@ flags:
     description: Enable swift JSON format
     manual: True
     default: False
+  use_crypton:
+    description: Use crypton etc. in cryptostore
+    manual: True
+    default: True
 
 when:
   - condition: flag(swift)
     cpp-options:
       - -DswiftJSON
+  - condition: impl(ghc >= 9.6.2)
+    dependencies:
+      - bytestring == 0.11.*
+      - template-haskell == 2.20.*
+      - text >= 2.0.1 && < 2.2
+  - condition: impl(ghc < 9.6.2)
+    dependencies:
+      - bytestring == 0.10.*
+      - template-haskell == 2.16.*
+      - text >= 1.2.3.0 && < 1.3
 
 library:
   source-dirs: src

simplexmq.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.36.0.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -34,6 +34,11 @@ flag swift
   manual: True
   default: False
 
+flag use_crypton
+  description: Use crypton etc. in cryptostore
+  manual: True
+  default: True
+
 library
   exposed-modules:
       Simplex.FileTransfer.Agent
@@ -174,13 +179,15 @@ library
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -192,7 +199,7 @@ library
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -204,24 +211,28 @@ library
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3
 
 executable ntf-server
   main-is: Main.hs
@@ -239,13 +250,15 @@ executable ntf-server
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -257,7 +270,7 @@ executable ntf-server
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -270,24 +283,28 @@ executable ntf-server
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3
 
 executable smp-agent
   main-is: Main.hs
@@ -305,13 +322,15 @@ executable smp-agent
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -323,7 +342,7 @@ executable smp-agent
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -336,24 +355,28 @@ executable smp-agent
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3
 
 executable smp-server
   main-is: Main.hs
@@ -371,13 +394,15 @@ executable smp-server
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -389,7 +414,7 @@ executable smp-server
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -402,24 +427,28 @@ executable smp-server
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3
 
 executable xftp
   main-is: Main.hs
@@ -437,13 +466,15 @@ executable xftp
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -455,7 +486,7 @@ executable xftp
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -468,24 +499,28 @@ executable xftp
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3
 
 executable xftp-server
   main-is: Main.hs
@@ -503,13 +538,15 @@ executable xftp-server
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -521,7 +558,7 @@ executable xftp-server
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -534,24 +571,28 @@ executable xftp-server
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3
 
 test-suite simplexmq-test
   type: exitcode-stdio-1.0
@@ -600,13 +641,15 @@ test-suite simplexmq-test
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , bytestring ==0.11.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , cryptonite ==0.30.*
-    , cryptostore ==0.2.*
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
     , data-default ==0.7.*
     , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
@@ -623,7 +666,7 @@ test-suite simplexmq-test
     , iso8601-time ==0.1.*
     , main-tester ==0.2.*
     , memory ==0.18.*
-    , mtl ==2.3.*
+    , mtl >=2.3.1 && <3.0
     , network >=3.1.2.7 && <3.2
     , network-info ==0.2.*
     , network-transport ==0.5.6
@@ -637,22 +680,26 @@ test-suite simplexmq-test
     , socks ==0.6.*
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , template-haskell >=2.16 && <2.21
     , temporary ==1.3.*
-    , text ==2.0.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
+    , time ==1.12.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
     , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3

src/Simplex/Messaging/Agent.hs

@@ -64,6 +64,7 @@ module Simplex.Messaging.Agent
     resubscribeConnection,
     resubscribeConnections,
     sendMessage,
+    sendMessages,
     ackMessage,
     switchConnection,
     abortConnectionSwitch,
@@ -119,14 +120,17 @@ import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:), (.:.), (.::), (.::.))
-import Data.Foldable (foldl')
+import Data.Either (rights)
+import Data.Foldable (foldl', toList)
 import Data.Functor (($>))
+import Data.Functor.Identity
 import Data.List (find)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
+import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock
@@ -277,6 +281,12 @@ resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
 sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
 sendMessage c = withAgentEnv c .:. sendMessage' c
 
+type MsgReq = (ConnId, MsgFlags, MsgBody)
+
+-- | Send multiple messages to different connections (SEND command)
+sendMessages :: MonadUnliftIO m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
+sendMessages c = withAgentEnv c . sendMessages' c
+
 ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
 ackMessage c = withAgentEnv c .:. ackMessage' c
 
@@ -849,37 +859,47 @@ getNotificationMessage' c nonce encNtfInfo = do
       (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
       ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
       maxMsgs <- asks $ ntfMaxMessages . config
-      (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId maxMsgs ntfMsgMeta []
+      (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId ntfMsgMeta maxMsgs
     _ -> throwError $ CMD PROHIBITED
   where
-    getNtfMessages ntfConnId maxMs nMeta ms
-      | length ms < maxMs =
-          getConnectionMessage' c ntfConnId >>= \case
-            Just m@SMP.SMPMsgMeta {msgId, msgTs, msgFlags} -> case nMeta of
-              Just SMP.NMsgMeta {msgId = msgId', msgTs = msgTs'}
-                | msgId == msgId' || msgTs > msgTs' -> pure $ reverse (m : ms)
-                | otherwise -> getMsg (m : ms)
-              _
-                | SMP.notification msgFlags -> pure $ reverse (m : ms)
-                | otherwise -> getMsg (m : ms)
-            _ -> pure $ reverse ms
-      | otherwise = pure $ reverse ms
+    getNtfMessages ntfConnId nMeta = getMsg
       where
-        getMsg = getNtfMessages ntfConnId maxMs nMeta
+        getMsg 0 = pure []
+        getMsg n =
+          getConnectionMessage' c ntfConnId >>= \case
+            Just m
+              | lastMsg m -> pure [m]
+              | otherwise -> (m :) <$> getMsg (n - 1)
+            Nothing -> pure []
+        lastMsg SMP.SMPMsgMeta {msgId, msgTs, msgFlags} = case nMeta of
+          Just SMP.NMsgMeta {msgId = msgId', msgTs = msgTs'} -> msgId == msgId' || msgTs > msgTs'
+          Nothing -> SMP.notification msgFlags
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
-sendMessage' c connId msgFlags msg = withConnLock c connId "sendMessage" $ do
-  SomeConn _ conn <- withStore c (`getConn` connId)
-  case conn of
-    DuplexConnection cData _ sqs -> enqueueMsgs cData sqs
-    SndConnection cData sq -> enqueueMsgs cData [sq]
-    _ -> throwError $ CONN SIMPLEX
+sendMessage' c connId msgFlags msg = liftEither . runIdentity =<< sendMessagesB c (Identity (Right (connId, msgFlags, msg)))
+
+-- | Send multiple messages to different connections (SEND command) in Reader monad
+sendMessages' :: forall m. AgentMonad' m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
+sendMessages' c = sendMessagesB c . map Right
+
+sendMessagesB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType AgentMsgId))
+sendMessagesB c reqs = withConnLocks c connIds "sendMessages" $ do
+  reqs' <- withStoreBatch c (\db -> fmap (mapE $ \req@(connId, _, _) -> bimap storeError (req,) <$> getConn db connId) reqs)
+  let reqs'' = fmap (>>= prepareConn) reqs'
+  enqueueMessagesB c reqs''
   where
-    enqueueMsgs :: ConnData -> NonEmpty SndQueue -> m AgentMsgId
-    enqueueMsgs cData sqs = do
-      when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
-      enqueueMessages c cData sqs msgFlags $ A_MSG msg
+    prepareConn :: (MsgReq, SomeConn) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
+    prepareConn ((_, msgFlags, msg), SomeConn _ conn) = case conn of
+      DuplexConnection cData _ sqs -> prepareMsgs cData sqs
+      SndConnection cData sq -> prepareMsgs cData [sq]
+      _ -> Left $ CONN SIMPLEX
+      where
+        prepareMsgs :: ConnData -> NonEmpty SndQueue -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
+        prepareMsgs cData sqs
+          | ratchetSyncSendProhibited cData = Left $ CMD PROHIBITED
+          | otherwise = Right (cData, sqs, msgFlags, A_MSG msg)
+    connIds = foldl' (\cs -> either (\_ -> cs) (\(connId, _, _) -> S.insert connId cs)) S.empty reqs
 
 -- / async command processing v v v
 
@@ -1058,22 +1078,37 @@ enqueueMessages c cData sqs msgFlags aMessage = do
   enqueueMessages' c cData sqs msgFlags aMessage
 
 enqueueMessages' :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
-enqueueMessages' c cData (sq :| sqs) msgFlags aMessage = do
-  msgId <- enqueueMessage c cData sq msgFlags aMessage
-  mapM_ (enqueueSavedMessage c cData msgId) $
-    filter (\SndQueue {status} -> status == Secured || status == Active) sqs
-  pure msgId
+enqueueMessages' c cData sqs msgFlags aMessage =
+  liftEither . runIdentity =<< enqueueMessagesB c (Identity (Right (cData, sqs, msgFlags, aMessage)))
+
+enqueueMessagesB :: (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType AgentMsgId))
+enqueueMessagesB c reqs = do
+  reqs' <- enqueueMessageB c reqs
+  enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs'
+  pure $ fst <$$> reqs'
+
+isActiveSndQ :: SndQueue -> Bool
+isActiveSndQ SndQueue {status} = status == Secured || status == Active
 
 enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
-enqueueMessage c cData@ConnData {connId} sq msgFlags aMessage = do
-  resumeMsgDelivery c cData sq
-  aVRange <- asks $ smpAgentVRange . config
-  msgId <- storeSentMsg $ maxVersion aVRange
-  queuePendingMsgs c sq [msgId]
-  pure $ unId msgId
+enqueueMessage c cData sq msgFlags aMessage =
+  liftEither . fmap fst . runIdentity =<< enqueueMessageB c (Identity (Right (cData, [sq], msgFlags, aMessage)))
+
+-- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries
+enqueueMessageB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType (AgentMsgId, Maybe (ConnData, [SndQueue], AgentMsgId))))
+enqueueMessageB c reqs = do
+  void . forME reqs $ \(cData, sq :| _, _, _) ->
+    runExceptT $ resumeMsgDelivery c cData sq
+  aVRange <- asks $ maxVersion . smpAgentVRange . config
+  reqMids <- withStoreBatch c $ \db -> fmap (mapE $ storeSentMsg db aVRange) reqs
+  forME reqMids $ \((cData, sq :| sqs, _, _), mId) -> do
+    let InternalId msgId = mId
+    queuePendingMsgs c sq [mId]
+    let sqs' = filter isActiveSndQ sqs
+    pure $ Right (msgId, if null sqs' then Nothing else Just (cData, sqs', msgId))
   where
-    storeSentMsg :: Version -> m InternalId
-    storeSentMsg agentVersion = withStore c $ \db -> runExceptT $ do
+    storeSentMsg :: DB.Connection -> Version -> (ConnData, NonEmpty SndQueue, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, MsgFlags, AMessage), InternalId))
+    storeSentMsg db agentVersion req@(ConnData {connId}, sq :| _, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
       internalTs <- liftIO getCurrentTime
       (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
@@ -1086,14 +1121,25 @@ enqueueMessage c cData@ConnData {connId} sq msgFlags aMessage = do
           msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, internalHash, prevMsgHash}
       liftIO $ createSndMsg db connId msgData
       liftIO $ createSndMsgDelivery db connId sq internalId
-      pure internalId
+      pure (req, internalId)
 
-enqueueSavedMessage :: AgentMonad m => AgentClient -> ConnData -> AgentMsgId -> SndQueue -> m ()
-enqueueSavedMessage c cData@ConnData {connId} msgId sq = do
-  resumeMsgDelivery c cData sq
-  let mId = InternalId msgId
-  queuePendingMsgs c sq [mId]
-  withStore' c $ \db -> createSndMsgDelivery db connId sq mId
+enqueueSavedMessage :: AgentMonad' m => AgentClient -> ConnData -> AgentMsgId -> SndQueue -> m ()
+enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId)
+
+enqueueSavedMessageB :: (AgentMonad' m, Foldable t) => AgentClient -> t (ConnData, [SndQueue], AgentMsgId) -> m ()
+enqueueSavedMessageB c reqs = do
+  -- saving to the database has to be before enqueue to avoid race condition when delivery is read from queue before it is saved
+  void $ withStoreBatch' c $ \db -> concatMap (storeDeliveries db) reqs
+  forM_ reqs $ \(cData, sqs, msgId) ->
+    forM sqs $ \sq -> do
+      void . runExceptT $ resumeMsgDelivery c cData sq
+      let mId = InternalId msgId
+      queuePendingMsgs c sq [mId]
+  where
+    storeDeliveries :: DB.Connection -> (ConnData, [SndQueue], AgentMsgId) -> [IO ()]
+    storeDeliveries db (ConnData {connId}, sqs, msgId) = do
+      let mId = InternalId msgId
+       in map (\sq -> createSndMsgDelivery db connId sq mId) sqs
 
 resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
 resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
@@ -1103,20 +1149,23 @@ resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
       >>= \a -> atomically (TM.insert qKey a $ smpQueueMsgDeliveries c)
   unlessM msgsQueued $
     withStore' c (\db -> getPendingMsgs db connId sq)
-      >>= queuePendingMsgs c sq
+      >>= queuePendingMsgs' c False sq
   where
     queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
     msgsQueued = atomically $ isJust <$> TM.lookupInsert (server, sndId) True (pendingMsgsQueued c)
 
 queuePendingMsgs :: AgentMonad' m => AgentClient -> SndQueue -> [InternalId] -> m ()
-queuePendingMsgs c sq msgIds = atomically $ do
-  modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds}
+queuePendingMsgs c = queuePendingMsgs' c True
+
+queuePendingMsgs' :: AgentMonad' m => AgentClient -> Bool -> SndQueue -> [InternalId] -> m ()
+queuePendingMsgs' c setDeliveryOps sq msgIds = atomically $ do
+  when setDeliveryOps $ modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds}
   -- s <- readTVar (msgDeliveryOp c)
   -- unsafeIOToSTM $ putStrLn $ "msgDeliveryOp: " <> show (opsInProgress s)
   (mq, _) <- getPendingMsgQ c sq
-  mapM_ (writeTQueue mq) msgIds
+  mapM_ (writeTQueue mq . (,setDeliveryOps)) msgIds
 
-getPendingMsgQ :: AgentClient -> SndQueue -> STM (TQueue InternalId, TMVar ())
+getPendingMsgQ :: AgentClient -> SndQueue -> STM (TQueue (InternalId, Bool), TMVar ())
 getPendingMsgQ c SndQueue {server, sndId} = do
   let qKey = (server, sndId)
   maybe (newMsgQueue qKey) pure =<< TM.lookup qKey (smpQueueMsgQueues c)
@@ -1134,9 +1183,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
     atomically $ endAgentOperation c AOSndNetwork
     atomically $ throwWhenInactive c
     atomically $ throwWhenNoDelivery c sq
-    msgId <- atomically $ readTQueue mq
+    (msgId, deliveryOp) <- atomically $ readTQueue mq
     atomically $ beginAgentOperation c AOSndNetwork
-    atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in queuePendingMsgs
+    when deliveryOp $ atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in queuePendingMsgs
     let mId = unId msgId
     tryAgentError (withStore c $ \db -> getPendingMsgData db connId msgId) >>= \case
       Left e -> notify $ MERR mId e
@@ -1885,10 +1934,13 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
       cData@ConnData {userId, connId, duplexHandshake, connAgentVersion, ratchetSyncState = rss} =
         withConnLock c connId "processSMP" $ case cmd of
           SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} ->
-            handleNotifyAck $
-              decryptSMPMessage v rq msg >>= \case
+            handleNotifyAck $ do
+              msg' <- decryptSMPMessage v rq msg
+              handleNotifyAck $ case msg' of
                 SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
                 SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
+              whenM (atomically $ hasGetLock c rq) $
+                notify (MSGNTF $ SMP.rcvMessageMeta srvMsgId msg')
             where
               queueDrained = case conn of
                 DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ QCONT (sndAddress rq)
@@ -2430,8 +2482,7 @@ storeConfirmation c ConnData {connId, connAgentVersion} sq e2eEncryption_ agentM
 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
+  mapM_ (enqueueSavedMessage c cData msgId) $ filter isActiveSndQ sqs
   pure msgId
 
 enqueueRatchetKey :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> CR.E2ERatchetParams 'C.X448 -> m AgentMsgId

src/Simplex/Messaging/Agent/Client.hs

@@ -24,6 +24,7 @@ module Simplex.Messaging.Agent.Client
     ProtocolTestStep (..),
     newAgentClient,
     withConnLock,
+    withConnLocks,
     withInvLock,
     closeAgentClient,
     closeProtocolServerClients,
@@ -72,6 +73,7 @@ module Simplex.Messaging.Agent.Client
     logSecret,
     removeSubscription,
     hasActiveSubscription,
+    hasGetLock,
     agentClientStore,
     agentDRG,
     getAgentSubscriptions,
@@ -98,6 +100,8 @@ module Simplex.Messaging.Agent.Client
     withStore',
     withStoreCtx,
     withStoreCtx',
+    withStoreBatch,
+    withStoreBatch',
     storeError,
     userServers,
     pickServer,
@@ -234,7 +238,7 @@ data AgentClient = AgentClient
     pendingSubs :: TRcvQueues,
     removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
     pendingMsgsQueued :: TMap SndQAddr Bool,
-    smpQueueMsgQueues :: TMap SndQAddr (TQueue InternalId, TMVar ()),
+    smpQueueMsgQueues :: TMap SndQAddr (TQueue (InternalId, Bool), TMVar ()),
     smpQueueMsgDeliveries :: TMap SndQAddr (Async ()),
     connCmdsQueued :: TMap ConnId Bool,
     asyncCmdQueues :: TMap (Maybe SMPServer) (TQueue AsyncCmdId),
@@ -657,8 +661,17 @@ withConnLock AgentClient {connLocks} connId name = withLockMap_ connLocks connId
 withInvLock :: MonadUnliftIO m => AgentClient -> ByteString -> String -> m a -> m a
 withInvLock AgentClient {invLocks} = withLockMap_ invLocks
 
+withConnLocks :: MonadUnliftIO m => AgentClient -> Set ConnId -> String -> m a -> m a
+withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . S.filter (not . B.null)
+
 withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
-withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pure
+withLockMap_ = withGetLock . getMapLock
+
+withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> String -> m a -> m a
+withLocksMap_ = withGetLocks . getMapLock
+
+getMapLock :: Ord k => TMap k Lock -> k -> STM Lock
+getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
   where
     newLock = createLock >>= \l -> TM.insert key l locks $> l
 
@@ -897,8 +910,8 @@ subscribeQueues c qs = do
   -- 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
+    checkQueue rq = do
+      prohibited <- atomically $ hasGetLock c rq
       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
@@ -1049,6 +1062,10 @@ sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
     ackSMPMessage smp rcvPrivateKey rcvId msgId
   atomically $ releaseGetLock c rq
 
+hasGetLock :: AgentClient -> RcvQueue -> STM Bool
+hasGetLock c RcvQueue {server, rcvId} =
+  TM.member (server, rcvId) $ getMsgLocks c
+
 releaseGetLock :: AgentClient -> RcvQueue -> STM ()
 releaseGetLock c RcvQueue {server, rcvId} =
   TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
@@ -1286,6 +1303,18 @@ withStoreCtx_ ctx_ c action = do
     handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
     handleInternal ctxStr e = pure . Left . SEInternal . B.pack $ show e <> ctxStr
 
+withStoreBatch :: (AgentMonad' m, Traversable t) => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> m (t (Either AgentErrorType a))
+withStoreBatch c actions = do
+  st <- asks store
+  liftIO $ agentOperationBracket c AODatabase (\_ -> pure ()) $
+      withTransaction st $ mapM (`E.catch` handleInternal) . actions
+  where
+    handleInternal :: E.SomeException -> IO (Either AgentErrorType a)
+    handleInternal = pure . Left . INTERNAL . show
+
+withStoreBatch' :: (AgentMonad' m, Traversable t) => AgentClient -> (DB.Connection -> t (IO a)) -> m (t (Either AgentErrorType a))
+withStoreBatch' c actions = withStoreBatch c $ \db -> fmap Right <$> actions db
+
 storeError :: StoreError -> AgentErrorType
 storeError = \case
   SEConnNotFound -> CONN NOT_FOUND

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

@@ -34,6 +34,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
+import Data.ByteArray (ScrubbedBytes)
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
@@ -163,7 +164,7 @@ defaultAgentConfig =
       ntfWorkerDelay = 100000, -- microseconds
       ntfSMPWorkerDelay = 500000, -- microseconds
       ntfSubCheckInterval = nominalDay,
-      ntfMaxMessages = 4,
+      ntfMaxMessages = 3,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -196,8 +197,8 @@ newSMPAgentEnv config@AgentConfig {initialClientId} store = do
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
-createAgentStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
-createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
+createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
+createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey keepKey Migrations.app
 
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),

src/Simplex/Messaging/Agent/Lock.hs

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

src/Simplex/Messaging/Agent/Protocol.hs

@@ -193,6 +193,7 @@ import Simplex.Messaging.Protocol
     MsgId,
     NMsgMeta,
     ProtocolServer (..),
+    SMPMsgMeta,
     SMPServer,
     SMPServerWithAuth,
     SndPublicVerifyKey,
@@ -337,6 +338,7 @@ 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
+  MSGNTF :: SMPMsgMeta -> ACommand Agent AEConn
   ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn
   RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn
   SWCH :: ACommand Client AEConn
@@ -397,6 +399,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   SENT_ :: ACommandTag Agent AEConn
   MERR_ :: ACommandTag Agent AEConn
   MSG_ :: ACommandTag Agent AEConn
+  MSGNTF_ :: ACommandTag Agent AEConn
   ACK_ :: ACommandTag Client AEConn
   RCVD_ :: ACommandTag Agent AEConn
   SWCH_ :: ACommandTag Client AEConn
@@ -450,6 +453,7 @@ aCommandTag = \case
   SENT _ -> SENT_
   MERR {} -> MERR_
   MSG {} -> MSG_
+  MSGNTF {} -> MSGNTF_
   ACK {} -> ACK_
   RCVD {} -> RCVD_
   SWCH -> SWCH_
@@ -1604,6 +1608,7 @@ instance StrEncoding ACmdTag where
       "SENT" -> ct SENT_
       "MERR" -> ct MERR_
       "MSG" -> ct MSG_
+      "MSGNTF" -> ct MSGNTF_
       "ACK" -> t ACK_
       "RCVD" -> ct RCVD_
       "SWCH" -> t SWCH_
@@ -1659,6 +1664,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     SENT_ -> "SENT"
     MERR_ -> "MERR"
     MSG_ -> "MSG"
+    MSGNTF_ -> "MSGNTF"
     ACK_ -> "ACK"
     RCVD_ -> "RCVD"
     SWCH_ -> "SWCH"
@@ -1727,6 +1733,7 @@ commandP binaryP =
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
           MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP)
+          MSGNTF_ -> s (MSGNTF <$> strP)
           RCVD_ -> s (RCVD <$> strP <* A.space <*> strP)
           DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP)
           DEL_CONN_ -> pure DEL_CONN
@@ -1781,6 +1788,7 @@ serializeCommand = \case
   SENT mId -> s (SENT_, Str $ bshow mId)
   MERR mId e -> s (MERR_, Str $ bshow mId, e)
   MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, s msgMeta, smpEncode msgFlags, serializeBinary msgBody]
+  MSGNTF smpMsgMeta -> s (MSGNTF_, smpMsgMeta)
   ACK mId rcptInfo_ -> s (ACK_, Str $ bshow mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_
   RCVD msgMeta rcpts -> s (RCVD_, msgMeta, rcpts)
   SWCH -> s SWCH_

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

@@ -31,7 +31,10 @@ module Simplex.Messaging.Agent.Store.SQLite
     connectSQLiteStore,
     closeSQLiteStore,
     openSQLiteStore,
+    reopenSQLiteStore,
     sqlString,
+    keyString,
+    storeKey,
     execSQL,
     upMigration, -- used in tests
 
@@ -221,6 +224,8 @@ import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (second)
+import Data.ByteArray (ScrubbedBytes)
+import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import Data.Char (toLower)
@@ -267,7 +272,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, from
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ifM, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ifM, safeDecodeUtf8, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
@@ -316,11 +321,11 @@ instance StrEncoding MigrationConfirmation where
       "error" -> pure MCError
       _ -> fail "invalid MigrationConfirmation"
 
-createSQLiteStore :: FilePath -> String -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
-createSQLiteStore dbFilePath dbKey migrations confirmMigrations = do
+createSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
+createSQLiteStore dbFilePath dbKey keepKey migrations confirmMigrations = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing True dbDir
-  st <- connectSQLiteStore dbFilePath dbKey
+  st <- connectSQLiteStore dbFilePath dbKey keepKey
   r <- migrateSchema st migrations confirmMigrations `onException` closeSQLiteStore st
   case r of
     Right () -> pure $ Right st
@@ -366,17 +371,17 @@ confirmOrExit s = do
   ok <- getLine
   when (map toLower ok /= "y") exitFailure
 
-connectSQLiteStore :: FilePath -> String -> IO SQLiteStore
-connectSQLiteStore dbFilePath dbKey = do
+connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> IO SQLiteStore
+connectSQLiteStore dbFilePath key keepKey = do
   dbNew <- not <$> doesFileExist dbFilePath
-  dbConn <- dbBusyLoop (connectDB dbFilePath dbKey)
+  dbConn <- dbBusyLoop (connectDB dbFilePath key)
   atomically $ do
     dbConnection <- newTMVar dbConn
-    dbEncrypted <- newTVar . not $ null dbKey
+    dbKey <- newTVar $! storeKey key keepKey
     dbClosed <- newTVar False
-    pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection, dbNew, dbClosed}
+    pure SQLiteStore {dbFilePath, dbKey, dbConnection, dbNew, dbClosed}
 
-connectDB :: FilePath -> String -> IO DB.Connection
+connectDB :: FilePath -> ScrubbedBytes -> IO DB.Connection
 connectDB path key = do
   db <- DB.open path
   prepare db `onException` DB.close db
@@ -385,7 +390,7 @@ connectDB path key = do
   where
     prepare db = do
       let exec = SQLite3.exec $ SQL.connectionHandle $ DB.conn db
-      unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";"
+      unless (BA.null key) . exec $ "PRAGMA key = " <> keyString key <> ";"
       exec . fromQuery $
         [sql|
           PRAGMA busy_timeout = 100;
@@ -402,22 +407,36 @@ closeSQLiteStore st@SQLiteStore {dbClosed} =
       DB.close conn
       atomically $ writeTVar dbClosed True
 
-openSQLiteStore :: SQLiteStore -> String -> IO ()
-openSQLiteStore SQLiteStore {dbConnection, dbFilePath, dbClosed} key =
-  ifM (readTVarIO dbClosed) open (putStrLn "closeSQLiteStore: already opened")
+openSQLiteStore :: SQLiteStore -> ScrubbedBytes -> Bool -> IO ()
+openSQLiteStore st@SQLiteStore {dbClosed} key keepKey =
+  ifM (readTVarIO dbClosed) (openSQLiteStore_ st key keepKey) (putStrLn "openSQLiteStore: already opened")
+
+openSQLiteStore_ :: SQLiteStore -> ScrubbedBytes -> Bool -> IO ()
+openSQLiteStore_ SQLiteStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey =
+  bracketOnError
+    (atomically $ takeTMVar dbConnection)
+    (atomically . tryPutTMVar dbConnection)
+    $ \DB.Connection {slow} -> do
+      DB.Connection {conn} <- connectDB dbFilePath key
+      atomically $ do
+        putTMVar dbConnection DB.Connection {conn, slow}
+        writeTVar dbClosed False
+        writeTVar dbKey $! storeKey key keepKey
+
+reopenSQLiteStore :: SQLiteStore -> IO ()
+reopenSQLiteStore st@SQLiteStore {dbKey, dbClosed} =
+  ifM (readTVarIO dbClosed) open (putStrLn "reopenSQLiteStore: already opened")
   where
     open =
-      bracketOnError
-        (atomically $ takeTMVar dbConnection)
-        (atomically . tryPutTMVar dbConnection)
-        $ \DB.Connection {slow} -> do
-          DB.Connection {conn} <- connectDB dbFilePath key
-          atomically $ do
-            putTMVar dbConnection DB.Connection {conn, slow}
-            writeTVar dbClosed False
+      readTVarIO dbKey >>= \case
+        Just key -> openSQLiteStore_ st key True
+        Nothing -> fail "reopenSQLiteStore: no key"
 
-sqlString :: String -> Text
-sqlString s = quote <> T.replace quote "''" (T.pack s) <> quote
+keyString :: ScrubbedBytes -> Text
+keyString = sqlString . safeDecodeUtf8 . BA.convert
+
+sqlString :: Text -> Text
+sqlString s = quote <> T.replace quote "''" s <> quote
   where
     quote = "'"
 

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

@@ -10,10 +10,13 @@ module Simplex.Messaging.Agent.Store.SQLite.Common
     withTransaction',
     withTransactionCtx,
     dbBusyLoop,
+    storeKey,
   )
 where
 
 import Control.Concurrent (threadDelay)
+import Data.ByteArray (ScrubbedBytes)
+import qualified Data.ByteArray as BA
 import Data.Time.Clock (diffUTCTime, getCurrentTime)
 import Database.SQLite.Simple (SQLError)
 import qualified Database.SQLite.Simple as SQL
@@ -23,9 +26,12 @@ import UnliftIO.Exception (bracket)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
+storeKey :: ScrubbedBytes -> Bool -> Maybe ScrubbedBytes
+storeKey key keepKey = if keepKey || BA.null key then Just key else Nothing
+
 data SQLiteStore = SQLiteStore
   { dbFilePath :: FilePath,
-    dbEncrypted :: TVar Bool,
+    dbKey :: TVar (Maybe ScrubbedBytes),
     dbConnection :: TMVar DB.Connection,
     dbClosed :: TVar Bool,
     dbNew :: Bool

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

@@ -48,7 +48,7 @@ timeIt slow sql a = do
   r <- a
   t' <- getCurrentTime
   let diff = diffToMilliseconds $ diffUTCTime t' t
-  atomically $ when (diff > 50) $ TM.alter (updateQueryStats diff) sql slow
+  atomically $ when (diff > 5) $ TM.alter (updateQueryStats diff) sql slow
   pure r
   where
     updateQueryStats :: Int64 -> Maybe SlowQueryStats -> Maybe SlowQueryStats

src/Simplex/Messaging/Client.hs

@@ -226,9 +226,9 @@ defaultNetworkConfig =
       hostMode = HMOnionViaSocks,
       requiredHostMode = False,
       sessionMode = TSMUser,
-      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
+      tcpConnectTimeout = 20_000_000,
+      tcpTimeout = 15_000_000,
+      tcpTimeoutPerKb = 45_000, -- 45ms, should be less than 130ms to avoid Int overflow on 32 bit systems
       tcpKeepAlive = Just defaultKeepAliveOpts,
       smpPingInterval = 600_000_000, -- 10min
       smpPingCount = 3,

src/Simplex/Messaging/Protocol.hs

@@ -460,7 +460,14 @@ data SMPMsgMeta = SMPMsgMeta
     msgTs :: SystemTime,
     msgFlags :: MsgFlags
   }
-  deriving (Show)
+  deriving (Eq, Show)
+
+instance StrEncoding SMPMsgMeta where
+  strEncode SMPMsgMeta {msgId, msgTs, msgFlags} =
+    strEncode (msgId, msgTs, msgFlags)
+  strP = do
+    (msgId, msgTs, msgFlags) <- strP
+    pure SMPMsgMeta {msgId, msgTs, msgFlags}
 
 rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
 rcvMessageMeta msgId = \case

src/Simplex/Messaging/Server/Stats.hs

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

src/Simplex/Messaging/Util.hs

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

stack.yaml

@@ -1,88 +0,0 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: nightly-2023-08-22
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-#   subdirs:
-#   - auto-update
-#   - wai
-packages:
-  - .
-# Dependency packages to be pulled from upstream that are not in the resolver.
-# These entries can reference officially published versions as well as
-# forks / in-progress versions pinned to a git hash. For example:
-#
-extra-deps:
-  - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
-  - network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
-  - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
-  - tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987
-  # below dependencies are to update Aeson to 2.0.3
-  - OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
-  - attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
-  - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005
-  - semialign-1.2.0.1@sha256:0e179b4d3a8eff79001d374d6c91917c6221696b9620f0a4d86852fc6a9b9501,2836
-  - text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498
-  - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
-  - github: simplex-chat/aeson
-    commit: aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b
-  - github: kazu-yamamoto/http2
-    commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb
-  # - ../direct-sqlcipher
-  - github: simplex-chat/direct-sqlcipher
-    commit: f814ee68b16a9447fbb467ccc8f29bdd3546bfd9
-  # - ../sqlcipher-simple
-  - github: simplex-chat/sqlcipher-simple
-    commit: a46bd361a19376c5211f1058908fc0ae6bf42446
-  - github: simplex-chat/network-transport
-    commit: 0013798272a683e35ca38d2fdaf480942311fba8
-  # - ../hs-tls/core
-  # - github: simplex-chat/hs-tls
-  #   commit: f6cc753611f80af300401cfae63846e9d7c40d9e
-  #   subdirs:
-  #     - core
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=2.1"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor

tests/AgentTests/FunctionalAPITests.hs

@@ -1010,34 +1010,35 @@ testOnlyCreatePull :: IO ()
 testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate
   aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
-  getMsg alice bobId
-  Just ("", _, CONF confId _ "bob's connInfo") <- timeout 5_000000 $ get alice
+  Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
-  getMsg bob aliceId
-  get bob ##> ("", aliceId, INFO "alice's connInfo")
+  getMsg bob aliceId $
+    get bob ##> ("", aliceId, INFO "alice's connInfo")
   liftIO $ threadDelay 1_000000
-  getMsg alice bobId
+  getMsg alice bobId $ pure ()
   get alice ##> ("", bobId, CON)
-  getMsg bob aliceId
-  get bob ##> ("", aliceId, CON)
+  getMsg bob aliceId $
+    get bob ##> ("", aliceId, CON)
   -- exchange messages
   4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
   get alice ##> ("", bobId, SENT 4)
-  getMsg bob aliceId
-  get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+  getMsg bob aliceId $
+    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
   ackMessage bob aliceId 4 Nothing
   5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
   get bob ##> ("", aliceId, SENT 5)
-  getMsg alice bobId
-  get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
+  getMsg alice bobId $
+    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
   ackMessage alice bobId 5 Nothing
   where
-    getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-    getMsg c cId = do
+    getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a
+    getMsg c cId action = do
       liftIO $ noMessages c "nothing should be delivered before GET"
       Just _ <- getConnectionMessage c cId
-      pure ()
+      r <- action
+      get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False
+      pure r
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection alice bob = makeConnectionForUsers alice 1 bob 1
@@ -2049,7 +2050,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
 
 getSMPAgentClient' :: AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient
 getSMPAgentClient' cfg' initServers dbPath = do
-  Right st <- liftIO $ createAgentStore dbPath "" MCError
+  Right st <- liftIO $ createAgentStore dbPath "" False MCError
   getSMPAgentClient cfg' initServers st
 
 testServerMultipleIdentities :: HasCallStack => IO ()

tests/AgentTests/MigrationTests.hs

@@ -178,16 +178,16 @@ testMigration ::
 testMigration (initMs, initTables) (finalMs, confirmModes, tablesOrError) = forM_ confirmModes $ \confirmMode -> do
   r <- randomIO :: IO Word32
   let dpPath = testDB <> show r
-  Right st <- createSQLiteStore dpPath "" initMs MCError
+  Right st <- createSQLiteStore dpPath "" False initMs MCError
   st `shouldHaveTables` initTables
   closeSQLiteStore st
   case tablesOrError of
     Right tables -> do
-      Right st' <- createSQLiteStore dpPath "" finalMs confirmMode
+      Right st' <- createSQLiteStore dpPath "" False finalMs confirmMode
       st' `shouldHaveTables` tables
       closeSQLiteStore st'
     Left e -> do
-      Left e' <- createSQLiteStore dpPath "" finalMs confirmMode
+      Left e' <- createSQLiteStore dpPath "" False finalMs confirmMode
       e `shouldBe` e'
   removeFile dpPath
   where

tests/AgentTests/SQLiteTests.hs

@@ -16,6 +16,7 @@ import Control.Concurrent.STM
 import Control.Exception (SomeException)
 import Control.Monad (replicateM_)
 import Crypto.Random (drgNew)
+import Data.ByteArray (ScrubbedBytes)
 import Data.ByteString.Char8 (ByteString)
 import Data.List (isInfixOf)
 import qualified Data.Text as T
@@ -49,18 +50,18 @@ withStore2 = before connect2 . after (removeStore . fst)
     connect2 :: IO (SQLiteStore, SQLiteStore)
     connect2 = do
       s1 <- createStore
-      s2 <- connectSQLiteStore (dbFilePath s1) ""
+      s2 <- connectSQLiteStore (dbFilePath s1) "" False
       pure (s1, s2)
 
 createStore :: IO SQLiteStore
-createStore = createEncryptedStore ""
+createStore = createEncryptedStore "" False
 
-createEncryptedStore :: String -> IO SQLiteStore
-createEncryptedStore key = do
+createEncryptedStore :: ScrubbedBytes -> Bool -> IO SQLiteStore
+createEncryptedStore key keepKey = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  Right st <- createSQLiteStore (testDB <> show r) key Migrations.app MCError
+  Right st <- createSQLiteStore (testDB <> show r) key keepKey Migrations.app MCError
   pure st
 
 removeStore :: SQLiteStore -> IO ()
@@ -112,6 +113,7 @@ storeTests = do
   describe "open/close store" $ do
     it "should close and re-open" testCloseReopenStore
     it "should close and re-open encrypted store" testCloseReopenEncryptedStore
+    it "should close and re-open encrypted store (keep key)" testReopenEncryptedStoreKeepKey
 
 testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
 testConcurrentWrites =
@@ -520,28 +522,39 @@ testCloseReopenStore = do
   closeSQLiteStore st
   closeSQLiteStore st
   errorGettingMigrations st
-  openSQLiteStore st ""
-  openSQLiteStore st ""
+  openSQLiteStore st "" False
+  openSQLiteStore st "" False
   hasMigrations st
   closeSQLiteStore st
   errorGettingMigrations st
-  openSQLiteStore st ""
+  reopenSQLiteStore st
   hasMigrations st
 
 testCloseReopenEncryptedStore :: IO ()
 testCloseReopenEncryptedStore = do
   let key = "test_key"
-  st <- createEncryptedStore key
+  st <- createEncryptedStore key False
   hasMigrations st
   closeSQLiteStore st
   closeSQLiteStore st
   errorGettingMigrations st
-  openSQLiteStore st key
-  openSQLiteStore st key
+  reopenSQLiteStore st `shouldThrow` \(e :: SomeException) -> "reopenSQLiteStore: no key" `isInfixOf` show e
+  openSQLiteStore st key True
+  openSQLiteStore st key True
   hasMigrations st
   closeSQLiteStore st
   errorGettingMigrations st
-  openSQLiteStore st key
+  reopenSQLiteStore st
+  hasMigrations st
+
+testReopenEncryptedStoreKeepKey :: IO ()
+testReopenEncryptedStoreKeepKey = do
+  let key = "test_key"
+  st <- createEncryptedStore key True
+  hasMigrations st
+  closeSQLiteStore st
+  errorGettingMigrations st
+  reopenSQLiteStore st
   hasMigrations st
 
 getMigrations :: SQLiteStore -> IO Bool

tests/AgentTests/SchemaDump.hs

@@ -33,14 +33,14 @@ testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
   savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
   savedSchema `deepseq` pure ()
-  void $ createSQLiteStore testDB "" Migrations.app MCConsole
+  void $ createSQLiteStore testDB "" False Migrations.app MCConsole
   getSchema testDB appSchema `shouldReturn` savedSchema
   removeFile testDB
 
 testSchemaMigrations :: IO ()
 testSchemaMigrations = do
   let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app
-  Right st <- createSQLiteStore testDB "" noDownMigrations MCError
+  Right st <- createSQLiteStore testDB "" False noDownMigrations MCError
   mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app
   closeSQLiteStore st
   removeFile testDB

tests/SMPAgentClient.hs

@@ -213,7 +213,7 @@ withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
       initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
    in serverBracket
         ( \started -> do
-            Right st <- liftIO $ createAgentStore db' "" MCError
+            Right st <- liftIO $ createAgentStore db' "" False MCError
             runSMPAgentBlocking t cfg' initServers' st started
         )
         afterProcess

tests/XFTPServerTests.hs

@@ -142,7 +142,7 @@ runTestFileChunkDelete s r = do
   deleteXFTPChunk s spKey sId
   liftIO $
     readChunk sId
-      `shouldThrow` \(e :: SomeException) -> "withBinaryFile" `isInfixOf` show e
+      `shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e
   downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   deleteXFTPChunk s spKey sId