debug

This reverts commit c71f0d7beb.

.github/workflows/build.yml

@@ -63,7 +63,7 @@ jobs:
           mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}}
 
       - name: Build changelog
-        if: startsWith(github.ref, 'refs/tags/v')
+        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-22.04'
         id: build_changelog
         uses: mikepenz/release-changelog-builder-action@v1
         with:

CHANGELOG.md

@@ -1,54 +1,3 @@
-# 6.1.3
-
-SMP server: fix restoring notification credentials.
-
-# 6.1.2
-
-Servers: more reliable restoring of state.
-
-SMP server: reduced memory usage and faster start.
-
-Notifications: compensate for iOS notifications being droppted by Apple while device is offline (#1378):
-- Ntf server: send multiple SMP notifications in one iOS notification.
-- Agent: get multiple messages for one iOS notification.
-
-# 6.1.1
-
-SMP:
-- stop server faster (#1371)
-- add STORE error (#1372)
-
-# 6.1.0
-
-Version 6.1.0.7
-
-SMP server and client:
-- transport block encryption (#1317).
-
-Agent:
-- batch and optimize iOS notifications processing (#1308, #1311, #1313, #1316, #1330, #1331, #1333, #1337, #1346).
-- allow receiving multiple messages from single iOS notification (#1355, #1362).
-- prepare connection to accept to avoid race condition with events (#1365).
-- transport isolation mode "Session" (default) to use new SOCKS credentials when client restarts or SOCKS proxy configuration changes (#1321).
-
-Ntf server:
-- control port (#1354).
-- enable pings on ntf subscriptions, to resubscribe on reconnection (#1353).
-
-SMP server:
-- support multiple server ports (#1319).
-- support serving HTTPS and SMP transport on the same port (#1326, #1327).
-- persist iOS notifications to avoid losing them when Ntf server is offline (#1336, #1339, #1350).
-- fix lost notification subscriptions (#1347).
-- reject SKEY with different key earlier, at verification step (#1366).
-- pass server information via CLI during server initialization (#1356).
-- show version on server page (#1341).
-- explicit graceful shutdown on SIGINT (#1360).
-
-XRCP (remote access protocol):
-- use SHA3-256 in hybrid key agreement (#1302).
-- session encryption with forward secrecy (#1328).
-
 # 6.0.5
 
 SMP agent:

README.md

@@ -149,15 +149,8 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
 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 '53fcdb4ceab324316e2c4cda7e84dbbb344f32550a65975a7895425e5a1be757 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
+curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
+&& if echo 'c90886104cd640b2ed64921dba80e90691db36788e8d6dcc13d8f33f92f0ea54 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

apps/smp-server/static/index.html

@@ -295,12 +295,6 @@
                   <td>${hostingEntity} (${hostingCountry})</td>
                 </tr>
               </x-hosting>
-              <x-hostingType>
-                <tr class="text-grey-black dark:text-white text-base">
-                  <td>Hosting type:</td>
-                  <td>${hostingType}</td>
-                </tr>
-              </x-hostingType>
               <x-serverCountry>
                 <tr class="text-grey-black dark:text-white text-base">
                   <td>Server country:</td>

apps/smp-server/web/Static.hs

@@ -8,7 +8,6 @@ import Control.Logger.Simple
 import Control.Monad
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (toUpper)
 import Data.IORef (readIORef)
 import Data.Maybe (fromMaybe)
 import Data.String (fromString)
@@ -42,22 +41,23 @@ serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
     WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app
   where
     app = staticFiles webStaticPath
-    mkSettings port = W.setPort port warpSettings
+    mkSettings port = W.setPort port W.defaultSettings
 
 -- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
 attachStaticFiles :: FilePath -> (AttachHTTP -> IO ()) -> IO ()
 attachStaticFiles path action =
   -- Initialize global internal state for http server.
-  WI.withII warpSettings $ \ii -> do
+  WI.withII settings $ \ii -> do
     action $ \socket cxt -> do
       -- Initialize internal per-connection resources.
       addr <- getPeerName socket
       withConnection addr cxt $ \(conn, transport) ->
         withTimeout ii conn $ \th ->
           -- Run Warp connection handler to process HTTP requests for static files.
-          WI.serveConnection conn ii th addr transport warpSettings app
+          WI.serveConnection conn ii th addr transport settings app
   where
     app = staticFiles path
+    settings = W.defaultSettings
     -- from warp-tls
     withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
     -- from warp
@@ -68,9 +68,6 @@ attachStaticFiles path action =
     -- shared clean up
     terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
 
-warpSettings :: W.Settings
-warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings
-
 staticFiles :: FilePath -> Application
 staticFiles root = S.staticApp settings
   where
@@ -153,8 +150,7 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
             ("hostingCountry", encodeUtf8 <$> country)
           ]
         server =
-          [ ("serverCountry", encodeUtf8 <$> serverCountry spi),
-            ("hostingType",  (\s -> maybe s (\(c, rest) -> toUpper c `B.cons` rest) $ B.uncons s) . strEncode <$> hostingType spi)
+          [ ("serverCountry", fmap encodeUtf8 $ serverCountry =<< information)
           ]
 
 -- Copy-pasted from simplex-chat Simplex.Chat.Types.Preferences

cabal.project

@@ -4,14 +4,6 @@ packages: .
 -- packages: . ../http2
 -- packages: . ../network-transport
 
--- package *
-   -- coverage: True
-   -- library-coverage: True
-
--- package attoparsec
-   -- coverage: False
-   -- library-coverage: False
-
 index-state: 2023-12-12T00:00:00Z
 
 package cryptostore

install.sh

@@ -2,6 +2,9 @@
 set -eu
 
 # Links to scripts/configs
+bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
+remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
+
 scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
 scripts_systemd_smp="$scripts/smp-server.service"
 scripts_systemd_xftp="$scripts/xftp-server.service"
@@ -54,7 +57,7 @@ ${GRN}1.${NC} Install latest binaries from GitHub releases:
 ${GRN}2.${NC} Create server directories:
     - smp: ${YLW}${path_conf_smp}${NC}
     - xftp: ${YLW}${path_conf_xftp}${NC}
-${GRN}3.${NC} Setup user for server:
+${GRN}3.${NC} Setup user for each server:
     - xmp: ${YLW}${user_smp}${NC}
     - xftp: ${YLW}${user_xftp}${NC}
 ${GRN}4.${NC} Create systemd services:
@@ -64,8 +67,9 @@ ${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}1${NC} to install smp server
-  - ${GRN}2${NC} to install xftp server
+  - ${GRN}ENTER${NC} to continue installing both xftp and smp servers
+  - ${GRN}1${NC} to install only smp server
+  - ${GRN}2${NC} to install only xftp server
   - ${RED}Ctrl+C${NC} to cancel installation
   
 Selection: "
@@ -79,21 +83,6 @@ Please checkout our server guides:
 To uninstall with full clean-up, simply run: ${YLW}sudo /usr/local/bin/simplex-servers-uninstall${NC}
 "
 
-set_version() {
-  ver="${VER:-latest}"
-
-  case "$ver" in 
-    latest)
-      bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
-      remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
-      ;;
-    *)
-      bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}"
-      remote_version="${ver}"
-      ;;
-  esac
-}
-
 os_test() {
  . /etc/os-release
 
@@ -166,7 +155,6 @@ checks() {
   exit 1
  fi
  
- set_version
  os_test
 
  mkdir -p $path_conf_info  
@@ -178,11 +166,13 @@ main() {
  printf "%b\n%b" "${BLU}$logo${NC}" "$welcome"
  read ans
 
- case "$ans" in
-  1) setup='smp' ;;
-  2) setup='xftp' ;;
-  *) printf 'Installation aborted.\n' && exit 0 ;;
- esac
+ if [ "$ans" = '1' ]; then
+  setup='smp'
+ elif [ "$ans" = '2' ]; then
+  setup='xftp'
+ else
+  setup='smp xftp'
+ fi
 
  printf "Installing binaries..."
  

package.yaml

@@ -0,0 +1,223 @@
+name: simplexmq
+version: 6.1.0.2
+synopsis: SimpleXMQ message broker
+description: |
+  This package includes <./docs/Simplex-Messaging-Server.html server>,
+  <./docs/Simplex-Messaging-Client.html client> and
+  <./docs/Simplex-Messaging-Agent.html agent> for SMP protocols:
+  .
+  * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md SMP protocol>
+  * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md SMP agent protocol>
+  .
+  See <https://github.com/simplex-chat/simplex-chat terminal chat prototype> built with SimpleXMQ broker.
+
+homepage: https://github.com/simplex-chat/simplexmq#readme
+license: AGPL-3
+author: simplex.chat
+maintainer: chat@simplex.chat
+copyright: 2020-2022 simplex.chat
+category: Chat, Network, Web, System, Cryptography
+extra-source-files:
+  - README.md
+  - CHANGELOG.md
+  - cbits/sha512.h
+  - cbits/sntrup761.h
+  - apps/smp-server/static/*.html
+  - apps/smp-server/static/media/*
+
+dependencies:
+  - aeson == 2.2.*
+  - ansi-terminal >= 0.10 && < 0.12
+  - asn1-encoding == 0.9.*
+  - asn1-types == 0.3.*
+  - async == 2.2.*
+  - attoparsec == 0.14.*
+  - base >= 4.14 && < 5
+  - base64-bytestring >= 1.0 && < 1.3
+  - case-insensitive == 1.2.*
+  - composition == 1.0.*
+  - constraints >= 0.12 && < 0.14
+  - containers == 0.6.*
+  - 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.*
+  - filepath == 1.4.*
+  - hashable == 1.4.*
+  - hourglass == 0.2.*
+  - http-types == 0.12.*
+  - http2 >= 4.2.2 && < 4.3
+  - ini == 0.4.1
+  - iproute == 1.7.*
+  - iso8601-time == 0.1.*
+  - memory == 0.18.*
+  - mtl >= 2.3.1 && < 3.0
+  - network >= 3.1.2.7 && < 3.2
+  - network-info >= 0.2 && < 0.3
+  - network-transport == 0.5.6
+  - network-udp >= 0.0 && < 0.1
+  - optparse-applicative >= 0.15 && < 0.17
+  - process == 1.6.*
+  - random >= 1.1 && < 1.3
+  - simple-logger == 0.1.*
+  - socks == 0.6.*
+  - sqlcipher-simple == 0.4.*
+  - stm == 2.5.*
+  - temporary == 1.3.*
+  - time == 1.12.*
+  - time-manager == 0.0.*
+  - tls >= 1.9.0 && < 1.10
+  - transformers == 0.6.*
+  - unliftio == 0.2.*
+  - unliftio-core == 0.2.*
+  - websockets == 0.12.*
+  - yaml == 0.11.*
+  - zstd == 0.1.3.*
+
+flags:
+  swift:
+    description: Enable swift JSON format
+    manual: True
+    default: False
+  use_crypton:
+    description: Use crypton etc. in cryptostore
+    manual: True
+    default: True
+
+# cpp-options:
+#   - -Dslow_servers
+
+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
+  c-sources:
+    - cbits/sha512.c
+    - cbits/sntrup761.c
+  include-dirs: cbits
+  extra-libraries: crypto
+
+executables:
+  smp-server:
+    source-dirs:
+    - apps/smp-server
+    - apps/smp-server/web
+    main: Main.hs
+    dependencies:
+      - file-embed
+      - simplexmq
+      - wai
+      - wai-app-static
+      - warp ==3.3.30 # the last one before http2-5.0
+      - warp-tls ==3.4.7 # extra internals exposed
+    ghc-options:
+      - -threaded
+      - -rtsopts
+
+  ntf-server:
+    source-dirs: apps/ntf-server
+    main: Main.hs
+    dependencies:
+      - simplexmq
+    ghc-options:
+      - -threaded
+      - -rtsopts
+
+  xftp-server:
+    source-dirs: apps/xftp-server
+    main: Main.hs
+    dependencies:
+      - simplexmq
+    ghc-options:
+      - -threaded
+      - -rtsopts
+
+  xftp:
+    source-dirs: apps/xftp
+    main: Main.hs
+    dependencies:
+      - simplexmq
+    ghc-options:
+      - -threaded
+      - -rtsopts
+
+tests:
+  simplexmq-test:
+    source-dirs:
+    - tests
+    - apps/smp-server/web
+    main: Test.hs
+    dependencies:
+      - deepseq == 1.4.*
+      - file-embed
+      - generic-random == 1.5.*
+      - hspec == 2.11.*
+      - hspec-core == 2.11.*
+      - http-client
+      - http-client-tls
+      - HUnit == 1.6.*
+      - main-tester == 0.2.*
+      - QuickCheck == 2.14.*
+      - silently == 1.2.*
+      - simplexmq
+      - timeit == 2.0.*
+      - unordered-containers
+      - wai
+      - wai-app-static
+      - warp
+      - warp-tls
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-A64M
+      - -with-rtsopts=-N1
+
+ghc-options:
+  # - -haddock
+  - -Weverything
+  - -Wno-missing-exported-signatures
+  - -Wno-missing-import-lists
+  - -Wno-missed-specialisations
+  - -Wno-all-missed-specialisations
+  - -Wno-unsafe
+  - -Wno-safe
+  - -Wno-missing-local-signatures
+  - -Wno-missing-kind-signatures
+  - -Wno-missing-deriving-strategies
+  - -Wno-monomorphism-restriction
+  - -Wno-prepositive-qualified-module
+  - -Wno-unused-packages
+  - -Wno-implicit-prelude
+  - -Wno-missing-safe-haskell-mode
+  - -Wno-missing-export-lists
+  - -Wno-partial-fields
+  - -Wcompat
+  - -Werror=incomplete-record-updates
+  - -Werror=incomplete-patterns
+  - -Werror=incomplete-uni-patterns
+  - -Werror=missing-methods
+  - -Werror=tabs
+  - -Wredundant-constraints
+  - -Wincomplete-record-updates
+  - -Wunused-type-patterns
+  - -O2
+
+default-extensions:
+  - StrictData

protocol/xftp.md

@@ -559,13 +559,11 @@ In current implementation of XFTP protocol in SimpleX Chat clients don't use FAC
 
  - perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers.
 
- - observe how much traffic is being sent, and make guesses as to its purpose.
+ - observe how much traffic is being sent, and make guesses as to its purpose
 
- - in case of a compromised transport protocol, correlate file senders and receivers.
+*cannot, even in case of a compromised transport protocol:*
 
-*cannot, in case of a non-compromised transport protocol:*
-
- - perform traffic correlation attacks.
+ - perform traffic correlation attacks with any increase in efficiency over a non-compromised transport protocol
 
 #### XFTP server
 

rfcs/2021-09-01-smp-message-storage.md

@@ -96,7 +96,7 @@ else if write_msg = max_queue_messages:
     add quota_exceeded message to write_file
     update queue state: write_msg += 1
     append updated queue state to queue.log
-else
+else ]
     // It is required that `max_queue_messages < max_file_messages`,
     // so that we never need more than one additional write file.
     if write_msg >= max_file_messages: // queue file rotation

rfcs/2024-09-25-ios-notifications-2.md

@@ -1,49 +0,0 @@
-# iOS notifications delivery
-
-## Problem
-
-For iOS notifications to be delivered the client has to create credentials for notification subscription on SMP server using NKEY command and after that create a subscription on notification server using SNEW command. These two commands are sent in sequence, after the connections are created, and for it to happen the client needs to be online and in foreground.
-
-iOS users tend to close the app when it is not used, and iOS has very limited permissions for background activities, so these notification subscriptions are created with a substantial delay, and notifications do not work.
-
-This problem is distinct from and probably more common than other problems affecting notifications delivery described [here](./2024-07-06-ios-notifications.md).
-
-## Solution
-
-1. When the new connection is created, the client already knows if it needs to create notification subscription or not, based on the conversation setting (e.g., if the group is muted, the client will not create notification subscription as well.). We should extend NEW command to avoid the need to send additional NKEY command with an option to create notification subscription at the point where connection is created. NDEL would still be used to disable this notification, and NKEY will be used to re-enable it.
-
-2. In the same way we stopped using SDEL command (NDEL sends notification DELD to subscribed notification server) to delete notificaiton subscriptions from notification server, we should delegate creating notification subscription on notification server to SMP servers. Clients could use keys agreed with ntf server for e2e encryption and for command authorization to encrypt and sign instruction to create notification subscription that will be forwarded to notification server using protocol similar to SMP proxies. This will avoid the need for clients to separately contact notification servers that won't happen until they are online.
-
-3. Instead of making Ntf server trust DELD notifications, we could send deletion instructions signed by the client, which will only fail to send in case notification server is down (and they won't be sent later after server restart).
-
-Cons:
-- If SMP servers were to retain in the storage the information about which notification server is used for which queue, it would reduce metadata privacy. While currently it is not an issue, as all notification servers are known and operated by us, once there are other client apps, this can be used for app users fingerprinting, which would act as a deterrence from using new apps – but only if app users use servers of operators who are different from the app provider. To mitigate it, we could only store it in server memory and include notification instruction in subscription commands (SUB) and include notification subscription status in SUB responses. We don't need to mitigate the problem of server being able to store this information, as messaging servers can observe which notification servers connect to them anyway.
-- If SMP server is restarted before the subscription request is forwared to the notification server, then it will have to be forwarded again, once the client subscribes. The problem here is that if the client is offline, it will neither subscribe to the queue to send notification subscription request, nor receive notifications from this queue. Storing notification server and subscription request would mitigate that, as in this case we could send all pending requests on server start, without depending on client subscriptions.
-- "Small" agent will need to support connections to ntf servers and manage workers that retry sending pending subscription requests.
-- Until the client learns the public keys of notification server, it will not be able to decrypt notifications. It potentially can be mitigated by using the public key of the server returned when token is created, in this way different client keys (per-queue) will be combined with the same ntf server key (per-token).
-
-## Implementation details
-
-1. NEW and NKEY commands will need to be extended to include notification subscription request. As the notifier ID needs to be sent to notification server, this notifier ID will have to be client-generated and supplied as part of NEW command.
-
-now:
-
-```haskell
-NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
-NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
-```
-
-extended:
-
-```haskell
-NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Maybe NtfRequest -> Command Recipient
-
-data NtfRequest = NtfRequest NotifierId NtfPublicAuthKey RcvNtfPublicDhKey NtfServerRequest
-
-data NtfServerRequest = NtfServerRequest NtfServer EncSingedNtfCmd
-
-NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Maybe NtfServerRequest -> Command Recipient
--- NotifierID is passed in entity ID field of the transmission
-```
-
-2. Notification server will need to support an additional command to receive "proxied" subscription commands, `SFWD`, that would include `NtfServerRequest`. This command can include both `SNEW` and `SDEL` commands.

rfcs/2024-11-25-journal-expiration.md

@@ -1,15 +0,0 @@
-# Expiring messages in journal storage
-
-## Problem
-
-The journal storage servers recently migrated to do not delete delivered or expired messages, they only update pointers to journal file lines. The messages are actually deleted when the whole journal file is deleted (when fully deleted or fully expired).
-
-The problem is that in case the queue stops receiving the new messages then writing of messages won't switch to the new journal file, and the current journal file containing delivered or expired messages would never be deleted.
-
-## Solution
-
-Remove current journal file and update queue_state.log during message expiration of "idle" queue (that is, without any new messages received or delivered within 3 hours) in case when:
-- the queue is "empty" after the expiration
-- the queue contains only quota marker(s), in which case move them to a new journal file and update the queue_state accordingly. Quota markers can be kept indefinitely to prevent writing the new messages to the dormant queues that reached capacity, so it's important to handle this case.
-
-Also remove current journal file when the queue is opened in case it is empty (as it would not be ever expired in case it remains empty), and also update queue_state.log

rfcs/2024-11-25-queue-blobs-2.md

@@ -1,58 +0,0 @@
-# Blob extensions for SMP queues 2 and queue storage
-
-This document evolves the design proposed [here](./2024-09-09-smp-blobs.md).
-
-## Problems
-
-In addition to problems in the first doc, we have these issues with in-memory queue record storage:
-- many queues are idle or rarely used, but they are loaded to memory, and currently just loading all queues uses 20gb RAM on each server, and takes 10 min to process, increasing downtimes during restarts.
-- adding blobs to memory would make this problem much worse.
-
-## Proposed solution
-
-Move queues to the same journalling approach as [used for messages](./2024-09-01-smp-message-storage.md) now, with independent file names in the same folders.
-
-Each queue change would be logged to its own file, and every time the queue is opened the whole file will be read and compacted to a single line - replacing one store log for all queues, with individual log files for each queue.
-
-Queue deletion would not be making a record in the file, instead it would be deleting the entire folder - it would reduce retention period for any metadata of deleted queues.
-
-We could additionally record deletions to the central log, for debugging, and reset it on every start. But in this case we should not remove folders at the point of deletion, but rather mark them as deleted and delete on restart. TBC
-
-It would also allow simplifying blob storage by having only one blob per queue - for example, limied to 16kb (a bit smaller to fit in block) for contact address queues and 4-8kb for invitations (to fit PQ keys and conversation preferences).
-
-We would also need to be able to lookup recipient ID via sender/notifier/link IDs.
-
-One possible solution is to use and load to memory a central index file. But it is likely to also consume a lot of memory and result in slow starts.
-
-Another solution that is probably better is to use the same folder structure and put notifier/sender/link files with the ID of the recipient queue inside the files. So to locate recipient queue the sender would have to locate folder containing the reference file pointing to the recipient queue and then to locate the actual queue data.
-
-## Implementation details
-
-Each queue folder would these files:
-
-- queue_state.log (and timestamped backups) - to store pointers to message journals (already implemented)
-- messages.randomBase64.log - message journals (already implemented)
-- queue_rec.log (and timestamped backups) - to log complete queue record every time it is changed (so only the last line needs to be read following the same logic as with queue_state.log, to prevent file corruption).
-- blob.data, blob.data.bak, blob.timestamp.data - files for data blobs (to make sure some copy of this file is readable/correct in case of write corruption) - the same two step overwrite process will be used as currently with store log compacting:
-  - on write: 1. if file exists, move it to .bak, 2. store new blob to .data, 3. move .bak to .timestamp.data
-  - on read: 1. if .bak exists, move it to .data 2. use .data
-
-Additional suggestion to reduce probability of queue_state.log and queue_rec.log file corruption is to do one of the following:
-- log end of lines in the beginning of the output, not in the end, to prevent the last line from being corrupted in case the previous line was not fully stored. The downside is that the file will not be EOL terminated, and there will be no confirmation that the output was fully made.
-- log EOL both in the beginning and at the end of output, and ignore empty lines in between - this would both confirm that the last line is fully logged and prevent corruption of the next line in case it was not.
-- check the last byte of the file and log EOL if it is not EOL. Probably cleanest approach, but with a small performance cost.
-
-If queue folder is a reference to the queue, it may have one of these files:
-- notifier.id
-- sender.id
-- link.id
-
-These files would contain a one line with the recipient ID of the queue. These files would never change, they can only be deleted when queue is deleted or when notifier/link is deleted.
-
-There is logic in code preventing using the same ID in different contexts, and the ID size is large enough to make any collisions unlikely (192 bits), so with correctly working code the queue folder would either have one of reference files, and nothing else, or the queue and message files from the beginning of this section. But even if the same ID is re-used in different context, it should not cause any problems as file names don't overlap.
-
-While we could store different types of references in different types of folders, it would have additional costs of maintaining 4 folder hierarchies. Instead we could use the fact that it is one hierarchy to prevent using the same ID in different contexts.
-
-## Protocol
-
-The only change in protocol is that there will be only one blob per queue, without markers (see the previous doc). Otherwise the protocol and proposed privacy improvement seem reasonable.

rfcs/done/2023-10-25-remote-control.md

@@ -53,7 +53,7 @@ The session invitation contains this data:
 - CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
 - Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
 - Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
-- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. This DH public key is always sent unencrypted. NaCL Cryptobox is used for encryption.
+- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. These DH public key and KEM encapsulation key are always sent unencrypted. NaCL Cryptobox is used for encryption.
 
 Host device decrypts (except the first session) and validates the invitation:
 - Session signature is valid.

scripts/main/simplex-servers-update

@@ -2,6 +2,8 @@
 set -eu
 
 # Links to scripts/configs
+bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
+
 scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
 scripts_systemd_smp="$scripts/smp-server.service"
 scripts_systemd_xftp="$scripts/xftp-server.service"
@@ -74,21 +76,6 @@ installed_test() {
   set -u
 }
 
-set_version() {
-  ver="${VER:-latest}"
-
-  case "$ver" in 
-    latest)
-      bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
-      remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
-      ;;
-    *)
-      bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}"
-      remote_version="${ver}"
-      ;;
-  esac
-}
-
 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"
@@ -150,6 +137,8 @@ update_bins() {
   eval "bin=\$bin_${1}"
   eval "path_bin=\$path_bin_${1}"
 
+  remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
+
   set_ver() {
     local_version='unset'
     sed -i -- "s/local_version_${1}=.*/local_version_${1}='${remote_version}'/" "$path_conf_info/release"
@@ -203,7 +192,6 @@ checks() {
     exit 1
   fi
 
-  set_version
   os_test
   installed_test
 

scripts/main/smp-server.service

@@ -9,9 +9,7 @@ ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS
 ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server
 LimitNOFILE=65535
 KillSignal=SIGINT
-TimeoutStartSec=infinity
 TimeoutStopSec=infinity
-AmbientCapabilities=CAP_NET_BIND_SERVICE
 
 [Install]
 WantedBy=multi-user.target

scripts/main/xftp-server.service

@@ -9,7 +9,6 @@ ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
 ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server
 LimitNOFILE=65535
 KillSignal=SIGINT
-TimeoutStartSec=infinity
 TimeoutStopSec=infinity
 AmbientCapabilities=CAP_NET_BIND_SERVICE
    

simplexmq.cabal

@@ -1,7 +1,11 @@
 cabal-version: 1.12
 
+-- This file has been generated from package.yaml by hpack version 0.35.0.
+--
+-- see: https://github.com/sol/hpack
+
 name:           simplexmq
-version:        6.2.0.6
+version:        6.1.0.2
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -62,11 +66,6 @@ flag use_crypton
   manual: True
   default: True
 
-flag client_library
-  description: Don't build server-related code.
-  manual: True
-  default: False
-
 library
   exposed-modules:
       Simplex.FileTransfer.Agent
@@ -78,6 +77,13 @@ library
       Simplex.FileTransfer.Crypto
       Simplex.FileTransfer.Description
       Simplex.FileTransfer.Protocol
+      Simplex.FileTransfer.Server
+      Simplex.FileTransfer.Server.Control
+      Simplex.FileTransfer.Server.Env
+      Simplex.FileTransfer.Server.Main
+      Simplex.FileTransfer.Server.Stats
+      Simplex.FileTransfer.Server.Store
+      Simplex.FileTransfer.Server.StoreLog
       Simplex.FileTransfer.Transport
       Simplex.FileTransfer.Types
       Simplex.FileTransfer.Util
@@ -129,8 +135,6 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
@@ -148,13 +152,33 @@ library
       Simplex.Messaging.Encoding.String
       Simplex.Messaging.Notifications.Client
       Simplex.Messaging.Notifications.Protocol
+      Simplex.Messaging.Notifications.Server
+      Simplex.Messaging.Notifications.Server.Env
+      Simplex.Messaging.Notifications.Server.Main
+      Simplex.Messaging.Notifications.Server.Push.APNS
+      Simplex.Messaging.Notifications.Server.Push.APNS.Internal
+      Simplex.Messaging.Notifications.Server.Stats
+      Simplex.Messaging.Notifications.Server.Store
+      Simplex.Messaging.Notifications.Server.StoreLog
       Simplex.Messaging.Notifications.Transport
       Simplex.Messaging.Notifications.Types
       Simplex.Messaging.Parsers
       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.Information
+      Simplex.Messaging.Server.Main
+      Simplex.Messaging.Server.MsgStore
+      Simplex.Messaging.Server.MsgStore.STM
+      Simplex.Messaging.Server.NtfStore
+      Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.QueueInfo
+      Simplex.Messaging.Server.QueueStore.STM
+      Simplex.Messaging.Server.Stats
+      Simplex.Messaging.Server.StoreLog
       Simplex.Messaging.ServiceScheme
       Simplex.Messaging.Session
       Simplex.Messaging.TMap
@@ -177,44 +201,13 @@ library
       Simplex.RemoteControl.Discovery.Multicast
       Simplex.RemoteControl.Invitation
       Simplex.RemoteControl.Types
-  if !flag(client_library)
-      exposed-modules:
-          Simplex.FileTransfer.Server
-          Simplex.FileTransfer.Server.Control
-          Simplex.FileTransfer.Server.Env
-          Simplex.FileTransfer.Server.Main
-          Simplex.FileTransfer.Server.Stats
-          Simplex.FileTransfer.Server.Store
-          Simplex.FileTransfer.Server.StoreLog
-          Simplex.Messaging.Server
-          Simplex.Messaging.Server.Control
-          Simplex.Messaging.Server.Env.STM
-          Simplex.Messaging.Server.Information
-          Simplex.Messaging.Server.Main
-          Simplex.Messaging.Server.MsgStore
-          Simplex.Messaging.Server.MsgStore.Journal
-          Simplex.Messaging.Server.MsgStore.STM
-          Simplex.Messaging.Server.MsgStore.Types
-          Simplex.Messaging.Server.NtfStore
-          Simplex.Messaging.Server.QueueStore
-          Simplex.Messaging.Server.QueueStore.STM
-          Simplex.Messaging.Server.Stats
-          Simplex.Messaging.Server.StoreLog
-          Simplex.Messaging.Server.StoreLog.Types
-          Simplex.Messaging.Notifications.Server
-          Simplex.Messaging.Notifications.Server.Control
-          Simplex.Messaging.Notifications.Server.Env
-          Simplex.Messaging.Notifications.Server.Main
-          Simplex.Messaging.Notifications.Server.Push.APNS
-          Simplex.Messaging.Notifications.Server.Push.APNS.Internal
-          Simplex.Messaging.Notifications.Server.Stats
-          Simplex.Messaging.Notifications.Server.Store
-          Simplex.Messaging.Notifications.Server.StoreLog
   other-modules:
       Paths_simplexmq
   hs-source-dirs:
       src
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-home-modules -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
+  default-extensions:
+      StrictData
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
   include-dirs:
       cbits
   c-sources:
@@ -224,12 +217,14 @@ library
       crypto
   build-depends:
       aeson ==2.2.*
+    , ansi-terminal >=0.10 && <0.12
     , asn1-encoding ==0.9.*
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
+    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -242,6 +237,7 @@ library
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -274,37 +270,94 @@ library
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  if !flag(client_library)
-    build-depends:
-        case-insensitive ==1.2.*
-      , hashable ==1.4.*
   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
-  if flag(client_library)
-      buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
   hs-source-dirs:
       apps/ntf-server
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  default-extensions:
+      StrictData
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      base
-    , simple-logger
+      aeson ==2.2.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , 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.*
+    , filepath ==1.4.*
+    , hashable ==1.4.*
+    , hourglass ==0.2.*
+    , http-types ==0.12.*
+    , http2 >=4.2.2 && <4.3
+    , ini ==0.4.1
+    , iproute ==1.7.*
+    , iso8601-time ==0.1.*
+    , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
+    , network >=3.1.2.7 && <3.2
+    , network-info ==0.2.*
+    , network-transport ==0.5.6
+    , network-udp ==0.0.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , temporary ==1.3.*
+    , time ==1.12.*
+    , time-manager ==0.0.*
+    , tls >=1.9.0 && <1.10
+    , transformers ==0.6.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
+    , websockets ==0.12.*
+    , yaml ==0.11.*
+    , zstd ==0.1.3.*
   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
-  if flag(client_library)
-      buildable: False
   main-is: Main.hs
   other-modules:
       Static
@@ -313,56 +366,234 @@ executable smp-server
   hs-source-dirs:
       apps/smp-server
       apps/smp-server/web
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  default-extensions:
+      StrictData
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      base
-    , bytestring
-    , directory
+      aeson ==2.2.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , 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.*
     , file-embed
-    , filepath
-    , network
-    , simple-logger
+    , filepath ==1.4.*
+    , hashable ==1.4.*
+    , hourglass ==0.2.*
+    , http-types ==0.12.*
+    , http2 >=4.2.2 && <4.3
+    , ini ==0.4.1
+    , iproute ==1.7.*
+    , iso8601-time ==0.1.*
+    , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
+    , network >=3.1.2.7 && <3.2
+    , network-info ==0.2.*
+    , network-transport ==0.5.6
+    , network-udp ==0.0.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
     , simplexmq
-    , text
-    , unliftio
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , temporary ==1.3.*
+    , time ==1.12.*
+    , time-manager ==0.0.*
+    , tls >=1.9.0 && <1.10
+    , transformers ==0.6.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
     , wai
     , wai-app-static
     , warp ==3.3.30
     , warp-tls ==3.4.7
+    , websockets ==0.12.*
+    , yaml ==0.11.*
+    , zstd ==0.1.3.*
   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
-  if flag(client_library)
-      buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
   hs-source-dirs:
       apps/xftp
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  default-extensions:
+      StrictData
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      base
+      aeson ==2.2.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , 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.*
+    , filepath ==1.4.*
+    , hashable ==1.4.*
+    , hourglass ==0.2.*
+    , http-types ==0.12.*
+    , http2 >=4.2.2 && <4.3
+    , ini ==0.4.1
+    , iproute ==1.7.*
+    , iso8601-time ==0.1.*
+    , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
+    , network >=3.1.2.7 && <3.2
+    , network-info ==0.2.*
+    , network-transport ==0.5.6
+    , network-udp ==0.0.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , temporary ==1.3.*
+    , time ==1.12.*
+    , time-manager ==0.0.*
+    , tls >=1.9.0 && <1.10
+    , transformers ==0.6.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
+    , websockets ==0.12.*
+    , yaml ==0.11.*
+    , zstd ==0.1.3.*
   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
-  if flag(client_library)
-      buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
   hs-source-dirs:
       apps/xftp-server
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  default-extensions:
+      StrictData
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      base
-    , simple-logger
+      aeson ==2.2.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , 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.*
+    , filepath ==1.4.*
+    , hashable ==1.4.*
+    , hourglass ==0.2.*
+    , http-types ==0.12.*
+    , http2 >=4.2.2 && <4.3
+    , ini ==0.4.1
+    , iproute ==1.7.*
+    , iso8601-time ==0.1.*
+    , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
+    , network >=3.1.2.7 && <3.2
+    , network-info ==0.2.*
+    , network-transport ==0.5.6
+    , network-udp ==0.0.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , temporary ==1.3.*
+    , time ==1.12.*
+    , time-manager ==0.0.*
+    , tls >=1.9.0 && <1.10
+    , transformers ==0.6.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
+    , websockets ==0.12.*
+    , yaml ==0.11.*
+    , zstd ==0.1.3.*
   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
-  if flag(client_library)
-      buildable: False
   type: exitcode-stdio-1.0
   main-is: Test.hs
   other-modules:
@@ -374,17 +605,14 @@ test-suite simplexmq-test
       AgentTests.MigrationTests
       AgentTests.NotificationTests
       AgentTests.SchemaDump
-      AgentTests.ServerChoice
       AgentTests.SQLiteTests
       CLITests
       CoreTests.BatchingTests
       CoreTests.CryptoFileTests
       CoreTests.CryptoTests
       CoreTests.EncodingTests
-      CoreTests.MsgStoreTests
       CoreTests.RetryIntervalTests
       CoreTests.SOCKSSettings
-      CoreTests.StoreLogTests
       CoreTests.TRcvQueuesTests
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
@@ -407,53 +635,89 @@ test-suite simplexmq-test
   hs-source-dirs:
       tests
       apps/smp-server/web
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
+  default-extensions:
+      StrictData
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
   build-depends:
-      base
-    , aeson
-    , async
-    , base64-bytestring
-    , bytestring
-    , containers
-    , crypton
-    , crypton-x509
-    , crypton-x509-store
-    , crypton-x509-validation
-    , deepseq ==1.4.*
-    , directory
-    , file-embed
-    , filepath
-    , generic-random ==1.5.*
-    , hashable
-    , hspec ==2.11.*
-    , http-client
-    , http-types
-    , http2
-    , HUnit ==1.6.*
-    , ini
-    , iso8601-time
-    , main-tester ==0.2.*
-    , memory
-    , mtl
-    , network
-    , process
+      HUnit ==1.6.*
     , QuickCheck ==2.14.*
-    , random
+    , aeson ==2.2.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , 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.*
+    , directory ==1.3.*
+    , file-embed
+    , filepath ==1.4.*
+    , generic-random ==1.5.*
+    , hashable ==1.4.*
+    , hourglass ==0.2.*
+    , hspec ==2.11.*
+    , hspec-core ==2.11.*
+    , http-client
+    , http-client-tls
+    , http-types ==0.12.*
+    , http2 >=4.2.2 && <4.3
+    , ini ==0.4.1
+    , iproute ==1.7.*
+    , iso8601-time ==0.1.*
+    , main-tester ==0.2.*
+    , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
+    , network >=3.1.2.7 && <3.2
+    , network-info ==0.2.*
+    , network-transport ==0.5.6
+    , network-udp ==0.0.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
     , silently ==1.2.*
-    , simple-logger
+    , simple-logger ==0.1.*
     , simplexmq
-    , sqlcipher-simple
-    , stm
-    , text
-    , time
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , temporary ==1.3.*
+    , time ==1.12.*
+    , time-manager ==0.0.*
     , timeit ==2.0.*
-    , transformers
-    , unliftio
-    , unliftio-core
+    , tls >=1.9.0 && <1.10
+    , transformers ==0.6.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
     , unordered-containers
     , wai
     , wai-app-static
     , warp
     , warp-tls
-    , yaml
+    , websockets ==0.12.*
+    , yaml ==0.11.*
+    , zstd ==0.1.3.*
   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/FileTransfer/Agent.hs

@@ -461,14 +461,14 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
           pure srv
           where
             tryCreate = do
-              triedHosts <- newTVarIO S.empty
+              usedSrvs <- newTVarIO ([] :: [XFTPServer])
               let AgentClient {xftpServers} = c
               userSrvCount <- liftIO $ length <$> TM.lookupIO userId xftpServers
               withRetryIntervalCount (riFast ri) $ \n _ loop -> do
                 liftIO $ waitWhileSuspended c
                 liftIO $ waitForUserNetwork c
                 let triedAllSrvs = n > userSrvCount
-                createWithNextSrv triedHosts
+                createWithNextSrv usedSrvs
                   `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
               where
                 -- we don't do closeXFTPServerClient here to not risk closing connection for concurrent chunk upload
@@ -477,10 +477,10 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
                     when (triedAllSrvs && serverHostError e) $ notify c sndFileEntityId $ SFWARN e
                   liftIO $ assertAgentForeground c
                   loop
-            createWithNextSrv triedHosts = do
+            createWithNextSrv usedSrvs = do
               deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
               when deleted $ throwE $ FILE NO_FILE
-              withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do
+              withNextSrv c userId usedSrvs [] $ \srvAuth -> do
                 replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
                 pure (replica, srvAuth)
 
@@ -546,8 +546,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
         withStore' c $ \db -> updateSndFileComplete db sndFileId
       where
         addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica
-        addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {sndChunkReplicaId, rcvIdsKeys}
-          | length rcvIdsKeys > numRecipients = throwE $ INTERNAL ("too many recipients, sndChunkReplicaId = " <> show sndChunkReplicaId)
+        addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys}
+          | length rcvIdsKeys > numRecipients = throwE $ INTERNAL "too many recipients"
           | length rcvIdsKeys == numRecipients = pure cr
           | otherwise = do
               let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients

src/Simplex/FileTransfer/Client.hs

@@ -29,6 +29,7 @@ import qualified Data.X509.Validation as XV
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
 import Simplex.FileTransfer.Protocol
+import Simplex.FileTransfer.Server.Env (supportedXFTPhandshakes)
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
@@ -103,7 +104,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
+  let tcConfig = (transportClientConfig xftpNetworkConfig useHost True) {alpn = clientALPN}
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -112,7 +113,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let HTTP2Client {sessionId, sessionALPN} = http2Client
       v = VersionXFTP 1
       thServerVRange = versionToRange v
-      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
+      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
     Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0

src/Simplex/FileTransfer/Server.hs

@@ -55,7 +55,6 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
-import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime)
 import Simplex.Messaging.Server.Stats
@@ -120,7 +119,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         reqBody <- getHTTP2Body r xftpBlockSize
         let v = VersionXFTP 1
             thServerVRange = versionToRange v
-            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
+            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
             req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
         flip runReaderT env $ case sessionALPN of
           Nothing -> processRequest req0
@@ -181,7 +180,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
     stopServer = do
       withFileLog closeStoreLog
       saveServerStats
-      logInfo "Server stopped"
 
     expireFilesThread_ :: XFTPServerConfig -> [M ()]
     expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]

src/Simplex/FileTransfer/Server/Control.hs

@@ -8,6 +8,8 @@ import Simplex.FileTransfer.Protocol (XFTPFileId)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth)
 
+data CPClientRole = CPRNone | CPRUser | CPRAdmin
+
 data ControlProtocol
   = CPAuth BasicAuth
   | CPStatsRTS

src/Simplex/FileTransfer/Server/Env.hs

@@ -28,6 +28,7 @@ import Simplex.FileTransfer.Transport (VersionRangeXFTP)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (ALPN)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
@@ -71,7 +72,7 @@ data XFTPServerConfig = XFTPServerConfig
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
-    { ttl = 21600, -- seconds, 6 hours
+    { ttl = 43200, -- seconds, 12 hours
       checkInterval = 3600 -- seconds, 1 hours
     }
 
@@ -95,6 +96,9 @@ defaultFileExpiration =
       checkInterval = 2 * 3600 -- seconds, 2 hours
     }
 
+supportedXFTPhandshakes :: [ALPN]
+supportedXFTPhandshakes = ["xftp/1"]
+
 newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
 newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials} = do
   random <- C.newRandom

src/Simplex/FileTransfer/Server/Main.hs

@@ -51,9 +51,7 @@ xftpServerCLI cfgPath logPath = do
         True -> readIniFile iniFile >>= either exitError runServer
         _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Delete -> do
-      confirmOrExit
-        "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-        "Server NOT deleted"
+      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"
@@ -103,7 +101,6 @@ xftpServerCLI cfgPath logPath = do
                \\n\
                \# control_port_admin_password:\n\
                \# control_port_user_password:\n\
-               \\n\
                \[TRANSPORT]\n\
                \# host is only used to print server address on start\n"
             <> ("host: " <> T.pack host <> "\n")

src/Simplex/FileTransfer/Server/Store.hs

@@ -54,7 +54,6 @@ fileTimePrecision :: Int64
 fileTimePrecision = 3600 -- truncate creation time to 1 hour
 
 data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey
-  deriving (Show)
 
 instance StrEncoding FileRecipient where
   strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -34,7 +34,8 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (bshow)
+import Simplex.Messaging.Util (bshow, whenM)
+import System.Directory (doesFileExist, renameFile)
 import System.IO
 
 data FileStoreLogRecord
@@ -43,7 +44,6 @@ data FileStoreLogRecord
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
   | AckFile RecipientId
-  deriving (Show)
 
 instance StrEncoding FileStoreLogRecord where
   strEncode = \case
@@ -80,7 +80,13 @@ logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
 logAckFile s = logFileStoreRecord s . AckFile
 
 readWriteFileStore :: FilePath -> FileStore -> IO (StoreLog 'WriteMode)
-readWriteFileStore = readWriteStoreLog readFileStore writeFileStore
+readWriteFileStore f st = do
+  whenM (doesFileExist f) $ do
+    readFileStore f st
+    renameFile f $ f <> ".bak"
+  s <- openWriteStoreLog f
+  writeFileStore s st
+  pure s
 
 readFileStore :: FilePath -> FileStore -> IO ()
 readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f

src/Simplex/FileTransfer/Transport.hs

@@ -12,7 +12,6 @@ module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
     authCmdsXFTPVersion,
     xftpClientHandshakeStub,
-    supportedXFTPhandshakes,
     XFTPClientHandshake (..),
     -- xftpClientHandshake,
     XFTPServerHandshake (..),
@@ -58,7 +57,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (CommandError)
-import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
+import Simplex.Messaging.Transport (SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Transport.HTTP2.File
 import Simplex.Messaging.Util (bshow, tshow)
 import Simplex.Messaging.Version
@@ -102,9 +101,6 @@ supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
 xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
 xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion
 
-supportedXFTPhandshakes :: [ALPN]
-supportedXFTPhandshakes = ["xftp/1"]
-
 data XFTPServerHandshake = XFTPServerHandshake
   { xftpVersionRange :: VersionRangeXFTP,
     sessionId :: SessionId,

src/Simplex/Messaging/Agent.hs

@@ -56,15 +56,14 @@ module Simplex.Messaging.Agent
     createConnection,
     changeConnectionUser,
     prepareConnectionToJoin,
-    prepareConnectionToAccept,
     joinConnection,
     allowConnection,
     acceptContact,
     rejectContact,
     subscribeConnection,
     subscribeConnections,
-    getConnectionMessages,
-    getNotificationConns,
+    getConnectionMessage,
+    getNotificationMessage,
     resubscribeConnection,
     resubscribeConnections,
     sendMessage,
@@ -120,8 +119,6 @@ module Simplex.Messaging.Agent
     debugAgentLocks,
     getAgentSubscriptions,
     logConnection,
-    -- for tests
-    withAgentEnv,
   )
 where
 
@@ -136,7 +133,7 @@ import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:), (.:.), (.::), (.::.))
-import Data.Either (isRight, partitionEithers, rights)
+import Data.Either (isRight, rights)
 import Data.Foldable (foldl', toList)
 import Data.Functor (($>))
 import Data.Functor.Identity
@@ -177,7 +174,8 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern P
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
+import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId)
+import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), pnMessagesP)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
 import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
@@ -334,7 +332,7 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
 
 -- | Create SMP agent connection (NEW command)
 createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
-createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId enableNtfs
+createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs
 {-# INLINE createConnection #-}
 
 -- | Changes the user id associated with a connection
@@ -350,13 +348,10 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne
 prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
 prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs
 
--- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID).
-prepareConnectionToAccept :: AgentClient -> Bool -> ConfirmationId -> PQSupport -> AE ConnId
-prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c "" enableNtfs
-
 -- | Join SMP agent connection (JOIN command).
-joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
-joinConnection c userId connId enableNtfs = withAgentEnv c .:: joinConn c userId connId enableNtfs
+joinConnection :: AgentClient -> UserId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
+joinConnection c userId Nothing enableNtfs = withAgentEnv c .:: joinConn c userId "" False enableNtfs
+joinConnection c userId (Just connId) enableNtfs = withAgentEnv c .:: joinConn c userId connId True enableNtfs
 {-# INLINE joinConnection #-}
 
 -- | Allow connection to continue after CONF notification (LET command)
@@ -365,8 +360,8 @@ allowConnection c = withAgentEnv c .:. allowConnection' c
 {-# INLINE allowConnection #-}
 
 -- | Accept contact after REQ notification (ACPT command)
-acceptContact :: AgentClient -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
-acceptContact c connId enableNtfs = withAgentEnv c .:: acceptContact' c connId enableNtfs
+acceptContact :: AgentClient -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
+acceptContact c enableNtfs = withAgentEnv c .:: acceptContact' c "" enableNtfs
 {-# INLINE acceptContact #-}
 
 -- | Reject contact (RJCT command)
@@ -384,15 +379,15 @@ subscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentE
 subscribeConnections c = withAgentEnv c . subscribeConnections' c
 {-# INLINE subscribeConnections #-}
 
--- | Get messages for connections (GET commands)
-getConnectionMessages :: AgentClient -> NonEmpty ConnId -> IO (NonEmpty (Maybe SMPMsgMeta))
-getConnectionMessages c = withAgentEnv' c . getConnectionMessages' c
-{-# INLINE getConnectionMessages #-}
+-- | Get connection message (GET command)
+getConnectionMessage :: AgentClient -> ConnId -> AE (Maybe SMPMsgMeta)
+getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
+{-# INLINE getConnectionMessage #-}
 
--- | Get connections for received notification
-getNotificationConns :: AgentClient -> C.CbNonce -> ByteString -> AE (NonEmpty NotificationInfo)
-getNotificationConns c = withAgentEnv c .: getNotificationConns' c
-{-# INLINE getNotificationConns #-}
+-- | Get connection message for received notification
+getNotificationMessage :: AgentClient -> C.CbNonce -> ByteString -> AE (NotificationInfo, Maybe SMPMsgMeta)
+getNotificationMessage c = withAgentEnv c .: getNotificationMessage' c
+{-# INLINE getNotificationMessage #-}
 
 resubscribeConnection :: AgentClient -> ConnId -> AE ()
 resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
@@ -654,15 +649,15 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue
 
 newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
 newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
-  connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
+  connId <- newConnNoQueues c userId "" enableNtfs cMode (CR.connPQEncryption pqInitKeys)
   enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode
   pure connId
 
-newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
-newConnNoQueues c userId enableNtfs cMode pqSupport = do
+newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
+newConnNoQueues c userId connId enableNtfs cMode pqSupport = do
   g <- asks random
   connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
-  let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
+  let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
   withStore c $ \db -> createNewConn db g cData cMode
 
 joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
@@ -749,12 +744,9 @@ switchConnectionAsync' c corrId connId =
             pure . connectionStats $ DuplexConnection cData rqs' sqs
       _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
 
-newConn :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
-newConn c userId enableNtfs cMode clientData pqInitKeys subMode = do
-  srv <- getSMPServer c userId
-  connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
-  cReq <- newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
-  pure (connId, cReq)
+newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
+newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
+  getSMPServer c userId >>= newConnSrv c userId connId False enableNtfs cMode clientData pqInitKeys subMode
 
 changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
 changeConnectionUser' c oldUserId connId newUserId = do
@@ -766,7 +758,15 @@ changeConnectionUser' c oldUserId connId newUserId = do
   where
     updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
 
-newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
+newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
+newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys subMode srv = do
+  connId' <-
+    if hasNewConn
+      then pure connId
+      else newConnNoQueues c userId connId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
+  newRcvConnSrv c userId connId' enableNtfs cMode clientData pqInitKeys subMode srv
+
+newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
 newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
   case (cMode, pqInitKeys) of
     (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
@@ -782,12 +782,12 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
     atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
   let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
   case cMode of
-    SCMContact -> pure $ CRContactUri crData
+    SCMContact -> pure (connId, CRContactUri crData)
     SCMInvitation -> do
       g <- asks random
       (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
       withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
-      pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
+      pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
 
 newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
 newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
@@ -807,26 +807,16 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
           cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
       withStore c $ \db -> createNewConn db g cData SCMInvitation
 
-newConnToAccept :: AgentClient -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId
-newConnToAccept c connId enableNtfs invId pqSup = do
-  Invitation {connReq, contactConnId} <- withStore c (`getInvitation` invId)
-  withStore c (`getConn` contactConnId) >>= \case
-    SomeConn _ (ContactConnection ConnData {userId} _) ->
-      newConnToJoin c userId connId enableNtfs connReq pqSup
-    _ -> throwE $ CMD PROHIBITED "newConnToAccept"
+joinConn :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
+joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do
+  srv <- case cReq of
+    CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
+      getNextServer c userId [qServer q]
+    _ -> getSMPServer c userId
+  joinConnSrv c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode srv
 
-joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
-joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
-  srv <- getNextSMPServer c userId [qServer cReqQueue]
-  joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
-  where
-    cReqQueue :: SMPQueueUri
-    cReqQueue = case cReq of
-      CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q
-      CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q
-
-startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448)
-startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
+startJoinInvitation :: UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, C.PublicKeyX25519, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448)
+startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup =
   lift (compatibleInvitationUri cReqUri) >>= \case
     Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do
       g <- asks random
@@ -839,14 +829,11 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
           rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
       -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
       -- e2ePubKey is always present, it's Maybe historically
-      q <- case sq_ of
-        Just sq@SndQueue {e2ePubKey = Just _k} -> pure (sq :: SndQueue) {dbQueueId = DBNewQueue}
-        _ -> lift $ fst <$> newSndQueue userId "" qInfo
+      (q, e2ePubKey) <- case sq_ of
+        Just sq@SndQueue {e2ePubKey = Just k} -> pure ((sq :: SndQueue) {dbQueueId = DBNewQueue}, k)
+        _ -> lift $ newSndQueue userId "" qInfo
       let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
-      sq' <- withStore c $ \db -> runExceptT $ do
-        liftIO $ createRatchet db connId rc
-        maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
-      pure (cData, sq', e2eSndParams)
+      pure (cData, q, e2ePubKey, rc, e2eSndParams)
     Nothing -> throwE $ AGENT A_VERSION
 
 connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
@@ -879,25 +866,34 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
 versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
 {-# INLINE versionPQSupport_ #-}
 
-joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
-joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
+joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, SndQueueSecured)
+joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
   withInvLock c (strEncode inv) "joinConnSrv" $ do
-    SomeConn cType conn <- withStore c (`getConn` connId)
-    case conn of
-      NewConnection _ -> doJoin Nothing
-      SndConnection _ sq -> doJoin $ Just sq
-      _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType
-  where
-    doJoin :: Maybe SndQueue -> AM SndQueueSecured
-    doJoin sq_ = do
-      (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup
-      secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode
-joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
+    (cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup
+    g <- asks random
+    (connId', sq) <- withStore c $ \db -> runExceptT $ do
+      r@(connId', _) <-
+        if hasNewConn
+          then (connId,) <$> ExceptT (updateNewConnSnd db connId q)
+          else ExceptT $ createSndConn db g cData q
+      liftIO $ createRatchet db connId' rc
+      pure r
+    let cData' = (cData :: ConnData) {connId = connId'}
+    -- joinConnSrv is only used on user interaction, and its failure is permanent,
+    -- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key,
+    -- similar to how joinConnAsync does that.
+    tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
+      Right sqSecured -> pure (connId', sqSecured)
+      Left e -> do
+        -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
+        void $ withStore' c $ \db -> deleteConn db Nothing connId'
+        throwE e
+joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
   lift (compatibleContactUri cReqUri) >>= \case
     Just (qInfo, vrsn) -> do
-      cReq <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
-      void $ sendInvitation c userId connId qInfo vrsn cReq cInfo
-      pure False
+      (connId', cReq) <- newConnSrv c userId connId hasNewConn enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
+      void $ sendInvitation c userId connId' qInfo vrsn cReq cInfo
+      pure (connId', False)
     Nothing -> throwE $ AGENT A_VERSION
 
 joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
@@ -910,8 +906,11 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
   where
     doJoin :: Maybe SndQueue -> AM SndQueueSecured
     doJoin sq_ = do
-      (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport
-      secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode
+      (cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport
+      sq' <- withStore c $ \db -> runExceptT $ do
+        liftIO $ createRatchet db connId rc
+        maybe (ExceptT $ updateNewConnSnd db connId sq) pure sq_
+      secureConfirmQueueAsync c cData sq' srv cInfo (Just e2eSndParams) subMode
 joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do
   throwE $ CMD PROHIBITED "joinConnSrvAsync"
 
@@ -939,13 +938,13 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
     _ -> throwE $ CMD PROHIBITED "allowConnection"
 
 -- | Accept contact (ACPT command) in Reader monad
-acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
+acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
 acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
   Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
-      joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
+      joinConn c userId connId False enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
         withStore' c (`unacceptInvitation` invId)
         throwE err
     _ -> throwE $ CMD PROHIBITED "acceptContact"
@@ -1050,57 +1049,29 @@ resubscribeConnections' c connIds = do
   -- union is left-biased, so results returned by subscribeConnections' take precedence
   (`M.union` r) <$> subscribeConnections' c connIds'
 
-getConnectionMessages' :: AgentClient -> NonEmpty ConnId -> AM' (NonEmpty (Maybe SMPMsgMeta))
-getConnectionMessages' c = mapM getMsg
-  where
-    getMsg :: ConnId -> AM' (Maybe SMPMsgMeta)
-    getMsg connId =
-      getConnectionMessage connId `catchAgentError'` \e -> do
-        logError $ "Error loading message: " <> tshow e
-        pure Nothing
-    getConnectionMessage :: ConnId -> AM (Maybe SMPMsgMeta)
-    getConnectionMessage connId = do
-      whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed"
-      SomeConn _ conn <- withStore c (`getConn` connId)
-      case conn of
-        DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq
-        RcvConnection _ rq -> getQueueMessage c rq
-        ContactConnection _ rq -> getQueueMessage c rq
-        SndConnection _ _ -> throwE $ CONN SIMPLEX
-        NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
+getConnectionMessage' :: AgentClient -> ConnId -> AM (Maybe SMPMsgMeta)
+getConnectionMessage' c connId = do
+  whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed"
+  SomeConn _ conn <- withStore c (`getConn` connId)
+  case conn of
+    DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq
+    RcvConnection _ rq -> getQueueMessage c rq
+    ContactConnection _ rq -> getQueueMessage c rq
+    SndConnection _ _ -> throwE $ CONN SIMPLEX
+    NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
 
-getNotificationConns' :: AgentClient -> C.CbNonce -> ByteString -> AM (NonEmpty NotificationInfo)
-getNotificationConns' c nonce encNtfInfo =
+getNotificationMessage' :: AgentClient -> C.CbNonce -> ByteString -> AM (NotificationInfo, Maybe SMPMsgMeta)
+getNotificationMessage' c nonce encNtfInfo = do
   withStore' c getActiveNtfToken >>= \case
     Just NtfToken {ntfDhSecret = Just dhSecret} -> do
-      ntfData <- liftEither $ agentCbDecrypt dhSecret nonce encNtfInfo
+      ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo
       pnMsgs <- liftEither (parse pnMessagesP (INTERNAL "error parsing PNMessageData") ntfData)
-      let (initNtfs, lastNtf) = (L.init pnMsgs, L.last pnMsgs)
-      rs <-
-        lift $ withStoreBatch c $ \db ->
-          let initNtfInfos = map (getInitNtfInfo db) initNtfs
-              lastNtfInfo = Just . fst <$$> getNtfInfo db lastNtf
-           in initNtfInfos <> [lastNtfInfo]
-      let (errs, ntfInfos_) = partitionEithers rs
-      logError $ "Error(s) loading notifications: " <> tshow errs
-      case L.nonEmpty $ catMaybes ntfInfos_ of
-        Just r -> pure r
-        Nothing -> throwE $ INTERNAL "getNotificationConns: couldn't get conn info"
-    _ -> throwE $ CMD PROHIBITED "getNotificationConns"
-  where
-    getNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (NotificationInfo, Maybe UTCTime))
-    getNtfInfo db PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = runExceptT $ do
-      (ntfConnId, rcvNtfDhSecret, lastBrokerTs_) <- liftError' storeError $ getNtfRcvQueue db smpQueue
-      let ntfMsgMeta = eitherToMaybe $ smpDecode =<< first show (C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta)
-          ntfInfo = NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta}
-      pure (ntfInfo, lastBrokerTs_)
-    getInitNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (Maybe NotificationInfo))
-    getInitNtfInfo db msgData = runExceptT $ do
-      (nftInfo, lastBrokerTs_) <- ExceptT $ getNtfInfo db msgData
-      pure $ case (ntfMsgMeta nftInfo, lastBrokerTs_) of
-        (Just SMP.NMsgMeta {msgTs}, Just lastBrokerTs)
-          | systemToUTCTime msgTs > lastBrokerTs -> Just nftInfo
-        _ -> Nothing
+      let PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = L.last pnMsgs
+      (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
+      ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
+      msgMeta <- getConnectionMessage' c ntfConnId
+      pure (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta}, msgMeta)
+    _ -> throwE $ CMD PROHIBITED "getNotificationMessage"
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption)
@@ -1198,13 +1169,14 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
     processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of
       AClientCommand cmd -> case cmd of
         NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
-          triedHosts <- newTVarIO S.empty
-          tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do
-            cReq <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
+          usedSrvs <- newTVarIO ([] :: [SMPServer])
+          tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
+            (_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
             notify $ INV (ACR cMode cReq)
         JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
-          triedHosts <- newTVarIO S.empty
-          tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do
+          let initUsed = [qServer q]
+          usedSrvs <- newTVarIO initUsed
+          tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do
             sqSecured <- joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
             notify $ JOINED sqSecured
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
@@ -1652,8 +1624,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s
   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 _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
-  srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
+  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, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False
   let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
   rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
@@ -1709,21 +1681,14 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
     _ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex"
 
 ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM ()
-ackQueueMessage c rq@RcvQueue {userId, connId, server} srvMsgId = do
+ackQueueMessage c rq@RcvQueue {userId, server} srvMsgId = do
   atomically $ incSMPServerStat c userId server ackAttempts
   tryAgentError (sendAck c rq srvMsgId) >>= \case
-    Right _ -> sendMsgNtf ackMsgs
-    Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs
+    Right _ -> atomically $ incSMPServerStat c userId server ackMsgs
+    Left (SMP _ SMP.NO_MSG) -> atomically $ incSMPServerStat c userId server ackNoMsgErrs
     Left e -> do
       unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs
       throwE e
-  where
-    sendMsgNtf stat = do
-      atomically $ incSMPServerStat c userId server stat
-      whenM (liftIO $ hasGetLock c rq) $ do
-        atomically $ releaseGetLock c rq
-        brokerTs_ <- eitherToMaybe <$> tryAgentError (withStore c $ \db -> getRcvMsgBrokerTs db connId srvMsgId)
-        atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ MSGNTF srvMsgId brokerTs_)
 
 -- | Suspend SMP agent connection (OFF command) in Reader monad
 suspendConnection' :: AgentClient -> ConnId -> AM ()
@@ -1941,8 +1906,12 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
               -- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
               pure ntfTknStatus
           | otherwise -> replaceToken tknId
-        -- deprecated
-        (Just _tknId, Just NTADelete) -> deleteToken c tkn $> NTExpired
+        (Just tknId, Just NTADelete) -> do
+          agentNtfDeleteToken c tknId tkn
+          withStore' c (`removeNtfToken` tkn)
+          ns <- asks ntfSupervisor
+          atomically $ nsRemoveNtfToken ns
+          pure NTExpired
         _ -> pure ntfTknStatus
       withStore' c $ \db -> updateNtfMode db tkn suppliedNtfMode
       pure status
@@ -2016,7 +1985,7 @@ deleteNtfToken' c deviceToken =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
       when (deviceToken /= savedDeviceToken) $ logWarn "deleteNtfToken: different token"
-      deleteToken c tkn
+      deleteToken_ c tkn
       deleteNtfSubs c NSCSmpDelete
     _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
 
@@ -2051,6 +2020,20 @@ toggleConnectionNtfs' c connId enable = do
           let cmd = if enable then NSCCreate else NSCSmpDelete
           atomically $ sendNtfSubCommand ns (cmd, [connId])
 
+deleteToken_ :: AgentClient -> NtfToken -> AM ()
+deleteToken_ c@AgentClient {subQ} tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
+  ns <- asks ntfSupervisor
+  forM_ ntfTokenId $ \tknId -> do
+    let ntfTknAction = Just NTADelete
+    withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction
+    atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction}
+    agentNtfDeleteToken c tknId tkn `catchAgentError` \e -> notify (ERR e) -- TODO cleanup task
+  withStore' c $ \db -> removeNtfToken db tkn
+  atomically $ nsRemoveNtfToken ns
+  where
+    notify :: forall e. AEntityI e => AEvent e -> AM ()
+    notify cmd = atomically $ writeTBQueue subQ ("", "", AEvt (sAEntity @e) cmd)
+
 withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
 withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
   ns <- asks ntfSupervisor
@@ -2161,13 +2144,9 @@ debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do
     getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
 
 getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth
-getSMPServer c userId = getNextSMPServer c userId []
+getSMPServer c userId = withUserServers c userId pickServer
 {-# INLINE getSMPServer #-}
 
-getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
-getNextSMPServer c userId = getNextServer c userId storageSrvs
-{-# INLINE getNextSMPServer #-}
-
 subscriber :: AgentClient -> AM' ()
 subscriber c@AgentClient {msgQ} = forever $ do
   t <- atomically $ readTBQueue msgQ
@@ -2185,7 +2164,6 @@ cleanupManager c@AgentClient {subQ} = do
     run ERR $ withStore' c (`deleteRcvMsgHashesExpired` ttl)
     run ERR $ withStore' c (`deleteSndMsgsExpired` ttl)
     run ERR $ withStore' c (`deleteRatchetKeyHashesExpired` ttl)
-    run ERR $ withStore' c (`deleteExpiredNtfTokensToDelete` ttl)
     run RFERR deleteRcvFilesExpired
     run RFERR deleteRcvFilesDeleted
     run RFERR deleteRcvFilesTmpPaths
@@ -2324,9 +2302,12 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
             atomically $ incSMPServerStat c userId srv recvMsgs
             void . handleNotifyAck $ do
               msg' <- decryptSMPMessage rq msg
-              handleNotifyAck $ case msg' of
+              ack' <- handleNotifyAck $ case msg' of
                 SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
                 SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
+              whenM (liftIO $ hasGetLock c rq) $
+                notify (MSGNTF $ SMP.rcvMessageMeta srvMsgId msg')
+              pure ack'
             where
               queueDrained = case conn of
                 DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ A_QCONT (sndAddress rq)
@@ -2513,7 +2494,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
 
           decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> AM (SMP.PrivHeader, AgentMsgEnvelope)
           decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do
-            clientMsg <- liftEither $ agentCbDecrypt e2eDh cmNonce cmEncBody
+            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,

src/Simplex/Messaging/Agent/Client.hs

@@ -30,7 +30,6 @@ module Simplex.Messaging.Agent.Client
     withConnLocks,
     withInvLock,
     withLockMap,
-    getMapLock,
     ipAddressProtected,
     closeAgentClient,
     closeProtocolServerClients,
@@ -93,7 +92,6 @@ module Simplex.Messaging.Agent.Client
     hasActiveSubscription,
     hasPendingSubscription,
     hasGetLock,
-    releaseGetLock,
     activeClientSession,
     agentClientStore,
     agentDRG,
@@ -149,6 +147,7 @@ module Simplex.Messaging.Agent.Client
     userServers,
     pickServer,
     getNextServer,
+    withUserServers,
     withNextSrv,
     incSMPServerStat,
     incSMPServerStat',
@@ -192,12 +191,12 @@ import qualified Data.ByteString.Char8 as B
 import Data.Either (isRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find, foldl', partition)
+import Data.List (deleteFirstsBy, find, foldl', 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 (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -263,6 +262,7 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
     XFTPServer,
     XFTPServerWithAuth,
+    sameSrvAddr',
     pattern NoEntity,
   )
 import qualified Simplex.Messaging.Protocol as SMP
@@ -499,7 +499,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
   getMsgLocks <- TM.emptyIO
   connLocks <- TM.emptyIO
   invLocks <- TM.emptyIO
-  deleteLock <- createLockIO
+  deleteLock <- atomically createLock
   smpSubWorkers <- TM.emptyIO
   smpServersStats <- TM.emptyIO
   xftpServersStats <- TM.emptyIO
@@ -617,7 +617,7 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
 getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
 getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do
   unlessM (readTVarIO active) $ throwE INACTIVE
-  proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_
+  proxySrv <- maybe (getNextServer c userId [destSrv]) pure proxySrv_
   ts <- liftIO getCurrentTime
   atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) ->
     either (newProxyClient tSess auth ts) (waitForProxyClient tSess auth) v
@@ -1072,7 +1072,7 @@ sendOrProxySMPCommand ::
   (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
   (SMPClient -> ExceptT SMPClientError IO ()) ->
   AM (Maybe SMPServer)
-sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
+sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
   tSess <- mkTransportSession c userId destSrv connId
   ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
   where
@@ -1091,7 +1091,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
         SPFAllow -> True
         SPFAllowProtected -> ipAddressProtected cfg destSrv
         SPFProhibit -> False
-    unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
+    unknownServer = liftIO $ maybe True (notElem destSrv . knownSrvs) <$> TM.lookupIO userId (smpServers c)
     sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
     sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
       r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
@@ -1386,7 +1386,6 @@ temporaryAgentError = \case
   PROXY _ _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> tempBrokerError e
   PROXY _ _ (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> True
   INACTIVE -> True
-  CRITICAL True _ -> True -- critical errors that do not show restart button are likely to be permanent
   _ -> False
   where
     tempBrokerError = \case
@@ -1590,7 +1589,7 @@ getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
 
 decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
 decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
-  liftEither $ parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
+  liftEither . parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
   where
     decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
 
@@ -1647,9 +1646,10 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
     queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvPrivateKey, rcvId)
 
 sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
-sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
+sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
   withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
-    ackSMPMessage smp rcvPrivateKey rcvId msgId      
+    ackSMPMessage smp rcvPrivateKey rcvId msgId
+  atomically $ releaseGetLock c rq
 
 hasGetLock :: AgentClient -> RcvQueue -> IO Bool
 hasGetLock c RcvQueue {server, rcvId} =
@@ -1721,8 +1721,8 @@ agentNtfReplaceToken :: AgentClient -> NtfTokenId -> NtfToken -> DeviceToken ->
 agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
   withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
 
-agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
-agentNtfDeleteToken c ntfServer ntfPrivKey tknId =
+agentNtfDeleteToken :: AgentClient -> NtfTokenId -> NtfToken -> AM ()
+agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
   withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
 
 agentNtfEnableCron :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
@@ -1830,9 +1830,9 @@ agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
 
 -- | NaCl crypto-box decrypt - both for messages received from the server
 -- and per-queue E2E encrypted messages from the sender that were inside.
-agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> Either AgentErrorType ByteString
+agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> AM ByteString
 agentCbDecrypt dhSecret nonce msg =
-  first cryptoError $
+  liftEither . first cryptoError $
     C.cbDecrypt dhSecret nonce msg
 
 cryptoError :: C.CryptoError -> AgentErrorType
@@ -1865,12 +1865,13 @@ withWork c doWork getWork action =
     noWork = liftIO $ noWorkToDo doWork
     notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
 
-withWorkItems :: AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError [Either StoreError a])) -> (NonEmpty a -> AM ()) -> AM ()
-withWorkItems c doWork getWork action = do
+withWorkItems :: String -> AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError [Either StoreError a])) -> (NonEmpty a -> AM ()) -> AM ()
+withWorkItems str c doWork getWork action = do
   withStore' c getWork >>= \case
     Right [] -> noWork
     Right rs -> do
       let (errs, items) = partitionEithers rs
+      liftIO $ print $ "withWorkItems - " <> str <> " - length items = " <> show (length items) <> ", length errs = " <> show (length errs)
       case L.nonEmpty items of
         Just items' -> action items'
         Nothing -> do
@@ -2034,82 +2035,33 @@ userServers c = case protocolTypeI @p of
   SPXFTP -> xftpServers c
 {-# INLINE userServers #-}
 
-pickServer :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
+pickServer :: forall p. NonEmpty (ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
 pickServer = \case
-  (_, srv) :| [] -> pure srv
+  srv :| [] -> pure srv
   servers -> do
     gen <- asks randomServer
-    atomically $ snd . (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
+    atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
 
-getNextServer ::
-  (ProtocolTypeI p, UserProtocol p) =>
-  AgentClient ->
-  UserId -> 
-  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
-  [ProtocolServer p] ->
-  AM (ProtoServerWithAuth p)
-getNextServer c userId srvsSel usedSrvs = do
-  srvs <- getUserServers_ c userId srvsSel
-  snd <$> getNextServer_ srvs (usedOperatorsHosts srvs usedSrvs)
+getNextServer :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> [ProtocolServer p] -> AM (ProtoServerWithAuth p)
+getNextServer c userId usedSrvs = withUserServers c userId $ \srvs ->
+  case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of
+    Just srvs' -> pickServer srvs'
+    _ -> pickServer srvs
 
-usedOperatorsHosts :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> [ProtocolServer p] -> (Set (Maybe OperatorId), Set TransportHost)
-usedOperatorsHosts srvs usedSrvs = (usedOperators, usedHosts)
-  where
-    usedHosts = S.unions $ map serverHosts usedSrvs
-    usedOperators = S.fromList $ mapMaybe usedOp $ L.toList srvs
-    usedOp (op, srv) = if hasUsedHost srv then Just op else Nothing
-    hasUsedHost (ProtoServerWithAuth srv _) = any (`S.member` usedHosts) $ serverHosts srv
-
-getNextServer_ ::
-  (ProtocolTypeI p, UserProtocol p) =>
-  NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) ->
-  (Set (Maybe OperatorId), Set TransportHost) ->
-  AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p), ProtoServerWithAuth p)
-getNextServer_ servers (usedOperators, usedHosts) = do
-  -- choose from servers of unused operators, when possible
-  let otherOpsSrvs = filterOrAll ((`S.notMember` usedOperators) . fst) servers
-      -- choose from servers with unused hosts when possible
-      unusedSrvs = filterOrAll (isUnusedServer usedHosts) otherOpsSrvs
-  (otherOpsSrvs,) <$> pickServer unusedSrvs
-  where
-    filterOrAll p srvs = fromMaybe srvs $ L.nonEmpty $ L.filter p srvs
-
-isUnusedServer :: Set TransportHost -> (Maybe OperatorId, ProtoServerWithAuth p) -> Bool
-isUnusedServer usedHosts (_, ProtoServerWithAuth ProtocolServer {host} _) = all (`S.notMember` usedHosts) host
-
-getUserServers_ ::
-  (ProtocolTypeI p, UserProtocol p) =>
-  AgentClient ->
-  UserId ->
-  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
-  AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p))
-getUserServers_ c userId srvsSel =
+withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a
+withUserServers c userId action =
   liftIO (TM.lookupIO userId $ userServers c) >>= \case
-    Just srvs -> pure $ srvsSel srvs
+    Just srvs -> action $ enabledSrvs srvs
     _ -> throwE $ INTERNAL "unknown userId - no user servers"
 
--- This function checks used servers and operators every time to allow
--- changing configuration while retry look is executing.
--- This function is not thread safe.
-withNextSrv ::
-  (ProtocolTypeI p, UserProtocol p) =>
-  AgentClient ->
-  UserId ->
-  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
-  TVar (Set TransportHost) ->
-  [ProtocolServer p] -> 
-  (ProtoServerWithAuth p -> AM a) ->
-  AM a
-withNextSrv c userId srvsSel triedHosts usedSrvs action = do
-  srvs <- getUserServers_ c userId srvsSel
-  let (usedOperators, usedHosts) = usedOperatorsHosts srvs usedSrvs
-  tried <- readTVarIO triedHosts
-  let triedOrUsed = S.union tried usedHosts
-  (otherOpsSrvs, srvAuth@(ProtoServerWithAuth srv _)) <- getNextServer_ srvs (usedOperators, triedOrUsed)
-  let newHosts = serverHosts srv
-      unusedSrvs = L.filter (isUnusedServer $ S.union triedOrUsed newHosts) otherOpsSrvs
-      !tried' = if null unusedSrvs then S.empty else S.union tried newHosts
-  atomically $ writeTVar triedHosts tried'
+withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a
+withNextSrv c userId usedSrvs initUsed action = do
+  used <- readTVarIO usedSrvs
+  srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
+  srvs_ <- liftIO $ TM.lookupIO userId $ userServers c
+  let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_
+      used' = if null unused then initUsed else srv : used
+  atomically $ writeTVar usedSrvs $! used'
   action srvAuth
 
 incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()

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

@@ -17,14 +17,11 @@ module Simplex.Messaging.Agent.Env.SQLite
     AgentConfig (..),
     InitialAgentServers (..),
     ServerCfg (..),
-    ServerRoles (..),
-    OperatorId,
     UserServers (..),
     NetworkConfig (..),
     presetServerCfg,
-    allRoles,
+    enabledServerCfg,
     mkUserServers,
-    serverHosts,
     defaultAgentConfig,
     defaultReconnectInterval,
     tryAgentError,
@@ -45,7 +42,6 @@ module Simplex.Messaging.Agent.Env.SQLite
 where
 
 import Control.Concurrent (ThreadId)
-import Control.Exception (BlockedIndefinitelyOnSTM (..), SomeException, fromException)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -58,8 +54,6 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import qualified Data.Set as S
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Word (Word16)
@@ -77,14 +71,14 @@ import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Notifications.Transport (NTFVersion)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (defaultJSON)
-import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion)
-import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
 import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
+import UnliftIO (SomeException)
 import UnliftIO.STM
 
 type AM' a = ReaderT Env IO a
@@ -100,42 +94,29 @@ data InitialAgentServers = InitialAgentServers
 
 data ServerCfg p = ServerCfg
   { server :: ProtoServerWithAuth p,
-    operator :: Maybe OperatorId,
-    enabled :: Bool,
-    roles :: ServerRoles
+    preset :: Bool,
+    tested :: Maybe Bool,
+    enabled :: Bool
   }
   deriving (Show)
 
-data ServerRoles = ServerRoles
-  { storage :: Bool,
-    proxy :: Bool
-  }
-  deriving (Show)
+enabledServerCfg :: ProtoServerWithAuth p -> ServerCfg p
+enabledServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True}
 
-allRoles :: ServerRoles
-allRoles = ServerRoles True True
-
-presetServerCfg :: Bool -> ServerRoles -> Maybe OperatorId -> ProtoServerWithAuth p -> ServerCfg p
-presetServerCfg enabled roles operator server =
-  ServerCfg {server, operator, enabled, roles}
+presetServerCfg :: Bool -> ProtoServerWithAuth p -> ServerCfg p
+presetServerCfg enabled server = ServerCfg {server, preset = True, tested = Nothing, enabled}
 
 data UserServers p = UserServers
-  { storageSrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
-    proxySrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
-    knownHosts :: Set TransportHost
+  { enabledSrvs :: NonEmpty (ProtoServerWithAuth p),
+    knownSrvs :: NonEmpty (ProtocolServer p)
   }
 
-type OperatorId = Int64
-
 -- This function sets all servers as enabled in case all passed servers are disabled.
 mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p
-mkUserServers srvs = UserServers {storageSrvs = filterSrvs storage, proxySrvs = filterSrvs proxy, knownHosts}
+mkUserServers srvs = UserServers {enabledSrvs, knownSrvs}
   where
-    filterSrvs role = L.map (\ServerCfg {operator, server} -> (operator, server)) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled, roles} -> enabled && role roles) srvs
-    knownHosts = S.unions $ L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> serverHosts srv) srvs
-
-serverHosts :: ProtocolServer p -> Set TransportHost
-serverHosts ProtocolServer {host} = S.fromList $ L.toList host
+    enabledSrvs = L.map (\ServerCfg {server} -> server) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled} -> enabled) srvs
+    knownSrvs = L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> srv) srvs
 
 data AgentConfig = AgentConfig
   { tcpPort :: Maybe ServiceName,
@@ -278,8 +259,7 @@ data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
     ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId),
     ntfWorkers :: TMap NtfServer Worker,
-    ntfSMPWorkers :: TMap SMPServer Worker,
-    ntfTknDelWorkers :: TMap NtfServer Worker
+    ntfSMPWorkers :: TMap SMPServer Worker
   }
 
 data NtfSupervisorCommand = NSCCreate | NSCSmpDelete | NSCDeleteSub
@@ -291,8 +271,7 @@ newNtfSubSupervisor qSize = do
   ntfSubQ <- newTBQueueIO qSize
   ntfWorkers <- TM.emptyIO
   ntfSMPWorkers <- TM.emptyIO
-  ntfTknDelWorkers <- TM.emptyIO
-  pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers, ntfTknDelWorkers}
+  pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
 
 data XFTPAgent = XFTPAgent
   { -- if set, XFTP file paths will be considered as relative to this directory
@@ -332,9 +311,7 @@ agentFinally = allFinally mkInternal
 {-# INLINE agentFinally #-}
 
 mkInternal :: SomeException -> AgentErrorType
-mkInternal e = case fromException e of
-  Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
-  _ -> INTERNAL $ show e
+mkInternal = INTERNAL . show
 {-# INLINE mkInternal #-}
 
 data Worker = Worker
@@ -356,8 +333,6 @@ updateRestartCount t (RestartCount minute count) = do
 
 $(pure [])
 
-$(JQ.deriveJSON defaultJSON ''ServerRoles)
-
 instance ProtocolTypeI p => ToJSON (ServerCfg p) where
   toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
   toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)

src/Simplex/Messaging/Agent/Lock.hs

@@ -1,7 +1,6 @@
 module Simplex.Messaging.Agent.Lock
   ( Lock,
     createLock,
-    createLockIO,
     withLock,
     withLock',
     withGetLock,
@@ -25,10 +24,6 @@ createLock :: STM Lock
 createLock = newEmptyTMVar
 {-# INLINE createLock #-}
 
-createLockIO :: IO Lock
-createLockIO = newEmptyTMVarIO
-{-# INLINE createLockIO #-}
-
 withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
 withLock lock name = ExceptT . withLock' lock name . runExceptT
 {-# INLINE withLock #-}

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -15,7 +15,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
     nsRemoveNtfToken,
     sendNtfSubCommand,
     instantNotifications,
-    deleteToken,
     closeNtfSupervisor,
     getNtfServer,
   )
@@ -59,20 +58,14 @@ import qualified UnliftIO.Exception as E
 runNtfSupervisor :: AgentClient -> AM' ()
 runNtfSupervisor c = do
   ns <- asks ntfSupervisor
-  runExceptT startTknDelete >>= \case
-    Left e -> notifyErr e
-    Right _ -> pure ()
   forever $ do
+    liftIO $ print "#################### runNtfSupervisor - in forever loop"
     cmd <- atomically . readTBQueue $ ntfSubQ ns
     handleErr . agentOperationBracket c AONtfNetwork waitUntilActive $
       runExceptT (processNtfCmd c cmd) >>= \case
         Left e -> notifyErr e
         Right _ -> return ()
   where
-    startTknDelete :: AM ()
-    startTknDelete = do
-      pendingDelServers <- withStore' c getPendingDelTknServers
-      lift . forM_ pendingDelServers $ getNtfTknDelWorker True c
     handleErr :: AM' () -> AM' ()
     handleErr = E.handle $ \(e :: E.SomeException) -> do
       logError $ "runNtfSupervisor error " <> tshow e
@@ -198,29 +191,25 @@ getNtfSMPWorker hasWork c server = do
   ws <- asks $ ntfSMPWorkers . ntfSupervisor
   getAgentWorker "ntf_smp" hasWork c server ws $ runNtfSMPWorker c server
 
-getNtfTknDelWorker :: Bool -> AgentClient -> NtfServer -> AM' Worker
-getNtfTknDelWorker hasWork c server = do
-  ws <- asks $ ntfTknDelWorkers . ntfSupervisor
-  getAgentWorker "ntf_tkn_del" hasWork c server ws $ runNtfTknDelWorker c server
-
 withTokenServer :: (NtfServer -> AM ()) -> AM ()
 withTokenServer action = lift getNtfToken >>= mapM_ (\NtfToken {ntfServer} -> action ntfServer)
 
 runNtfWorker :: AgentClient -> NtfServer -> Worker -> AM ()
 runNtfWorker c srv Worker {doWork} =
   forever $ do
+    liftIO $ print "#################### runNtfWorker - in forever loop"
     waitForWork doWork
     ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
   where
     runNtfOperation :: AM ()
     runNtfOperation = do
       ntfBatchSize <- asks $ ntfBatchSize . config
-      withWorkItems c doWork (\db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
+      withWorkItems "runNtfWorker" c doWork (\db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
         logInfo $ "runNtfWorker - length nextSubs = " <> tshow (length nextSubs)
         currTs <- liftIO getCurrentTime
         let (creates, checks, deletes, rotates) = splitActions currTs nextSubs
         if null creates && null checks && null deletes && null rotates
-          then
+          then 
             let (_, _, firstActionTs) = L.head nextSubs
              in lift $ rescheduleWork doWork currTs firstActionTs
           else do
@@ -377,15 +366,18 @@ runNtfWorker c srv Worker {doWork} =
 
 runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
 runNtfSMPWorker c srv Worker {doWork} = forever $ do
+  ts <- liftIO getCurrentTime
+  liftIO $ print $ "#################### runNtfSMPWorker - in forever loop - ts = " <> show ts
   waitForWork doWork
   ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfSMPOperation
   where
     runNtfSMPOperation :: AM ()
     runNtfSMPOperation = do
       ntfBatchSize <- asks $ ntfBatchSize . config
-      withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
+      withWorkItems "runNtfSMPWorker" c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
         logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
         let (creates, deletes) = splitActions nextSubs
+        liftIO $ print $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs) <> ", length creates = " <> tshow (length creates) <> ", length deletes = " <> tshow (length deletes)
         retrySubActions c creates createNotifierKeys
         retrySubActions c deletes deleteNotifierKeys
     splitActions :: NonEmpty (NtfSubSMPAction, NtfSubscription) -> ([NtfSubscription], [NtfSubscription])
@@ -535,51 +527,10 @@ instantNotifications = \case
   Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
   _ -> False
 
-deleteToken :: AgentClient -> NtfToken -> AM ()
-deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
-  setToDelete <- withStore' c $ \db -> do
-    removeNtfToken db tkn
-    case ntfTokenId of
-      Just tknId -> addNtfTokenToDelete db ntfServer ntfPrivKey tknId $> True
-      Nothing -> pure False
-  ns <- asks ntfSupervisor
-  atomically $ nsRemoveNtfToken ns
-  when setToDelete $ void $ lift $ getNtfTknDelWorker True c ntfServer
-
-runNtfTknDelWorker :: AgentClient -> NtfServer -> Worker -> AM ()
-runNtfTknDelWorker c srv Worker {doWork} =
-  forever $ do
-    waitForWork doWork
-    ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
-  where
-    runNtfOperation :: AM ()
-    runNtfOperation =
-      withWork c doWork (`getNextNtfTokenToDelete` srv) $
-        \nextTknToDelete -> do
-          logInfo $ "runNtfTknDelWorker, nextTknToDelete " <> tshow nextTknToDelete
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop -> do
-            liftIO $ waitWhileSuspended c
-            liftIO $ waitForUserNetwork c
-            processTknToDelete nextTknToDelete `catchAgentError` retryTmpError loop nextTknToDelete
-    retryTmpError :: AM () -> NtfTokenToDelete -> AgentErrorType -> AM ()
-    retryTmpError loop (tknDbId, _, _) e = do
-      logError $ "ntf tkn del error: " <> tshow e
-      if temporaryOrHostError e
-        then retryNetworkLoop c loop
-        else do
-          withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
-          notifyInternalError' c (show e)
-    processTknToDelete :: NtfTokenToDelete -> AM ()
-    processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
-      agentNtfDeleteToken c srv ntfPrivKey tknId
-      withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
-
 closeNtfSupervisor :: NtfSupervisor -> IO ()
 closeNtfSupervisor ns = do
   stopWorkers $ ntfWorkers ns
   stopWorkers $ ntfSMPWorkers ns
-  stopWorkers $ ntfTknDelWorkers ns
   where
     stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 

src/Simplex/Messaging/Agent/Protocol.hs

@@ -108,7 +108,6 @@ module Simplex.Messaging.Agent.Protocol
     ConnReqUriData (..),
     CRClientData,
     ServiceScheme,
-    sameConnReqContact,
     simplexChat,
     connReqUriP',
     AgentErrorType (..),
@@ -199,6 +198,7 @@ import Simplex.Messaging.Protocol
     NMsgMeta,
     ProtocolServer (..),
     SMPClientVersion,
+    SMPMsgMeta,
     SMPServer,
     SMPServerWithAuth,
     SndPublicAuthKey,
@@ -356,7 +356,7 @@ data AEvent (e :: AEntity) where
   MERR :: AgentMsgId -> AgentErrorType -> AEvent AEConn
   MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> AEvent AEConn
   MSG :: MsgMeta -> MsgFlags -> MsgBody -> AEvent AEConn
-  MSGNTF :: MsgId -> Maybe UTCTime -> AEvent AEConn
+  MSGNTF :: SMPMsgMeta -> AEvent AEConn
   RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn
   QCONT :: AEvent AEConn
   DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> AEvent AEConn
@@ -1264,12 +1264,6 @@ instance Eq AConnectionRequestUri where
 
 deriving instance Show AConnectionRequestUri
 
-sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
-sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
-  L.length qs == L.length qs' && all same (L.zip qs qs')
-  where
-    same (q, q') = sameQAddress (qAddress q) (qAddress q')
-
 data ConnReqUriData = ConnReqUriData
   { crScheme :: ServiceScheme,
     crAgentVRange :: VersionRangeSMPA,

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

@@ -122,7 +122,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     getRcvMsg,
     getLastMsg,
     checkRcvMsgHashExists,
-    getRcvMsgBrokerTs,
     deleteMsg,
     deleteDeliveredSndMsg,
     deleteSndMsgDelivery,
@@ -151,13 +150,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateNtfMode,
     updateNtfToken,
     removeNtfToken,
-    addNtfTokenToDelete,
-    deleteExpiredNtfTokensToDelete,
-    NtfTokenToDelete,
-    getNextNtfTokenToDelete,
-    markNtfTokenToDeleteFailed_, -- exported for tests
-    getPendingDelTknServers,
-    deleteNtfTokenToDelete,
     -- Notification subscription persistence
     NtfSupervisorSub,
     getNtfSubscription,
@@ -976,11 +968,10 @@ updateRcvIds db connId = do
   pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
 
 createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
-createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId, broker = (_, brokerTs)}, internalRcvId, internalHash} = do
+createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalRcvId, internalHash} = do
   insertRcvMsgBase_ db connId rcvMsgData
   insertRcvMsgDetails_ db connId rq rcvMsgData
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
-  DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId)
 
 updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
 updateSndIds db connId = runExceptT $ do
@@ -1187,11 +1178,6 @@ checkRcvMsgHashExists db connId hash = do
           (connId, hash)
       )
 
-getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
-getRcvMsgBrokerTs db connId msgId =
-  firstRow fromOnly SEMsgNotFound $
-    DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId)
-
 deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
 deleteMsg db connId msgId =
   DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
@@ -1500,70 +1486,6 @@ removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer
     |]
     (provider, token, host, port)
 
-addNtfTokenToDelete :: DB.Connection -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> IO ()
-addNtfTokenToDelete db ProtocolServer {host, port, keyHash} ntfPrivKey tknId =
-  DB.execute db "INSERT INTO ntf_tokens_to_delete (ntf_host, ntf_port, ntf_key_hash, tkn_id, tkn_priv_key) VALUES (?,?,?,?,?)" (host, port, keyHash, tknId, ntfPrivKey)
-
-deleteExpiredNtfTokensToDelete :: DB.Connection -> NominalDiffTime -> IO ()
-deleteExpiredNtfTokensToDelete db ttl = do
-  cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
-  DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE created_at < ?" (Only cutoffTs)
-
-type NtfTokenToDelete = (Int64, C.APrivateAuthKey, NtfTokenId)
-
-getNextNtfTokenToDelete :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe NtfTokenToDelete))
-getNextNtfTokenToDelete db (NtfServer ntfHost ntfPort _) =
-  getWorkItem "ntf tkn del" getNtfTknDbId getNtfTknToDelete (markNtfTokenToDeleteFailed_ db)
-  where
-    getNtfTknDbId :: IO (Maybe Int64)
-    getNtfTknDbId =
-      maybeFirstRow fromOnly $
-        DB.query
-          db
-          [sql|
-            SELECT ntf_token_to_delete_id
-            FROM ntf_tokens_to_delete
-            WHERE ntf_host = ? AND ntf_port = ?
-              AND del_failed = 0
-            ORDER BY created_at ASC
-            LIMIT 1
-          |]
-          (ntfHost, ntfPort)
-    getNtfTknToDelete :: Int64 -> IO (Either StoreError NtfTokenToDelete)
-    getNtfTknToDelete tknDbId =
-      firstRow ntfTokenToDelete err $
-        DB.query
-          db
-          [sql|
-            SELECT tkn_priv_key, tkn_id
-            FROM ntf_tokens_to_delete
-            WHERE ntf_token_to_delete_id = ?
-          |]
-          (Only tknDbId)
-      where
-        err = SEInternal $ "ntf token to delete " <> bshow tknDbId <> " returned []"
-        ntfTokenToDelete (tknPrivKey, tknId) = (tknDbId, tknPrivKey, tknId)
-
-markNtfTokenToDeleteFailed_ :: DB.Connection -> Int64 -> IO ()
-markNtfTokenToDeleteFailed_ db tknDbId =
-  DB.execute db "UPDATE ntf_tokens_to_delete SET del_failed = 1 where ntf_token_to_delete_id = ?" (Only tknDbId)
-
-getPendingDelTknServers :: DB.Connection -> IO [NtfServer]
-getPendingDelTknServers db =
-  map toNtfServer
-    <$> DB.query_
-      db
-      [sql|
-        SELECT DISTINCT ntf_host, ntf_port, ntf_key_hash
-        FROM ntf_tokens_to_delete
-      |]
-  where
-    toNtfServer (host, port, keyHash) = NtfServer host port keyHash
-
-deleteNtfTokenToDelete :: DB.Connection -> Int64 -> IO ()
-deleteNtfTokenToDelete db tknDbId =
-  DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE ntf_token_to_delete_id = ?" (Only tknDbId)
-
 type NtfSupervisorSub = (NtfSubscription, Maybe (NtfSubAction, NtfActionTs))
 
 getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe NtfSupervisorSub)
@@ -1818,19 +1740,19 @@ getActiveNtfToken db =
           ntfMode = fromMaybe NMPeriodic ntfMode_
        in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
-getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime))
+getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret))
 getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
   firstRow' res SEConnNotFound $
     DB.query
       db
       [sql|
-        SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts
+        SELECT conn_id, rcv_ntf_dh_secret
         FROM rcv_queues
         WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
       |]
       (host, port, notifierId)
   where
-    res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_)
+    res (connId, Just rcvNtfDhSecret) = Right (connId, rcvNtfDhSecret)
     res _ = Left SEConnNotFound
 
 setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()

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

@@ -74,8 +74,6 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -118,9 +116,7 @@ schemaMigrations =
     ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
     ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
     ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
-    ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats),
-    ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
-    ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts)
+    ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -1,27 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20240930_ntf_tokens_to_delete :: Query
-m20240930_ntf_tokens_to_delete =
-    [sql|
-CREATE TABLE ntf_tokens_to_delete (
-  ntf_token_to_delete_id INTEGER PRIMARY KEY,
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_key_hash BLOB NOT NULL,
-  tkn_id BLOB NOT NULL, -- token ID assigned by notifications server
-  tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands,
-  del_failed INTEGER DEFAULT 0,
-  created_at TEXT NOT NULL DEFAULT (datetime('now'))
-);
-|]
-
-down_m20240930_ntf_tokens_to_delete :: Query
-down_m20240930_ntf_tokens_to_delete =
-    [sql|
-DROP TABLE ntf_tokens_to_delete;
-|]

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

@@ -1,18 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20241007_rcv_queues_last_broker_ts :: Query
-m20241007_rcv_queues_last_broker_ts =
-    [sql|
-ALTER TABLE rcv_queues ADD COLUMN last_broker_ts TEXT;
-|]
-
-down_m20241007_rcv_queues_last_broker_ts :: Query
-down_m20241007_rcv_queues_last_broker_ts =
-    [sql|
-ALTER TABLE rcv_queues DROP COLUMN last_broker_ts;
-|]

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

@@ -1 +0,0 @@
-CREATE INDEX 'ratchets_conn_id' ON 'ratchets'('conn_id'); --> connections(conn_id)

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

@@ -56,7 +56,6 @@ CREATE TABLE rcv_queues(
   switch_status TEXT,
   deleted INTEGER NOT NULL DEFAULT 0,
   snd_secure INTEGER NOT NULL DEFAULT 0,
-  last_broker_ts TEXT,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -404,16 +403,6 @@ CREATE TABLE servers_stats(
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
-CREATE TABLE ntf_tokens_to_delete(
-  ntf_token_to_delete_id INTEGER PRIMARY KEY,
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_key_hash BLOB NOT NULL,
-  tkn_id BLOB NOT NULL, -- token ID assigned by notifications server
-  tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands,
-del_failed INTEGER DEFAULT 0,
-created_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);

src/Simplex/Messaging/Client.hs

@@ -199,7 +199,6 @@ smpClientStub g sessionId thVersion thAuth = do
               thAuth,
               blockSize = smpBlockSize,
               implySessId = thVersion >= authCmdsSMPVersion,
-              encryptBlock = Nothing,
               batch = True
             },
         sessionTs = ts,
@@ -428,9 +427,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
 defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
 defaultSMPClientConfig =
   (defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
-    { defaultTransport = (show defaultSMPPort, transport @TLS),
-      agreeSecret = True
-    }
+    {defaultTransport = (show defaultSMPPort, transport @TLS)}
 {-# INLINE defaultSMPClientConfig #-}
 
 data Request err msg = Request
@@ -717,8 +714,8 @@ createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
 subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
-subscribeSMPQueue c rpKey rId = do
-  liftIO $ enablePings c
+subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = do
+  liftIO . atomically $ writeTVar sendPings True
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> pure ()
     cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
@@ -726,8 +723,8 @@ subscribeSMPQueue c rpKey rId = do
 
 -- | Subscribe to multiple SMP queues batching commands if supported.
 subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
-subscribeSMPQueues c qs = do
-  liftIO $ enablePings c
+subscribeSMPQueues c@ProtocolClient {client_ = PClient {sendPings}} qs = do
+  atomically $ writeTVar sendPings True
   sendProtocolCommands c cs >>= mapM (processSUBResponse c)
   where
     cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
@@ -766,22 +763,14 @@ getSMPMessage c rpKey rId =
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
 subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO ()
-subscribeSMPQueueNotifications c npKey nId = do
-  liftIO $ enablePings c
-  okSMPCommand NSUB c npKey nId
+subscribeSMPQueueNotifications = okSMPCommand NSUB
 {-# INLINE subscribeSMPQueueNotifications #-}
 
 -- | Subscribe to multiple SMP queues notifications batching commands if supported.
 subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
-subscribeSMPQueuesNtfs c qs = do
-  liftIO $ enablePings c
-  okSMPCommands NSUB c qs
+subscribeSMPQueuesNtfs = okSMPCommands NSUB
 {-# INLINE subscribeSMPQueuesNtfs #-}
 
-enablePings :: SMPClient -> IO ()
-enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeTVar sendPings True
-{-# INLINE enablePings #-}
-
 -- | 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

src/Simplex/Messaging/Client/Agent.hs

@@ -84,8 +84,8 @@ defaultSMPClientAgentConfig =
             maxInterval = 10 * second
           },
       persistErrorInterval = 30, -- seconds
-      msgQSize = 2048,
-      agentQSize = 2048,
+      msgQSize = 1024,
+      agentQSize = 1024,
       agentSubsBatchSize = 1360,
       ownServerDomains = []
     }

src/Simplex/Messaging/Notifications/Client.hs

@@ -24,7 +24,7 @@ type NtfClientError = ProtocolClientError ErrorType
 
 defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
 defaultNTFClientConfig =
-  (defaultClientConfig (Just supportedNTFHandshakes) False supportedClientNTFVRange)
+  (defaultClientConfig (Just supportedNTFHandshakes) True supportedClientNTFVRange)
     {defaultTransport = ("443", transport @TLS)}
 {-# INLINE defaultNTFClientConfig #-}
 

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -20,11 +20,8 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Kind
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as L
 import Data.Maybe (isNothing)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock.System
 import Data.Type.Equality
 import Data.Word (Word16)
 import Database.SQLite.Simple.FromField (FromField (..))
@@ -429,30 +426,6 @@ instance FromJSON DeviceToken where
     t <- encodeUtf8 <$> o .: "token"
     pure $ DeviceToken pp t
 
--- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
--- because strEncode of NonEmpty list uses comma for separator,
--- and encoding of PNMessageData's smpQueue has comma in list of hosts
-encodePNMessages :: NonEmpty PNMessageData -> ByteString
-encodePNMessages = B.intercalate ";" . map strEncode . L.toList
-
-pnMessagesP :: A.Parser (NonEmpty PNMessageData)
-pnMessagesP = L.fromList <$> strP `A.sepBy1` A.char ';'
-
-data PNMessageData = PNMessageData
-  { smpQueue :: SMPQueueNtf,
-    ntfTs :: SystemTime,
-    nmsgNonce :: C.CbNonce,
-    encNMsgMeta :: EncNMsgMeta
-  }
-  deriving (Show)
-
-instance StrEncoding PNMessageData where
-  strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
-    strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
-  strP = do
-    (smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
-    pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
-
 type NtfEntityId = EntityId
 
 type NtfSubscriptionId = NtfEntityId

src/Simplex/Messaging/Notifications/Server.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -19,17 +17,13 @@ import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
-import Data.Bifunctor (first)
-import qualified Data.ByteString.Builder as BLD
 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.IORef
 import Data.Int (Int64)
-import qualified Data.IntSet as IS
-import Data.List (intercalate, partition, sort)
+import Data.List (intercalate, sort)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
@@ -40,42 +34,34 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import GHC.IORef (atomicSwapIORef)
-import GHC.Stats (getRTSStats)
-import Network.Socket (ServiceName, Socket, socketToHandle)
+import Network.Socket (ServiceName)
 import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
-import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
-import Simplex.Messaging.Server.Control (CPClientRole (..))
-import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats)
-import Simplex.Messaging.TMap (TMap)
+import Simplex.Messaging.Server.Stats
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
-import Simplex.Messaging.Transport.Buffer (trimCR)
-import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
+import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
-import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode)
+import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
 import System.Mem.Weak (deRefWeak)
-import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, async, uninterruptibleCancel, unliftIO, withFile)
+import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
 import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.STM
-#if MIN_VERSION_base(4,18,0)
-import GHC.Conc (listThreads)
-#endif
 
 runNtfServer :: NtfServerConfig -> IO ()
 runNtfServer cfg = do
@@ -89,12 +75,11 @@ type M a = ReaderT NtfEnv IO a
 
 ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
 ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
-  restoreServerLastNtfs
   restoreServerStats
   s <- asks subscriber
   ps <- asks pushServer
   resubscribe s
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
   where
     runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
     runServer (tcpPort, ATransport t, _addHTTP) = do
@@ -115,15 +100,11 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
 
     stopServer :: M ()
     stopServer = do
-      logInfo "Saving server state..."
-      saveServer
+      withNtfLog closeStoreLog
+      saveServerStats
       NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber
       liftIO $ readTVarIO smpSubscribers >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (deRefWeak >=> mapM_ killThread))
       liftIO $ closeSMPClientAgent smpAgent
-      logInfo "Server stopped"
-
-    saveServer :: M ()
-    saveServer = withNtfLog closeStoreLog >> saveServerLastNtfs >> saveServerStats
 
     serverStatsThread_ :: NtfServerConfig -> [M ()]
     serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -171,131 +152,6 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
               ]
         liftIO $ threadDelay' interval
 
-    controlPortThread_ :: NtfServerConfig -> [M ()]
-    controlPortThread_ NtfServerConfig {controlPort = Just port} = [runCPServer port]
-    controlPortThread_ _ = []
-
-    runCPServer :: ServiceName -> M ()
-    runCPServer port = do
-      cpStarted <- newEmptyTMVarIO
-      u <- askUnliftIO
-      liftIO $ do
-        labelMyThread "control port server"
-        runLocalTCPServer cpStarted port $ runCPClient u
-      where
-        runCPClient :: UnliftIO (ReaderT NtfEnv IO) -> Socket -> IO ()
-        runCPClient u sock = do
-          labelMyThread "control port client"
-          h <- socketToHandle sock ReadWriteMode
-          hSetBuffering h LineBuffering
-          hSetNewlineMode h universalNewlineMode
-          hPutStrLn h "Ntf server control port\n'help' for supported commands"
-          role <- newTVarIO CPRNone
-          cpLoop h role
-          where
-            cpLoop h role = do
-              s <- trimCR <$> B.hGetLine h
-              case strDecode s of
-                Right CPQuit -> hClose h
-                Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role
-                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role
-            logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s
-              where
-                shouldLog = case cmd of
-                  CPAuth _ -> False
-                  CPHelp -> False
-                  CPQuit -> False
-                  CPSkip -> False
-                  _ -> True
-            processCP h role = \case
-              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
-                where
-                  newRole NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
-                    | Just auth == admin = CPRAdmin
-                    | Just auth == user = CPRUser
-                    | otherwise = CPRNone
-              CPStats -> withUserRole $ do
-                ss <- unliftIO u $ asks serverStats
-                let getStat :: (NtfServerStats -> IORef a) -> IO a
-                    getStat var = readIORef (var ss)
-                    putStat :: Show a => String -> (NtfServerStats -> IORef a) -> IO ()
-                    putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v
-                putStat "fromTime" fromTime
-                putStat "tknCreated" tknCreated
-                putStat "tknVerified" tknVerified
-                putStat "tknDeleted" tknDeleted
-                putStat "subCreated" subCreated
-                putStat "subDeleted" subDeleted
-                putStat "ntfReceived" ntfReceived
-                getStat (day . activeTokens) >>= \v -> hPutStrLn h $ "daily active tokens: " <> show (IS.size v)
-                getStat (day . activeSubs) >>= \v -> hPutStrLn h $ "daily active subscriptions: " <> show (IS.size v)
-              CPStatsRTS -> tryAny getRTSStats >>= either (hPrint h) (hPrint h)
-              CPServerInfo -> readTVarIO role >>= \case
-                CPRNone -> do
-                  logError "Unauthorized control port command"
-                  hPutStrLn h "AUTH"
-                r -> do
-#if MIN_VERSION_base(4,18,0)
-                  threads <- liftIO listThreads
-                  hPutStrLn h $ "Threads: " <> show (length threads)
-#else
-                  hPutStrLn h "Threads: not available on GHC 8.10"
-#endif
-                  NtfSubscriber {smpSubscribers, smpAgent = a} <- unliftIO u $ asks subscriber
-                  putSMPWorkers a "SMP subcscribers" smpSubscribers
-                  let SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
-                  putSMPWorkers a "SMP clients" smpClients
-                  putSMPWorkers a "SMP subscription workers" smpSubWorkers
-                  sessions <- readTVarIO smpSessions
-                  hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions)
-                  putSMPSubs a "SMP subscriptions" srvSubs
-                  putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs
-                  where
-                    putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO ()
-                    putSMPSubs a name v = do
-                      subs <- readTVarIO v
-                      (totalCnt, ownCount, otherCnt, servers, ownByServer) <- foldM countSubs (0, 0, 0, [], M.empty) $ M.assocs subs
-                      showServers a name servers
-                      hPutStrLn h $ name <> " total: " <> show totalCnt
-                      hPutStrLn h $ name <> " on own servers: " <> show ownCount
-                      when (r == CPRAdmin && not (null ownByServer)) $
-                        forM_ (M.assocs ownByServer) $ \(SMPServer (host :| _) _ _, cnt) ->
-                          hPutStrLn h $ name <> " on " <> B.unpack (strEncode host) <> ": " <> show cnt
-                      hPutStrLn h $ name <> " on other servers: " <> show otherCnt
-                      where
-                        countSubs :: (Int, Int, Int, [SMPServer], M.Map SMPServer Int) -> (SMPServer, TMap SMPSub a) -> IO (Int, Int, Int, [SMPServer], M.Map SMPServer Int)
-                        countSubs (!totalCnt, !ownCount, !otherCnt, !servers, !ownByServer) (srv, srvSubs) = do
-                          cnt <- M.size <$> readTVarIO srvSubs
-                          let totalCnt' = totalCnt + cnt
-                              ownServer = isOwnServer a srv
-                              (ownCount', otherCnt')
-                                | ownServer = (ownCount + cnt, otherCnt)
-                                | otherwise = (ownCount, otherCnt + cnt)
-                              servers' = if cnt > 0 then srv : servers else servers
-                              ownByServer'
-                                | r == CPRAdmin && ownServer && cnt > 0 = M.alter (Just . maybe cnt (+ cnt)) srv ownByServer
-                                | otherwise = ownByServer
-                          pure (totalCnt', ownCount', otherCnt', servers', ownByServer')
-                    putSMPWorkers :: SMPClientAgent -> String -> TMap SMPServer a -> IO ()
-                    putSMPWorkers a name v = readTVarIO v >>= showServers a name . M.keys
-                    showServers :: SMPClientAgent -> String -> [SMPServer] -> IO ()
-                    showServers a name srvs = do
-                      let (ownSrvs, otherSrvs) = partition (isOwnServer a) srvs
-                      hPutStrLn h $ name <> " own servers count: " <> show (length ownSrvs)
-                      when (r == CPRAdmin) $ hPutStrLn h $ name <> " own servers: " <> intercalate "," (sort $ map (\(SMPServer (host :| _) _ _) -> B.unpack $ strEncode host) ownSrvs)
-                      hPutStrLn h $ name <> " other servers count: " <> show (length otherSrvs)
-              CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, help, quit"
-              CPQuit -> pure ()
-              CPSkip -> pure ()
-              where
-                withUserRole action =
-                  readTVarIO role >>= \case
-                    CPRAdmin -> action
-                    CPRUser -> action
-                    _ -> do
-                      logError "Unauthorized control port command"
-                      hPutStrLn h "AUTH"
-
 resubscribe :: NtfSubscriber -> M ()
 resubscribe NtfSubscriber {newSubQ} = do
   logInfo "Preparing SMP resubscriptions..."
@@ -364,11 +220,8 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
               NtfPushServer {pushQ} <- asks pushServer
               stats <- asks serverStats
               liftIO $ updatePeriodStats (activeSubs stats) ntfId
-              tkn_ <- atomically (findNtfSubscriptionToken st smpQueue)
-              forM_ tkn_ $ \tkn -> do
-                let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
-                lastNtfs <- liftIO $ addTokenLastNtf st (ntfTknId tkn) newNtf
-                atomically (writeTBQueue pushQ (tkn, PNMessage lastNtfs))
+              atomically (findNtfSubscriptionToken st smpQueue)
+                >>= mapM_ (\tkn -> atomically (writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| []))))
               incNtfStat ntfReceived
             Right SMP.END ->
               whenM (atomically $ activeClientSession' ca sessionId srv) $
@@ -736,44 +589,6 @@ incNtfStat statSel = do
   stats <- asks serverStats
   liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
 
-saveServerLastNtfs :: M ()
-saveServerLastNtfs = asks (storeLastNtfsFile . config) >>= mapM_ saveLastNtfs
-  where
-    saveLastNtfs f = do
-      logInfo $ "saving last notifications to file " <> T.pack f
-      NtfStore {tokenLastNtfs} <- asks store
-      liftIO . withFile f WriteMode $ \h ->
-        readTVarIO tokenLastNtfs >>= mapM_ (saveTokenLastNtfs h) . M.assocs
-      logInfo "notifications saved"
-      where
-        -- reverse on save, to save notifications in order, will become reversed again when restoring.
-        saveTokenLastNtfs h (tknId, v) = BLD.hPutBuilder h . encodeLastNtfs tknId . L.reverse =<< readTVarIO v
-        encodeLastNtfs tknId = mconcat . L.toList . L.map (\ntf -> BLD.byteString (strEncode $ TNMRv1 tknId ntf) <> BLD.char8 '\n')
-
-restoreServerLastNtfs :: M ()
-restoreServerLastNtfs =
-  asks (storeLastNtfsFile . config) >>= mapM_ restoreLastNtfs
-  where
-    restoreLastNtfs f =
-      whenM (doesFileExist f) $ do
-        logInfo $ "restoring last notifications from file " <> T.pack f
-        st <- asks store
-        runExceptT (liftIO (LB.readFile f) >>= mapM (restoreNtf st) . LB.lines) >>= \case
-          Left e -> do
-            logError . T.pack $ "error restoring last notifications: " <> e
-            liftIO exitFailure
-          Right _ -> do
-            renameFile f $ f <> ".bak"
-            logInfo "last notifications restored"
-      where
-        restoreNtf st s' = do
-          TNMRv1 tknId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s
-          liftIO $ storeTokenLastNtf st tknId ntf
-          where
-            s = LB.toStrict s'
-            ntfErr :: Show e => String -> e -> String
-            ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
-
 saveServerStats :: M ()
 saveServerStats =
   asks (serverStatsBackupFile . config)

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

@@ -1,37 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Server.Control where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth)
-
-data ControlProtocol
-  = CPAuth BasicAuth
-  | CPStats
-  | CPStatsRTS
-  | CPServerInfo
-  | CPHelp
-  | CPQuit
-  | CPSkip
-
-instance StrEncoding ControlProtocol where
-  strEncode = \case
-    CPAuth tok -> "auth " <> strEncode tok
-    CPStats -> "stats"
-    CPStatsRTS -> "stats-rts"
-    CPServerInfo -> "server-info"
-    CPHelp -> "help"
-    CPQuit -> "quit"
-    CPSkip -> ""
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "auth" -> CPAuth <$> _strP
-      "stats" -> pure CPStats
-      "stats-rts" -> pure CPStatsRTS
-      "server-info" -> pure CPServerInfo
-      "help" -> pure CPHelp
-      "quit" -> pure CPQuit
-      "" -> pure CPSkip
-      _ -> fail "bad ControlProtocol command"

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

@@ -28,7 +28,7 @@ import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
-import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission)
+import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -40,9 +40,6 @@ import UnliftIO.STM
 
 data NtfServerConfig = NtfServerConfig
   { transports :: [(ServiceName, ATransport, AddHTTP)],
-    controlPort :: Maybe ServiceName,
-    controlPortUserAuth :: Maybe BasicAuth,
-    controlPortAdminAuth :: Maybe BasicAuth,
     subIdBytes :: Int,
     regCodeBytes :: Int,
     clientQSize :: Natural,
@@ -53,7 +50,6 @@ data NtfServerConfig = NtfServerConfig
     subsBatchSize :: Int,
     inactiveClientExpiration :: Maybe ExpirationConfig,
     storeLogFile :: Maybe FilePath,
-    storeLastNtfsFile :: Maybe FilePath,
     ntfCredentials :: ServerCredentials,
     -- stats config - see SMP server config
     logStatsInterval :: Maybe Int64,

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

@@ -14,7 +14,6 @@ import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
@@ -53,9 +52,7 @@ ntfServerCLI cfgPath logPath =
         True -> readIniFile iniFile >>= either exitError runServer
         _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Delete -> do
-      confirmOrExit
-        "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-        "Server NOT deleted"
+      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"
@@ -87,14 +84,7 @@ ntfServerCLI cfgPath logPath =
           \# and restoring it when the server is started.\n\
           \# Log is compacted on start (deleted objects are removed).\n"
             <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-            <> "# Last notifications are optionally saved and restored when the server restarts,\n\
-               \# they are preserved in the .bak file until the next restart.\n"
-            <> ("restore_last_notifications: " <> onOff enableStoreLog <> "\n\n")
             <> "log_stats: off\n\n\
-               \[AUTH]\n\
-               \# control_port_admin_password:\n\
-               \# control_port_user_password:\n\
-               \\n\
                \[TRANSPORT]\n\
                \# Host is only used to print server address on start.\n\
                \# You can specify multiple server ports.\n"
@@ -103,8 +93,6 @@ ntfServerCLI cfgPath logPath =
             <> "log_tls_errors: off\n\n\
                \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
                \websockets: off\n\n\
-               \# control_port: 5227\n\
-               \\n\
                \[SUBSCRIBER]\n\
                \# Network configuration for notification server client.\n\
                \# `host_mode` can be 'public' (default) or 'onion'.\n\
@@ -117,8 +105,6 @@ ntfServerCLI cfgPath logPath =
                \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
                \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
                \# socks_mode: onion\n\n\
-               \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
-               \# own_server_domains: \n\n\
                \[INACTIVE_CLIENTS]\n\
                \# TTL and interval to check inactive clients\n\
                \disconnect: off\n"
@@ -139,17 +125,9 @@ ntfServerCLI cfgPath logPath =
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
-        restoreLastNtfsFile path = case iniOnOff "STORE_LOG" "restore_last_notifications" ini of
-          Just True -> Just path
-          Just False -> Nothing
-          -- if the setting is not set, it is enabled when store log is enabled
-          _ -> enableStoreLog $> path
         serverConfig =
           NtfServerConfig
             { transports = iniTransports ini,
-              controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
-              controlPortAdminAuth = either error id <$!> strDecodeIni "AUTH" "control_port_admin_password" ini,
-              controlPortUserAuth = either error id <$!> strDecodeIni "AUTH" "control_port_user_password" ini,
               subIdBytes = 24,
               regCodeBytes = 32,
               clientQSize = 64,
@@ -165,10 +143,9 @@ ntfServerCLI cfgPath logPath =
                                 socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
                                 hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
                                 requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
-                                smpPingInterval = 60_000_000 -- 1 minute
+                                smpPingInterval = 60_000_000 -- 1 minutes
                               }
                         },
-                    ownServerDomains = either (const []) (map encodeUtf8 . T.words) $ lookupValue "SUBSCRIBER" "own_server_domains" ini,
                     persistErrorInterval = 0 -- seconds
                   },
               apnsConfig = defaultAPNSPushClientConfig,
@@ -180,7 +157,6 @@ ntfServerCLI cfgPath logPath =
                       checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
                     },
               storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeLastNtfsFile = restoreLastNtfsFile $ combine logPath "ntf-server-last-notifications.log",
               ntfCredentials =
                 ServerCredentials
                   { caCertificateFile = Just $ c caCrtFile,

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

@@ -28,13 +28,16 @@ import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
@@ -48,10 +51,12 @@ import Network.HTTP2.Client (Request)
 import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
 import Simplex.Messaging.Parsers (defaultJSON)
+import Simplex.Messaging.Protocol (EncNMsgMeta)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
@@ -107,6 +112,30 @@ data PushNotification
     PNCheckMessages
   deriving (Show)
 
+-- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
+-- because strEncode of NonEmpty list uses comma for separator,
+-- and encoding of PNMessageData's smpQueue has comma in list of hosts
+encodePNMessages :: NonEmpty PNMessageData -> ByteString
+encodePNMessages = B.intercalate ";" . map strEncode . L.toList
+
+pnMessagesP :: A.Parser (NonEmpty PNMessageData)
+pnMessagesP = L.fromList <$> strP `A.sepBy1` A.char ';'
+
+data PNMessageData = PNMessageData
+  { smpQueue :: SMPQueueNtf,
+    ntfTs :: SystemTime,
+    nmsgNonce :: C.CbNonce,
+    encNMsgMeta :: EncNMsgMeta
+  }
+  deriving (Show)
+
+instance StrEncoding PNMessageData where
+  strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
+    strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
+  strP = do
+    (smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
+    pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
+
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show)
 
@@ -192,7 +221,7 @@ defaultAPNSPushClientConfig =
       authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start
       authKeyAlg = "ES256",
       authKeyIdEnv = "APNS_KEY_ID",
-      paddedNtfLength = 3072,
+      paddedNtfLength = 512,
       appName = "chat.simplex.app",
       appTeamId = "5NN7GUYB6T",
       apnsPort = "443",

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

@@ -1,12 +1,9 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Notifications.Server.Store where
@@ -15,14 +12,12 @@ import Control.Concurrent.STM
 import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import Data.Functor (($>))
-import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer)
 import Simplex.Messaging.TMap (TMap)
@@ -35,8 +30,7 @@ data NtfStore = NtfStore
     tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
     subscriptions :: TMap NtfSubscriptionId NtfSubData,
     tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
-    subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
-    tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData))
+    subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId
   }
 
 newNtfStore :: IO NtfStore
@@ -46,8 +40,7 @@ newNtfStore = do
   subscriptions <- TM.emptyIO
   tokenSubscriptions <- TM.emptyIO
   subscriptionLookup <- TM.emptyIO
-  tokenLastNtfs <- TM.emptyIO
-  pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
+  pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup}
 
 data NtfTknData = NtfTknData
   { ntfTknId :: NtfTokenId,
@@ -118,7 +111,6 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
       forM_ tIds $ \(regKey, tId') -> do
         TM.delete regKey tknRegs
         TM.delete tId' $ tokens st
-        TM.delete tId' $ tokenLastNtfs st
         void $ deleteTokenSubs st tId'
       pure $ map snd tIds
 
@@ -138,7 +130,6 @@ deleteNtfToken st tknId = do
       TM.lookup token regs $>>= \tIds ->
         TM.delete (regKey tknVerifyKey) tIds
           >> whenM (TM.null tIds) (TM.delete token regs) $> Just ()
-  TM.delete tknId $ tokenLastNtfs st
   deleteTokenSubs st tknId
   where
     regs = tokenRegistrations st
@@ -205,42 +196,3 @@ deleteNtfSubscription st subId = do
           ts_ <- TM.lookup tokenId (tokenSubscriptions st)
           forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
       )
-
-addTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO (NonEmpty PNMessageData)
-addTokenLastNtf st tknId newNtf =
-  TM.lookupIO tknId (tokenLastNtfs st) >>= maybe (atomically maybeNewTokenLastNtfs) (atomically . addNtf)
-  where
-    maybeNewTokenLastNtfs =
-      TM.lookup tknId (tokenLastNtfs st) >>= maybe newTokenLastNtfs addNtf
-    newTokenLastNtfs = do
-      v <- newTVar [newNtf]
-      TM.insert tknId v $ tokenLastNtfs st
-      pure [newNtf]
-    addNtf v =
-      stateTVar v $ \ntfs -> let !ntfs' = rebuildList ntfs in (ntfs', ntfs')
-      where
-        rebuildList :: NonEmpty PNMessageData -> NonEmpty PNMessageData
-        rebuildList = foldr keepPrevNtf [newNtf]
-          where
-            PNMessageData {smpQueue = newNtfQ} = newNtf
-            keepPrevNtf ntf@PNMessageData {smpQueue} ntfs
-              | smpQueue /= newNtfQ && length ntfs < maxNtfs = ntf <| ntfs
-              | otherwise = ntfs
-        maxNtfs = 6
-
--- This function is expected to be called after store log is read,
--- as it checks for token existence when adding last notification.
-storeTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO ()
-storeTokenLastNtf (NtfStore {tokens, tokenLastNtfs}) tknId ntf = do
-  TM.lookupIO tknId tokenLastNtfs >>= atomically . maybe newTokenLastNtfs (`modifyTVar'` (ntf <|))
-  where
-    newTokenLastNtfs = TM.lookup tknId tokenLastNtfs >>= maybe insertForExistingToken (`modifyTVar'` (ntf <|))
-    insertForExistingToken =
-      whenM (TM.member tknId tokens) $
-        TM.insertM tknId (newTVar [ntf]) tokenLastNtfs
-
-data TokenNtfMessageRecord = TNMRv1 NtfTokenId PNMessageData
-
-instance StrEncoding TokenNtfMessageRecord where
-  strEncode (TNMRv1 tknId ntf) = strEncode (Str "v1", tknId, ntf)
-  strP = "v1 " *> (TNMRv1 <$> strP_ <*> strP)

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

@@ -37,7 +37,8 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (safeDecodeUtf8, whenM)
+import System.Directory (doesFileExist, renameFile)
 import System.IO
 
 data NtfStoreLogRecord
@@ -49,7 +50,6 @@ data NtfStoreLogRecord
   | CreateSubscription NtfSubRec
   | SubscriptionStatus NtfSubscriptionId NtfSubStatus
   | DeleteSubscription NtfSubscriptionId
-  deriving (Show)
 
 data NtfTknRec = NtfTknRec
   { ntfTknId :: NtfTokenId,
@@ -61,7 +61,6 @@ data NtfTknRec = NtfTknRec
     tknRegCode :: NtfRegCode,
     tknCronInterval :: Word16
   }
-  deriving (Show)
 
 mkTknData :: NtfTknRec -> STM NtfTknData
 mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
@@ -82,7 +81,6 @@ data NtfSubRec = NtfSubRec
     tokenId :: NtfTokenId,
     subStatus :: NtfSubStatus
   }
-  deriving (Show)
 
 mkSubData :: NtfSubRec -> STM NtfSubData
 mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
@@ -185,7 +183,13 @@ logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
 logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
 
 readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
-readWriteNtfStore = readWriteStoreLog readNtfStore writeNtfStore
+readWriteNtfStore f st = do
+  whenM (doesFileExist f) $ do
+    readNtfStore f st
+    renameFile f $ f <> ".bak"
+  s <- openWriteStoreLog f
+  writeNtfStore s st
+  pure s
 
 readNtfStore :: FilePath -> NtfStore -> IO ()
 readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f

src/Simplex/Messaging/Notifications/Transport.hs

@@ -169,6 +169,5 @@ ntfTHandle c = THandle {connection = c, params}
           thServerVRange = versionToRange v,
           thAuth = Nothing,
           implySessId = False,
-          encryptBlock = Nothing,
           batch = False
         }

src/Simplex/Messaging/Protocol.hs

@@ -258,14 +258,13 @@ supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClie
 -- TODO v6.0 remove dependency on version
 maxMessageLength :: VersionSMP -> Int
 maxMessageLength v
-  | v >= encryptedBlockSMPVersion = 16048 -- max 16051
   | v >= sendingProxySMPVersion = 16064 -- max 16067
-  | otherwise = 16088 -- 16048 - always use this size to determine allowed ranges
+  | otherwise = 16088 -- 16064 - always use this size to determine allowed ranges
 
 paddedProxiedTLength :: Int
-paddedProxiedTLength = 16226 -- 16225 .. 16227
+paddedProxiedTLength = 16242 -- 16241 .. 16243
 
--- TODO v7.0 change to 16048
+-- TODO v6.0 change to 16064
 type MaxMessageLen = 16088
 
 -- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
@@ -273,10 +272,10 @@ type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
 
 -- it is shorter to allow per-queue e2e encryption DH key in the "public" header
 e2eEncConfirmationLength :: Int
-e2eEncConfirmationLength = 15904 -- 15865 .. 15960
+e2eEncConfirmationLength = 15920 -- 15881 .. 15976
 
 e2eEncMessageLength :: Int
-e2eEncMessageLength = 16000 -- 15988 .. 16005
+e2eEncMessageLength = 16016 -- 16004 .. 16021
 
 -- | SMP protocol clients
 data Party = Recipient | Sender | Notifier | ProxiedClient
@@ -399,6 +398,8 @@ data Command (p :: Party) where
   NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
   NDEL :: Command Recipient
   GET :: Command Recipient
+  -- ACK v1 has to be supported for encoding/decoding
+  -- ACK :: Command Recipient
   ACK :: MsgId -> Command Recipient
   OFF :: Command Recipient
   DEL :: Command Recipient
@@ -538,13 +539,11 @@ messageId :: Message -> MsgId
 messageId = \case
   Message {msgId} -> msgId
   MessageQuota {msgId} -> msgId
-{-# INLINE messageId #-}
 
 messageTs :: Message -> SystemTime
 messageTs = \case
   Message {msgTs} -> msgTs
   MessageQuota {msgTs} -> msgTs
-{-# INLINE messageTs #-}
 
 newtype EncRcvMsgBody = EncRcvMsgBody ByteString
   deriving (Eq, Show)
@@ -1198,8 +1197,6 @@ data ErrorType
     CRYPTO
   | -- | SMP queue capacity is exceeded on the server
     QUOTA
-  | -- | SMP server storage error
-    STORE {storeErr :: String}
   | -- | ACK command is sent without message to be acknowledged
     NO_MSG
   | -- | sent message is too large (> maxMessageLength = 16088 bytes)
@@ -1515,7 +1512,6 @@ instance Encoding ErrorType where
     AUTH -> "AUTH"
     CRYPTO -> "CRYPTO"
     QUOTA -> "QUOTA"
-    STORE err -> "STORE " <> smpEncode err
     EXPIRED -> "EXPIRED"
     NO_MSG -> "NO_MSG"
     LARGE_MSG -> "LARGE_MSG"
@@ -1531,7 +1527,6 @@ instance Encoding ErrorType where
       "AUTH" -> pure AUTH
       "CRYPTO" -> pure CRYPTO
       "QUOTA" -> pure QUOTA
-      "STORE" -> STORE <$> _smpP
       "EXPIRED" -> pure EXPIRED
       "NO_MSG" -> pure NO_MSG
       "LARGE_MSG" -> pure LARGE_MSG
@@ -1668,8 +1663,8 @@ batchTransmissions' batch bSize ts
 batchTransmissions_ :: Int -> NonEmpty (Either TransportError ByteString, r) -> [TransportBatch r]
 batchTransmissions_ bSize = addBatch . foldr addTransmission ([], 0, 0, [], [])
   where
-    -- 19 = 2 bytes reserved for pad size + 1 for transmission count + 16 auth tag from block encryption
-    bSize' = bSize - 19
+    -- 3 = 2 bytes reserved for pad size + 1 for transmission count
+    bSize' = bSize - 3
     addTransmission :: (Either TransportError ByteString, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
     addTransmission (t_, r) acc@(bs, !len, !n, ss, rs) = case t_ of
       Left e -> (TBError e r : addBatch acc, 0, 0, [], [])

src/Simplex/Messaging/Server/CLI.hs

@@ -44,11 +44,11 @@ import Text.Read (readMaybe)
 exitError :: String -> IO a
 exitError msg = putStrLn msg >> exitFailure
 
-confirmOrExit :: String -> String -> IO ()
-confirmOrExit s no =
+confirmOrExit :: String -> IO ()
+confirmOrExit s =
   withPrompt (s <> "\nContinue (Y/n): ") $ do
     ok <- getLine
-    when (ok /= "Y") $ putStrLn no >> exitFailure
+    when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
 
 data SignAlgorithm = ED448 | ED25519
   deriving (Read, Show)

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

@@ -1,14 +1,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE TypeFamilies #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -23,6 +19,8 @@ import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Data.Maybe (isJust, isNothing)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
@@ -39,11 +37,9 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
-import Simplex.Messaging.Server.MsgStore.Journal
 import Simplex.Messaging.Server.MsgStore.STM
-import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.NtfStore
-import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
@@ -61,10 +57,7 @@ data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
-    msgStoreType :: AMSType,
     msgQueueQuota :: Int,
-    maxJournalMsgCount :: Int,
-    maxJournalStateLines :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
@@ -79,9 +72,6 @@ data ServerConfig = ServerConfig
     controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
-    expireMessagesOnStart :: Bool,
-    -- | interval of inactivity after which journal queue is closed
-    idleQueueInterval :: Int64,
     -- | notification expiration interval (seconds)
     notificationExpiration :: ExpirationConfig,
     -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -123,12 +113,9 @@ defaultMessageExpiration :: ExpirationConfig
 defaultMessageExpiration =
   ExpirationConfig
     { ttl = defMsgExpirationDays * 86400, -- seconds
-      checkInterval = 14400 -- seconds, 4 hours
+      checkInterval = 43200 -- seconds, 12 hours
     }
 
-defaultIdleQueueInterval :: Int64
-defaultIdleQueueInterval = 28800 -- seconds, 8 hours
-
 defNtfExpirationHours :: Int64
 defNtfExpirationHours = 24
 
@@ -149,62 +136,34 @@ defaultInactiveClientExpiration =
 defaultProxyClientConcurrency :: Int
 defaultProxyClientConcurrency = 32
 
-journalMsgStoreDepth :: Int
-journalMsgStoreDepth = 5
-
-defaultMaxJournalStateLines :: Int
-defaultMaxJournalStateLines = 16
-
-defaultMaxJournalMsgCount :: Int
-defaultMaxJournalMsgCount = 256
-
-defaultMsgQueueQuota :: Int
-defaultMsgQueueQuota = 128
-
-defaultStateTailSize :: Int
-defaultStateTailSize = 512
-
 data Env = Env
   { config :: ServerConfig,
-    serverActive :: TVar Bool,
     serverInfo :: ServerInformation,
     server :: Server,
     serverIdentity :: KeyHash,
-    msgStore :: AMsgStore,
+    queueStore :: QueueStore,
+    msgStore :: STMMsgStore,
     ntfStore :: NtfStore,
     random :: TVar ChaChaDRG,
+    storeLog :: Maybe (StoreLog 'WriteMode),
     tlsServerCreds :: T.Credential,
     httpServerCreds :: Maybe T.Credential,
     serverStats :: ServerStats,
-    sockets :: TVar [(ServiceName, SocketState)],
+    sockets :: SocketState,
     clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap (Maybe AClient)),
+    clients :: TVar (IntMap (Maybe Client)),
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
-type family MsgStore s where
-  MsgStore 'MSMemory = STMMsgStore
-  MsgStore 'MSJournal = JournalMsgStore
-
-data AMsgStore = forall s. (STMQueueStore (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s)
-
-data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s))
-
-data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s))
-
-msgPersistence :: AMsgStoreCfg -> Bool
-msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath
-msgPersistence (AMSC SMSJournal _) = True
-
 type Subscribed = Bool
 
 data Server = Server
   { subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
-    subscribers :: TMap RecipientId (TVar AClient),
+    subscribers :: TMap RecipientId (TVar Client),
     ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
-    notifiers :: TMap NotifierId (TVar AClient),
-    subClients :: TVar (IntMap AClient), -- clients with SMP subscriptions
-    ntfSubClients :: TVar (IntMap AClient), -- clients with Ntf subscriptions
+    notifiers :: TMap NotifierId (TVar Client),
+    subClients :: TVar (IntMap Client), -- clients with SMP subscriptions
+    ntfSubClients :: TVar (IntMap Client), -- clients with Ntf subscriptions
     pendingSubEvents :: TVar (IntMap (NonEmpty (RecipientId, Subscribed))),
     pendingNtfSubEvents :: TVar (IntMap (NonEmpty (NotifierId, Subscribed))),
     savingLock :: Lock
@@ -216,16 +175,11 @@ newtype ProxyAgent = ProxyAgent
 
 type ClientId = Int
 
-data AClient = forall s. MsgStoreClass (MsgStore s) => AClient (SMSType s) (Client (MsgStore s))
-
-clientId' :: AClient -> ClientId
-clientId' (AClient _ Client {clientId}) = clientId
-
-data Client s = Client
+data Client = Client
   { clientId :: ClientId,
     subscriptions :: TMap RecipientId Sub,
     ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (NonEmpty (Maybe (StoreQueue s, QueueRec), Transmission Cmd)),
+    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
     sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     procThreads :: TVar Int,
@@ -258,11 +212,11 @@ newServer = do
   ntfSubClients <- newTVarIO IM.empty
   pendingSubEvents <- newTVarIO IM.empty
   pendingNtfSubEvents <- newTVarIO IM.empty
-  savingLock <- createLockIO
+  savingLock <- atomically createLock
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock}
 
-newClient :: SMSType s -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore s))
-newClient _msType clientId qSize thVersion sessionId createdAt = do
+newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
+newClient clientId qSize thVersion sessionId createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
   rcvQ <- newTBQueueIO qSize
@@ -288,33 +242,27 @@ newProhibitedSub = do
   return Sub {subThread = ProhibitSub, delivered}
 
 newEnv :: ServerConfig -> IO Env
-newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
-  serverActive <- newTVarIO True
+newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do
   server <- newServer
-  msgStore@(AMS _ store) <- case msgStoreType of
-    AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota}
-    AMSType SMSJournal -> case storeMsgsFile of
-      Just storePath -> 
-        let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval}
-         in AMS SMSJournal <$> newMsgStore cfg
-      Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure
+  queueStore <- newQueueStore
+  msgStore <- newMsgStore
   ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
-  forM_ storeLogFile $ \f -> do
-    logInfo $ "restoring queues from file " <> T.pack f
-    sl <- readWriteQueueStore f store
-    setStoreLog store sl
+  storeLog <-
+    forM storeLogFile $ \f -> do
+      logInfo $ "restoring queues from file " <> T.pack f
+      restoreQueues queueStore f
   tlsServerCreds <- getCredentials "SMP" smpCredentials
   httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
   mapM_ checkHTTPSCredentials httpServerCreds
   Fingerprint fp <- loadFingerprint smpCredentials
   let serverIdentity = KeyHash fp
   serverStats <- newServerStats =<< getCurrentTime
-  sockets <- newTVarIO []
+  sockets <- newSocketState
   clientSeq <- newTVarIO 0
   clients <- newTVarIO mempty
   proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
+  pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, ntfStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
   where
     getCredentials protocol creds = do
       files <- missingCreds
@@ -336,6 +284,19 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt
           putStrLn $ "Error: unsupported HTTPS credentials, required 4096-bit RSA\n" <> letsEncrypt
           exitFailure
     letsEncrypt = "Use Let's Encrypt to generate: certbot certonly --standalone -d yourdomainname --key-type rsa --rsa-key-size 4096"
+    restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
+    restoreQueues QueueStore {queues, senders, notifiers} f = do
+      (qs, s) <- readWriteStoreLog f
+      atomically . writeTVar queues =<< mapM newTVarIO qs
+      atomically $ writeTVar senders $! M.foldr' addSender M.empty qs
+      atomically $ writeTVar notifiers $! M.foldr' addNotifier M.empty qs
+      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
+    addNotifier q = case notifier q of
+      Nothing -> id
+      Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q)
     serverInfo =
       ServerInformation
         { information,
@@ -351,13 +312,10 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt
       where
         persistence
           | isNothing storeLogFile = SPMMemoryOnly
-          | isJust storeMsgsFile = SPMMessages
+          | isJust (storeMsgsFile config) = SPMMessages
           | otherwise = SPMQueues
 
 newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
 newSMPProxyAgent smpAgentCfg random = do
   smpAgent <- newSMPClientAgent smpAgentCfg random
   pure ProxyAgent {smpAgent}
-
-readWriteQueueStore :: STMQueueStore s => FilePath -> s -> IO (StoreLog 'WriteMode)
-readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore

src/Simplex/Messaging/Server/Information.hs

@@ -1,21 +1,14 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Messaging.Server.Information where
 
-import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Int (Int64)
-import Data.Maybe (isJust)
 import Data.Text (Text)
 import Simplex.Messaging.Agent.Protocol (ConnectionMode (..), ConnectionRequestUri)
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
 
 data ServerInformation = ServerInformation
@@ -43,59 +36,16 @@ data ServerPublicInfo = ServerPublicInfo
     adminContacts :: Maybe ServerContactAddress,
     complaintsContacts :: Maybe ServerContactAddress,
     hosting :: Maybe Entity,
-    hostingType :: Maybe HostingType,
     serverCountry :: Maybe Text
   }
   deriving (Show)
 
-emptyServerInfo :: Text -> ServerPublicInfo
-emptyServerInfo sourceCode =
-  ServerPublicInfo
-    { sourceCode,
-      usageConditions = Nothing,
-      operator = Nothing,
-      website = Nothing,
-      adminContacts = Nothing,
-      complaintsContacts = Nothing,
-      hosting = Nothing,
-      hostingType = Nothing,
-      serverCountry = Nothing
-    }
-
-hasServerInfo :: ServerPublicInfo -> Bool
-hasServerInfo ServerPublicInfo {usageConditions, operator, website, adminContacts, complaintsContacts, hosting, hostingType, serverCountry} =
-  isJust usageConditions || isJust operator || isJust website || isJust adminContacts || isJust complaintsContacts || isJust hosting || isJust hostingType || isJust serverCountry
-
 data ServerPersistenceMode = SPMMemoryOnly | SPMQueues | SPMMessages
   deriving (Show)
 
 data ServerConditions = ServerConditions {conditions :: Text, amendments :: Maybe Text}
   deriving (Show)
 
-data HostingType = HTVirtual | HTDedicated | HTColocation | HTOwned
-  deriving (Show)
-
-instance StrEncoding HostingType where
-  strEncode = \case
-    HTVirtual -> "virtual"
-    HTDedicated -> "dedicated"
-    HTColocation -> "colocation"
-    HTOwned -> "owned"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "virtual" -> pure HTVirtual
-      "dedicated" -> pure HTDedicated
-      "colocation" -> pure HTColocation
-      "owned" -> pure HTOwned
-      _ -> fail "bad HostingType"
-
-instance FromJSON HostingType where
-  parseJSON = strParseJSON "HostingType"
-
-instance ToJSON HostingType where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
 data Entity = Entity {name :: Text, country :: Maybe Text}
   deriving (Show)
 

src/Simplex/Messaging/Server/Main.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -14,13 +13,11 @@
 module Simplex.Messaging.Server.Main where
 
 import Control.Concurrent.STM
-import Control.Exception (finally)
 import Control.Logger.Simple
-import Control.Monad
+import Control.Monad (void, when, (<$!>))
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlpha, isAscii, toUpper)
-import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.List (find, isPrefixOf)
@@ -28,7 +25,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
@@ -39,21 +36,17 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
-import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
+import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
-import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..))
-import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore)
-import Simplex.Messaging.Server.QueueStore.STM (readQueueStore)
 import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange)
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
-import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow)
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
 import Simplex.Messaging.Version (mkVersionRange)
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
-import System.Exit (exitFailure)
+import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
@@ -74,95 +67,25 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       doesFileExist iniFile >>= \case
         True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
         _ -> initializeServer opts
-    OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts
-    Start -> withIniFile runServer
+    OnlineCert certOpts ->
+      doesFileExist iniFile >>= \case
+        True -> genOnline cfgPath certOpts
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError runServer
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Delete -> do
-      confirmOrExit
-        "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-        "Server NOT deleted"
+      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"
-    Journal cmd -> withIniFile $ \ini -> do
-      msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
-      msgsFileExists <- doesFileExist storeMsgsFilePath
-      let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
-      storeLogFile <- case enableStoreLog $> storeLogFilePath of
-        Just storeLogFile -> do
-          ifM
-            (doesFileExist storeLogFile)
-            (pure storeLogFile)
-            (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
-        Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
-      case cmd of
-        JCImport
-          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
-          | msgsDirExists -> do
-              putStrLn $ storeMsgsJournalDir <> " directory already exists."
-              exitFailure
-          | not msgsFileExists -> do
-              putStrLn $ storeMsgsFilePath <> " file does not exists."
-              exitFailure
-          | otherwise -> do
-              confirmOrExit
-                ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
-                "Messages not imported"
-              ms <- newJournalMsgStore
-              readQueueStore storeLogFile ms
-              msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration
-              putStrLn "Import completed"
-              printMessageStats "Messages" msgStats
-              putStrLn $ case readMsgStoreType ini of
-                Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
-                Right (AMSType SMSJournal) -> "store_messages set to `journal`"
-                Left e -> e <> ", update it to `journal` in INI file"
-        JCExport
-          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
-          | msgsFileExists -> do
-              putStrLn $ storeMsgsFilePath <> " file already exists."
-              exitFailure
-          | otherwise -> do
-              confirmOrExit
-                ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
-                "Journal not exported"
-              ms <- newJournalMsgStore
-              readQueueStore storeLogFile ms
-              exportMessages True ms storeMsgsFilePath False
-              putStrLn "Export completed"
-              putStrLn $ case readMsgStoreType ini of
-                Right (AMSType SMSMemory) -> "store_messages set to `memory`"
-                Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
-                Left e -> e <> ", update it to `memory` in INI file"
-        JCDelete
-          | not msgsDirExists -> do
-              putStrLn $ storeMsgsJournalDir <> " directory does not exists."
-              exitFailure
-          | otherwise -> do
-              confirmOrExit
-                ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be permanently deleted.\nTHIS CANNOT BE UNDONE!")
-                "Messages NOT deleted"
-              deleteDirIfExists storeMsgsJournalDir
-              putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
   where
-    withIniFile a =
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError a
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration}
     iniFile = combine cfgPath "smp-server.ini"
     serverVersion = "SMP server v" <> simplexMQVersion
     defaultServerPorts = "5223,443"
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
-    storeMsgsFilePath = combine logPath "smp-server-messages.log"
-    storeMsgsJournalDir = combine logPath "messages"
-    storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
-    readMsgStoreType :: Ini -> Either String AMSType
-    readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages"
-    textToMsgStoreType = \case
-      "memory" -> Right $ AMSType SMSMemory
-      "journal" -> Right $ AMSType SMSJournal
-      s -> Left $ "invalid store_messages: " <> T.unpack s
     httpsCertFile = combine cfgPath "web.crt"
     httpsKeyFile = combine cfgPath "web.key"
     defaultStaticPath = combine logPath "www"
@@ -170,7 +93,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       | scripted = initialize opts
       | otherwise = do
           putStrLn "Use `smp-server init -h` for available options."
-          checkInitOptions opts
           void $ withPrompt "SMP server will be initialized (press Enter)" getLine
           enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
           logStats <- onOffPrompt "Enable logging daily statistics" False
@@ -186,7 +108,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 logStats,
                 fqdn = if null host' then fqdn else Just host',
                 password,
-                sourceCode = (T.pack <$> sourceCode') <|> src' <|> Just (T.pack simplexmqSource),
+                sourceCode = (T.pack <$> sourceCode') <|> src',
                 webStaticPath = if null staticPath' then sp' else Just staticPath',
                 disableWeb = noWeb'
               }
@@ -200,18 +122,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               case strDecode $ encodeUtf8 $ T.pack s of
                 Right auth -> pure . Just $ ServerPassword auth
                 _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
-        checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do
-          let err_
-                | isNothing sourceCode && hasServerInfo serverInfo =
-                    Just "Error: passing any server information requires passing --source-code"
-                | isNothing (operator serverInfo) && isJust operatorCountry =
-                    Just "Error: passing --operator-country requires passing --operator"
-                | isNothing (hosting serverInfo) && isJust hostingCountry =
-                    Just "Error: passing --hosting-country requires passing --hosting"
-                | otherwise = Nothing
-          forM_ err_ $ \err -> putStrLn err >> exitFailure
-        initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
-          checkInitOptions opts'
+        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password, sourceCode, webStaticPath, disableWeb} = do
           clearDirIfExists cfgPath
           clearDirIfExists logPath
           createDirectoryIfMissing True cfgPath
@@ -219,10 +130,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
           fp <- createServerX509 cfgPath x509cfg
           basicAuth <- mapM createServerPassword password
-          controlPortPwds <- forM controlPort $ \_ -> let pwd = decodeLatin1 <$> randomBase64 18 in (,) <$> pwd <*> pwd
           let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
               srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
-          T.writeFile iniFile $ iniFileContent host basicAuth controlPortPwds
+          T.writeFile iniFile $ iniFileContent host basicAuth $ Just "https://github.com/simplex-chat/simplexmq"
           putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "."
           putStrLn $ "Run `" <> executableName <> " start` to start server."
           warnCAPrivateKeyFile cfgPath x509cfg
@@ -231,10 +141,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           where
             createServerPassword = \case
               ServerPassword s -> pure s
-              SPRandom -> BasicAuth <$> randomBase64 32
-            randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
-            iniFileContent host basicAuth controlPortPwds =
-              informationIniContent opts'
+              SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom)
+            iniFileContent host basicAuth sourceCode' =
+              informationIniContent sourceCode'
                 <> "[STORE_LOG]\n\
                    \# The server uses STM memory for persistence,\n\
                    \# that will be lost on restart (e.g., as with redis).\n\
@@ -242,14 +151,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                    \# and restoring it when the server is started.\n\
                    \# Log is compacted on start (deleted objects are removed).\n"
                 <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Message storage mode: `memory` or `journal`.\n\
-                   \store_messages: memory\n\n\
-                   \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
-                   \# when the server restarts, they are preserved in the .bak file until the next restart.\n"
-                <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Messages and notifications expiration periods.\n"
+                <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
+                   \# they are preserved in the .bak file until the next restart.\n"
+                <> ("restore_messages: " <> onOff enableStoreLog <> "\n")
                 <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
-                <> "expire_messages_on_start: on\n"
                 <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
                 <> "# Log daily server statistics to CSV file\n"
                 <> ("log_stats: " <> onOff logStats <> "\n\n")
@@ -262,13 +167,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                    \# smp://fingerprint:password@host1,host2\n\
                    \# The password will not be shared with the connecting contacts, you must share it only\n\
                    \# with the users who you want to allow creating messaging queues on your server.\n"
-                <> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')"
-                      in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth
+                <> ( case basicAuth of
+                      Just auth -> "create_password: " <> safeDecodeUtf8 (strEncode auth)
+                      _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
                    )
-                <> "\n\n"
-                <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
-                <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
-                <> "\n\
+                <> "\n\n\
+                   \# control_port_admin_password:\n\
+                   \# control_port_user_password:\n\n\
                    \[TRANSPORT]\n\
                    \# Host is only used to print server address on start.\n\
                    \# You can specify multiple server ports.\n"
@@ -276,44 +181,38 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 <> ("port: " <> T.pack defaultServerPorts <> "\n")
                 <> "log_tls_errors: off\n\n\
                    \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
-                   \# This option is deprecated and should be used for testing only.\n\
-                   \# , port 443 should be specified in port above\n\
-                   \websockets: off\n"
-                <> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort))
-                <> "\n\n\
+                   \websockets: off\n\
+                   \# control_port: 5224\n\n\
                    \[PROXY]\n\
                    \# Network configuration for SMP proxy client.\n\
                    \# `host_mode` can be 'public' (default) or 'onion'.\n\
                    \# It defines prefferred hostname for destination servers with multiple hostnames.\n\
                    \# host_mode: public\n\
                    \# required_host_mode: off\n\n\
-                   \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n"
-                <> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains)
-                <> "\n\n\
+                   \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
+                   \# own_server_domains: \n\n\
                    \# SOCKS proxy port for forwarding messages to destination servers.\n\
-                   \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n"
-                <> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy)
-                <> "\n\n\
+                   \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
+                   \# socks_proxy: localhost:9050\n\n\
                    \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
                    \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
                    \# socks_mode: onion\n\n\
                    \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
-                <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency)
-                <> "\n\n\
-                   \[INACTIVE_CLIENTS]\n\
+                <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency <> "\n\n")
+                <> "[INACTIVE_CLIENTS]\n\
                    \# TTL and interval to check inactive clients\n\
-                   \disconnect: on\n"
-                <> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
-                <> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration))
+                   \disconnect: off\n"
+                <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
+                <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
                 <> "\n\n\
                    \[WEB]\n\
                    \# Set path to generate static mini-site for server information and qr codes/links\n"
                 <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n")
                 <> "# Run an embedded server on this port\n\
                    \# Onion sites can use any port and register it in the hidden service config.\n\
-                   \# Running on a port 80 may require setting process capabilities.\n\
-                   \# http: 8000\n\n\
-                   \# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
+                   \# Running on a port 80 may require setting process capabilities.\n"
+                <> (webDisabled <> "http: 8000\n\n")
+                <> "# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
                    \# Not required for running relay on onion address.\n"
                 <> (webDisabled <> "https: 443\n")
                 <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n")
@@ -326,13 +225,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       fp <- checkSavedFingerprint cfgPath defaultX509Config
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@ServerConfig {information, storeLogFile, msgStoreType, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
+          cfg@ServerConfig {information, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
           sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
           srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
       printServiceInfo serverVersion srv
       printSourceCode sourceCode'
       printServerConfig transports storeLogFile
-      checkMsgStoreMode msgStoreType
       putStrLn $ case messageExpiration of
         Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
         _ -> "not expiring messages"
@@ -360,16 +258,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       case webStaticPath' of
         Just path | sharedHTTP -> do
           runWebServer path Nothing ServerInformation {config, information}
-          attachStaticFiles path $ \attachHTTP -> do
-            logDebug "Allocated web server resources"
-            runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
+          attachStaticFiles path $ \attachHTTP -> runSMPServer cfg $ Just attachHTTP
         Just path -> do
           runWebServer path webHttpsParams' ServerInformation {config, information}
           runSMPServer cfg Nothing
         Nothing -> do
           logWarn "No server static path set"
           runSMPServer cfg Nothing
-      logDebug "Bye"
       where
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
@@ -381,16 +276,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           _ -> enableStoreLog $> path
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
-        iniMsgStoreType = either error id $! readMsgStoreType ini
         serverConfig =
           ServerConfig
             { transports,
               smpHandshakeTimeout = 120000000,
               tbqSize = 128,
-              msgStoreType = iniMsgStoreType,
-              msgQueueQuota = defaultMsgQueueQuota,
-              maxJournalMsgCount = defaultMaxJournalMsgCount,
-              maxJournalStateLines = defaultMaxJournalStateLines,
+              msgQueueQuota = 128,
               queueIdBytes = 24,
               msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
               smpCredentials =
@@ -401,10 +292,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   },
               httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
               storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeMsgsFile = case iniMsgStoreType of
-                AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath
-                AMSType SMSJournal -> Just storeMsgsJournalDir,
-              storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
+              storeMsgsFile = restoreMessagesFile $ combine logPath "smp-server-messages.log",
+              storeNtfsFile = restoreMessagesFile $ combine logPath "smp-server-ntfs.log",
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
               newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini,
@@ -415,8 +304,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   defaultMessageExpiration
                     { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
                     },
-              expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
-              idleQueueInterval = defaultIdleQueueInterval,
               notificationExpiration =
                 defaultNtfExpiration
                   { ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
@@ -480,31 +367,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             pure WebHttpsParams {port, cert, key}
         webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
 
-    checkMsgStoreMode :: AMSType -> IO ()
-    checkMsgStoreMode mode = do
-      msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
-      msgsFileExists <- doesFileExist storeMsgsFilePath
-      case mode of
-        _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
-        AMSType SMSJournal
-          | msgsFileExists -> do
-              putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present."
-              putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate."
-              exitFailure
-          | not msgsDirExists ->
-              putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created."
-        AMSType SMSMemory
-          | msgsDirExists -> do
-              putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present."
-              putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate."
-              exitFailure
-        _ -> pure ()
-
-    exitConfigureMsgStorage = do
-      putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
-      putStrLn "Configure memory storage."
-      exitFailure
-
 data EmbeddedWebParams = EmbeddedWebParams
   { webStaticPath :: FilePath,
     webHttpPort :: Maybe Int,
@@ -527,31 +389,28 @@ getServerSourceCode =
 simplexmqSource :: String
 simplexmqSource = "https://github.com/simplex-chat/simplexmq"
 
-defaultControlPort :: Int
-defaultControlPort = 5224
-
-informationIniContent :: InitOptions -> Text
-informationIniContent InitOptions {sourceCode, serverInfo} =
+informationIniContent :: Maybe Text -> Text
+informationIniContent sourceCode_ =
   "[INFORMATION]\n\
   \# AGPLv3 license requires that you make any source code modifications\n\
   \# available to the end users of the server.\n\
   \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
   \# Include correct source code URI in case the server source code is modified in any way.\n\
   \# If any other information fields are present, source code property also MUST be present.\n\n"
-    <> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode)
-    <> "\n\n\
-       \# Declaring all below information is optional, any of these fields can be omitted.\n\
+    <> (maybe "# source_code: URI" ("source_code: " <>) sourceCode_ <> "\n\n")
+    <> "# Declaring all below information is optional, any of these fields can be omitted.\n\
        \\n\
        \# Server usage conditions and amendments.\n\
        \# It is recommended to use standard conditions with any amendments in a separate document.\n\
        \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\
        \# condition_amendments: link\n\
        \\n\
-       \# Server location and operator.\n"
-    <> countryStr "server" serverCountry
-    <> enitiyStrs "operator" operator
-    <> (optDisabled website <> "website: " <> fromMaybe "" website)
-    <> "\n\n\
+       \# Server location and operator.\n\
+       \# server_country: ISO-3166 2-letter code\n\
+       \# operator: entity (organization or person name)\n\
+       \# operator_country: ISO-3166 2-letter code\n\
+       \# website:\n\
+       \\n\
        \# Administrative contacts.\n\
        \# admin_simplex: SimpleX address\n\
        \# admin_email:\n\
@@ -564,21 +423,9 @@ informationIniContent InitOptions {sourceCode, serverInfo} =
        \# complaints_pgp:\n\
        \# complaints_pgp_fingerprint:\n\
        \\n\
-       \# Hosting provider.\n"
-    <> enitiyStrs "hosting" hosting
-    <> "\n\
-       \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n"
-    <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n")
-  where
-    ServerPublicInfo {operator, website, hosting, hostingType, serverCountry} = serverInfo
-    countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n"
-    enitiyStrs optName entity =
-      optDisabled entity
-        <> optName
-        <> ": "
-        <> maybe "entity (organization or person name)" name entity
-        <> "\n"
-        <> countryStr optName (country =<< entity)
+       \# Hosting provider.\n\
+       \# hosting: entity (organization or person name)\n\
+       \# hosting_country: ISO-3166 2-letter code\n\n"
 
 serverPublicInfo :: Ini -> Maybe ServerPublicInfo
 serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
@@ -594,14 +441,15 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
           website = infoValue "website",
           adminContacts = iniContacts "admin_simplex" "admin_email" "admin_pgp" "admin_pgp_fingerprint",
           complaintsContacts = iniContacts "complaints_simplex" "complaints_email" "complaints_pgp" "complaints_pgp_fingerprint",
-          hosting = iniEntity "hosting" "hosting_country",
-          hostingType = either error id <$!> strDecodeIni "INFORMATION" "hosting_type" ini
+          hosting = iniEntity "hosting" "hosting_country"
         }
     infoValue name = eitherToMaybe $ lookupValue "INFORMATION" name ini
     iniEntity nameField countryField =
       (\name -> Entity {name, country = countryValue countryField})
         <$!> infoValue nameField
-    countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
+    countryValue field =
+      (\cs -> if T.length cs == 2 && T.all (\c -> isAscii c && isAlpha c) cs then T.map toUpper cs else error $ "Use ISO3166 2-letter code for " <> T.unpack field)
+        <$!> infoValue field
     iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
       let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
           email = infoValue emailField
@@ -612,14 +460,6 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
             (Nothing, Nothing, _, Nothing) -> Nothing
             (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint}
 
-optDisabled :: Maybe a -> Text
-optDisabled p = if isNothing p then "# " else ""
-
-validCountryValue :: String -> String -> Either String Text
-validCountryValue field s
-  | length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s
-  | otherwise = Left $ "Use ISO3166 2-letter code for " <> field
-
 printSourceCode :: Maybe Text -> IO ()
 printSourceCode = \case
   Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode
@@ -632,9 +472,6 @@ data CliCommand
   | OnlineCert CertOptions
   | Start
   | Delete
-  | Journal JournalCmd
-
-data JournalCmd = JCImport | JCExport | JCDelete
 
 data InitOptions = InitOptions
   { enableStoreLog :: Bool,
@@ -643,13 +480,7 @@ data InitOptions = InitOptions
     ip :: HostName,
     fqdn :: Maybe HostName,
     password :: Maybe ServerPassword,
-    controlPort :: Maybe Int,
-    socksProxy :: Maybe SocksProxy,
-    ownDomains :: Maybe (L.NonEmpty TransportHost),
     sourceCode :: Maybe Text,
-    serverInfo :: ServerPublicInfo,
-    operatorCountry :: Maybe Text,
-    hostingCountry :: Maybe Text,
     webStaticPath :: Maybe FilePath,
     disableWeb :: Bool,
     scripted :: Bool
@@ -666,7 +497,6 @@ cliCommandP cfgPath logPath iniFile =
         <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
         <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
-        <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
     )
   where
     initP :: Parser InitOptions
@@ -719,45 +549,11 @@ cliCommandP cfgPath logPath iniFile =
                   <> help "Set password to create new messaging queues"
                   <> value SPRandom
               )
-      controlPort <-
-        flag' (Just defaultControlPort) (long "control-port" <> help ("Enable control port on " <> show defaultControlPort))
-          <|> option strParse (long "control-port" <> help "Enable control port" <> metavar "PORT" <> value Nothing)
-      socksProxy <-
-        flag' (Just defaultSocksProxy) (long "socks-proxy" <> help "Outgoing SOCKS proxy on port 9050")
-          <|> option
-            strParse
-            ( long "socks-proxy"
-                <> metavar "PROXY"
-                <> help "Outgoing SOCKS proxy to forward messages to onion-only servers"
-                <> value Nothing
-            )
-      ownDomains :: Maybe (L.NonEmpty TransportHost) <-
-        option
-          strParse
-          ( long "own-domains"
-              <> metavar "DOMAINS"
-              <> help "Own server domain names (comma-separated)"
-              <> value Nothing
-          )
       sourceCode <-
-        flag' (Just simplexmqSource) (long "source-code" <> help ("Server source code (default: " <> simplexmqSource <> ")"))
-          <|> (optional . strOption) (long "source-code" <> metavar "URI" <> help "Server source code")
-      operator_ <- entityP "operator" "OPERATOR" "Server operator"
-      hosting_ <- entityP "hosting" "HOSTING" "Hosting provider"
-      hostingType <-
-        option
-          strParse
-          ( long "hosting-type"
-              <> metavar "HOSTING_TYPE"
-              <> help "Hosting type: virtual, dedicated, colocation, owned"
-              <> value Nothing
-          )
-      serverCountry <- countryP "server" "SERVER" "Server datacenter"
-      website <-
         (optional . strOption)
-          ( long "operator-website"
-              <> help "Operator public website"
-              <> metavar "WEBSITE"
+          ( long "source-code"
+              <> help "Server source code will be communicated to the users"
+              <> metavar "URI"
           )
       webStaticPath <-
         (optional . strOption)
@@ -784,53 +580,10 @@ cliCommandP cfgPath logPath iniFile =
             ip,
             fqdn,
             password,
-            controlPort,
-            socksProxy,
-            ownDomains,
-            sourceCode = T.pack <$> sourceCode,
-            serverInfo =
-              ServerPublicInfo
-                { sourceCode = T.pack simplexmqSource,
-                  usageConditions = Nothing,
-                  operator = fst operator_,
-                  website,
-                  adminContacts = Nothing,
-                  complaintsContacts = Nothing,
-                  hosting = fst hosting_,
-                  hostingType,
-                  serverCountry
-                },
-            operatorCountry = snd operator_,
-            hostingCountry = snd hosting_,
+            sourceCode,
             webStaticPath,
             disableWeb,
             scripted
           }
-    journalCmdP =
-      hsubparser
-        ( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage"))
-            <> command "export" (info (pure JCExport) (progDesc "Export journal storage to message log file"))
-            <> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage"))
-        )
-
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
-    entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
-    entityP opt' metavar' help' = do
-      name_ <-
-        (optional . strOption)
-          ( long opt'
-              <> metavar (metavar' <> "_NAME")
-              <> help (help' <> " name")
-          )
-      country <- countryP opt' metavar' help'
-      pure ((\name -> Entity {name, country}) <$> name_, country)
-    countryP :: String -> String -> String -> Parser (Maybe Text)
-    countryP opt' metavar' help' =
-      (optional . option (eitherReader $ validCountryValue opt'))
-        ( long (opt' <> "-country")
-            <> metavar (metavar' <> "_COUNTRY")
-            <> help (help' <> " country")
-        )
-    strParse :: StrEncoding a => ReadM a
-    strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack

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

@@ -1,782 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TupleSections #-}
-
-module Simplex.Messaging.Server.MsgStore.Journal
-  ( JournalMsgStore (queues, senders, notifiers, random),
-    JournalQueue,
-    JournalMsgQueue (queue, state),
-    JMQueue (queueDirectory, statePath),
-    JournalStoreConfig (..),
-    closeMsgQueue,
-    closeMsgQueueHandles,
-    -- below are exported for tests
-    MsgQueueState (..),
-    JournalState (..),
-    SJournalType (..),
-    msgQueueDirectory,
-    msgQueueStatePath,
-    readWriteQueueState,
-    newMsgQueueState,
-    newJournalId,
-    appendState,
-    queueLogFileName,
-    journalFilePath,
-    logFileExt,
-  )
-where
-
-import Control.Concurrent.STM
-import qualified Control.Exception as E
-import Control.Logger.Simple
-import Control.Monad
-import Control.Monad.Trans.Except
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
-import Data.Int (Int64)
-import Data.List (intercalate)
-import Data.Maybe (catMaybes, fromMaybe, isNothing)
-import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
-import GHC.IO (catchAny)
-import Simplex.Messaging.Agent.Client (getMapLock, withLockMap)
-import Simplex.Messaging.Agent.Lock
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.MsgStore.Types
-import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$>))
-import System.Directory
-import System.Exit
-import System.FilePath ((</>))
-import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout)
-import qualified System.IO as IO
-import System.Random (StdGen, genByteString, newStdGen)
-
-data JournalMsgStore = JournalMsgStore
-  { config :: JournalStoreConfig,
-    random :: TVar StdGen,
-    queueLocks :: TMap RecipientId Lock,
-    queues :: TMap RecipientId JournalQueue,
-    senders :: TMap SenderId RecipientId,
-    notifiers :: TMap NotifierId RecipientId,
-    storeLog :: TVar (Maybe (StoreLog 'WriteMode))
-  }
-
-data JournalStoreConfig = JournalStoreConfig
-  { storePath :: FilePath,
-    pathParts :: Int,
-    quota :: Int,
-    -- Max number of messages per journal file - ignored in STM store.
-    -- When this limit is reached, the file will be changed.
-    -- This number should be set bigger than queue quota.
-    maxMsgCount :: Int,
-    maxStateLines :: Int,
-    stateTailSize :: Int,
-    -- time in seconds after which the queue will be closed after message expiration
-    idleInterval :: Int64
-  }
-
-data JournalQueue = JournalQueue
-  { queueLock :: Lock,
-    -- To avoid race conditions and errors when restoring queues,
-    -- Nothing is written to TVar when queue is deleted.
-    queueRec :: TVar (Maybe QueueRec),
-    msgQueue_ :: TVar (Maybe JournalMsgQueue),
-    -- system time in seconds since epoch
-    activeAt :: TVar Int64,
-    -- Just True - empty, Just False - non-empty, Nothing - unknown
-    isEmpty :: TVar (Maybe Bool)
-  }
-
-data JMQueue = JMQueue
-  { queueDirectory :: FilePath,
-    statePath :: FilePath
-  }
-
-data JournalMsgQueue = JournalMsgQueue
-  { queue :: JMQueue,
-    state :: TVar MsgQueueState,
-    -- tipMsg contains last message and length incl. newline
-    -- Nothing - unknown, Just Nothing - empty queue.
-    -- It  prevents reading each message twice,
-    -- and reading it after it was just written.
-    tipMsg :: TVar (Maybe (Maybe (Message, Int64))),
-    handles :: TVar (Maybe MsgQueueHandles)
-  }
-
-data MsgQueueState = MsgQueueState
-  { readState :: JournalState 'JTRead,
-    writeState :: JournalState 'JTWrite,
-    canWrite :: Bool,
-    size :: Int
-  }
-  deriving (Show)
-
-data MsgQueueHandles = MsgQueueHandles
-  { stateHandle :: Handle, -- handle to queue state log file, rotates and removes old backups when server is restarted
-    readHandle :: Handle,
-    writeHandle :: Maybe Handle -- optional, used when write file is different from read file
-  }
-
-data JournalState t = JournalState
-  { journalType :: SJournalType t,
-    journalId :: ByteString,
-    msgPos :: Int,
-    msgCount :: Int,
-    bytePos :: Int64,
-    byteCount :: Int64
-  }
-  deriving (Show)
-
-data JournalType = JTRead | JTWrite
-
-data SJournalType (t :: JournalType) where
-  SJTRead :: SJournalType 'JTRead
-  SJTWrite :: SJournalType 'JTWrite
-
-class JournalTypeI t where sJournalType :: SJournalType t
-
-instance JournalTypeI 'JTRead where sJournalType = SJTRead
-
-instance JournalTypeI 'JTWrite where sJournalType = SJTWrite
-
-deriving instance Show (SJournalType t)
-
-newMsgQueueState :: ByteString -> MsgQueueState
-newMsgQueueState journalId =
-  MsgQueueState
-    { writeState = newJournalState journalId,
-      readState = newJournalState journalId,
-      canWrite = True,
-      size = 0
-    }
-
-newJournalState :: JournalTypeI t => ByteString -> JournalState t
-newJournalState journalId = JournalState sJournalType journalId 0 0 0 0
-
-journalFilePath :: FilePath -> ByteString -> FilePath
-journalFilePath dir journalId = dir </> (msgLogFileName <> "." <> B.unpack journalId <> logFileExt)
-
-instance StrEncoding MsgQueueState where
-  strEncode MsgQueueState {writeState, readState, canWrite, size} =
-    B.unwords
-      [ "write=" <> strEncode writeState,
-        "read=" <> strEncode readState,
-        "canWrite=" <> strEncode canWrite,
-        "size=" <> strEncode size
-      ]
-  strP = do
-    writeState <- "write=" *> strP
-    readState <- " read=" *> strP
-    canWrite <- " canWrite=" *> strP
-    size <- " size=" *> strP
-    pure MsgQueueState {writeState, readState, canWrite, size}
-
-instance JournalTypeI t => StrEncoding (JournalState t) where
-  strEncode JournalState {journalId, msgPos, msgCount, bytePos, byteCount} =
-    B.intercalate "," [journalId, e msgPos, e msgCount, e bytePos, e byteCount]
-    where
-      e :: StrEncoding a => a -> ByteString
-      e = strEncode
-  strP = do
-    journalId <- A.takeTill (== ',')
-    JournalState sJournalType journalId <$> i <*> i <*> i <*> i
-    where
-      i :: Integral a => A.Parser a
-      i = A.char ',' *> A.decimal
-
-queueLogFileName :: String
-queueLogFileName = "queue_state"
-
-msgLogFileName :: String
-msgLogFileName = "messages"
-
-logFileExt :: String
-logFileExt = ".log"
-
-newtype StoreIO a = StoreIO {unStoreIO :: IO a}
-  deriving newtype (Functor, Applicative, Monad)
-
-instance STMQueueStore JournalMsgStore where
-  queues' = queues
-  senders' = senders
-  notifiers' = notifiers
-  storeLog' = storeLog
-  mkQueue st qr = do
-    lock <- getMapLock (queueLocks st) $ recipientId qr
-    q <- newTVar $ Just qr
-    mq <- newTVar Nothing
-    activeAt <- newTVar 0
-    isEmpty <- newTVar Nothing
-    pure $ JournalQueue lock q mq activeAt isEmpty
-  msgQueue_' = msgQueue_
-
-instance MsgStoreClass JournalMsgStore where
-  type StoreMonad JournalMsgStore = StoreIO
-  type StoreQueue JournalMsgStore = JournalQueue
-  type MsgQueue JournalMsgStore = JournalMsgQueue
-  type MsgStoreConfig JournalMsgStore = JournalStoreConfig
-
-  newMsgStore :: JournalStoreConfig -> IO JournalMsgStore
-  newMsgStore config = do
-    random <- newTVarIO =<< newStdGen
-    queueLocks <- TM.emptyIO
-    queues <- TM.emptyIO
-    senders <- TM.emptyIO
-    notifiers <- TM.emptyIO
-    storeLog <- newTVarIO Nothing
-    pure JournalMsgStore {config, random, queueLocks, queues, senders, notifiers, storeLog}
-
-  setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO ()
-  setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
-
-  closeMsgStore st = do
-    readTVarIO (storeLog st) >>= mapM_ closeStoreLog
-    readTVarIO (queues st) >>= mapM_ closeMsgQueue
-
-  activeMsgQueues = queues
-  {-# INLINE activeMsgQueues #-}
-
-  -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result.
-  -- It is used to export storage to a single file and also to expire messages and validate all queues when server is started.
-  -- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID.
-  -- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name.
-  withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (RecipientId -> JournalQueue -> IO a) -> IO a
-  withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty)
-    where
-      processStore = do
-        (!count, !res) <- foldQueues 0 processQueue (0, mempty) ("", storePath)
-        putStrLn $ progress count
-        pure res
-      JournalStoreConfig {storePath, pathParts} = config
-      processQueue :: (Int, a) -> (String, FilePath) -> IO (Int, a)
-      processQueue (!i, !r) (queueId, dir) = do
-        when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout
-        r' <- case strDecode $ B.pack queueId of
-          Right rId ->
-            getQueue ms SRecipient rId >>= \case
-              Right q -> unStoreIO (getMsgQueue ms rId q) *> action rId q <* closeMsgQueue q
-              Left AUTH -> do
-                logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir
-                removeQueueDirectory_ dir
-                pure mempty
-              Left e -> do
-                logError $ "STORE: processQueue, error getting queue " <> T.pack queueId <> ", " <> tshow e
-                exitFailure
-          Left e -> do
-            logError $ "STORE: processQueue, message queue directory " <> T.pack dir <> " is invalid, " <> tshow e
-            exitFailure
-        pure (i + 1, r <> r')
-      progress i = "Processed: " <> show i <> " queues"
-      foldQueues depth f acc (queueId, path) = do
-        let f' = if depth == pathParts - 1 then f else foldQueues (depth + 1) f
-        listDirs >>= foldM f' acc
-        where
-          listDirs = fmap catMaybes . mapM queuePath =<< listDirectory path
-          queuePath dir = do
-            let !path' = path </> dir
-                !queueId' = queueId <> dir
-            ifM
-              (doesDirectoryExist path')
-              (pure $ Just (queueId', path'))
-              (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping"))
-
-  logQueueStates :: JournalMsgStore -> IO ()
-  logQueueStates ms = withActiveMsgQueues ms $ \_ -> unStoreIO . logQueueState
-
-  logQueueState :: JournalQueue -> StoreIO ()
-  logQueueState q =
-    StoreIO . void $
-      readTVarIO (msgQueue_ q)
-        $>>= \mq -> readTVarIO (handles mq)
-        $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ())
-
-  queueRec' = queueRec
-  {-# INLINE queueRec' #-}
-
-  getMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO JournalMsgQueue
-  getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} =
-    StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure
-    where
-      newQ = do
-        let dir = msgQueueDirectory ms rId
-            statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
-            queue = JMQueue {queueDirectory = dir, statePath}
-        q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue)
-        atomically $ writeTVar msgQueue_ $ Just q
-        pure q
-        where
-          createQ :: JMQueue -> IO JournalMsgQueue
-          createQ queue = do
-            -- folder and files are not created here,
-            -- to avoid file IO for queues without messages during subscription
-            journalId <- newJournalId random
-            mkJournalQueue queue (newMsgQueueState journalId) Nothing
-
-  getPeekMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message))
-  getPeekMsgQueue ms rId q@JournalQueue {isEmpty} =
-    StoreIO (readTVarIO isEmpty) >>= \case
-      Just True -> pure Nothing
-      Just False -> peek
-      Nothing -> do
-        -- We only close the queue if we just learnt it's empty.
-        -- This is needed to reduce file descriptors and memory usage
-        -- after the server just started and many clients subscribe.
-        -- In case the queue became non-empty on write and then again empty on read
-        -- we won't be closing it, to avoid frequent open/close on active queues.
-        r <- peek
-        when (isNothing r) $ StoreIO $ closeMsgQueue q
-        pure r
-    where
-      peek = do
-        mq <- getMsgQueue ms rId q
-        (mq,) <$$> tryPeekMsg_ q mq
-
-  -- only runs action if queue is not empty
-  withIdleMsgQueue :: Int64 -> JournalMsgStore -> RecipientId -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int)
-  withIdleMsgQueue now ms@JournalMsgStore {config} rId q action =
-    StoreIO $ readTVarIO (msgQueue_ q) >>= \case
-      Nothing ->
-        E.bracket
-          (unStoreIO $ getPeekMsgQueue ms rId q)
-          (mapM_ $ \_ -> closeMsgQueue q)
-          (maybe (pure (Nothing, 0)) (unStoreIO . run))
-        where
-          run (mq, _) = do
-            r <- action mq
-            sz <- getQueueSize_ mq
-            pure (Just r, sz)
-      Just mq -> do
-        ts <- readTVarIO $ activeAt q
-        r <- if now - ts >= idleInterval config
-          then Just <$> unStoreIO (action mq) `E.finally` closeMsgQueue q
-          else pure Nothing
-        sz <- unStoreIO $ getQueueSize_ mq
-        pure (r, sz)
-
-  deleteQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType QueueRec)
-  deleteQueue ms rId q =
-    fst <$$> deleteQueue_ ms rId q
-
-  deleteQueueSize :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Int))
-  deleteQueueSize ms rId q =
-    deleteQueue_ ms rId q >>= mapM (traverse getSize)
-    -- traverse operates on the second tuple element
-    where
-      getSize = maybe (pure (-1)) (fmap size . readTVarIO . state)
-
-  getQueueMessages_ :: Bool -> JournalMsgQueue -> StoreIO [Message]
-  getQueueMessages_ drainMsgs q = StoreIO (run [])
-    where
-      run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
-      getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg
-        where
-          readMsg (rs, h) = do
-            (msg, len) <- hGetMsgAt h $ bytePos rs
-            updateReadPos q drainMsgs len hs
-            (msg :) <$> run msgs
-
-  writeMsg :: JournalMsgStore -> RecipientId -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
-  writeMsg ms rId q' logState msg = isolateQueue rId q' "writeMsg" $ do
-    q <- getMsgQueue ms rId q'
-    StoreIO $ (`E.finally` updateActiveAt q') $ do
-      st@MsgQueueState {canWrite, size} <- readTVarIO (state q)
-      let empty = size == 0
-      if canWrite || empty
-        then do
-          atomically $ writeTVar (isEmpty q') (Just False)
-          let canWrt' = quota > size
-          if canWrt'
-            then writeToJournal q st canWrt' msg $> Just (msg, empty)
-            else writeToJournal q st canWrt' msgQuota $> Nothing
-        else pure Nothing
-    where
-      JournalStoreConfig {quota, maxMsgCount} = config ms
-      msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
-      writeToJournal q st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do
-        let msgStr = strEncode msg' `B.snoc` '\n'
-            msgLen = fromIntegral $ B.length msgStr
-        hs <- maybe createQueueDir pure =<< readTVarIO handles
-        (ws, wh) <- case writeHandle hs of
-          Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs
-          wh_ -> pure (writeState, fromMaybe (readHandle hs) wh_)
-        let msgPos' = msgPos ws + 1
-            bytePos' = bytePos ws + msgLen
-            ws' = ws {msgPos = msgPos', msgCount = msgPos', bytePos = bytePos', byteCount = bytePos'}
-            rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs
-            !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1}
-        hAppend wh (bytePos ws) msgStr
-        updateQueueState q logState hs st' $
-          when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen))
-        where
-          JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} = q
-          createQueueDir = do
-            createDirectoryIfMissing True queueDirectory
-            sh <- openFile statePath AppendMode
-            B.hPutStr sh ""
-            rh <- createNewJournal queueDirectory $ journalId rs
-            let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing}
-            atomically $ writeTVar handles $ Just hs
-            pure hs
-          switchWriteJournal hs = do
-            journalId <- newJournalId $ random ms
-            wh <- createNewJournal queueDirectory journalId
-            atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh}
-            pure (newJournalState journalId, wh)
-
-  -- can ONLY be used while restoring messages, not while server running
-  setOverQuota_ :: JournalQueue -> IO ()
-  setOverQuota_ q =
-    readTVarIO (msgQueue_ q)
-      >>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False})
-
-  getQueueSize_ :: JournalMsgQueue -> StoreIO Int
-  getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state
-
-  tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message)
-  tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} =
-    StoreIO $ (readTVarIO handles $>>= chooseReadJournal mq True $>>= peekMsg) >>= setEmpty
-    where
-      peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst)
-        where
-          readMsg = do
-            ml@(msg, _) <- hGetMsgAt h $ bytePos rs
-            atomically $ writeTVar tipMsg $ Just (Just ml)
-            pure $ Just msg
-      setEmpty msg = do
-        atomically $ writeTVar (isEmpty q) (Just $ isNothing msg)
-        pure msg
-
-  tryDeleteMsg_ :: JournalQueue -> JournalMsgQueue -> Bool -> StoreIO ()
-  tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $
-    void $
-      readTVarIO tipMsg -- if there is no cached tipMsg, do nothing
-        $>>= (pure . fmap snd)
-        $>>= \len -> readTVarIO handles
-        $>>= \hs -> updateReadPos mq logState len hs $> Just ()
-
-  isolateQueue :: RecipientId -> JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a
-  isolateQueue rId JournalQueue {queueLock} op =
-    tryStore' op rId . withLock' queueLock op . unStoreIO
-
-updateActiveAt :: JournalQueue -> IO ()
-updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime
-
-tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a
-tryStore' op rId = tryStore op rId . fmap Right
-
-tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
-tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure
-  where
-    storeErr :: E.SomeException -> IO (Either ErrorType a)
-    storeErr e =
-      let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
-       in logError ("STORE: " <> T.pack e') $> Left (STORE e')
-
-isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
-isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op
-
-openMsgQueue :: JournalMsgStore -> JMQueue -> IO JournalMsgQueue
-openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do
-  (st, sh) <- readWriteQueueState ms statePath
-  (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh
-  let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_}
-  mkJournalQueue q st' (Just hs)
-
-mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO JournalMsgQueue
-mkJournalQueue queue st hs_ = do
-  state <- newTVarIO st
-  tipMsg <- newTVarIO Nothing
-  handles <- newTVarIO hs_
-  -- using the same queue lock which is currently locked,
-  -- to avoid map lookup on queue operations
-  pure JournalMsgQueue {queue, state, tipMsg, handles}
-
-chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle))
-chooseReadJournal q log' hs = do
-  st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q)
-  case writeHandle hs of
-    Just wh | msgPos rs >= msgCount rs && journalId rs /= journalId ws -> do
-      -- switching to write journal
-      atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing}
-      hClose $ readHandle hs
-      when log' $ removeJournal (queueDirectory $ queue q) rs
-      let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws}
-          !st' = st {readState = rs'}
-      updateQueueState q log' hs st' $ pure ()
-      pure $ Just (rs', wh)
-    _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing
-    _ -> pure $ Just (rs, readHandle hs)
-
-updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO ()
-updateQueueState q log' hs st a = do
-  unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st
-  when log' $ appendState (stateHandle hs) st
-  atomically $ writeTVar (state q) st >> a
-
-appendState :: Handle -> MsgQueueState -> IO ()
-appendState h st = E.uninterruptibleMask_ $ B.hPutStr h $ strEncode st `B.snoc` '\n'
-
-updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO ()
-updateReadPos q log' len hs = do
-  st@MsgQueueState {readState = rs, size} <- readTVarIO (state q)
-  let JournalState {msgPos, bytePos} = rs
-  let msgPos' = msgPos + 1
-      rs' = rs {msgPos = msgPos', bytePos = bytePos + len}
-      st' = st {readState = rs', size = size - 1}
-  updateQueueState q log' hs st' $ writeTVar (tipMsg q) Nothing
-
-msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath
-msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId =
-  storePath </> B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId)
-  where
-    splitSegments _ "" = []
-    splitSegments 1 s = [s]
-    splitSegments n s =
-      let (seg, s') = B.splitAt 2 s
-       in seg : splitSegments (n - 1) s'
-
-msgQueueStatePath :: FilePath -> String -> FilePath
-msgQueueStatePath dir queueId = dir </> (queueLogFileName <> "." <> queueId <> logFileExt)
-
-createNewJournal :: FilePath -> ByteString -> IO Handle
-createNewJournal dir journalId = do
-  let path = journalFilePath dir journalId -- TODO retry if file exists
-  h <- openFile path ReadWriteMode
-  B.hPutStr h ""
-  pure h
-
-newJournalId :: TVar StdGen -> IO ByteString
-newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12)
-
-openJournals :: JournalMsgStore -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle)
-openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = do
-  let rjId = journalId rs
-      wjId = journalId ws
-  openJournal rs >>= \case
-    Left path
-      | rjId == wjId -> do
-          logError $ "STORE: openJournals, no read/write file - creating new file, " <> T.pack path
-          newReadJournal
-      | otherwise -> do
-          let rs' = (newJournalState wjId) {msgCount = msgCount ws, byteCount = byteCount ws}
-              st' = st {readState = rs', size = msgCount ws}
-          openJournal rs' >>= \case
-            Left path' -> do
-              logError $ "STORE: openJournals, no read and write files - creating new file, read: " <> T.pack path <> ", write: " <> T.pack path'
-              newReadJournal
-            Right rh -> do
-              logError $ "STORE: openJournals, no read file - switched to write file, " <> T.pack path
-              closeOnException rh $ fixFileSize rh $ bytePos ws
-              pure (st', rh, Nothing)
-    Right rh
-      | rjId == wjId -> do
-          closeOnException rh $ fixFileSize rh $ bytePos ws
-          pure (st, rh, Nothing)
-      | otherwise -> closeOnException rh $ do
-          fixFileSize rh $ byteCount rs
-          openJournal ws >>= \case
-            Left path -> do
-              let msgs = msgCount rs
-                  bytes = byteCount rs
-                  size' = msgs - msgPos rs
-                  ws' = (newJournalState rjId) {msgPos = msgs, msgCount = msgs, bytePos = bytes, byteCount = bytes}
-                  st' = st {writeState = ws', size = size'} -- we don't amend canWrite to trigger QCONT
-              logError $ "STORE: openJournals, no write file, " <> T.pack path
-              pure (st', rh, Nothing)
-            Right wh -> do
-              closeOnException wh $ fixFileSize wh $ bytePos ws
-              pure (st, rh, Just wh)
-  where
-    newReadJournal = do
-      rjId' <- newJournalId $ random ms
-      rh <- createNewJournal dir rjId'
-      let st' = newMsgQueueState rjId'
-      closeOnException rh $ appendState sh st'
-      pure (st', rh, Nothing)
-    openJournal :: JournalState t -> IO (Either FilePath Handle)
-    openJournal JournalState {journalId} =
-      let path = journalFilePath dir journalId
-       in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path)
-    -- do that for all append operations
-
-fixFileSize :: Handle -> Int64 -> IO ()
-fixFileSize h pos = do
-  let pos' = fromIntegral pos
-  size <- IO.hFileSize h
-  if
-    | size > pos' -> do
-        name <- IO.hShow h
-        logWarn $ "STORE: fixFileSize, size " <> tshow size <> " > pos " <> tshow pos <> " - truncating, " <> T.pack name
-        IO.hSetFileSize h pos'
-    | size < pos' -> do
-        -- From code logic this can't happen.
-        name <- IO.hShow h
-        E.throwIO $ userError $ "fixFileSize size " <> show size <> " < pos " <> show pos <> " - aborting: " <> name
-    | otherwise -> pure ()
-
-removeJournal :: FilePath -> JournalState t -> IO ()
-removeJournal dir JournalState {journalId} = do
-  let path = journalFilePath dir journalId
-  removeFile path `catchAny` (\e -> logError $ "STORE: removeJournal, " <> T.pack path <> ", " <> tshow e)
-
--- This function is supposed to be resilient to crashes while updating state files,
--- and also resilient to crashes during its execution.
-readWriteQueueState :: JournalMsgStore -> FilePath -> IO (MsgQueueState, Handle)
-readWriteQueueState JournalMsgStore {random, config} statePath =
-  ifM
-    (doesFileExist tempBackup)
-    (renameFile tempBackup statePath >> readQueueState)
-    (ifM (doesFileExist statePath) readQueueState writeNewQueueState)
-  where
-    tempBackup = statePath <> ".bak"
-    readQueueState = do
-      ls <- B.lines <$> readFileTail
-      case ls of
-        [] -> writeNewQueueState
-        _ -> do
-          r@(st, _) <- useLastLine (length ls) True ls
-          unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st
-          pure r
-    writeNewQueueState = do
-      logWarn $ "STORE: readWriteQueueState, empty queue state - initialized, " <> T.pack statePath
-      st <- newMsgQueueState <$> newJournalId random
-      writeQueueState st
-    useLastLine len isLastLine ls = case strDecode $ last ls of
-      Right st
-        | len > maxStateLines config || not isLastLine ->
-            backupWriteQueueState st
-        | otherwise -> do
-            -- when state file has fewer than maxStateLines, we don't compact it
-            sh <- openFile statePath AppendMode
-            pure (st, sh)
-      Left e -- if the last line failed to parse
-        | isLastLine -> case init ls of -- or use the previous line
-            [] -> do
-              logWarn $ "STORE: readWriteQueueState, invalid 1-line queue state - initialized, " <> T.pack statePath
-              st <- newMsgQueueState <$> newJournalId random
-              backupWriteQueueState st
-            ls' -> do
-              logWarn $ "STORE: readWriteQueueState, invalid last line in queue state - using the previous line, " <> T.pack statePath
-              useLastLine len False ls'
-        | otherwise -> E.throwIO $ userError $ "readWriteQueueState invalid state " <> statePath <> ": " <> show e
-    backupWriteQueueState st = do
-      -- State backup is made in two steps to mitigate the crash during the backup.
-      -- Temporary backup file will be used when it is present.
-      renameFile statePath tempBackup -- 1) temp backup
-      r <- writeQueueState st -- 2) save state
-      ts <- getCurrentTime
-      renameFile tempBackup (statePath <> "." <> iso8601Show ts <> ".bak") -- 3) timed backup
-      pure r
-    writeQueueState st = do
-      sh <- openFile statePath AppendMode
-      closeOnException sh $ appendState sh st
-      pure (st, sh)
-    readFileTail =
-      IO.withFile statePath ReadMode $ \h -> do
-        size <- IO.hFileSize h
-        let sz = stateTailSize config
-            sz' = fromIntegral sz
-        if size > sz'
-          then IO.hSeek h AbsoluteSeek (size - sz') >> B.hGet h sz
-          else B.hGet h (fromIntegral size)
-
-validQueueState :: MsgQueueState -> Bool
-validQueueState MsgQueueState {readState = rs, writeState = ws, size}
-  | journalId rs == journalId ws =
-      alwaysValid
-        && msgPos rs <= msgPos ws
-        && msgCount rs == msgCount ws
-        && bytePos rs <= bytePos ws
-        && byteCount rs == byteCount ws
-        && size == msgCount rs - msgPos rs
-  | otherwise =
-      alwaysValid
-        && size == msgCount ws + msgCount rs - msgPos rs
-  where
-    alwaysValid =
-      msgPos rs <= msgCount rs
-        && bytePos rs <= byteCount rs
-        && msgPos ws == msgCount ws
-        && bytePos ws == byteCount ws
-
-deleteQueue_ :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue))
-deleteQueue_ ms rId q =
-  runExceptT $ isolateQueueId "deleteQueue_" ms rId $
-    deleteQueue' ms rId q >>= mapM remove
-  where
-    remove r@(_, mq_) = do
-      mapM_ closeMsgQueueHandles mq_
-      removeQueueDirectory ms rId
-      pure r
-
-closeMsgQueue :: JournalQueue -> IO ()
-closeMsgQueue JournalQueue {msgQueue_} = atomically (swapTVar msgQueue_ Nothing) >>= mapM_ closeMsgQueueHandles
-
-closeMsgQueueHandles :: JournalMsgQueue -> IO ()
-closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
-  where
-    closeHandles (MsgQueueHandles sh rh wh_) = do
-      hClose sh
-      hClose rh
-      mapM_ hClose wh_
-
-removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO ()
-removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st
-
-removeQueueDirectory_ :: FilePath -> IO ()
-removeQueueDirectory_ dir =
-  removePathForcibly dir `catchAny` \e ->
-    logError $ "STORE: removeQueueDirectory, " <> T.pack dir <> ", " <> tshow e
-
-hAppend :: Handle -> Int64 -> ByteString -> IO ()
-hAppend h pos s = do
-  fixFileSize h pos
-  IO.hSeek h SeekFromEnd 0
-  B.hPutStr h s
-
-hGetMsgAt :: Handle -> Int64 -> IO (Message, Int64)
-hGetMsgAt h pos = do
-  IO.hSeek h AbsoluteSeek $ fromIntegral pos
-  s <- B.hGetLine h
-  case strDecode s of
-    Right !msg ->
-      let !len = fromIntegral (B.length s) + 1
-       in pure (msg, len)
-    Left e -> E.throwIO $ userError $ "hGetMsgAt invalid message: " <> e
-
-openFile :: FilePath -> IOMode -> IO Handle
-openFile f mode = do
-  h <- IO.openFile f mode
-  IO.hSetBuffering h LineBuffering
-  pure h
-
-hClose :: Handle -> IO ()
-hClose h =
-  IO.hClose h `catchAny` \e -> do
-    name <- IO.hShow h
-    logError $ "STORE: hClose, " <> T.pack name <> ", " <> tshow e
-
-closeOnException :: Handle -> IO a -> IO a
-closeOnException h a = a `E.onException` hClose h

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

@@ -1,175 +1,129 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.MsgStore.STM
-  ( STMMsgStore (..),
-    STMStoreConfig (..),
+  ( STMMsgStore,
+    MsgQueue (msgQueue),
+    newMsgStore,
+    getMsgQueue,
+    delMsgQueue,
+    delMsgQueueSize,
+    writeMsg,
+    tryPeekMsg,
+    tryPeekMsgIO,
+    tryDelMsg,
+    tryDelPeekMsg,
+    deleteExpiredMsgs,
+    getQueueSize,
   )
 where
 
-import Control.Concurrent.STM
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
+import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.MsgStore.Types
-import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Server.StoreLog
+import Data.Time.Clock.System (SystemTime (systemSeconds))
+import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util ((<$$>), ($>>=))
-import System.IO (IOMode (..))
+import UnliftIO.STM
 
-data STMMsgStore = STMMsgStore
-  { storeConfig :: STMStoreConfig,
-    queues :: TMap RecipientId STMQueue,
-    senders :: TMap SenderId RecipientId,
-    notifiers :: TMap NotifierId RecipientId,
-    storeLog :: TVar (Maybe (StoreLog 'WriteMode))
-  }
-
-data STMQueue = STMQueue
-  { -- To avoid race conditions and errors when restoring queues,
-    -- Nothing is written to TVar when queue is deleted.
-    queueRec :: TVar (Maybe QueueRec),
-    msgQueue_ :: TVar (Maybe STMMsgQueue)
-  }
-
-data STMMsgQueue = STMMsgQueue
+data MsgQueue = MsgQueue
   { msgQueue :: TQueue Message,
+    quota :: Int,
     canWrite :: TVar Bool,
     size :: TVar Int
   }
 
-data STMStoreConfig = STMStoreConfig
-  { storePath :: Maybe FilePath,
-    quota :: Int
-  }
+type STMMsgStore = TMap RecipientId MsgQueue
 
-instance STMQueueStore STMMsgStore where
-  queues' = queues
-  senders' = senders
-  notifiers' = notifiers
-  storeLog' = storeLog
-  mkQueue _ qr = STMQueue <$> newTVar (Just qr) <*> newTVar Nothing
-  msgQueue_' = msgQueue_
+newMsgStore :: IO STMMsgStore
+newMsgStore = TM.emptyIO
 
-instance MsgStoreClass STMMsgStore where
-  type StoreMonad STMMsgStore = STM
-  type StoreQueue STMMsgStore = STMQueue
-  type MsgQueue STMMsgStore = STMMsgQueue
-  type MsgStoreConfig STMMsgStore = STMStoreConfig
+-- The reason for double lookup is that majority of messaging queues exist,
+-- because multiple messages are sent to the same queue,
+-- so the first lookup without STM transaction will return the queue faster.
+-- In case the queue does not exist, it needs to be looked-up again inside transaction.
+getMsgQueue :: STMMsgStore -> RecipientId -> Int -> IO MsgQueue
+getMsgQueue st rId quota = TM.lookupIO rId st >>= maybe (atomically maybeNewQ) pure
+  where
+    maybeNewQ = TM.lookup rId st >>= maybe newQ pure
+    newQ = do
+      msgQueue <- newTQueue
+      canWrite <- newTVar True
+      size <- newTVar 0
+      let q = MsgQueue {msgQueue, quota, canWrite, size}
+      TM.insert rId q st
+      pure q
 
-  newMsgStore :: STMStoreConfig -> IO STMMsgStore
-  newMsgStore storeConfig = do
-    queues <- TM.emptyIO
-    senders <- TM.emptyIO
-    notifiers <- TM.emptyIO
-    storeLog <- newTVarIO Nothing
-    pure STMMsgStore {storeConfig, queues, senders, notifiers, storeLog}
+delMsgQueue :: STMMsgStore -> RecipientId -> IO ()
+delMsgQueue st rId = atomically $ TM.delete rId st
 
-  setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO ()
-  setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
+delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int
+delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size)
 
-  closeMsgStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog
+writeMsg :: MsgQueue -> Message -> IO (Maybe (Message, Bool))
+writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do
+  canWrt <- readTVar canWrite
+  empty <- isEmptyTQueue q
+  if canWrt || empty
+    then do
+      canWrt' <- (quota >) <$> readTVar size
+      writeTVar canWrite $! canWrt'
+      modifyTVar' size (+ 1)
+      if canWrt'
+        then writeTQueue q msg $> Just (msg, empty)
+        else (writeTQueue q $! msgQuota) $> Nothing
+    else pure Nothing
+  where
+    msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
 
-  activeMsgQueues = queues
-  {-# INLINE activeMsgQueues #-}
+tryPeekMsgIO :: MsgQueue -> IO (Maybe Message)
+tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue
+{-# INLINE tryPeekMsgIO #-}
 
-  withAllMsgQueues _ = withActiveMsgQueues
-  {-# INLINE withAllMsgQueues #-}
+-- TODO remove once deliverToSub is split
+tryPeekMsg :: MsgQueue -> STM (Maybe Message)
+tryPeekMsg = tryPeekTQueue . msgQueue
+{-# INLINE tryPeekMsg #-}
 
-  logQueueStates _ = pure ()
+tryDelMsg :: MsgQueue -> MsgId -> IO (Maybe Message)
+tryDelMsg mq msgId' = atomically $
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg_ mq >> pure msg_
+      | otherwise -> pure Nothing
+    _ -> pure Nothing
 
-  logQueueState _ = pure ()
+-- atomic delete (== read) last and peek next message if available
+tryDelPeekMsg :: MsgQueue -> MsgId -> IO (Maybe Message, Maybe Message)
+tryDelPeekMsg mq msgId' = atomically $
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg mq)
+      | otherwise -> pure (Nothing, msg_)
+    _ -> pure (Nothing, Nothing)
 
-  queueRec' = queueRec
-  {-# INLINE queueRec' #-}
+deleteExpiredMsgs :: MsgQueue -> Int64 -> IO Int
+deleteExpiredMsgs mq old = atomically $ loop 0
+  where
+    loop dc =
+      tryPeekMsg mq >>= \case
+        Just Message {msgTs}
+          | systemSeconds msgTs < old ->
+              tryDeleteMsg_ mq >> loop (dc + 1)
+        _ -> pure dc
 
-  getMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM STMMsgQueue
-  getMsgQueue _ _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure
-    where
-      newQ = do
-        msgQueue <- newTQueue
-        canWrite <- newTVar True
-        size <- newTVar 0
-        let q = STMMsgQueue {msgQueue, canWrite, size}
-        writeTVar msgQueue_ (Just q)
-        pure q
+tryDeleteMsg_ :: MsgQueue -> STM ()
+tryDeleteMsg_ MsgQueue {msgQueue = q, size} =
+  tryReadTQueue q >>= \case
+    Just _ -> modifyTVar' size (subtract 1)
+    _ -> pure ()
 
-  getPeekMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
-  getPeekMsgQueue _ _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
-
-  -- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue)
-  withIdleMsgQueue :: Int64 -> STMMsgStore -> RecipientId -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int)
-  withIdleMsgQueue _ _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case
-    Just q -> do
-      r <- action q
-      sz <- getQueueSize_ q
-      pure (Just r, sz)
-    Nothing -> pure (Nothing, 0)
-
-  deleteQueue :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType QueueRec)
-  deleteQueue ms rId q = fst <$$> deleteQueue' ms rId q
-
-  deleteQueueSize :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType (QueueRec, Int))
-  deleteQueueSize ms rId q = deleteQueue' ms rId q >>= mapM (traverse getSize)
-    -- traverse operates on the second tuple element
-    where
-      getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
-
-  getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message]
-  getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue
-    where
-      snapshotTQueue q = do
-        msgs <- flushTQueue q
-        mapM_ (writeTQueue q) msgs
-        pure msgs
-
-  writeMsg :: STMMsgStore -> RecipientId -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
-  writeMsg ms rId q' _logState msg = liftIO $ atomically $ do
-    STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms rId q'
-    canWrt <- readTVar canWrite
-    empty <- isEmptyTQueue q
-    if canWrt || empty
-      then do
-        canWrt' <- (quota >) <$> readTVar size
-        writeTVar canWrite $! canWrt'
-        modifyTVar' size (+ 1)
-        if canWrt'
-          then (writeTQueue q $! msg) $> Just (msg, empty)
-          else (writeTQueue q $! msgQuota) $> Nothing
-      else pure Nothing
-    where
-      STMMsgStore {storeConfig = STMStoreConfig {quota}} = ms
-      msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
-
-  setOverQuota_ :: STMQueue -> IO ()
-  setOverQuota_ q = readTVarIO (msgQueue_ q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
-
-  getQueueSize_ :: STMMsgQueue -> STM Int
-  getQueueSize_ STMMsgQueue {size} = readTVar size
-
-  tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
-  tryPeekMsg_ _ = tryPeekTQueue . msgQueue
-  {-# INLINE tryPeekMsg_ #-}
-
-  tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
-  tryDeleteMsg_ _ STMMsgQueue {msgQueue = q, size} _logState =
-    tryReadTQueue q >>= \case
-      Just _ -> modifyTVar' size (subtract 1)
-      _ -> pure ()
-
-  isolateQueue :: RecipientId -> STMQueue -> String -> STM a -> ExceptT ErrorType IO a
-  isolateQueue _ _ _ = liftIO . atomically
+getQueueSize :: MsgQueue -> IO Int
+getQueueSize MsgQueue {size} = readTVarIO size

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

@@ -1,141 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Redundant multi-way if" #-}
-
-module Simplex.Messaging.Server.MsgStore.Types where
-
-import Control.Concurrent.STM
-import Control.Monad (foldM)
-import Control.Monad.Trans.Except
-import Data.Functor (($>))
-import Data.Int (Int64)
-import Data.Kind
-import qualified Data.Map.Strict as M
-import Data.Time.Clock.System (SystemTime (systemSeconds))
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.StoreLog.Types
-import Simplex.Messaging.TMap (TMap)
-import Simplex.Messaging.Util ((<$$>))
-import System.IO (IOMode (..))
-
-class MsgStoreClass s => STMQueueStore s where
-  queues' :: s -> TMap RecipientId (StoreQueue s)
-  senders' :: s -> TMap SenderId RecipientId
-  notifiers' :: s -> TMap NotifierId RecipientId
-  storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode))
-  mkQueue :: s -> QueueRec -> STM (StoreQueue s)
-  msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s))
-
-class Monad (StoreMonad s) => MsgStoreClass s where
-  type StoreMonad s = (m :: Type -> Type) | m -> s
-  type MsgStoreConfig s = c | c -> s
-  type StoreQueue s = q | q -> s
-  type MsgQueue s = q | q -> s
-  newMsgStore :: MsgStoreConfig s -> IO s
-  setStoreLog :: s -> StoreLog 'WriteMode -> IO ()
-  closeMsgStore :: s -> IO ()
-  activeMsgQueues :: s -> TMap RecipientId (StoreQueue s)
-  withAllMsgQueues :: Monoid a => Bool -> s -> (RecipientId -> StoreQueue s -> IO a) -> IO a
-  logQueueStates :: s -> IO ()
-  logQueueState :: StoreQueue s -> StoreMonad s ()
-  queueRec' :: StoreQueue s -> TVar (Maybe QueueRec)
-  getPeekMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
-  getMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (MsgQueue s)
-
-  -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
-  withIdleMsgQueue :: Int64 -> s -> RecipientId -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
-  deleteQueue :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType QueueRec)
-  deleteQueueSize :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
-  getQueueMessages_ :: Bool -> MsgQueue s -> StoreMonad s [Message]
-  writeMsg :: s -> RecipientId -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
-  setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
-  getQueueSize_ :: MsgQueue s -> StoreMonad s Int
-  tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message)
-  tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
-  isolateQueue :: RecipientId -> StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a
-
-data MSType = MSMemory | MSJournal
-
-data SMSType :: MSType -> Type where
-  SMSMemory :: SMSType 'MSMemory
-  SMSJournal :: SMSType 'MSJournal
-
-data AMSType = forall s. AMSType (SMSType s)
-
-withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> StoreQueue s -> IO a) -> IO a
-withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty . M.assocs
-  where
-    run !acc (k, v) = do
-      r <- f k v
-      pure $! acc <> r
-
-getQueueMessages :: MsgStoreClass s => Bool -> s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO [Message]
-getQueueMessages drainMsgs st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst)
-{-# INLINE getQueueMessages #-}
-
-getQueueSize :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO Int
-getQueueSize st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
-{-# INLINE getQueueSize #-}
-
-tryPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
-tryPeekMsg st rId q = snd <$$> withPeekMsgQueue st rId q "tryPeekMsg" pure
-{-# INLINE tryPeekMsg #-}
-
-tryDelMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
-tryDelMsg st rId q msgId' =
-  withPeekMsgQueue st rId q "tryDelMsg" $
-    maybe (pure Nothing) $ \(mq, msg) ->
-      if
-        | messageId msg == msgId' ->
-            tryDeleteMsg_ q mq True $> Just msg
-        | otherwise -> pure Nothing
-
--- atomic delete (== read) last and peek next message if available
-tryDelPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
-tryDelPeekMsg st rId q msgId' =
-  withPeekMsgQueue st rId q "tryDelPeekMsg" $
-    maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
-      if
-        | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq)
-        | otherwise -> pure (Nothing, Just msg)
-
--- The action is called with Nothing when it is known that the queue is empty
-withPeekMsgQueue :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
-withPeekMsgQueue st rId q op a = isolateQueue rId q op $ getPeekMsgQueue st rId q >>= a
-{-# INLINE withPeekMsgQueue #-}
-
-deleteExpiredMsgs :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
-deleteExpiredMsgs st rId q old =
-  isolateQueue rId q "deleteExpiredMsgs" $
-    getMsgQueue st rId q >>= deleteExpireMsgs_ old q
-
--- closed and idle queues will be closed after expiration
--- returns (expired count, queue size after expiration)
-idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int)
-idleDeleteExpiredMsgs now st rId q old =
-  isolateQueue rId q "idleDeleteExpiredMsgs" $
-    withIdleMsgQueue now st rId q (deleteExpireMsgs_ old q)
-
-deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
-deleteExpireMsgs_ old q mq = do
-  n <- loop 0
-  logQueueState q
-  pure n
-  where
-    loop dc =
-      tryPeekMsg_ q mq >>= \case
-        Just Message {msgTs}
-          | systemSeconds msgTs < old ->
-              tryDeleteMsg_ q mq False >> loop (dc + 1)
-        _ -> pure dc

src/Simplex/Messaging/Server/NtfStore.hs

@@ -34,8 +34,18 @@ storeNtf (NtfStore ns) nId ntf = do
   where
     newNtfs = TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :))
 
-deleteNtfs :: NtfStore -> NotifierId -> IO Int
-deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO)
+deleteNtfs :: NtfStore -> NotifierId -> IO ()
+deleteNtfs (NtfStore ns) nId = atomically $ TM.delete nId ns
+
+flushNtfs :: NtfStore -> NotifierId -> IO [MsgNtf]
+flushNtfs (NtfStore ns) nId = do
+  TM.lookupIO nId ns >>= maybe (pure []) swapNtfs
+  where
+    swapNtfs v =
+      readTVarIO v >>= \case
+        [] -> pure []
+        -- if notifications available, atomically swap with empty array
+        _ -> atomically (swapTVar v [])
 
 deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int
 deleteExpiredNtfs (NtfStore ns) old =

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

@@ -1,196 +1,120 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Simplex.Messaging.Server.QueueStore.STM
-  ( addQueue,
+  ( QueueStore (..),
+    newQueueStore,
+    addQueue,
     getQueue,
-    getQueueRec,
     secureQueue,
     addQueueNotifier,
     deleteQueueNotifier,
     suspendQueue,
     updateQueueTime,
-    deleteQueue',
-    readQueueStore,
-    withLog',
+    deleteQueue,
   )
 where
 
-import qualified Control.Exception as E
-import Control.Logger.Simple
 import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
-import Data.Bitraversable (bimapM)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$))
-import System.IO
+import Simplex.Messaging.Util (ifM, ($>>=))
 import UnliftIO.STM
 
-addQueue :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s))
-addQueue st qr@QueueRec {recipientId = rId, senderId = sId, notifier}=
-  atomically add
-    $>>= \q -> q <$$ withLog "addQueue" st (`logCreateQueue` qr)
+data QueueStore = QueueStore
+  { queues :: TMap RecipientId (TVar QueueRec),
+    senders :: TMap SenderId RecipientId,
+    notifiers :: TMap NotifierId RecipientId
+  }
+
+newQueueStore :: IO QueueStore
+newQueueStore = do
+  queues <- TM.emptyIO
+  senders <- TM.emptyIO
+  notifiers <- TM.emptyIO
+  pure QueueStore {queues, senders, notifiers}
+
+addQueue :: QueueStore -> QueueRec -> IO (Either ErrorType ())
+addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = atomically $ do
+  ifM hasId (pure $ Left DUPLICATE_) $ do
+    qVar <- newTVar q
+    TM.insert rId qVar queues
+    TM.insert sId rId senders
+    pure $ Right ()
   where
-    add = ifM hasId (pure $ Left DUPLICATE_) $ do
-      q <- mkQueue st qr -- STMQueue lock <$> (newTVar $! Just qr) <*> newTVar Nothing
-      TM.insert rId q $ queues' st
-      TM.insert sId rId $ senders' st
-      forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st
-      pure $ Right q
-    hasId = or <$> sequence [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier]
-    hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier
+    hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
 
-getQueue :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
-getQueue st party qId =
-  maybe (Left AUTH) Right <$> case party of
-    SRecipient -> TM.lookupIO qId $ queues' st
-    SSender -> TM.lookupIO qId (senders' st) $>>= (`TM.lookupIO` queues' st)
-    SNotifier -> TM.lookupIO qId (notifiers' st) $>>= (`TM.lookupIO` queues' st)
-
-getQueueRec :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
-getQueueRec st party qId =
-  getQueue st party qId
-    $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec' q))
-
-secureQueue :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ())
-secureQueue st sq sKey =
-  atomically (readQueueRec qr $>>= secure)
-    $>>= \rId -> withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey
+getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> IO (Either ErrorType QueueRec)
+getQueue QueueStore {queues, senders, notifiers} party qId =
+  toResult <$> (mapM readTVarIO =<< getVar)
   where
-    qr = queueRec' sq
-    secure q@QueueRec {recipientId = rId} = case senderKey q of
-      Just k -> pure $ if sKey == k then Right rId else Left AUTH
-      Nothing -> do
-        writeTVar qr $ Just q {senderKey = Just sKey}
-        pure $ Right rId
+    getVar = case party of
+      SRecipient -> TM.lookupIO qId queues
+      SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
+      SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
 
-addQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
-addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} =
-  atomically (readQueueRec qr $>>= add)
-    $>>= \(rId, nId_) -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
-  where
-    qr = queueRec' sq
-    add q@QueueRec {recipientId = rId} = ifM (TM.member nId (notifiers' st)) (pure $ Left DUPLICATE_) $ do
-      nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId (notifiers' st) $> notifierId
+secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> IO (Either ErrorType QueueRec)
+secureQueue QueueStore {queues} rId sKey = toResult <$> do
+  TM.lookupIO rId queues $>>= \qVar -> atomically $ 
+    readTVar qVar >>= \q -> case senderKey q of
+      Just k -> pure $ if sKey == k then Just q else Nothing
+      _ ->
+        let !q' = q {senderKey = Just sKey}
+         in writeTVar qVar q' $> Just q'
+
+addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
+  TM.lookupIO rId queues >>= \case
+    Just qVar -> atomically $ ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
+      q <- readTVar qVar
+      nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
       let !q' = q {notifier = Just ntfCreds}
-      writeTVar qr $ Just q'
-      TM.insert nId rId $ notifiers' st
-      pure $ Right (rId, nId_)
+      writeTVar qVar q'
+      TM.insert nId rId notifiers
+      pure $ Right nId_
+    Nothing -> pure $ Left AUTH
 
-deleteQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId))
-deleteQueueNotifier st sq =
-  atomically (readQueueRec qr >>= mapM delete)
-    $>>= \(rId, nId_) -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
-  where
-    qr = queueRec' sq
-    delete q = fmap (recipientId q,) $ forM (notifier q) $ \NtfCreds {notifierId} -> do
-      TM.delete notifierId $ notifiers' st
-      writeTVar qr $! Just q {notifier = Nothing}
+deleteQueueNotifier :: QueueStore -> RecipientId -> IO (Either ErrorType (Maybe NotifierId))
+deleteQueueNotifier QueueStore {queues, notifiers} rId =
+  withQueue rId queues $ \qVar -> do
+    q <- readTVar qVar
+    forM (notifier q) $ \NtfCreds {notifierId} -> do
+      TM.delete notifierId notifiers
+      writeTVar qVar $! q {notifier = Nothing}
       pure notifierId
 
-suspendQueue :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ())
-suspendQueue st sq =
-  atomically (readQueueRec qr >>= mapM suspend)
-    $>>= \rId -> withLog "suspendQueue" st (`logSuspendQueue` rId)
-  where
-    qr = queueRec' sq
-    suspend q = do
-      writeTVar qr $! Just q {status = QueueOff}
-      pure $ recipientId q
+suspendQueue :: QueueStore -> RecipientId -> IO (Either ErrorType ())
+suspendQueue QueueStore {queues} rId =
+  withQueue rId queues (`modifyTVar'` \q -> q {status = QueueOff})
 
-updateQueueTime :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
-updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log'
-  where
-    qr = queueRec' sq
-    update q@QueueRec {updatedAt}
-      | updatedAt == Just t = pure (q, False)
-      | otherwise =
-          let !q' = q {updatedAt = Just t}
-           in (writeTVar qr $! Just q') $> (q', True)
-    log' (q, changed)
-      | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId q) t)
-      | otherwise = pure $ Right q
+updateQueueTime :: QueueStore -> RecipientId -> RoundedSystemTime -> IO ()
+updateQueueTime QueueStore {queues} rId t =
+  void $ withQueue rId queues (`modifyTVar'` \q -> q {updatedAt = Just t})
 
-deleteQueue' :: STMQueueStore s => s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s)))
-deleteQueue' st rId sq =
-  atomically (readQueueRec qr >>= mapM delete)
-    $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` rId)
-    >>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing))
-  where
-    qr = queueRec' sq
-    delete q = do
-      writeTVar qr Nothing
-      TM.delete (senderId q) $ senders' st
-      forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers' st
-      pure q
+deleteQueue :: QueueStore -> RecipientId -> IO (Either ErrorType QueueRec)
+deleteQueue QueueStore {queues, senders, notifiers} rId = atomically $ do
+  TM.lookupDelete rId queues >>= \case
+    Just qVar ->
+      readTVar qVar >>= \q -> do
+        TM.delete (senderId q) senders
+        forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
+        pure $ Right q
+    _ -> pure $ Left AUTH
 
-readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
-readQueueRec qr = maybe (Left AUTH) Right <$> readTVar qr
-{-# INLINE readQueueRec #-}
+toResult :: Maybe a -> Either ErrorType a
+toResult = maybe (Left AUTH) Right
 
-withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
-withLog' name sl action =
-  readTVarIO sl
-    >>= maybe (pure $ Right ()) (E.try . action >=> bimapM logErr pure)
-  where
-    logErr :: E.SomeException -> IO ErrorType
-    logErr e = logError ("STORE: " <> T.pack err) $> STORE err
-      where
-        err = name <> ", withLog, " <> show e
-
-withLog :: STMQueueStore s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
-withLog name = withLog' name . storeLog'
-
-readQueueStore :: forall s. STMQueueStore s => FilePath -> s -> IO ()
-readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines
-  where
-    processLine :: LB.ByteString -> IO ()
-    processLine s' = either printError procLogRecord (strDecode s)
-      where
-        s = LB.toStrict s'
-        procLogRecord :: StoreLogRecord -> IO ()
-        procLogRecord = \case
-          CreateQueue q -> addQueue st q >>= qError (recipientId q) "CreateQueue"
-          SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey
-          AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds
-          SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st
-          DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId
-          DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st
-          UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t
-        printError :: String -> IO ()
-        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
-        withQueue :: forall a. RecipientId -> T.Text -> (StoreQueue s -> IO (Either ErrorType a)) -> IO ()
-        withQueue qId op a = runExceptT go >>= qError qId op
-          where
-            go = do
-              q <- ExceptT $ getQueue st SRecipient qId
-              liftIO (readTVarIO $ queueRec' q) >>= \case
-                Nothing -> logWarn $ logPfx qId op <> "already deleted"
-                Just _ -> void $ ExceptT $ a q
-        qError qId op = \case
-          Left e -> logError $ logPfx qId op <> tshow e
-          Right _ -> pure ()
-        logPfx qId op = "STORE: " <> op <> ", stored queue " <> decodeLatin1 (strEncode qId) <> ", "
+withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM a) -> IO (Either ErrorType a)
+withQueue rId queues f = toResult <$> TM.lookupIO rId queues >>= atomically . mapM f

src/Simplex/Messaging/Server/Stats.hs

@@ -77,8 +77,7 @@ data ServerStats = ServerStats
     pMsgFwdsOwn :: ProxyStats,
     pMsgFwdsRecv :: IORef Int,
     qCount :: IORef Int,
-    msgCount :: IORef Int,
-    ntfCount :: IORef Int
+    msgCount :: IORef Int
   }
 
 data ServerStatsData = ServerStatsData
@@ -130,8 +129,7 @@ data ServerStatsData = ServerStatsData
     _pMsgFwdsOwn :: ProxyStatsData,
     _pMsgFwdsRecv :: Int,
     _qCount :: Int,
-    _msgCount :: Int,
-    _ntfCount :: Int
+    _msgCount :: Int
   }
   deriving (Show)
 
@@ -186,7 +184,6 @@ newServerStats ts = do
   pMsgFwdsRecv <- newIORef 0
   qCount <- newIORef 0
   msgCount <- newIORef 0
-  ntfCount <- newIORef 0
   pure
     ServerStats
       { fromTime,
@@ -237,8 +234,7 @@ newServerStats ts = do
         pMsgFwdsOwn,
         pMsgFwdsRecv,
         qCount,
-        msgCount,
-        ntfCount
+        msgCount
       }
 
 getServerStatsData :: ServerStats -> IO ServerStatsData
@@ -292,7 +288,6 @@ getServerStatsData s = do
   _pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s
   _qCount <- readIORef $ qCount s
   _msgCount <- readIORef $ msgCount s
-  _ntfCount <- readIORef $ ntfCount s
   pure
     ServerStatsData
       { _fromTime,
@@ -343,8 +338,7 @@ getServerStatsData s = do
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
         _qCount,
-        _msgCount,
-        _ntfCount
+        _msgCount
       }
 
 -- this function is not thread safe, it is used on server start only
@@ -399,7 +393,6 @@ setServerStats s d = do
   writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
   writeIORef (qCount s) $! _qCount d
   writeIORef (msgCount s) $! _msgCount d
-  writeIORef (ntfCount s) $! _ntfCount d
 
 instance StrEncoding ServerStatsData where
   strEncode d =
@@ -573,8 +566,7 @@ instance StrEncoding ServerStatsData where
           _pMsgFwdsOwn,
           _pMsgFwdsRecv,
           _qCount,
-          _msgCount = 0,
-          _ntfCount = 0
+          _msgCount = 0
         }
     where
       opt s = A.string s *> strP <* A.endOfLine <|> pure 0

src/Simplex/Messaging/Server/StoreLog.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
@@ -6,12 +5,10 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Simplex.Messaging.Server.StoreLog
   ( StoreLog, -- constructors are not exported
-    StoreLogRecord (..), -- used in tests
     openWriteStoreLog,
     openReadStoreLog,
     storeLogFilePath,
@@ -25,32 +22,31 @@ module Simplex.Messaging.Server.StoreLog
     logDeleteNotifier,
     logUpdateQueueTime,
     readWriteStoreLog,
-    writeQueueStore,
   )
 where
 
 import Control.Applicative (optional, (<|>))
-import Control.Concurrent.STM
-import qualified Control.Exception as E
-import Control.Logger.Simple
-import Control.Monad
+import Control.Monad (foldM, unless, when)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Functor (($>))
+import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
-import GHC.IO (catchAny)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.StoreLog.Types
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM)
+import Simplex.Messaging.Transport.Buffer (trimCR)
+import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO
 
+-- | opaque container for file handle with a type-safe IOMode
+-- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
+data StoreLog (a :: IOMode) where
+  ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
+  WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode
+
 data StoreLogRecord
   = CreateQueue QueueRec
   | SecureQueue QueueId SndPublicAuthKey
@@ -59,7 +55,6 @@ data StoreLogRecord
   | DeleteQueue QueueId
   | DeleteNotifier QueueId
   | UpdateTime QueueId RoundedSystemTime
-  deriving (Show)
 
 data SLRTag
   = CreateQueue_
@@ -79,11 +74,10 @@ instance StrEncoding QueueRec where
         "sid=" <> strEncode senderId,
         "sk=" <> strEncode senderKey
       ]
-      <> sndSecureStr
+      <> if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
       <> maybe "" notifierStr notifier
       <> maybe "" updatedAtStr updatedAt
     where
-      sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
       notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
       updatedAtStr t = " updated_at=" <> strEncode t
 
@@ -147,7 +141,7 @@ openWriteStoreLog f = do
 
 openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode)
 openReadStoreLog f = do
-  unlessM (doesFileExist f) (writeFile f "")
+  doesFileExist f >>= (`unless` writeFile f "")
   ReadStoreLog f <$> openFile f ReadMode
 
 storeLogFilePath :: StoreLog a -> FilePath
@@ -157,13 +151,11 @@ storeLogFilePath = \case
 
 closeStoreLog :: StoreLog a -> IO ()
 closeStoreLog = \case
-  WriteStoreLog _ h -> close_ h
-  ReadStoreLog _ h -> close_ h
-  where
-    close_ h = hClose h `catchAny` \e -> logError ("STORE: closeStoreLog, error closing, " <> tshow e)
+  WriteStoreLog _ h -> hClose h
+  ReadStoreLog _ h -> hClose h
 
 writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
-writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do
+writeStoreLogRecord (WriteStoreLog _ h) r = do
   B.hPut h $ strEncode r `B.snoc` '\n' -- hPutStrLn makes write non-atomic for length > 1024
   hFlush h
 
@@ -188,46 +180,37 @@ logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
 logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t
 
-readWriteStoreLog :: (FilePath -> s -> IO ()) -> (StoreLog 'WriteMode -> s -> IO ()) -> FilePath -> s -> IO (StoreLog 'WriteMode)
-readWriteStoreLog readStore writeStore f st =
-  ifM
-    (doesFileExist tempBackup)
-    (useTempBackup >> readWriteLog)
-    (ifM (doesFileExist f) readWriteLog (writeLog "creating store log..."))
+readWriteStoreLog :: FilePath -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
+readWriteStoreLog f = do
+  qs <- ifM (doesFileExist f) readQS (pure M.empty)
+  s <- openWriteStoreLog f
+  writeQueues s qs
+  pure (qs, s)
   where
-    f' = T.pack f
-    tempBackup = f <> ".start"
-    useTempBackup = do
-      -- preserve current file, use temp backup
-      logWarn $ "Server terminated abnormally on last start, restoring state from " <> T.pack tempBackup
-      whenM (doesFileExist f) $ do
-        renameFile f (f <> ".bak")
-        logInfo $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak")
-      renameFile tempBackup f
-    readWriteLog = do
-      -- log backup is made in two steps to mitigate the crash during the compacting.
-      -- Temporary backup file .start will be used when it is present.
-      readStore f st
-      renameFile f tempBackup -- 1) make temp backup
-      s <- writeLog "compacting store log (do not terminate)..." -- 2) save state
-      renameBackup -- 3) timed backup
-      pure s
-    writeLog msg = do
-      s <- openWriteStoreLog f
-      logInfo msg
-      writeStore s st
-      pure s
-    renameBackup = do
-      ts <- getCurrentTime
-      let timedBackup = f <> "." <> iso8601Show ts
-      renameFile tempBackup timedBackup
-      logInfo $ "original state preserved as " <> T.pack timedBackup
+    readQS = readQueues f <* renameFile f (f <> ".bak")
 
-writeQueueStore :: STMQueueStore s => StoreLog 'WriteMode -> s -> IO ()
-writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M.assocs
+writeQueues :: StoreLog 'WriteMode -> Map RecipientId QueueRec -> IO ()
+writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q
   where
-    writeQueue (rId, q) =
-      readTVarIO (queueRec' q) >>= \case
-        Just q' -> when (active q') $ logCreateQueue s q' -- TODO we should log suspended queues when we use them
-        Nothing -> atomically $ TM.delete rId $ activeMsgQueues st
     active QueueRec {status} = status == QueueActive
+
+readQueues :: FilePath -> IO (Map RecipientId QueueRec)
+readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f
+  where
+    processLine :: Map RecipientId QueueRec -> LB.ByteString -> IO (Map RecipientId QueueRec)
+    processLine m s' = case strDecode $ trimCR s of
+      Right r -> pure $ procLogRecord r
+      Left e -> printError e $> m
+      where
+        s = LB.toStrict s'
+        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
+          UpdateTime qId t -> M.adjust (\q -> q {updatedAt = Just t}) qId m
+        printError :: String -> IO ()
+        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

src/Simplex/Messaging/Server/StoreLog/Types.hs

@@ -1,13 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-
-module Simplex.Messaging.Server.StoreLog.Types where
-
-import System.IO (Handle, IOMode (..))
-
--- | opaque container for file handle with a type-safe IOMode
--- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
-data StoreLog (a :: IOMode) where
-  ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
-  WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode

src/Simplex/Messaging/Transport.hs

@@ -48,7 +48,6 @@ module Simplex.Messaging.Transport
     sendingProxySMPVersion,
     sndAuthKeySMPVersion,
     deletedEventSMPVersion,
-    encryptedBlockSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -91,7 +90,6 @@ import Control.Applicative (optional)
 import Control.Concurrent.STM
 import Control.Monad (forM, (<$!>))
 import Control.Monad.Except
-import Control.Monad.IO.Class
 import Control.Monad.Trans.Except (throwE)
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
@@ -103,7 +101,6 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Default (def)
 import Data.Functor (($>))
-import Data.Tuple (swap)
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Data.Word (Word16)
@@ -141,7 +138,6 @@ smpBlockSize = 16384
 -- 8 - SMP proxy for sender commands
 -- 9 - faster handshake: SKEY command for sender to secure queue
 -- 10 - DELD event to subscriber when queue is deleted via another connnection
--- 11 - additional encryption of transport blocks with forward secrecy (9/14/2024)
 
 data SMPVersion
 
@@ -175,17 +171,14 @@ sndAuthKeySMPVersion = VersionSMP 9
 deletedEventSMPVersion :: VersionSMP
 deletedEventSMPVersion = VersionSMP 10
 
-encryptedBlockSMPVersion :: VersionSMP
-encryptedBlockSMPVersion = VersionSMP 11
-
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 11
+currentClientSMPRelayVersion = VersionSMP 10
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 11
+currentServerSMPRelayVersion = VersionSMP 10
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -407,8 +400,6 @@ data THandleParams v p = THandleParams
     -- | do NOT send session ID in transmission, but include it into signed message
     -- based on protocol version
     implySessId :: Bool,
-    -- -- | additional block encryption
-    encryptBlock :: Maybe TSbChainKeys,
     -- | send multiple transmissions in a single block
     -- based on protocol version
     batch :: Bool
@@ -534,26 +525,16 @@ instance Encoding TransportError where
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
-tPutBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlock}} block = do
-  block_ <- case encryptBlock of
-    Just TSbChainKeys {sndKey} -> do
-      (sk, nonce) <- atomically $ stateTVar sndKey C.sbcHkdf
-      pure $ C.sbEncrypt sk nonce block (blockSize - 16)
-    Nothing -> pure $ C.pad block blockSize
-  bimapM (const $ pure TELargeMsg) (cPut c) block_
+tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
+  bimapM (const $ pure TELargeMsg) (cPut c) $
+    C.pad block blockSize
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlock}} = do
+tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
   msg <- cGet c blockSize
   if B.length msg == blockSize
-    then
-      first (const TELargeMsg) <$>
-        case encryptBlock of
-          Just TSbChainKeys {rcvKey} -> do
-            (sk, nonce) <- atomically $ stateTVar rcvKey C.sbcHkdf
-            pure $ C.sbDecrypt sk nonce msg
-          Nothing -> pure $ C.unPad msg
+    then pure . first (const TELargeMsg) $ C.unPad msg
     else ioe_EOF
 
 -- | Server SMP transport handshake.
@@ -572,7 +553,7 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
           throwE $ TEHandshake IDENTITY
       | otherwise ->
           case compatibleVRange' smpVersionRange v of
-            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k'
+            Just (Compatible vr) -> pure $ smpTHandleServer th v vr pk k'
             Nothing -> throwE TEVersion
 
 -- | Client SMP transport handshake.
@@ -596,36 +577,23 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
             (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
         let v = maxVersion vr
         sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
-        liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_
+        pure $ smpTHandleClient th v vr (snd <$> ks_) ck_
       Nothing -> throwE TEVersion
 
-smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> IO (THandleSMP c 'TServer)
-smpTHandleServer th v vr pk k_ = do
-  let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
-  be <- blockEncryption th v thAuth
-  pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
+smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
+smpTHandleServer th v vr pk k_ =
+  let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
+   in smpTHandle_ th v vr (Just thAuth)
 
-smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> IO (THandleSMP c 'TClient)
-smpTHandleClient th v vr pk_ ck_ = do
+smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
+smpTHandleClient th v vr pk_ ck_ =
   let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
-  be <- blockEncryption th v thAuth
-  -- swap is needed to use client's sndKey as server's rcvKey and vice versa
-  pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be
+   in smpTHandle_ th v vr thAuth
 
-blockEncryption :: THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
-blockEncryption THandle {params = THandleParams {sessionId}} v = \case
-  Just thAuth | v >= encryptedBlockSMPVersion -> case thAuth of
-    THAuthClient {sessSecret} -> be sessSecret
-    THAuthServer {sessSecret'} -> be sessSecret'
-  _ -> pure Nothing
-  where
-    be :: Maybe C.DhSecretX25519 -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
-    be = mapM $ \(C.DhSecretX25519 secret) -> bimapM newTVarIO newTVarIO $ C.sbcInit sessionId secret
-
-smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p
-smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
+smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> THandleSMP c p
+smpTHandle_ th@THandle {params} v vr thAuth =
   -- TODO drop SMP v6: make thAuth non-optional
-  let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion, encryptBlock}
+  let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion}
    in (th :: THandleSMP c p) {params = params'}
 
 {-# INLINE forceCertChain #-}
@@ -657,7 +625,6 @@ smpTHandle c = THandle {connection = c, params}
           thVersion = v,
           thAuth = Nothing,
           implySessId = False,
-          encryptBlock = Nothing,
           batch = True
         }
 

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

@@ -79,7 +79,7 @@ defaultHTTP2ClientConfig =
             logTLSErrors = True,
             clientCredentials = Nothing,
             alpn = Nothing,
-            useSNI = False
+            useSNI = True
           },
       bufferSize = defaultHTTP2BufferSize,
       bodyHeadSize = 16384,

src/Simplex/Messaging/Transport/Server.hs

@@ -132,7 +132,7 @@ runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()
 runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket server =
   E.bracket getSocket (closeServer started clients) $ \sock ->
     forever . E.bracketOnError (safeAccept sock) (close . fst) $ \(conn, _peer) -> do
-      cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId' `seq` (cId', cId')
+      cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId `seq` (cId', cId')
       let closeConn _ = do
             atomically $ modifyTVar' clients $ IM.delete cId
             gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
@@ -168,8 +168,8 @@ newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO mempty
 
 closeServer :: TMVar Bool -> TVar (IntMap (Weak ThreadId)) -> Socket -> IO ()
 closeServer started clients sock = do
-  close sock
   readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)
+  close sock
   void . atomically $ tryPutTMVar started False
 
 startTCPServer :: TMVar Bool -> Maybe HostName -> ServiceName -> IO Socket

src/Simplex/Messaging/Util.hs

@@ -14,13 +14,11 @@ import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.IORef
 import Data.Int (Int64)
+import Data.IORef
 import Data.List (groupBy, sortOn)
 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.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
@@ -35,16 +33,12 @@ raceAny_ = r []
     r as (m : ms) = withAsync m $ \a -> r (a : as) ms
     r as [] = void $ waitAnyCancel as
 
-infixl 4 <$$>, <$$, <$?>
+infixl 4 <$$>, <$?>
 
 (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
 (<$$>) = fmap . fmap
 {-# INLINE (<$$>) #-}
 
-(<$$) :: (Functor f, Functor g) => b -> f (g a) -> f (g b)
-(<$$) = fmap . fmap . const
-{-# INLINE (<$$) #-}
-
 (<$?>) :: MonadFail m => (a -> Either String b) -> m a -> m b
 f <$?> m = either fail pure . f =<< m
 {-# INLINE (<$?>) #-}
@@ -191,7 +185,3 @@ encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
 
 decodeJSON :: FromJSON a => Text -> Maybe a
 decodeJSON = J.decode . LB.fromStrict . encodeUtf8
-
-traverseWithKey_ :: Monad m => (k -> v -> m ()) -> Map k v -> m ()
-traverseWithKey_ f = M.foldrWithKey (\k v -> (f k v >>)) (pure ())
-{-# INLINE traverseWithKey_ #-}

tests/AgentTests.hs

@@ -16,7 +16,6 @@ import AgentTests.FunctionalAPITests (functionalAPITests)
 import AgentTests.MigrationTests (migrationTests)
 import AgentTests.NotificationTests (notificationTests)
 import AgentTests.SQLiteTests (storeTests)
-import AgentTests.ServerChoice (serverChoiceTests)
 import Simplex.Messaging.Transport (ATransport (..))
 import Test.Hspec
 
@@ -27,5 +26,4 @@ agentTests (ATransport t) = do
   describe "Functional API" $ functionalAPITests (ATransport t)
   describe "Notification tests" $ notificationTests (ATransport t)
   describe "SQLite store" storeTests
-  describe "Chosen servers" serverChoiceTests
   describe "Migration tests" migrationTests

tests/AgentTests/FunctionalAPITests.hs

@@ -12,7 +12,6 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -77,7 +76,7 @@ import Data.Word (Word16)
 import qualified Database.SQLite.Simple as SQL
 import GHC.Stack (withFrozenCallStack)
 import SMPAgentClient
-import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
+import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
 import qualified Simplex.Messaging.Agent as A
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
@@ -96,7 +95,6 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..))
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes)
 import Simplex.Messaging.Util (bshow, diffToMicroseconds)
@@ -248,9 +246,7 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe
 createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn)
 
 joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
-joinConnection c userId enableNtfs cReq connInfo subMode = do
-  connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
-  (connId,) <$> A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
+joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId Nothing enableNtfs cReq connInfo PQSupportOn
 
 sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId
 sendMessage c connId msgFlags msgBody = do
@@ -531,7 +527,7 @@ testRatchetMatrix2 t runTest = do
 testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec
 testServerMatrix2 t runTest = do
   it "1 server" $ withSmpServer t $ runTest initAgentServers
-  it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> runTest initAgentServers2
+  it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
 
 testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
 testPQMatrix2 = pqMatrix2_ True
@@ -609,8 +605,7 @@ runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient,
 runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
     (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe
-    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
+    (aliceId, sqSecured') <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
@@ -812,12 +807,13 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
   runRight_ $ do
     (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    sqSecuredJoin <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
-    liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
+    (aliceId', sqSecuredJoin) <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe
+    liftIO $ do
+      aliceId' `shouldBe` aliceId
+      sqSecuredJoin `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` reqPQSupport
-    bobId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
-    sqSecured' <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+    (bobId, sqSecured') <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
     liftIO $ pqSup'' `shouldBe` bPQ
@@ -863,12 +859,13 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
     msgId = subtract baseId . fst
     connectViaContact b pq qInfo = do
       aId <- A.prepareConnectionToJoin b 1 True qInfo pq
-      sqSecuredJoin <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
-      liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
+      (aId', sqSecuredJoin) <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe
+      liftIO $ do
+        aId' `shouldBe` aId
+        sqSecuredJoin `shouldBe` False -- joining via contact address connection
       ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
-      bId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
-      sqSecuredAccept <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+      (bId, sqSecuredAccept) <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
       liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
       ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
       liftIO $ pqSup'' `shouldBe` pq
@@ -909,8 +906,10 @@ testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     (addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
+    (aliceId', sqSecured) <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    liftIO $ do
+      aliceId' `shouldBe` aliceId
+      sqSecured `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
     liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
     rejectContact alice addrConnId invId
@@ -923,8 +922,10 @@ testUpdateConnectionUserId =
     newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
     _ <- changeConnectionUser alice 1 connId newUserId
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    liftIO $ sqSecured' `shouldBe` True
+    (aliceId', sqSecured') <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    liftIO $ do
+      aliceId' `shouldBe` aliceId
+      sqSecured' `shouldBe` True
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` PQSupportOn
     allowConnection alice connId confId "alice's connInfo"
@@ -1042,7 +1043,7 @@ testAllowConnectionClientRestart t = do
   bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2
   withSmpServerStoreLogOn t testPort $ \_ -> do
     (aliceId, bobId, confId) <-
-      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
+      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
         runRight $ do
           (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
           (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
@@ -1064,7 +1065,8 @@ testAllowConnectionClientRestart t = do
     alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
     runRight_ $ subscribeConnection alice2 bobId
     threadDelay 500000
-    withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
+
+    withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
       runRight $ do
         ("", "", UP _ _) <- nGet bob
         get alice2 ##> ("", bobId, CON)
@@ -1282,7 +1284,7 @@ testSkippedMessages :: HasCallStack => ATransport -> IO ()
 testSkippedMessages t = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aliceId, bobId) <- withSmpServerConfigOn t cfg' testPort $ \_ -> do
+  (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ makeConnection alice bob
     runRight_ $ do
       2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
@@ -1310,7 +1312,7 @@ testSkippedMessages t = do
   alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
   bob2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
 
-  withSmpServerConfigOn t cfg' testPort $ \_ -> do
+  withSmpServerStoreLogOn t testPort $ \_ -> do
     runRight_ $ do
       subscribeConnection bob2 aliceId
       subscribeConnection alice2 bobId
@@ -1326,8 +1328,6 @@ testSkippedMessages t = do
       ackMessage bob2 aliceId 4 Nothing
   disposeAgentClient alice2
   disposeAgentClient bob2
-  where
-    cfg' = cfg {msgStoreType = AMSType SMSMemory, storeMsgsFile = Nothing}
 
 testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO ()
 testDeliveryAfterSubscriptionError t = do
@@ -1431,7 +1431,7 @@ withUP a bId p =
       ]
 
 testExpireMessageQuota :: HasCallStack => ATransport -> IO ()
-testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
+testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
   (aId, bId) <- runRight $ do
@@ -1457,7 +1457,7 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJo
   disposeAgentClient a
 
 testExpireManyMessagesQuota :: ATransport -> IO ()
-testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
+testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
   (aId, bId) <- runRight $ do
@@ -1681,45 +1681,34 @@ testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProx
   (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
   liftIO $ sqSecured `shouldBe` False
   Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
-  getMSGNTF alice bobId
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
   getMsg bob aliceId $
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-  getMSGNTF bob aliceId
   liftIO $ threadDelay 1_000000
   getMsg alice bobId $ pure ()
-  inAnyOrder
-    (get alice)
-    [ \case ("", c, CON) -> c == bobId; _ -> False,
-      \case ("", c, MSGNTF {}) -> c == bobId; _ -> False
-    ]
+  get alice ##> ("", bobId, CON)
   getMsg bob aliceId $
     get bob ##> ("", aliceId, CON)
-  getMSGNTF bob aliceId
   -- 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
   ackMessage bob aliceId 4 Nothing
-  getMSGNTF bob aliceId
   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
   ackMessage alice bobId 5 Nothing
-  getMSGNTF alice bobId
 
 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 _] <- lift $ getConnectionMessages c [cId]
-  action
-
-getMSGNTF :: AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-getMSGNTF c cId =
-  get c =##> \case ("", c', MSGNTF {}) -> c' == cId; _ -> False
+  Just _ <- getConnectionMessage c cId
+  r <- action
+  get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False
+  pure r
 
 testOnlyCreatePull :: IO ()
 testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
@@ -1727,13 +1716,11 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
   liftIO $ sqSecured `shouldBe` True
   Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
-  getMSGNTF alice bobId
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
   getMsg bob aliceId $ do
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
-  getMSGNTF bob aliceId
   liftIO $ threadDelay 1_000000
   get alice ##> ("", bobId, CON) -- sent to initiating party after sending confirmation
   -- exchange messages
@@ -1742,13 +1729,11 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   getMsg bob aliceId $
     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
   ackMessage bob aliceId 2 Nothing
-  getMSGNTF bob aliceId
   3 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
   get bob ##> ("", aliceId, SENT 3)
   getMsg alice bobId $
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
   ackMessage alice bobId 3 Nothing
-  getMSGNTF alice bobId
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection = makeConnection_ PQSupportOn True
@@ -1763,8 +1748,10 @@ makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> Agent
 makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
   (bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
-  sqSecured' <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
-  liftIO $ sqSecured' `shouldBe` sqSecured
+  (aliceId', sqSecured') <- A.joinConnection bob bobUserId (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
+  liftIO $ do
+    aliceId' `shouldBe` aliceId
+    sqSecured' `shouldBe` sqSecured
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
   liftIO $ pqSup' `shouldBe` pqSupport
   allowConnection alice bobId confId "alice's connInfo"
@@ -1946,7 +1933,7 @@ testBatchedSubscriptions nCreate nDel t =
     runServers :: ExceptT AgentErrorType IO a -> IO a
     runServers a = do
       withSmpServerStoreLogOn t testPort $ \t1 -> do
-        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 ->
+        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
           runRight a `finally` killThread t2
         killThread t1
         pure res
@@ -2008,7 +1995,7 @@ pattern SentB :: AgentMsgId -> Either AgentErrorType (AgentMsgId, PQEncryption)
 pattern SentB msgId <- Right (msgId, PQEncOn)
 
 receiveMsg :: AgentClient -> ConnId -> AgentMsgId -> MsgBody -> ExceptT AgentErrorType IO ()
-receiveMsg c cId msgId msg = do
+receiveMsg c cId msgId msg  = do
   get c =##> \case ("", cId', Msg' mId' PQEncOn msg') -> cId' == cId && mId' == msgId && msg' == msg; _ -> False
   ackMessage c cId msgId Nothing
 
@@ -2358,7 +2345,7 @@ testJoinConnectionAsyncReplyErrorV8 t = do
         ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
         pure (aId, bId)
       nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
-      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
+      withSmpServerOn t testPort2 $ do
         get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False
         confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
           pGet a >>= \case
@@ -2397,7 +2384,7 @@ testJoinConnectionAsyncReplyError t = do
         ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
         pure (aId, bId)
       nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
-      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
+      withSmpServerOn t testPort2 $ do
         confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
           -- both servers need to be online for connection to progress because of SKEY
           get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False
@@ -2976,7 +2963,7 @@ testDeliveryReceiptsVersion t = do
 
 testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO ()
 testDeliveryReceiptsConcurrent t =
-  withSmpServerConfigOn t cfg {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do
+  withSmpServerConfigOn t cfg {msgQueueQuota = 256} testPort $ \_ -> do
     withAgentClients2 $ \a b -> do
       (aId, bId) <- runRight $ makeConnection a b
       t1 <- liftIO getCurrentTime
@@ -3076,9 +3063,8 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     ("", "", DOWN _ _) <- nGet a
     ("", "", DOWN _ _) <- nGet a
     ("", "", DOWN _ _) <- nGet a
-    -- to avoice race condition
-    nGet a =##> \case ("", "", DOWN _ _) -> True; ("", "", UP _ _) -> True; _ -> False
-    nGet a =##> \case ("", "", UP _ _) -> True; ("", "", DOWN _ _) -> True; _ -> False
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
     ("", "", UP _ _) <- nGet a

tests/AgentTests/NotificationTests.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -50,13 +49,12 @@ import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple.QQ (sql)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
-import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
+import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
@@ -492,11 +490,8 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
     (nonce, message) <- messageNotification apns tkn
     pure (bobId, aliceId, nonce, message)
 
-  Right [NotificationInfo {ntfConnId = cId}] <- runExceptT $ getNotificationConns alice nonce message
-  cId `shouldBe` bobId
-  -- alice client already has subscription for the connection,
-  -- so get fails with CMD PROHIBITED (transformed into Nothing in catch)
-  [Nothing] <- getConnectionMessages alice [cId]
+  -- alice client already has subscription for the connection
+  Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
 
   threadDelay 500000
   suspendAgent alice 0
@@ -505,8 +500,8 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
   putStrLn "before opening the database from another agent"
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
-  withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> do
-    (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId]
+  withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
+    (_, Just SMPMsgMeta {msgFlags = MsgFlags True}) <- getNotificationMessage aliceNtf nonce message
     pure ()
 
   threadDelay 1000000
@@ -790,7 +785,7 @@ testNotificationsSMPRestartBatch n t apns =
     runServers :: ExceptT AgentErrorType IO a -> IO a
     runServers a = do
       withSmpServerStoreLogOn t testPort $ \t1 -> do
-        res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 ->
+        res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
           runRight a `finally` killThread t2
         killThread t1
         pure res

tests/AgentTests/SQLiteTests.hs

@@ -13,7 +13,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
-module AgentTests.SQLiteTests where
+module AgentTests.SQLiteTests (storeTests) where
 
 import AgentTests.EqInstances ()
 import Control.Concurrent.Async (concurrently_)
@@ -141,7 +141,6 @@ storeTests = do
         it "should getNextDeletedSndChunkReplica" testGetNextDeletedSndChunkReplica
         it "should markNtfSubActionNtfFailed_" testMarkNtfSubActionNtfFailed
         it "should markNtfSubActionSMPFailed_" testMarkNtfSubActionSMPFailed
-        it "should markNtfTokenToDeleteFailed_" testMarkNtfTokenToDeleteFailed
   describe "open/close store" $ do
     it "should close and re-open" testCloseReopenStore
     it "should close and re-open encrypted store" testCloseReopenEncryptedStore
@@ -839,8 +838,3 @@ testMarkNtfSubActionSMPFailed :: SQLiteStore -> Expectation
 testMarkNtfSubActionSMPFailed st = do
   withTransaction st $ \db -> do
     markNtfSubActionSMPFailed_ db "abc"
-
-testMarkNtfTokenToDeleteFailed :: SQLiteStore -> Expectation
-testMarkNtfTokenToDeleteFailed st = do
-  withTransaction st $ \db -> do
-    markNtfTokenToDeleteFailed_ db 1

tests/AgentTests/SchemaDump.hs

@@ -4,7 +4,6 @@
 module AgentTests.SchemaDump where
 
 import Control.DeepSeq
-import Control.Exception (bracket_)
 import Control.Monad (unless, void)
 import Data.List (dropWhileEnd)
 import Data.Maybe (fromJust, isJust)
@@ -15,7 +14,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..), MigrationsToRun (..), toDownMigration)
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Util (ifM)
-import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile)
+import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
 import Test.Hspec
 
@@ -25,22 +24,12 @@ testDB = "tests/tmp/test_agent_schema.db"
 appSchema :: FilePath
 appSchema = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql"
 
--- Some indexes found by `.lint fkey-indexes` are not added to schema, explanation:
---
--- - CREATE INDEX 'ratchets_conn_id' ON 'ratchets'('conn_id'); --> connections(conn_id)
---   Primary key is used instead. See for example:
---   EXPLAIN QUERY PLAN DELETE FROM connections;
---   (uses conn_id for ratchets table)
-appLint :: FilePath
-appLint = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_lint.sql"
-
 testSchema :: FilePath
 testSchema = "tests/tmp/test_agent_schema.sql"
 
 schemaDumpTest :: Spec
 schemaDumpTest = do
   it "verify and overwrite schema dump" testVerifySchemaDump
-  it "verify .lint fkey-indexes" testVerifyLintFKeyIndexes
   it "verify schema down migrations" testSchemaMigrations
   it "should NOT create user record for new database" testUsersMigrationNew
   it "should create user record for old database" testUsersMigrationOld
@@ -53,20 +42,6 @@ testVerifySchemaDump = do
   getSchema testDB appSchema `shouldReturn` savedSchema
   removeFile testDB
 
-testVerifyLintFKeyIndexes :: IO ()
-testVerifyLintFKeyIndexes = do
-  savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "")
-  savedLint `deepseq` pure ()
-  void $ createSQLiteStore testDB "" False Migrations.app MCConsole
-  getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint
-  removeFile testDB
-
-withTmpFiles :: IO () -> IO ()
-withTmpFiles =
-  bracket_
-    (createDirectoryIfMissing False "tests/tmp")
-    (removeDirectoryRecursive "tests/tmp")
-
 testSchemaMigrations :: IO ()
 testSchemaMigrations = do
   let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app
@@ -117,13 +92,7 @@ skipComparisonForDownMigrations =
   ]
 
 getSchema :: FilePath -> FilePath -> IO String
-getSchema dbPath schemaPath = do
-  void $ readCreateProcess (shell $ "sqlite3 " <> dbPath <> " '.schema --indent' > " <> schemaPath) ""
+getSchema dpPath schemaPath = do
+  void $ readCreateProcess (shell $ "sqlite3 " <> dpPath <> " '.schema --indent' > " <> schemaPath) ""
   sch <- readFile schemaPath
   sch `deepseq` pure sch
-
-getLintFKeyIndexes :: FilePath -> FilePath -> IO String
-getLintFKeyIndexes dbPath lintPath = do
-  void $ readCreateProcess (shell $ "sqlite3 " <> dbPath <> " '.lint fkey-indexes' > " <> lintPath) ""
-  lint <- readFile lintPath
-  lint `deepseq` pure lint

tests/AgentTests/ServerChoice.hs

@@ -1,85 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module AgentTests.ServerChoice where
-
-import AgentTests.FunctionalAPITests
-import Control.Monad.IO.Class
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.Map.Strict as M
-import SMPAgentClient
-import Simplex.Messaging.Agent (withAgentEnv)
-import Simplex.Messaging.Agent.Client hiding (userServers)
-import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Client (defaultNetworkConfig)
-import Simplex.Messaging.Protocol
-import Test.Hspec
-import Test.QuickCheck
-import XFTPClient (testXFTPServer)
-
-serverChoiceTests :: Spec
-serverChoiceTests = do
-  describe "Server operators" $ do
-    it "should choose server of different operator" $ ioProperty $ testChooseDifferentOperator
-
-operatorSimpleX :: Maybe OperatorId
-operatorSimpleX = Just 1
-
-operator2 :: Maybe OperatorId
-operator2 = Just 2
-
-testOp1Srv1 :: ProtoServerWithAuth 'PSMP
-testOp1Srv1 = "smp://LcJU@test1.simplex.im"
-
-testOp1Srv2 :: ProtoServerWithAuth 'PSMP
-testOp1Srv2 = "smp://LcJU@test2.simplex.im"
-
-testOp2Srv1 :: ProtoServerWithAuth 'PSMP
-testOp2Srv1 = "smp://LcJU@srv1.example.com"
-
-testOp2Srv2 :: ProtoServerWithAuth 'PSMP
-testOp2Srv2 = "smp://LcJU@srv2.example.com"
-
-testSMPServers :: NonEmpty (ServerCfg 'PSMP)
-testSMPServers =
-  [ presetServerCfg True allRoles operatorSimpleX testOp1Srv1,
-    presetServerCfg True allRoles operatorSimpleX testOp1Srv2,
-    presetServerCfg True proxyOnly operator2 testOp2Srv1,
-    presetServerCfg True proxyOnly operator2 testOp2Srv2
-  ]
-
-storageOnly :: ServerRoles
-storageOnly = ServerRoles {storage = True, proxy = False}
-
-proxyOnly :: ServerRoles
-proxyOnly = ServerRoles {storage = False, proxy = True}
-
-initServers :: InitialAgentServers
-initServers =
-  InitialAgentServers
-    { smp = M.fromList [(1, testSMPServers)],
-      ntf = [testNtfServer],
-      xftp = userServers [testXFTPServer],
-      netCfg = defaultNetworkConfig
-    }
-
-testChooseDifferentOperator :: IO ()
-testChooseDifferentOperator = do
-  c <- getSMPAgentClient' 1 agentCfg initServers testDB
-  runRight_ $ do
-    -- chooses the only operator with storage role
-    srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs []
-    liftIO $ srv1 == testOp1Srv1 || srv1 == testOp1Srv2 `shouldBe` True
-    -- chooses another server for storage
-    srv2 <- withAgentEnv c $ getNextServer c 1 storageSrvs [protoServer testOp1Srv1]
-    liftIO $ srv2 `shouldBe` testOp1Srv2
-    -- chooses another operator for proxy
-    srv3 <- withAgentEnv c $ getNextServer c 1 proxySrvs [protoServer srv1]
-    liftIO $ srv3 == testOp2Srv1 || srv3 == testOp2Srv2 `shouldBe` True
-    -- chooses another operator for proxy
-    srv3' <- withAgentEnv c $ getNextServer c 1 proxySrvs [protoServer testOp1Srv1, protoServer testOp1Srv2]
-    liftIO $ srv3' == testOp2Srv1 || srv3' == testOp2Srv2 `shouldBe` True
-    -- chooses any other server
-    srv4 <- withAgentEnv c $ getNextServer c 1 proxySrvs [protoServer testOp1Srv1, protoServer testOp2Srv1]
-    liftIO $ srv4 == testOp1Srv2 || srv4 == testOp2Srv2 `shouldBe` True

tests/CLITests.hs

@@ -88,14 +88,14 @@ smpServerTest storeLog basicAuth = do
   lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223,443"
   lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
   lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
-  lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "on"
+  lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "off"
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
   -- start
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
   r `shouldContain` ["SMP server v" <> simplexMQVersion]
   r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Serving SMP protocol on port 5223 (TLS)...", "Serving SMP protocol on port 443 (TLS)...", "Serving static site on port 443 (TLS)..."]
-  r `shouldContain` ["expiring clients inactive for 21600 seconds every 3600 seconds"]
+  r `shouldContain` ["not expiring inactive clients"]
   r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"])
   -- cert
   let certPath = cfgPath </> "server.crt"

tests/CoreTests/BatchingTests.hs

@@ -30,7 +30,7 @@ batchingTests :: Spec
 batchingTests = do
   describe "batchTransmissions" $ do
     describe "SMP v6 (previous)" $ do
-      it "should batch with 106 subscriptions per batch" testBatchSubscriptionsV6
+      it "should batch with 107 subscriptions per batch" testBatchSubscriptionsV6
       it "should break on message that does not fit" testBatchWithMessageV6
       it "should break on large message" testBatchWithLargeMessageV6
     describe "SMP current" $ do
@@ -39,7 +39,7 @@ batchingTests = do
       it "should break on large message" testBatchWithLargeMessage
   describe "batchTransmissions'" $ do
     describe "SMP v6 (previous)" $ do
-      it "should batch with 106 subscriptions per batch" testClientBatchSubscriptionsV6
+      it "should batch with 107 subscriptions per batch" testClientBatchSubscriptionsV6
       it "should break on message that does not fit" testClientBatchWithMessageV6
       it "should break on large message" testClientBatchWithLargeMessageV6
     describe "SMP current" $ do
@@ -59,7 +59,7 @@ testBatchSubscriptionsV6 = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (38, 106, 106)
+  (n1, n2, n3) `shouldBe` (36, 107, 107)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchSubscriptions :: IO ()
@@ -123,7 +123,7 @@ testBatchWithLargeMessageV6 = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (50, 44, 106)
+  (n1, n2, n3) `shouldBe` (50, 43, 107)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchWithLargeMessage :: IO ()
@@ -154,8 +154,8 @@ testClientBatchSubscriptionsV6 = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (38, 106, 106)
-  (length rs1, length rs2, length rs3) `shouldBe` (38, 106, 106)
+  (n1, n2, n3) `shouldBe` (36, 107, 107)
+  (length rs1, length rs2, length rs3) `shouldBe` (36, 107, 107)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchSubscriptions :: IO ()
@@ -251,16 +251,16 @@ testClientBatchWithLargeMessageV6 = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (50, 44, 106)
-  (length rs1, length rs2, length rs3) `shouldBe` (50, 44, 106)
+  (n1, n2, n3) `shouldBe` (50, 43, 107)
+  (length rs1, length rs2, length rs3) `shouldBe` (50, 43, 107)
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
   let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
   length batches' `shouldBe` 3
   [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
-  (n1', n2') `shouldBe` (94, 106)
-  (length rs1', length rs2') `shouldBe` (94, 106)
+  (n1', n2') `shouldBe` (93, 107)
+  (length rs1', length rs2') `shouldBe` (93, 107)
   all lenOk [s1', s2'] `shouldBe` True
 
 testClientBatchWithLargeMessage :: IO ()
@@ -380,7 +380,6 @@ testTHandleParams v sessionId =
       thServerVRange = supportedServerSMPRelayVRange,
       thAuth = Nothing,
       implySessId = v >= authCmdsSMPVersion,
-      encryptBlock = Nothing,
       batch = True
     }
 

tests/CoreTests/MsgStoreTests.hs

@@ -1,414 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module CoreTests.MsgStoreTests where
-
-import AgentTests.FunctionalAPITests (runRight, runRight_)
-import Control.Concurrent.STM
-import Control.Exception (bracket)
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
-import Crypto.Random (ChaChaDRG)
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Base64.URL as B64
-import Data.Maybe (fromJust)
-import Data.Time.Clock.System (getSystemTime)
-import Simplex.Messaging.Crypto (pattern MaxLenBS)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (EntityId (..), Message (..), RecipientId, SParty (..), noMsgFlags)
-import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages, printMessageStats)
-import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth, readWriteQueueStore)
-import Simplex.Messaging.Server.MsgStore.Journal
-import Simplex.Messaging.Server.MsgStore.STM
-import Simplex.Messaging.Server.MsgStore.Types
-import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue)
-import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
-import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile)
-import System.FilePath ((</>))
-import System.IO (IOMode (..), hClose, withFile)
-import Test.Hspec
-
-msgStoreTests :: Spec
-msgStoreTests = do
-  around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests
-  around (withMsgStore testJournalStoreCfg) $ describe "Journal message store" $ do
-    someMsgStoreTests
-    it "should export and import journal store" testExportImportStore
-    describe "queue state" $ do
-      it "should restore queue state from the last line" testQueueState
-      it "should recover when message is written and state is not" testMessageState
-    describe "missing files" $ do
-      it "should create read file when missing" testReadFileMissing
-      it "should switch to write file when read file missing" testReadFileMissingSwitch
-      it "should create write file when missing" testWriteFileMissing
-      it "should create read file when read and write files are missing" testReadAndWriteFilesMissing
-  where
-    someMsgStoreTests :: STMQueueStore s => SpecWith s
-    someMsgStoreTests = do
-      it "should get queue and store/read messages" testGetQueue
-      it "should not fail on EOF when changing read journal" testChangeReadJournal
-
-withMsgStore :: STMQueueStore s => MsgStoreConfig s -> (s -> IO ()) -> IO ()
-withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore
-
-testSMTStoreConfig :: STMStoreConfig
-testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3}
-
-testJournalStoreCfg :: JournalStoreConfig
-testJournalStoreCfg =
-  JournalStoreConfig
-    { storePath = testStoreMsgsDir,
-      pathParts = journalMsgStoreDepth,
-      quota = 3,
-      maxMsgCount = 4,
-      maxStateLines = 2,
-      stateTailSize = 256,
-      idleInterval = 21600
-    }
-
-mkMessage :: MonadIO m => ByteString -> m Message
-mkMessage body = liftIO $ do
-  g <- C.newRandom
-  msgTs <- getSystemTime
-  msgId <- atomically $ C.randomBytes 24 g
-  pure Message {msgId, msgTs, msgFlags = noMsgFlags, msgBody = C.unsafeMaxLenBS body}
-
-pattern Msg :: ByteString -> Maybe Message
-pattern Msg s <- Just Message {msgBody = MaxLenBS s}
-
-deriving instance Eq MsgQueueState
-
-deriving instance Eq (JournalState t)
-
-deriving instance Eq (SJournalType t)
-
-testNewQueueRec :: TVar ChaChaDRG -> Bool -> IO (RecipientId, QueueRec)
-testNewQueueRec g sndSecure = do
-  rId <- atomically $ EntityId <$> C.randomBytes 24 g
-  senderId <- atomically $ EntityId <$> C.randomBytes 24 g
-  (recipientKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
-  (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
-  let qr =
-        QueueRec
-          { recipientId = rId,
-            recipientKey,
-            rcvDhSecret = C.dh' k pk,
-            senderId,
-            senderKey = Nothing,
-            sndSecure,
-            notifier = Nothing,
-            status = QueueActive,
-            updatedAt = Nothing
-          }
-  pure (rId, qr)
-
-testGetQueue :: STMQueueStore s => s -> IO ()
-testGetQueue ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  runRight_ $ do
-    q <- ExceptT $ addQueue ms qr
-    let write s = writeMsg ms rId q True =<< mkMessage s
-    Just (Message {msgId = mId1}, True) <- write "message 1"
-    Just (Message {msgId = mId2}, False) <- write "message 2"
-    Just (Message {msgId = mId3}, False) <- write "message 3"
-    Msg "message 1" <- tryPeekMsg ms rId q
-    Msg "message 1" <- tryPeekMsg ms rId q
-    Nothing <- tryDelMsg ms rId q mId2
-    Msg "message 1" <- tryDelMsg ms rId q mId1
-    Nothing <- tryDelMsg ms rId q mId1
-    Msg "message 2" <- tryPeekMsg ms rId q
-    Nothing <- tryDelMsg ms rId q mId1
-    (Nothing, Msg "message 2") <- tryDelPeekMsg ms rId q mId1
-    (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms rId q mId2
-    (Nothing, Msg "message 3") <- tryDelPeekMsg ms rId q mId2
-    Msg "message 3" <- tryPeekMsg ms rId q
-    (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3
-    Nothing <- tryDelMsg ms rId q mId2
-    Nothing <- tryDelMsg ms rId q mId3
-    Nothing <- tryPeekMsg ms rId q
-    Just (Message {msgId = mId4}, True) <- write "message 4"
-    Msg "message 4" <- tryPeekMsg ms rId q
-    Just (Message {msgId = mId5}, False) <- write "message 5"
-    (Nothing, Msg "message 4") <- tryDelPeekMsg ms rId q mId3
-    (Msg "message 4", Msg "message 5") <- tryDelPeekMsg ms rId q mId4
-    Just (Message {msgId = mId6}, False) <- write "message 6"
-    Just (Message {msgId = mId7}, False) <- write "message 7"
-    Nothing <- write "message 8"
-    Msg "message 5" <- tryPeekMsg ms rId q
-    (Nothing, Msg "message 5") <- tryDelPeekMsg ms rId q mId4
-    (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms rId q mId5
-    (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms rId q mId6
-    (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms rId q mId7
-    (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms rId q mId8
-    (Nothing, Nothing) <- tryDelPeekMsg ms rId q mId8
-    void $ ExceptT $ deleteQueue ms rId q
-
-testChangeReadJournal :: STMQueueStore s => s -> IO ()
-testChangeReadJournal ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  runRight_ $ do
-    q <- ExceptT $ addQueue ms qr
-    let write s = writeMsg ms rId q True =<< mkMessage s
-    Just (Message {msgId = mId1}, True) <- write "message 1"
-    (Msg "message 1", Nothing) <- tryDelPeekMsg ms rId q mId1
-    Just (Message {msgId = mId2}, True) <- write "message 2"
-    (Msg "message 2", Nothing) <- tryDelPeekMsg ms rId q mId2
-    Just (Message {msgId = mId3}, True) <- write "message 3"
-    (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3
-    Just (Message {msgId = mId4}, True) <- write "message 4"
-    (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q mId4
-    Just (Message {msgId = mId5}, True) <- write "message 5"
-    (Msg "message 5", Nothing) <- tryDelPeekMsg ms rId q mId5
-    void $ ExceptT $ deleteQueue ms rId q
-
-testExportImportStore :: JournalMsgStore -> IO ()
-testExportImportStore ms = do
-  g <- C.newRandom
-  (rId1, qr1) <- testNewQueueRec g True
-  (rId2, qr2) <- testNewQueueRec g True
-  sl <- readWriteQueueStore testStoreLogFile ms
-  runRight_ $ do
-    let write rId q s = writeMsg ms rId q True =<< mkMessage s
-    q1 <- ExceptT $ addQueue ms qr1
-    liftIO $ logCreateQueue sl qr1
-    Just (Message {}, True) <- write rId1 q1 "message 1"
-    Just (Message {}, False) <- write rId1 q1 "message 2"
-    q2 <- ExceptT $ addQueue ms qr2
-    liftIO $ logCreateQueue sl qr2
-    Just (Message {msgId = mId3}, True) <- write rId2 q2 "message 3"
-    Just (Message {msgId = mId4}, False) <- write rId2 q2 "message 4"
-    (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms rId2 q2 mId3
-    (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId2 q2 mId4
-    Just (Message {}, True) <- write rId2 q2 "message 5"
-    Just (Message {}, False) <- write rId2 q2 "message 6"
-    Just (Message {}, False) <- write rId2 q2 "message 7"
-    Nothing <- write rId2 q2 "message 8"
-    pure ()
-  length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
-  length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3
-  exportMessages False ms testStoreMsgsFile False
-  renameFile testStoreMsgsFile (testStoreMsgsFile <> ".copy")
-  closeMsgStore ms
-  closeStoreLog sl
-  exportMessages False ms testStoreMsgsFile False
-  (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy")
-  let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2}
-  ms' <- newMsgStore cfg
-  readWriteQueueStore testStoreLogFile ms' >>= closeStoreLog
-  stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
-    importMessages False ms' testStoreMsgsFile Nothing
-  printMessageStats "Messages" stats
-  length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
-  length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 4 -- state file is backed up, 2 message files
-  exportMessages False ms' testStoreMsgsFile2 False
-  (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak")
-  stmStore <- newMsgStore testSMTStoreConfig
-  readWriteQueueStore testStoreLogFile stmStore >>= closeStoreLog
-  MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
-    importMessages False stmStore testStoreMsgsFile2 Nothing
-  exportMessages False stmStore testStoreMsgsFile False
-  (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak"))
-
-testQueueState :: JournalMsgStore -> IO ()
-testQueueState ms = do
-  g <- C.newRandom
-  rId <- EntityId <$> atomically (C.randomBytes 24 g)
-  let dir = msgQueueDirectory ms rId
-      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
-  createDirectoryIfMissing True dir
-  state <- newMsgQueueState <$> newJournalId (random ms)
-  withFile statePath WriteMode (`appendState` state)
-  length . lines <$> readFile statePath `shouldReturn` 1
-  readQueueState statePath `shouldReturn` state
-  length <$> listDirectory dir `shouldReturn` 1 -- no backup
-
-  let state1 =
-        state
-          { size = 1,
-            readState = (readState state) {msgCount = 1, byteCount = 100},
-            writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100, byteCount = 100}
-          }
-  withFile statePath AppendMode (`appendState` state1)
-  length . lines <$> readFile statePath `shouldReturn` 2
-  readQueueState statePath `shouldReturn` state1
-  length <$> listDirectory dir `shouldReturn` 1 -- no backup
-
-  let state2 =
-        state
-          { size = 2,
-            readState = (readState state) {msgCount = 2, byteCount = 200},
-            writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200, byteCount = 200}
-          }
-  withFile statePath AppendMode (`appendState` state2)
-  length . lines <$> readFile statePath `shouldReturn` 3
-  copyFile statePath (statePath <> ".2")
-  readQueueState statePath `shouldReturn` state2
-  length <$> listDirectory dir `shouldReturn` 3 -- new state, copy + backup
-  length . lines <$> readFile statePath `shouldReturn` 1
-
-  -- corrupt the only line
-  corruptFile statePath
-  newState <- readQueueState statePath
-  newState `shouldBe` newMsgQueueState (journalId $ writeState newState)
-
-  -- corrupt the last line
-  renameFile (statePath <> ".2") statePath
-  removeOtherFiles dir statePath
-  length . lines <$> readFile statePath `shouldReturn` 3
-  corruptFile statePath
-  readQueueState statePath `shouldReturn` state1
-  length <$> listDirectory dir `shouldReturn` 2
-  length . lines <$> readFile statePath `shouldReturn` 1
-  where
-    readQueueState statePath = do
-      (state, h) <- readWriteQueueState ms statePath
-      hClose h
-      pure state
-    corruptFile f = do
-      s <- readFile f
-      removeFile f
-      writeFile f $ take (length s - 4) s
-    removeOtherFiles dir keep = do
-      names <- listDirectory dir
-      forM_ names $ \name ->
-        let f = dir </> name
-         in unless (f == keep) $ removeFile f
-
-testMessageState :: JournalMsgStore -> IO ()
-testMessageState ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  let dir = msgQueueDirectory ms rId
-      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
-      write q s = writeMsg ms rId q True =<< mkMessage s
-
-  mId1 <- runRight $ do
-    q <- ExceptT $ addQueue ms qr
-    Just (Message {msgId = mId1}, True) <- write q "message 1"
-    Just (Message {}, False) <- write q "message 2"
-    liftIO $ closeMsgQueue q
-    pure mId1
-
-  ls <- B.lines <$> B.readFile statePath
-  B.writeFile statePath $ B.unlines $ take (length ls - 1) ls
-
-  runRight_ $ do
-    q <- ExceptT $ getQueue ms SRecipient rId
-    Just (Message {msgId = mId3}, False) <- write q "message 3"
-    (Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms rId q mId1
-    (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3
-    liftIO $ closeMsgQueue q
-
-testReadFileMissing :: JournalMsgStore -> IO ()
-testReadFileMissing ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  let write q s = writeMsg ms rId q True =<< mkMessage s
-  q <- runRight $ do
-    q <- ExceptT $ addQueue ms qr
-    Just (Message {}, True) <- write q "message 1"
-    Msg "message 1" <- tryPeekMsg ms rId q
-    pure q
-
-  mq <- fromJust <$> readTVarIO (msgQueue_' q)
-  MsgQueueState {readState = rs} <- readTVarIO $ state mq
-  closeMsgStore ms
-  let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
-  removeFile path
-
-  runRight_ $ do
-    q' <- ExceptT $ getQueue ms SRecipient rId
-    Nothing <- tryPeekMsg ms rId q'
-    Just (Message {}, True) <- write q' "message 2"
-    Msg "message 2" <- tryPeekMsg ms rId q'
-    pure ()
-
-testReadFileMissingSwitch :: JournalMsgStore -> IO ()
-testReadFileMissingSwitch ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  q <- writeMessages ms rId qr
-
-  mq <- fromJust <$> readTVarIO (msgQueue_' q)
-  MsgQueueState {readState = rs} <- readTVarIO $ state mq
-  closeMsgStore ms
-  let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
-  removeFile path
-
-  runRight_ $ do
-    q' <- ExceptT $ getQueue ms SRecipient rId
-    Just (Message {}, False) <- writeMsg ms rId q' True =<< mkMessage "message 6"
-    Msg "message 5" <- tryPeekMsg ms rId q'
-    pure ()
-
-testWriteFileMissing :: JournalMsgStore -> IO ()
-testWriteFileMissing ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  q <- writeMessages ms rId qr
-
-  mq <- fromJust <$> readTVarIO (msgQueue_' q)
-  MsgQueueState {writeState = ws} <- readTVarIO $ state mq
-  closeMsgStore ms
-  let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws
-  print path
-  removeFile path
-
-  runRight_ $ do
-    q' <- ExceptT $ getQueue ms SRecipient rId
-    Just Message {msgId = mId3} <- tryPeekMsg ms rId q'
-    (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms rId q' mId3
-    Just Message {msgId = mId4} <- tryPeekMsg ms rId q'
-    (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q' mId4
-    Just (Message {}, True) <- writeMsg ms rId q' True =<< mkMessage "message 6"
-    Msg "message 6" <- tryPeekMsg ms rId q'
-    pure ()
-
-testReadAndWriteFilesMissing :: JournalMsgStore -> IO ()
-testReadAndWriteFilesMissing ms = do
-  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
-  q <- writeMessages ms rId qr
-
-  mq <- fromJust <$> readTVarIO (msgQueue_' q)
-  MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq
-  closeMsgStore ms
-  removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs
-  removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws
-
-  runRight_ $ do
-    q' <- ExceptT $ getQueue ms SRecipient rId
-    Nothing <- tryPeekMsg ms rId q'
-    Just (Message {}, True) <- writeMsg ms rId q' True =<< mkMessage "message 6"
-    Msg "message 6" <- tryPeekMsg ms rId q'
-    pure ()
-
-writeMessages :: JournalMsgStore -> RecipientId -> QueueRec -> IO JournalQueue
-writeMessages ms rId qr = runRight $ do
-  q <- ExceptT $ addQueue ms qr
-  let write s = writeMsg ms rId q True =<< mkMessage s
-  Just (Message {msgId = mId1}, True) <- write "message 1"
-  Just (Message {msgId = mId2}, False) <- write "message 2"
-  Just (Message {}, False) <- write "message 3"
-  (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms rId q mId1
-  (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms rId q mId2
-  Just (Message {}, False) <- write "message 4"
-  Just (Message {}, False) <- write "message 5"
-  pure q

tests/CoreTests/RetryIntervalTests.hs

@@ -66,7 +66,7 @@ testRetryIntervalSameMode =
 
 testRetryIntervalSwitchMode :: Spec
 testRetryIntervalSwitchMode =
-  it "should increase elapased time and interval when the mode switches" $ do
+  it "should increase elapased time and interval when the mode stays the same" $ do
     lock <- newEmptyTMVarIO
     intervals <- newTVarIO []
     reportedIntervals <- newTVarIO []

tests/CoreTests/SOCKSSettings.hs

@@ -90,7 +90,7 @@ testSocksMode = do
   where
     transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
     transportSocksCfg cfg host =
-      let TransportClientConfig {socksProxy} = transportClientConfig cfg host False
+      let TransportClientConfig {socksProxy} = transportClientConfig cfg host True
        in socksProxy
 
 testSocksProxyEncoding :: Spec

tests/CoreTests/StoreLogTests.hs

@@ -1,112 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module CoreTests.StoreLogTests where
-
-import Control.Concurrent.STM
-import Control.Monad
-import Crypto.Random (ChaChaDRG)
-import qualified Data.ByteString.Char8 as B
-import Data.Either (partitionEithers)
-import qualified Data.Map.Strict as M
-import SMPClient
-import AgentTests.SQLiteTests
-import CoreTests.MsgStoreTests
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
-import Simplex.Messaging.Server.MsgStore.Journal
-import Simplex.Messaging.Server.MsgStore.Types
-import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.StoreLog
-import Test.Hspec
-
-testNtfCreds :: TVar ChaChaDRG -> IO NtfCreds
-testNtfCreds g = do
-  (notifierKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
-  (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
-  pure
-    NtfCreds
-      { notifierId = EntityId "ijkl",
-        notifierKey,
-        rcvNtfDhSecret = C.dh' k pk
-      }
-
-data StoreLogTestCase r s = SLTC {name :: String, saved :: [r], state :: s, compacted :: [r]}
-
-type SMPStoreLogTestCase = StoreLogTestCase StoreLogRecord (M.Map RecipientId QueueRec)
-
-deriving instance Eq QueueRec
-
-deriving instance Eq StoreLogRecord
-
-deriving instance Eq NtfCreds
-
-storeLogTests :: Spec
-storeLogTests =
-  forM_ [False, True] $ \sndSecure -> do
-    ((rId, qr), ntfCreds, date) <- runIO $ do
-      g <- C.newRandom
-      (,,) <$> testNewQueueRec g sndSecure <*> testNtfCreds g <*> getSystemDate
-    testSMPStoreLog ("SMP server store log, sndSecure = " <> show sndSecure)
-      [ SLTC
-          { name = "create new queue",
-            saved = [CreateQueue qr],
-            compacted = [CreateQueue qr],
-            state = M.fromList [(rId, qr)]
-          },
-        SLTC
-          { name = "secure queue",
-            saved = [CreateQueue qr, SecureQueue rId testPublicAuthKey],
-            compacted = [CreateQueue qr {senderKey = Just testPublicAuthKey}],
-            state = M.fromList [(rId, qr {senderKey = Just testPublicAuthKey})]
-          },          
-        SLTC
-          { name = "create and delete queue",
-            saved = [CreateQueue qr, DeleteQueue rId],
-            compacted = [],
-            state = M.fromList []
-          },
-        SLTC
-          { name = "create queue and add notifier",
-            saved = [CreateQueue qr, AddNotifier rId ntfCreds],
-            compacted = [CreateQueue $ qr {notifier = Just ntfCreds}],
-            state = M.fromList [(rId, qr {notifier = Just ntfCreds})]
-          },
-        SLTC
-          { name = "delete notifier",
-            saved = [CreateQueue qr, AddNotifier rId ntfCreds, DeleteNotifier rId],
-            compacted = [CreateQueue qr],
-            state = M.fromList [(rId, qr)]
-          },
-        SLTC
-          { name = "update time",
-            saved = [CreateQueue qr, UpdateTime rId date],
-            compacted = [CreateQueue qr {updatedAt = Just date}],
-            state = M.fromList [(rId, qr {updatedAt = Just date})]
-          }          
-      ]
-
-testSMPStoreLog :: String -> [SMPStoreLogTestCase] -> Spec
-testSMPStoreLog testSuite tests =
-  describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do
-    l <- openWriteStoreLog testStoreLogFile
-    mapM_ (writeStoreLogRecord l) saved
-    closeStoreLog l
-    replicateM_ 3 $ testReadWrite t
-  where
-    testReadWrite SLTC {compacted, state} = do
-      st <- newMsgStore testJournalStoreCfg
-      l <- readWriteQueueStore testStoreLogFile st
-      storeState st `shouldReturn` state
-      closeStoreLog l
-      ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile
-      compacted' `shouldBe` compacted
-    storeState :: JournalMsgStore -> IO (M.Map RecipientId QueueRec)
-    storeState st = M.mapMaybe id <$> (readTVarIO (queues st) >>= mapM (readTVarIO . queueRec'))

tests/NtfClient.hs

@@ -75,9 +75,6 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 ntfTestStoreLogFile :: FilePath
 ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 
-ntfTestStoreLastNtfsFile :: FilePath
-ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log"
-
 testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
 testNtfClient client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
@@ -90,9 +87,6 @@ ntfServerCfg :: NtfServerConfig
 ntfServerCfg =
   NtfServerConfig
     { transports = [],
-      controlPort = Nothing,
-      controlPortUserAuth = Nothing,
-      controlPortAdminAuth = Nothing,
       subIdBytes = 24,
       regCodeBytes = 32,
       clientQSize = 2,
@@ -107,7 +101,6 @@ ntfServerCfg =
       subsBatchSize = 900,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       storeLogFile = Nothing,
-      storeLastNtfsFile = Nothing,
       ntfCredentials =
         ServerCredentials
           { caCertificateFile = Just "tests/fixtures/ca.crt",
@@ -135,7 +128,7 @@ ntfServerCfgVPrev =
     serverVRange' = serverVRange smpCfg'
 
 withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
-withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, storeLastNtfsFile = Just ntfTestStoreLastNtfsFile, transports = [(ntfTestPort, t, False)]}
+withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t, False)]}
 
 withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)]}

tests/NtfServerTests.hs

@@ -38,6 +38,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
+import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS
 import Simplex.Messaging.Notifications.Transport (THandleNTF)
 import Simplex.Messaging.Parsers (parse, parseAll)
 import Simplex.Messaging.Protocol hiding (notification)
@@ -104,7 +105,7 @@ testNotificationSubscription (ATransport t) =
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
     let tkn = DeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \apns ->
-      smpTest2' t $ \rh sh ->
+      smpTest2 t $ \rh sh ->
         ntfTest t $ \nh -> do
           -- create queue
           (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub
@@ -135,7 +136,7 @@ testNotificationSubscription (ATransport t) =
               Right message = ntfData' .-> "message"
               Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message
               Right pnMsgs1 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
-              PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} = L.last pnMsgs1
+              APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} = L.last pnMsgs1
               Right nMsgMeta = C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta
               Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta
           smpServer `shouldBe` srv
@@ -166,6 +167,6 @@ testNotificationSubscription (ATransport t) =
               Right message3 = ntfData3 .-> "message"
               Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3
               Right pnMsgs2 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
-              PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2
+              APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2
           smpServer3 `shouldBe` srv
           notifierId3 `shouldBe` nId

tests/SMPAgentClient.hs

@@ -38,7 +38,7 @@ testSMPServer :: SMPServer
 testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
 
 testSMPServer2 :: SMPServer
-testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@127.0.0.1:5002"
+testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
 
 testNtfServer :: NtfServer
 testNtfServer = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"
@@ -92,7 +92,7 @@ userServers :: NonEmpty (ProtocolServer p) -> Map UserId (NonEmpty (ServerCfg p)
 userServers = userServers' . L.map noAuthSrv
 
 userServers' :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ServerCfg p))
-userServers' srvs = M.fromList [(1, L.map (presetServerCfg True (ServerRoles True True) (Just 1)) srvs)]
+userServers' srvs = M.fromList [(1, L.map (presetServerCfg True) srvs)]
 
 noAuthSrvCfg :: ProtocolServer p -> ServerCfg p
-noAuthSrvCfg = presetServerCfg True (ServerRoles True True) (Just 1) . noAuthSrv
+noAuthSrvCfg = presetServerCfg True . noAuthSrv

tests/SMPClient.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
@@ -24,7 +23,6 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
-import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..))
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import qualified Simplex.Messaging.Transport.Client as Client
@@ -43,9 +41,6 @@ import Util
 testHost :: NonEmpty TransportHost
 testHost = "localhost"
 
-testHost2 :: NonEmpty TransportHost
-testHost2 = "127.0.0.1"
-
 testPort :: ServiceName
 testPort = "5001"
 
@@ -67,12 +62,6 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 testStoreMsgsFile2 :: FilePath
 testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2"
 
-testStoreMsgsDir :: FilePath
-testStoreMsgsDir = "tests/tmp/messages"
-
-testStoreMsgsDir2 :: FilePath
-testStoreMsgsDir2 = "tests/tmp/messages.2"
-
 testStoreNtfsFile :: FilePath
 testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log"
 
@@ -111,32 +100,22 @@ testSMPClient_ host port vr client = do
       | otherwise = Nothing
 
 cfg :: ServerConfig
-cfg = cfgMS (AMSType SMSJournal)
-
-cfgMS :: AMSType -> ServerConfig
-cfgMS msType =
+cfg =
   ServerConfig
     { transports = [],
       smpHandshakeTimeout = 60000000,
       tbqSize = 1,
-      msgStoreType = msType,
       msgQueueQuota = 4,
-      maxJournalMsgCount = 5,
-      maxJournalStateLines = 2,
       queueIdBytes = 24,
       msgIdBytes = 24,
-      storeLogFile = Just testStoreLogFile,
-      storeMsgsFile = Just $ case msType of
-        AMSType SMSJournal -> testStoreMsgsDir
-        AMSType SMSMemory -> testStoreMsgsFile,
+      storeLogFile = Nothing,
+      storeMsgsFile = Nothing,
       storeNtfsFile = Nothing,
       allowNewQueues = True,
       newQueueBasicAuth = Nothing,
       controlPortUserAuth = Nothing,
       controlPortAdminAuth = Nothing,
       messageExpiration = Just defaultMessageExpiration,
-      expireMessagesOnStart = True,
-      idleQueueInterval = defaultIdleQueueInterval,
       notificationExpiration = defaultNtfExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
@@ -189,17 +168,18 @@ proxyVRangeV8 :: VersionRangeSMP
 proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
 
 withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSJournal)
-
-withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreMsgLogOnMS t msType =
-  withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
+withSmpServerStoreMsgLogOn t =
+  withSmpServerConfigOn
+    t
+    cfg
+      { storeLogFile = Just testStoreLogFile,
+        storeMsgsFile = Just testStoreMsgsFile,
+        storeNtfsFile = Just testStoreNtfsFile,
+        serverStatsBackupFile = Just testServerStatsBackupFile
+      }
 
 withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` AMSType SMSJournal)
-
-withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile}
+withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerConfigOn t cfg' port' =
@@ -232,11 +212,11 @@ withSmpServer t = withSmpServerOn t testPort
 withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a
 withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const
 
-runSmpTest :: forall c a. (HasCallStack, Transport c) => AMSType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
-runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test
+runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
+runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
 
-runSmpTestN :: forall c a. (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
-runSmpTestN msType = runSmpTestNCfg (cfgMS msType) supportedClientSMPRelayVRange
+runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
+runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange
 
 runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
 runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients []
@@ -251,7 +231,7 @@ smpServerTest ::
   TProxy c ->
   (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
   IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg)
-smpServerTest _ t = runSmpTest (AMSType SMSJournal) $ \h -> tPut' h t >> tGet' h
+smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
   where
     tPut' :: THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
     tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
@@ -262,17 +242,14 @@ smpServerTest _ t = runSmpTest (AMSType SMSJournal) $ \h -> tPut' h t >> tGet' h
       [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
-smpTest :: (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
-smpTest _ msType test' = runSmpTest msType test' `shouldReturn` ()
+smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest _ test' = runSmpTest test' `shouldReturn` ()
 
-smpTestN :: (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
-smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` ()
+smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
+smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
 
-smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
-smpTest2' = (`smpTest2` AMSType SMSJournal)
-
-smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
-smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t
+smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest2 = smpTest2Cfg cfg supportedClientSMPRelayVRange
 
 smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
@@ -281,15 +258,15 @@ smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `should
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
-smpTest3 _ msType test' = smpTestN msType 3 _test
+smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest3 _ test' = smpTestN 3 _test
   where
     _test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
     _test [h1, h2, h3] = test' h1 h2 h3
     _test _ = error "expected 3 handles"
 
-smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
-smpTest4 _ msType test' = smpTestN msType 4 _test
+smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest4 _ test' = smpTestN 4 _test
   where
     _test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
     _test [h1, h2, h3, h4] = test' h1 h2 h3 h4

tests/SMPProxyTests.hs

@@ -35,7 +35,7 @@ import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
-import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity)
+import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, maxMessageLength, noMsgFlags)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Transport
@@ -61,9 +61,9 @@ smpProxyTests = do
     xit "batching proxy requests" todo
   describe "deliver message via SMP proxy" $ do
     let srv1 = SMPServer testHost testPort testKeyHash
-        srv2 = SMPServer testHost2 testPort2 testKeyHash
+        srv2 = SMPServer testHost testPort2 testKeyHash
     describe "client API" $ do
-      let maxLen = maxMessageLength encryptedBlockSMPVersion
+      let maxLen = maxMessageLength sendingProxySMPVersion
       describe "one server" $ do
         it "deliver via proxy" . oneServer $ do
           deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2"
@@ -135,15 +135,14 @@ smpProxyTests = do
         let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
         it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
   where
-    oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128, maxJournalMsgCount = 256} testPort . const
+    oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const
     twoServers = twoServers_ proxyCfg proxyCfg
-    twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256}
-    twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256}
-    twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256}
+    twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128}
+    twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128}
+    twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128}
     twoServers_ cfg1 cfg2 runTest =
       withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ ->
-        let cfg2' = cfg2 {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2}
-         in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest
+        withSmpServerConfigOn (transport @TLS) cfg2 testPort2 $ const runTest
 
 deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
 deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg']
@@ -211,8 +210,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
   withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
     withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
       (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-      aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-      sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      (aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -267,8 +265,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
     -- otherwise the CONF messages would get mixed with MSG
     prePair alice bob = do
       (bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-      aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-      sqSecured <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      (aliceId, sqSecured) <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       confId <-
         get alice >>= \case
@@ -316,10 +313,9 @@ agentViaProxyVersionError :: IO ()
 agentViaProxyVersionError =
   withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
     Left (A.BROKER _ (TRANSPORT TEVersion)) <-
-      withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
+      withAgent 2 agentCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
         (_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-        aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-        A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+        A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     pure ()
   where
     servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers srvs}
@@ -338,8 +334,7 @@ agentViaProxyRetryOffline = do
       withServer $ \_ -> do
         (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
           (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-          aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-          sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+          (aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
           liftIO $ sqSecured `shouldBe` True
           ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
           liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -380,11 +375,11 @@ agentViaProxyRetryOffline = do
             ackMessage alice bobId (baseId + 4) Nothing
   where
     withServer :: (ThreadId -> IO a) -> IO a
-    withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort
+    withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort
     withServer2 :: (ThreadId -> IO a) -> IO a
-    withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2
-    withServer_ storeLog storeMsgs storeNtfs =
-      withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs}
+    withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2
+    withServer_ storeLog storeMsgs storeNtfs port =
+      withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs} port
     a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False
     a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False
     aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval}

tests/ServerTests.hs

@@ -16,7 +16,6 @@
 module ServerTests where
 
 import AgentTests.NotificationTests (removeFileIfExists)
-import CoreTests.MsgStoreTests (testJournalStoreCfg)
 import Control.Concurrent (ThreadId, killThread, threadDelay)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, try)
@@ -36,47 +35,40 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server (exportMessages)
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..), readWriteQueueStore)
+import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..))
-import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore)
 import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
-import Simplex.Messaging.Server.StoreLog (closeStoreLog)
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (whenM)
 import Simplex.Messaging.Version (mkVersionRange)
-import System.Directory (doesDirectoryExist, removeDirectoryRecursive, removeFile)
+import System.Directory (removeFile)
 import System.TimeIt (timeItT)
 import System.Timeout
 import Test.HUnit
 import Test.Hspec
 
-serverTests :: SpecWith (ATransport, AMSType)
-serverTests  = do
+serverTests :: ATransport -> Spec
+serverTests t@(ATransport t') = do
+  describe "SMP syntax" $ syntaxTests t
   describe "SMP queues" $ do
-    describe "NEW and KEY commands, SEND messages" testCreateSecure
-    describe "NEW and SKEY commands" $ do
-      testCreateSndSecure
-      testSndSecureProhibited
-    describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete
-    describe "Stress test" stressTest
-    describe "allowNewQueues setting" testAllowNewQueues
+    describe "NEW and KEY commands, SEND messages" $ testCreateSecure t
+    describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
+    describe "Stress test" $ stressTest t
+    describe "allowNewQueues setting" $ testAllowNewQueues t'
   describe "SMP messages" $ do
-    describe "duplex communication over 2 SMP connections" testDuplex
-    describe "switch subscription to another TCP connection" testSwitchSub
-    describe "GET command" testGetCommand
-    describe "GET & SUB commands" testGetSubCommands
-    describe "Exceeding queue quota" testExceedQueueQuota
-  describe "Store log" testWithStoreLog
-  describe "Restore messages" testRestoreMessages
-  describe "Restore messages (old / v2)" testRestoreExpireMessages
-  describe "Timing of AUTH error" testTiming
-  describe "Message notifications" testMessageNotifications
+    describe "duplex communication over 2 SMP connections" $ testDuplex t
+    describe "switch subscription to another TCP connection" $ testSwitchSub t
+    describe "GET command" $ testGetCommand t'
+    describe "GET & SUB commands" $ testGetSubCommands t'
+    describe "Exceeding queue quota" $ testExceedQueueQuota t'
+  describe "Store log" $ testWithStoreLog t
+  describe "Restore messages" $ testRestoreMessages t
+  describe "Restore messages (old / v2)" $ testRestoreExpireMessages t
+  describe "Timing of AUTH error" $ testTiming t
+  describe "Message notifications" $ testMessageNotifications t
   describe "Message expiration" $ do
-    testMsgExpireOnSend
-    testMsgExpireOnInterval
-    testMsgNOTExpireOnInterval
+    testMsgExpireOnSend t'
+    testMsgExpireOnInterval t'
+    testMsgNOTExpireOnInterval t'
 
 pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg
 pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
@@ -136,10 +128,10 @@ decryptMsgV3 dhShared nonce body =
     Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota"
     Left e -> Left e
 
-testCreateSecure :: SpecWith (ATransport, AMSType)
-testCreateSecure =
-  it "should create (NEW) and secure (KEY) queue" $ \(ATransport t, msType) ->
-    smpTest2 t msType $ \r s -> do
+testCreateSecure :: ATransport -> Spec
+testCreateSecure (ATransport t) =
+  it "should create (NEW) and secure (KEY) queue" $
+    smpTest2 t $ \r s -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
@@ -201,72 +193,10 @@ testCreateSecure =
       Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
       pure ()
 
-testCreateSndSecure :: SpecWith (ATransport, AMSType)
-testCreateSndSecure =
-  it "should create (NEW) and secure (SKEY) queue by sender" $ \(ATransport t, msType) ->
-    smpTest2 t msType $ \r s -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
-      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True)
-      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
-      (rId1, NoEntity) #== "creates queue"
-
-      (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
-      Resp "bcda" _ err2 <- sendRecv s (sampleSig, "bcda", sId, SKEY sPub)
-      (err2, ERR AUTH) #== "rejects SKEY with wrong signature"
-
-      Resp "cdab" _ err3 <- signSendRecv s sKey ("cdab", rId, SKEY sPub)
-      (err3, ERR AUTH) #== "rejects SKEY with recipients's ID"
-
-      Resp "dabc" sId2 OK <- signSendRecv s sKey ("dabc", sId, SKEY sPub)
-      (sId2, sId) #== "secures queue, same queue ID in response"
-
-      (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g
-      Resp "abcd" _ err4 <- signSendRecv s sKey ("abcd", sId, SKEY sPub')
-      (err4, ERR AUTH) #== "rejects if secured with different key"
-      Resp "abcd" _ OK <- signSendRecv s sKey ("abcd", sId, SKEY sPub)
-
-      Resp "bcda" _ ok3 <- signSendRecv s sKey ("bcda", sId, _SEND "hello")
-      (ok3, OK) #== "accepts signed SEND"
-
-      Resp "" _ (Msg mId2 msg2) <- tGet1 r
-      (dec mId2 msg2, Right "hello") #== "delivers message"
-
-      Resp "cdab" _ ok5 <- signSendRecv r rKey ("cdab", rId, ACK mId2)
-      (ok5, OK) #== "replies OK when message acknowledged"
-
-      Resp "dabc" _ err5 <- sendRecv s ("", "dabc", sId, _SEND "hello")
-      (err5, ERR AUTH) #== "rejects unsigned SEND"
-
-      let maxAllowedMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion) '-'
-      Resp "bcda" _ OK <- signSendRecv s sKey ("bcda", sId, _SEND maxAllowedMessage)
-      Resp "" _ (Msg mId3 msg3) <- tGet1 r
-      (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
-
-      let biggerMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion + 1) '-'
-      Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
-      pure ()
-
-testSndSecureProhibited :: SpecWith (ATransport, AMSType)
-testSndSecureProhibited =
-  it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $ \(ATransport t, msType) ->
-    smpTest2 t msType $ \r s -> do
-      g <- C.newRandom
-      (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
-      (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
-      (rId1, NoEntity) #== "creates queue"
-
-      (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
-      Resp "dabc" sId2 err <- signSendRecv s sKey ("dabc", sId, SKEY sPub)
-      (sId2, sId) #== "secures queue, same queue ID in response"
-      (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command"
-
-testCreateDelete :: SpecWith (ATransport, AMSType)
-testCreateDelete =
-  it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) ->
-    smpTest2 t msType $ \rh sh -> do
+testCreateDelete :: ATransport -> Spec
+testCreateDelete (ATransport t) =
+  it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
+    smpTest2 t $ \rh sh -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
@@ -334,10 +264,10 @@ testCreateDelete =
       Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB)
       (err10, ERR AUTH) #== "rejects SUB when deleted"
 
-stressTest :: SpecWith (ATransport, AMSType)
-stressTest =
-  it "should create many queues, disconnect and re-connect" $ \(ATransport t, msType) ->
-    smpTest3 t msType $ \h1 h2 h3 -> do
+stressTest :: ATransport -> Spec
+stressTest (ATransport t) =
+  it "should create many queues, disconnect and re-connect" $
+    smpTest3 t $ \h1 h2 h3 -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
@@ -352,10 +282,10 @@ stressTest =
       closeConnection $ connection h2
       subscribeQueues h3
 
-testAllowNewQueues :: SpecWith (ATransport, AMSType)
-testAllowNewQueues =
-  it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c), msType) ->
-    withSmpServerConfigOn (ATransport t) (cfgMS msType) {allowNewQueues = False} testPort $ \_ ->
+testAllowNewQueues :: forall c. Transport c => TProxy c -> Spec
+testAllowNewQueues t =
+  it "should prohibit creating new queues with allowNewQueues = False" $ do
+    withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ ->
       testSMPClient @c $ \h -> do
         g <- C.newRandom
         (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
@@ -363,10 +293,10 @@ testAllowNewQueues =
         Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
         pure ()
 
-testDuplex :: SpecWith (ATransport, AMSType)
-testDuplex =
-  it "should create 2 simplex connections and exchange messages" $ \(ATransport t, msType) ->
-    smpTest2 t msType $ \alice bob -> do
+testDuplex :: ATransport -> Spec
+testDuplex (ATransport t) =
+  it "should create 2 simplex connections and exchange messages" $
+    smpTest2 t $ \alice bob -> do
       g <- C.newRandom
       (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
@@ -418,10 +348,10 @@ testDuplex =
       Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
       (bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
 
-testSwitchSub :: SpecWith (ATransport, AMSType)
-testSwitchSub =
-  it "should create simplex connections and switch subscription to another TCP connection" $ \(ATransport t, msType) ->
-    smpTest3 t msType $ \rh1 rh2 sh -> do
+testSwitchSub :: ATransport -> Spec
+testSwitchSub (ATransport t) =
+  it "should create simplex connections and switch subscription to another TCP connection" $
+    smpTest3 t $ \rh1 rh2 sh -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
@@ -463,12 +393,12 @@ testSwitchSub =
         Nothing -> return ()
         Just _ -> error "nothing else is delivered to the 1st TCP connection"
 
-testGetCommand :: SpecWith (ATransport, AMSType)
-testGetCommand =
-  it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c), msType) -> do
+testGetCommand :: forall c. Transport c => TProxy c -> Spec
+testGetCommand t =
+  it "should retrieve messages from the queue using GET command" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    smpTest t msType $ \sh -> do
+    smpTest t $ \sh -> do
       queue <- newEmptyTMVarIO
       testSMPClient @c $ \rh ->
         atomically . putTMVar queue =<< createAndSecureQueue rh sPub
@@ -482,12 +412,12 @@ testGetCommand =
         Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET)
         pure ()
 
-testGetSubCommands :: SpecWith (ATransport, AMSType)
-testGetSubCommands =
-  it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ \(ATransport t, msType) -> do
+testGetSubCommands :: forall c. Transport c => TProxy c -> Spec
+testGetSubCommands t =
+  it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    smpTest3 t msType $ \rh1 rh2 sh -> do
+    smpTest3 t $ \rh1 rh2 sh -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub
       let dec = decryptMsgV3 dhShared
       Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1")
@@ -532,10 +462,10 @@ testGetSubCommands =
       Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET)
       pure ()
 
-testExceedQueueQuota :: SpecWith (ATransport, AMSType)
-testExceedQueueQuota =
-  it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c), msType) -> do
-    withSmpServerConfigOn (ATransport t) (cfgMS msType) {msgQueueQuota = 2} testPort $ \_ ->
+testExceedQueueQuota :: forall c. Transport c => TProxy c -> Spec
+testExceedQueueQuota t =
+  it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ do
+    withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ ->
       testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do
         g <- C.newRandom
         (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -559,9 +489,9 @@ testExceedQueueQuota =
         Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4)
         pure ()
 
-testWithStoreLog :: SpecWith (ATransport, AMSType)
-testWithStoreLog =
-  it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do
+testWithStoreLog :: ATransport -> Spec
+testWithStoreLog at@(ATransport t) =
+  it "should store simplex queues to log and restore them after server restart" $ do
     g <- C.newRandom
     (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -573,7 +503,7 @@ testWithStoreLog =
     senderId2 <- newTVarIO NoEntity
     notifierId <- newTVarIO NoEntity
 
-    withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do
+    withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
       (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
       Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey)
@@ -606,14 +536,13 @@ testWithStoreLog =
 
     logSize testStoreLogFile `shouldReturn` 6
 
-    let cfg' = (cfgMS msType) {msgStoreType = AMSType SMSMemory, storeLogFile = Nothing, storeMsgsFile = Nothing}
-    withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do
+    withSmpServerThreadOn at testPort . runTest t $ \h -> do
       sId1 <- readTVarIO senderId1
       -- fails if store log is disabled
       Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello")
       pure ()
 
-    withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do
+    withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       -- this queue is restored
       rId1 <- readTVarIO recipientId1
       Just rKey1 <- readTVarIO recipientKey1
@@ -647,12 +576,11 @@ logSize f =
     Right l -> pure l
     Left (_ :: SomeException) -> logSize f
 
-testRestoreMessages :: SpecWith (ATransport, AMSType)
-testRestoreMessages =
-  it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do
+testRestoreMessages :: ATransport -> Spec
+testRestoreMessages at@(ATransport t) =
+  it "should store messages on exit and restore on start" $ do
     removeFileIfExists testStoreLogFile
     removeFileIfExists testStoreMsgsFile
-    whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
     removeFileIfExists testServerStatsBackupFile
 
     g <- C.newRandom
@@ -662,7 +590,7 @@ testRestoreMessages =
     dhShared <- newTVarIO Nothing
     senderId <- newTVarIO NoEntity
 
-    withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       runClient t $ \h1 -> do
         (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
         atomically $ do
@@ -686,12 +614,12 @@ testRestoreMessages =
     rId <- readTVarIO recipientId
 
     logSize testStoreLogFile `shouldReturn` 2
-    -- logSize testStoreMsgsFile `shouldReturn` 5
+    logSize testStoreMsgsFile `shouldReturn` 5
     logSize testServerStatsBackupFile `shouldReturn` 74
     Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats1 [rId] 5 1
 
-    withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
       let dec = decryptMsgV3 dh
@@ -704,12 +632,12 @@ testRestoreMessages =
 
     logSize testStoreLogFile `shouldReturn` 1
     -- the last message is not removed because it was not ACK'd
-    -- logSize testStoreMsgsFile `shouldReturn` 3
+    logSize testStoreMsgsFile `shouldReturn` 3
     logSize testServerStatsBackupFile `shouldReturn` 74
     Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats2 [rId] 5 3
 
-    withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
       let dec = decryptMsgV3 dh
@@ -721,15 +649,15 @@ testRestoreMessages =
       (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered"
       Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6)
       pure ()
+
     logSize testStoreLogFile `shouldReturn` 1
-    -- logSize testStoreMsgsFile `shouldReturn` 0
+    logSize testStoreMsgsFile `shouldReturn` 0
     logSize testServerStatsBackupFile `shouldReturn` 74
     Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats3 [rId] 5 5
 
     removeFile testStoreLogFile
-    removeFileIfExists testStoreMsgsFile
-    whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
+    removeFile testStoreMsgsFile
     removeFile testServerStatsBackupFile
   where
     runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
@@ -756,9 +684,9 @@ checkStats s qs sent received = do
   IS.toList _week `shouldBe` map (hash . unEntityId) qs
   IS.toList _month `shouldBe` map (hash . unEntityId) qs
 
-testRestoreExpireMessages :: SpecWith (ATransport, AMSType)
-testRestoreExpireMessages =
-  it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do
+testRestoreExpireMessages :: ATransport -> Spec
+testRestoreExpireMessages at@(ATransport t) =
+  it "should store messages on exit and restore on start" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     recipientId <- newTVarIO NoEntity
@@ -766,7 +694,7 @@ testRestoreExpireMessages =
     dhShared <- newTVarIO Nothing
     senderId <- newTVarIO NoEntity
 
-    withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do
+    withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       runClient t $ \h1 -> do
         (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
         atomically $ do
@@ -783,40 +711,29 @@ testRestoreExpireMessages =
       pure ()
 
     logSize testStoreLogFile `shouldReturn` 2
-    exportStoreMessages msType
     msgs <- B.readFile testStoreMsgsFile
     length (B.lines msgs) `shouldBe` 4
 
     let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200}
-        cfg1 = (cfgMS msType) {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile}
+        cfg1 = cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile}
     withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure ()
 
     logSize testStoreLogFile `shouldReturn` 1
-    exportStoreMessages msType
     msgs' <- B.readFile testStoreMsgsFile
     msgs' `shouldBe` msgs
 
     let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200}
-        cfg2 = (cfgMS msType) {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile}
+        cfg2 = cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile}
     withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure ()
 
     logSize testStoreLogFile `shouldReturn` 1
     -- two messages expired
-    exportStoreMessages msType
     msgs'' <- B.readFile testStoreMsgsFile
     length (B.lines msgs'') `shouldBe` 2
     B.lines msgs'' `shouldBe` drop 2 (B.lines msgs)
     Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile
     _msgExpired `shouldBe` 2
   where
-    exportStoreMessages :: AMSType -> IO ()
-    exportStoreMessages = \case
-      AMSType SMSJournal -> do
-        ms <- newMsgStore testJournalStoreCfg {quota = 4}
-        readWriteQueueStore testStoreLogFile ms >>= closeStoreLog
-        removeFileIfExists testStoreMsgsFile
-        exportMessages False ms testStoreMsgsFile False
-      AMSType SMSMemory -> pure ()
     runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
       testSMPClient test' `shouldReturn` ()
@@ -836,12 +753,12 @@ createAndSecureQueue h sPub = do
   (rId', rId) #== "same queue ID"
   pure (sId, rId, rKey, dhShared)
 
-testTiming :: SpecWith (ATransport, AMSType)
-testTiming =
+testTiming :: ATransport -> Spec
+testTiming (ATransport t) =
   describe "should have similar time for auth error, whether queue exists or not, for all key types" $
     forM_ timingTests $ \tst ->
-      it (testName tst) $ \(ATransport t, msType) ->
-        smpTest2Cfg (cfgMS msType) (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh ->
+      it (testName tst) $
+        smpTest2Cfg cfg (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh ->
           testSameTiming rh sh tst
   where
     testName :: (C.AuthAlg, C.AuthAlg, Int) -> String
@@ -906,13 +823,13 @@ testTiming =
             ]
           ok `shouldBe` True
 
-testMessageNotifications :: SpecWith (ATransport, AMSType)
-testMessageNotifications =
-  it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do
+testMessageNotifications :: ATransport -> Spec
+testMessageNotifications (ATransport t) =
+  it "should create simplex connection, subscribe notifier and deliver notifications" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    smpTest4 t msType $ \rh sh nh1 nh2 -> do
+    smpTest4 t $ \rh sh nh1 nh2 -> do
       (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
       let dec = decryptMsgV3 dhShared
       (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
@@ -946,12 +863,12 @@ testMessageNotifications =
         Nothing -> pure ()
         Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
 
-testMsgExpireOnSend :: SpecWith (ATransport, AMSType)
-testMsgExpireOnSend =
-  it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c), msType) -> do
+testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec
+testMsgExpireOnSend t =
+  it "should expire messages that are not received before messageTTL on SEND" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
+    let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
@@ -966,13 +883,13 @@ testMsgExpireOnSend =
             Nothing -> return ()
             Just _ -> error "nothing else should be delivered"
 
-testMsgExpireOnInterval :: SpecWith (ATransport, AMSType)
-testMsgExpireOnInterval =
+testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
+testMsgExpireOnInterval t =
   -- fails on ubuntu
-  xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c), msType) -> do
+  xit' "should expire messages that are not received before messageTTL after expiry interval" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
+    let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
@@ -986,12 +903,12 @@ testMsgExpireOnInterval =
             Nothing -> return ()
             Just _ -> error "nothing should be delivered"
 
-testMsgNOTExpireOnInterval :: SpecWith (ATransport, AMSType)
-testMsgNOTExpireOnInterval =
-  it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ \(ATransport (t :: TProxy c), msType) -> do
+testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
+testMsgNOTExpireOnInterval t =
+  it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
+    let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
@@ -1024,8 +941,8 @@ instance Eq C.ASignature where
     Just Refl -> s == s'
     _ -> False
 
-serverSyntaxTests :: ATransport -> Spec
-serverSyntaxTests (ATransport t) = do
+syntaxTests :: ATransport -> Spec
+syntaxTests (ATransport t) = do
   it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
   describe "NEW" $ do
     it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)

tests/Test.hs

@@ -11,10 +11,8 @@ import CoreTests.BatchingTests
 import CoreTests.CryptoFileTests
 import CoreTests.CryptoTests
 import CoreTests.EncodingTests
-import CoreTests.MsgStoreTests
 import CoreTests.RetryIntervalTests
 import CoreTests.SOCKSSettings
-import CoreTests.StoreLogTests
 import CoreTests.TRcvQueuesTests
 import CoreTests.UtilTests
 import CoreTests.VersionRangeTests
@@ -25,9 +23,8 @@ import NtfServerTests (ntfServerTests)
 import RemoteControl (remoteControlTests)
 import SMPProxyTests (smpProxyTests)
 import ServerTests
-import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..))
 import Simplex.Messaging.Transport (TLS, Transport (..))
--- import Simplex.Messaging.Transport.WebSockets (WS)
+import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
@@ -55,20 +52,12 @@ main = do
           describe "Version range" versionRangeTests
           describe "Encryption tests" cryptoTests
           describe "Encrypted files tests" cryptoFileTests
-          describe "Message store tests" msgStoreTests
           describe "Retry interval tests" retryIntervalTests
           describe "SOCKS settings tests" socksSettingsTests
-          describe "Store log tests" storeLogTests
           describe "TRcvQueues tests" tRcvQueuesTests
           describe "Util tests" utilTests
-        describe "SMP server via TLS, jornal message store" $ do
-          describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
-          before (pure (transport @TLS, AMSType SMSJournal)) serverTests
-        describe "SMP server via TLS, memory message store" $
-          before (pure (transport @TLS, AMSType SMSMemory)) serverTests
-        -- xdescribe "SMP server via WebSockets" $ do
-        --   describe "SMP syntax" $ serverSyntaxTests (transport @WS)
-        --   before (pure (transport @WS, AMSType SMSJournal)) serverTests
+        describe "SMP server via TLS" $ serverTests (transport @TLS)
+        describe "SMP server via WebSockets" $ serverTests (transport @WS)
         describe "Notifications server" $ ntfServerTests (transport @TLS)
         describe "SMP client agent" $ agentTests (transport @TLS)
         describe "SMP proxy" smpProxyTests

tests/XFTPAgent.hs

@@ -24,8 +24,8 @@ import SMPClient (xit'')
 import Simplex.FileTransfer.Client (XFTPClientConfig (..))
 import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
-import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH), supportedXFTPhandshakes)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), supportedXFTPhandshakes)
+import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
 import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))

tests/XFTPClient.hs

@@ -14,8 +14,8 @@ import SMPClient (serverBracket)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Server (runXFTPServerBlocking)
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration)
-import Simplex.FileTransfer.Transport (supportedFileServerVRange, supportedXFTPhandshakes)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes)
+import Simplex.FileTransfer.Transport (supportedFileServerVRange)
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Transport (ALPN)
 import Simplex.Messaging.Transport.Server