Merge remote-tracking branch 'origin/master' into ab/tls-2

Merge branch 'master' into ab/tls-2
2026-08-30 18:28:23 +00:00 · 2024-10-27 16:05:24 +02:00 · 2024-08-17 23:06:27 +01:00 · 2024-07-17 13:09:43 +01:00 · 2024-07-09 22:46:52 +01:00 · 2024-06-24 15:21:57 +01:00
38 changed files with 1395 additions and 1603 deletions
@@ -12,7 +12,7 @@ packages: .
   -- coverage: False
   -- library-coverage: False

-index-state: 2023-12-12T00:00:00Z
+index-state: 2024-06-01T00:00:00Z

 package cryptostore
    flags: +use_crypton
@@ -0,0 +1,224 @@
+name: simplexmq
+version: 6.1.3.0
+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 >= 2.0.6 && < 2.1
+  - 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
+      # - -fhpc
+
+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
@@ -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
@@ -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.
@@ -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.3.0
 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
@@ -148,13 +154,36 @@ library
      Simplex.Messaging.Encoding.String
      Simplex.Messaging.Notifications.Client
      Simplex.Messaging.Notifications.Protocol
+      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
      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.Journal
+      Simplex.Messaging.Server.MsgStore.STM
+      Simplex.Messaging.Server.MsgStore.Types
+      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 +206,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 +222,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 +242,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
@@ -264,7 +265,7 @@ library
    , temporary ==1.3.*
    , time ==1.12.*
    , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=2.0.6 && <2.1
    , transformers ==0.6.*
    , unliftio ==0.2.*
    , unliftio-core ==0.2.*
@@ -274,37 +275,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 >=2.0.6 && <2.1
+    , 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 +371,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 >=2.0.6 && <2.1
+    , 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 >=2.0.6 && <2.1
+    , 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 >=2.0.6 && <2.1
+    , 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,7 +610,6 @@ test-suite simplexmq-test
      AgentTests.MigrationTests
      AgentTests.NotificationTests
      AgentTests.SchemaDump
-      AgentTests.ServerChoice
      AgentTests.SQLiteTests
      CLITests
      CoreTests.BatchingTests
@@ -407,53 +642,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 >=2.0.6 && <2.1
+    , 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
@@ -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
@@ -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 (..),
@@ -181,7 +181,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]
@@ -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 (..))
@@ -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
@@ -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,
@@ -120,8 +120,6 @@ module Simplex.Messaging.Agent
    debugAgentLocks,
    getAgentSubscriptions,
    logConnection,
-    -- for tests
-    withAgentEnv,
  )
 where

@@ -817,13 +815,11 @@ newConnToAccept c connId enableNtfs invId pqSup = do

 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]
+  srv <- case cReq of
+    CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
+      getNextServer c userId [qServer q]
+    _ -> getSMPServer c userId
  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 =
@@ -1198,13 +1194,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
+          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 +1649,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'
@@ -2161,13 +2158,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
@@ -149,6 +149,7 @@ module Simplex.Messaging.Agent.Client
    userServers,
    pickServer,
    getNextServer,
+    withUserServers,
    withNextSrv,
    incSMPServerStat,
    incSMPServerStat',
@@ -192,12 +193,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 +264,7 @@ import Simplex.Messaging.Protocol
    VersionSMPC,
    XFTPServer,
    XFTPServerWithAuth,
+    sameSrvAddr',
    pattern NoEntity,
  )
 import qualified Simplex.Messaging.Protocol as SMP
@@ -617,7 +619,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 +1074,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 +1093,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 +1388,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
@@ -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 ()
@@ -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,
@@ -332,9 +313,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 +335,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)
@@ -108,7 +108,6 @@ module Simplex.Messaging.Agent.Protocol
    ConnReqUriData (..),
    CRClientData,
    ServiceScheme,
-    sameConnReqContact,
    simplexChat,
    connReqUriP',
    AgentErrorType (..),
@@ -1264,12 +1263,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,
@@ -115,12 +115,10 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do

    stopServer :: M ()
    stopServer = do
-      logInfo "Saving server state..."
      saveServer
      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
@@ -538,13 +538,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)
@@ -43,7 +43,7 @@ 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 (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
@@ -79,9 +79,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 +120,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

@@ -161,24 +155,23 @@ defaultMaxJournalMsgCount = 256
 defaultMsgQueueQuota :: Int
 defaultMsgQueueQuota = 128

-defaultStateTailSize :: Int
-defaultStateTailSize = 512
-
 data Env = Env
  { config :: ServerConfig,
    serverActive :: TVar Bool,
    serverInfo :: ServerInformation,
    server :: Server,
    serverIdentity :: KeyHash,
+    queueStore :: QueueStore,
    msgStore :: AMsgStore,
    ntfStore :: NtfStore,
    random :: TVar ChaChaDRG,
+    storeLog :: Maybe (StoreLog 'WriteMode),
    tlsServerCreds :: T.Credential,
    httpServerCreds :: Maybe T.Credential,
    serverStats :: ServerStats,
    sockets :: TVar [(ServiceName, SocketState)],
    clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap (Maybe AClient)),
+    clients :: TVar (IntMap (Maybe Client)),
    proxyAgent :: ProxyAgent -- senders served on this proxy
  }

@@ -186,9 +179,9 @@ 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 AMsgStore = forall s. MsgStoreClass (MsgStore s) => AMS (SMSType s) (MsgStore s)

-data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s))
+data AMsgQueue = forall s. MsgStoreClass (MsgStore s) => AMQ (SMSType s) (MsgQueue (MsgStore s))

 data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s))

@@ -200,11 +193,11 @@ 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 +209,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,
@@ -261,8 +249,8 @@ newServer = do
  savingLock <- createLockIO
  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,22 +276,23 @@ 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
+newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
  serverActive <- newTVarIO True
  server <- newServer
-  msgStore@(AMS _ store) <- case msgStoreType of
+  queueStore <- newQueueStore
+  msgStore <- 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}
+        let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines}
         in AMS SMSJournal <$> newMsgStore cfg
      Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure
  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
+      readWriteQueueStore f queueStore
  tlsServerCreds <- getCredentials "SMP" smpCredentials
  httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
  mapM_ checkHTTPSCredentials httpServerCreds
@@ -314,7 +303,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt
  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 {serverActive, config, serverInfo, server, serverIdentity, queueStore, msgStore, ntfStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
  where
    getCredentials protocol creds = do
      files <- missingCreds
@@ -358,6 +347,3 @@ 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
@@ -46,11 +46,10 @@ 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.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)
@@ -86,14 +85,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
    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
@@ -108,7 +99,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                ("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
@@ -126,7 +116,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                ("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
@@ -148,7 +137,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
      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}
+    newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines}
    iniFile = combine cfgPath "smp-server.ini"
    serverVersion = "SMP server v" <> simplexMQVersion
    defaultServerPorts = "5223,443"
@@ -249,7 +238,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
                <> "# Messages and notifications expiration periods.\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")
@@ -415,8 +403,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
@@ -12,14 +12,13 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TupleSections #-}

 module Simplex.Messaging.Server.MsgStore.Journal
-  ( JournalMsgStore (queues, senders, notifiers, random),
-    JournalQueue,
-    JournalMsgQueue (queue, state),
+  ( JournalMsgStore (msgQueues, random),
+    JournalMsgQueue (queue),
    JMQueue (queueDirectory, statePath),
    JournalStoreConfig (..),
+    getQueueMessages,
    closeMsgQueue,
    closeMsgQueueHandles,
    -- below are exported for tests
@@ -33,7 +32,6 @@ module Simplex.Messaging.Server.MsgStore.Journal
    newJournalId,
    appendState,
    queueLogFileName,
-    journalFilePath,
    logFileExt,
  )
 where
@@ -44,28 +42,27 @@ import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Trans.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bitraversable (bimapM)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (intercalate)
-import Data.Maybe (catMaybes, fromMaybe, isNothing)
+import qualified Data.Map.Strict as M
+import Data.Maybe (catMaybes, fromMaybe)
 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.Protocol (ErrorType (..), Message (..), RecipientId)
 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 Simplex.Messaging.Util (ifM, tshow, ($>>=))
 import System.Directory
 import System.Exit
 import System.FilePath ((</>))
@@ -77,10 +74,7 @@ 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))
+    msgQueues :: TMap RecipientId JournalMsgQueue
  }

 data JournalStoreConfig = JournalStoreConfig
@@ -91,26 +85,12 @@ data JournalStoreConfig = JournalStoreConfig
    -- 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)
+    maxStateLines :: Int
  }

 data JMQueue = JMQueue
  { queueDirectory :: FilePath,
+    queueLock :: Lock,
    statePath :: FilePath
  }

@@ -218,23 +198,8 @@ 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

@@ -242,51 +207,39 @@ instance MsgStoreClass JournalMsgStore where
  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}
+    msgQueues <- TM.emptyIO
+    pure JournalMsgStore {config, random, queueLocks, msgQueues}

-  setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO ()
-  setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
+  closeMsgStore st = atomically (swapTVar (msgQueues st) M.empty) >>= mapM_ closeMsgQueueHandles

-  closeMsgStore st = do
-    readTVarIO (storeLog st) >>= mapM_ closeStoreLog
-    readTVarIO (queues st) >>= mapM_ closeMsgQueue
-
-  activeMsgQueues = queues
+  activeMsgQueues = msgQueues
  {-# 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 :: forall a. Monoid a => Bool -> JournalMsgStore -> (RecipientId -> JournalMsgQueue -> 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)
+        closeMsgStore ms
+        lock <- createLockIO -- the same lock is used for all queues
+        (!count, !res) <- foldQueues 0 (processQueue lock) (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
+      processQueue :: Lock -> (Int, a) -> (String, FilePath) -> IO (Int, a)
+      processQueue queueLock (!i, !r) (queueId, dir) = do
        when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout
+        let statePath = msgQueueStatePath dir queueId
+        q <- openMsgQueue ms JMQueue {queueDirectory = dir, queueLock, statePath}
        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
+          Right rId -> action rId q
          Left e -> do
-            logError $ "STORE: processQueue, message queue directory " <> T.pack dir <> " is invalid, " <> tshow e
+            putStrLn ("Error: message queue directory " <> dir <> " is invalid: " <> e)
            exitFailure
+        closeMsgQueueHandles q
        pure (i + 1, r <> r')
      progress i = "Processed: " <> show i <> " queues"
      foldQueues depth f acc (queueId, path) = do
@@ -303,28 +256,25 @@ instance MsgStoreClass JournalMsgStore where
              (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping"))

  logQueueStates :: JournalMsgStore -> IO ()
-  logQueueStates ms = withActiveMsgQueues ms $ \_ -> unStoreIO . logQueueState
+  logQueueStates ms = withActiveMsgQueues ms $ \_ -> logQueueState

-  logQueueState :: JournalQueue -> StoreIO ()
-  logQueueState q =
-    StoreIO . void $
-      readTVarIO (msgQueue_ q)
-        $>>= \mq -> readTVarIO (handles mq)
-        $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ())
+  logQueueState :: JournalMsgQueue -> IO ()
+  logQueueState q = 
+    readTVarIO (handles q)
+      >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= appendState (stateHandle hs))

-  queueRec' = queueRec
-  {-# INLINE queueRec' #-}
-
-  getMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO JournalMsgQueue
-  getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} =
-    StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure
+  getMsgQueue :: JournalMsgStore -> RecipientId -> ExceptT ErrorType IO JournalMsgQueue
+  getMsgQueue ms@JournalMsgStore {queueLocks, msgQueues, random} rId =
+    tryStore "getMsgQueue" (B.unpack $ strEncode rId) $ withLockMap queueLocks rId "getMsgQueue" $
+      TM.lookupIO rId msgQueues >>= maybe newQ pure
    where
      newQ = do
+        queueLock <- atomically $ getMapLock queueLocks rId
        let dir = msgQueueDirectory ms rId
            statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
-            queue = JMQueue {queueDirectory = dir, statePath}
+            queue = JMQueue {queueDirectory = dir, queueLock, statePath}
        q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue)
-        atomically $ writeTVar msgQueue_ $ Just q
+        atomically $ TM.insert rId q msgQueues
        pure q
        where
          createQ :: JMQueue -> IO JournalMsgQueue
@@ -332,62 +282,23 @@ instance MsgStoreClass JournalMsgStore where
            -- 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
+            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
+  delMsgQueue :: JournalMsgStore -> RecipientId -> IO ()
+  delMsgQueue ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do
+    closeMsgQueue ms rId
+    removeQueueDirectory ms rId

-  -- 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)
+  delMsgQueueSize :: JournalMsgStore -> RecipientId -> IO Int
+  delMsgQueueSize ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do
+    st_ <-
+      atomically (TM.lookupDelete rId (msgQueues ms))
+        >>= mapM (\q -> closeMsgQueueHandles q >> readTVarIO (state q))
+    removeQueueDirectory ms rId
+    pure $ maybe (-1) size st_

-  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 [])
+  getQueueMessages :: Bool -> JournalMsgQueue -> IO [Message]
+  getQueueMessages drainMsgs q = run []
    where
      run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
      getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg
@@ -397,24 +308,22 @@ instance MsgStoreClass JournalMsgStore where
            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
+  writeMsg :: JournalMsgStore -> JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  writeMsg ms q@JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} logState msg =
+    isolateQueue q "writeMsg" $ StoreIO $ 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
+            then writeToJournal st canWrt' msg $> Just (msg, empty)
+            else writeToJournal 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
+      msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
+      writeToJournal 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
@@ -430,7 +339,6 @@ instance MsgStoreClass JournalMsgStore where
        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
@@ -446,17 +354,15 @@ instance MsgStoreClass JournalMsgStore where
            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})
+  setOverQuota_ :: JournalMsgQueue -> IO ()
+  setOverQuota_ JournalMsgQueue {state} = atomically $ modifyTVar' state $ \st -> st {canWrite = False}

-  getQueueSize_ :: JournalMsgQueue -> StoreIO Int
-  getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state
+  getQueueSize :: JournalMsgQueue -> IO Int
+  getQueueSize JournalMsgQueue {state} = size <$> readTVarIO state

-  tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message)
-  tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} =
-    StoreIO $ (readTVarIO handles $>>= chooseReadJournal mq True $>>= peekMsg) >>= setEmpty
+  tryPeekMsg_ :: JournalMsgQueue -> StoreIO (Maybe Message)
+  tryPeekMsg_ q@JournalMsgQueue {tipMsg, handles} =
+    StoreIO $ readTVarIO handles $>>= chooseReadJournal q True $>>= peekMsg
    where
      peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst)
        where
@@ -464,48 +370,36 @@ instance MsgStoreClass JournalMsgStore where
            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)) $
+  tryDeleteMsg_ :: JournalMsgQueue -> Bool -> StoreIO ()
+  tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} logState = StoreIO $
    void $
      readTVarIO tipMsg -- if there is no cached tipMsg, do nothing
        $>>= (pure . fmap snd)
        $>>= \len -> readTVarIO handles
-        $>>= \hs -> updateReadPos mq logState len hs $> Just ()
+        $>>= \hs -> updateReadPos q 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
+  isolateQueue :: JournalMsgQueue -> String -> StoreIO a -> ExceptT ErrorType IO a
+  isolateQueue JournalMsgQueue {queue = q} op =
+    tryStore op (queueDirectory q) . withLock' (queueLock q) 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
+tryStore :: String -> String -> IO a -> ExceptT ErrorType IO a
+tryStore op qId a = ExceptT $ E.mask_ $ E.try a >>= bimapM storeErr pure
  where
-    storeErr :: E.SomeException -> IO (Either ErrorType a)
+    storeErr :: E.SomeException -> IO ErrorType
    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
+      let e' = intercalate ", " [op, qId, show e]
+       in logError ("STORE: " <> T.pack e') $> STORE e'

 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
+  (st', rh, wh_) <- closeOnException sh $ openJournals dir st sh
  let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_}
-  mkJournalQueue q st' (Just hs)
+  mkJournalQueue q (st', Just hs)

-mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO JournalMsgQueue
-mkJournalQueue queue st hs_ = do
+mkJournalQueue :: JMQueue -> (MsgQueueState, Maybe MsgQueueHandles) -> IO JournalMsgQueue
+mkJournalQueue queue (st, hs_) = do
  state <- newTVarIO st
  tipMsg <- newTVarIO Nothing
  handles <- newTVarIO hs_
@@ -570,26 +464,17 @@ createNewJournal dir journalId = do
 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
+openJournals :: FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle)
+openJournals 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)
+    Left path -> do
+      logError $ "STORE: openJournals, no read file - creating new file, " <> T.pack path
+      rh <- createNewJournal dir rjId
+      let st' = newMsgQueueState rjId
+      closeOnException rh $ appendState sh st'
+      pure (st', rh, Nothing)
    Right rh
      | rjId == wjId -> do
          closeOnException rh $ fixFileSize rh $ bytePos ws
@@ -598,23 +483,16 @@ openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = 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)
+              logError $ "STORE: openJournals, no write file - creating new file, " <> T.pack path
+              wh <- createNewJournal dir wjId
+              let size' = msgCount rs - msgPos rs
+                  st' = st {writeState = newJournalState wjId, size = size'} -- we don't amend canWrite to trigger QCONT
+              closeOnException wh $ appendState sh st'
+              pure (st', rh, Just wh)
            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
@@ -652,7 +530,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath =
  where
    tempBackup = statePath <> ".bak"
    readQueueState = do
-      ls <- B.lines <$> readFileTail
+      ls <- LB.lines <$> LB.readFile statePath
      case ls of
        [] -> writeNewQueueState
        _ -> do
@@ -663,7 +541,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath =
      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
+    useLastLine len isLastLine ls = case strDecode $ LB.toStrict $ last ls of
      Right st
        | len > maxStateLines config || not isLastLine ->
            backupWriteQueueState st
@@ -693,14 +571,6 @@ readWriteQueueState JournalMsgStore {random, config} statePath =
      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}
@@ -721,18 +591,10 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size}
        && 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
+closeMsgQueue :: JournalMsgStore -> RecipientId -> IO ()
+closeMsgQueue ms rId =
+  atomically (TM.lookupDelete rId (msgQueues ms))
+    >>= mapM_ closeMsgQueueHandles

 closeMsgQueueHandles :: JournalMsgQueue -> IO ()
 closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
@@ -743,12 +605,9 @@ closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
      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
+removeQueueDirectory st rId =
+  let dir = msgQueueDirectory st rId
+   in removePathForcibly dir `catchAny` (\e -> logError $ "STORE: removeQueueDirectory, " <> T.pack dir <> ", " <> tshow e)

 hAppend :: Handle -> Int64 -> ByteString -> IO ()
 hAppend h pos s = do
@@ -773,10 +632,7 @@ openFile f mode = do
  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
+hClose h = IO.hClose h `catchAny` (\e -> logError $ "STORE: hClose, error closing file, " <> tshow e)

 closeOnException :: Handle -> IO a -> IO a
 closeOnException h a = a `E.onException` hClose h
@@ -1,5 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -8,10 +8,10 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TupleSections #-}

 module Simplex.Messaging.Server.MsgStore.STM
  ( STMMsgStore (..),
+    STMMsgQueue (msgQueue),
    STMStoreConfig (..),
  )
 where
@@ -20,71 +20,41 @@ import Control.Concurrent.STM
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Data.Functor (($>))
-import Data.Int (Int64)
-import Simplex.Messaging.Protocol
+import Simplex.Messaging.Protocol (ErrorType, Message (..), RecipientId)
 import Simplex.Messaging.Server.MsgStore.Types
-import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util ((<$$>), ($>>=))
-import System.IO (IOMode (..))
-
-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
  { msgQueue :: TQueue Message,
+    quota :: Int,
    canWrite :: TVar Bool,
    size :: TVar Int
  }

+data STMMsgStore = STMMsgStore
+  { storeConfig :: STMStoreConfig,
+    msgQueues :: TMap RecipientId STMMsgQueue
+  }
+
 data STMStoreConfig = STMStoreConfig
  { storePath :: Maybe FilePath,
    quota :: Int
  }

-instance STMQueueStore STMMsgStore where
-  queues' = queues
-  senders' = senders
-  notifiers' = notifiers
-  storeLog' = storeLog
-  mkQueue _ qr = STMQueue <$> newTVar (Just qr) <*> newTVar Nothing
-  msgQueue_' = msgQueue_
-
 instance MsgStoreClass STMMsgStore where
  type StoreMonad STMMsgStore = STM
-  type StoreQueue STMMsgStore = STMQueue
  type MsgQueue STMMsgStore = STMMsgQueue
  type MsgStoreConfig STMMsgStore = STMStoreConfig

  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}
+    msgQueues <- TM.emptyIO
+    pure STMMsgStore {storeConfig, msgQueues}

-  setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO ()
-  setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
+  closeMsgStore _ = pure ()

-  closeMsgStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog
-
-  activeMsgQueues = queues
+  activeMsgQueues = msgQueues
  {-# INLINE activeMsgQueues #-}

  withAllMsgQueues _ = withActiveMsgQueues
@@ -94,52 +64,39 @@ instance MsgStoreClass STMMsgStore where

  logQueueState _ = pure ()

-  queueRec' = queueRec
-  {-# INLINE queueRec' #-}
-
-  getMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM STMMsgQueue
-  getMsgQueue _ _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure
+  -- 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 -> ExceptT ErrorType IO STMMsgQueue
+  getMsgQueue STMMsgStore {msgQueues = qs, storeConfig = STMStoreConfig {quota}} rId =
+    liftIO $ TM.lookupIO rId qs >>= maybe (atomically maybeNewQ) pure
    where
+      maybeNewQ = TM.lookup rId qs >>= maybe newQ pure
      newQ = do
        msgQueue <- newTQueue
        canWrite <- newTVar True
        size <- newTVar 0
-        let q = STMMsgQueue {msgQueue, canWrite, size}
-        writeTVar msgQueue_ (Just q)
+        let q = STMMsgQueue {msgQueue, quota, canWrite, size}
+        TM.insert rId q qs
        pure q

-  getPeekMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
-  getPeekMsgQueue _ _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
+  delMsgQueue :: STMMsgStore -> RecipientId -> IO ()
+  delMsgQueue st rId = atomically $ TM.delete rId $ msgQueues st

-  -- 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)
+  delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int
+  delMsgQueueSize st rId = atomically (TM.lookupDelete rId $ msgQueues st) >>= maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)

-  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
+  getQueueMessages :: Bool -> STMMsgQueue -> IO [Message]
+  getQueueMessages drainMsgs = atomically . (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'
+  writeMsg :: STMMsgStore -> STMMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  writeMsg _ STMMsgQueue {msgQueue = q, quota, canWrite, size} _logState msg = liftIO $ atomically $ do
    canWrt <- readTVar canWrite
    empty <- isEmptyTQueue q
    if canWrt || empty
@@ -152,24 +109,23 @@ instance MsgStoreClass STMMsgStore where
          else (writeTQueue q $! msgQuota) $> Nothing
      else pure Nothing
    where
-      STMMsgStore {storeConfig = STMStoreConfig {quota}} = ms
-      msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
+      msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}

-  setOverQuota_ :: STMQueue -> IO ()
-  setOverQuota_ q = readTVarIO (msgQueue_ q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
+  setOverQuota_ :: STMMsgQueue -> IO ()
+  setOverQuota_ q = atomically $ writeTVar (canWrite q) False

-  getQueueSize_ :: STMMsgQueue -> STM Int
-  getQueueSize_ STMMsgQueue {size} = readTVar size
+  getQueueSize :: STMMsgQueue -> IO Int
+  getQueueSize STMMsgQueue {size} = readTVarIO size

-  tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
-  tryPeekMsg_ _ = tryPeekTQueue . msgQueue
+  tryPeekMsg_ :: STMMsgQueue -> STM (Maybe Message)
+  tryPeekMsg_ = tryPeekTQueue . msgQueue
  {-# INLINE tryPeekMsg_ #-}

-  tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
-  tryDeleteMsg_ _ STMMsgQueue {msgQueue = q, size} _logState =
+  tryDeleteMsg_ :: 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
+  isolateQueue :: STMMsgQueue -> String -> STM a -> ExceptT ErrorType IO a
+  isolateQueue _ _ = liftIO . atomically
@@ -1,69 +1,44 @@
 {-# 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.Protocol (ErrorType, Message (..), MsgId, RecipientId)
 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
+  activeMsgQueues :: s -> TMap RecipientId (MsgQueue s)
+  withAllMsgQueues :: Monoid a => Bool -> s -> (RecipientId -> MsgQueue 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
+  logQueueState :: MsgQueue s -> IO ()
+  getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s)
+  delMsgQueue :: s -> RecipientId -> IO ()
+  delMsgQueueSize :: s -> RecipientId -> IO Int
+  getQueueMessages :: Bool -> MsgQueue s -> IO [Message]
+  writeMsg :: s -> MsgQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  setOverQuota_ :: MsgQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
+  getQueueSize :: MsgQueue s -> IO Int
+  tryPeekMsg_ :: MsgQueue s -> StoreMonad s (Maybe Message)
+  tryDeleteMsg_ :: MsgQueue s -> Bool -> StoreMonad s ()
+  isolateQueue :: MsgQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a

 data MSType = MSMemory | MSJournal

@@ -73,69 +48,42 @@ data SMSType :: MSType -> Type where

 data AMSType = forall s. AMSType (SMSType s)

-withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> StoreQueue s -> IO a) -> IO a
+withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> MsgQueue 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
+tryPeekMsg :: MsgStoreClass s => MsgQueue s -> ExceptT ErrorType IO (Maybe Message)
+tryPeekMsg mq = isolateQueue mq "tryPeekMsg" $ tryPeekMsg_ mq
 {-# 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
+tryDelMsg :: MsgStoreClass s => MsgQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
+tryDelMsg mq msgId' =
+  isolateQueue mq "tryDelMsg" $
+    tryPeekMsg_ mq >>= \case
+      msg_@(Just msg)
+        | msgId msg == msgId' ->
+            tryDeleteMsg_ mq True >> pure msg_
+      _ -> 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)
+tryDelPeekMsg :: MsgStoreClass s => MsgQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
+tryDelPeekMsg mq msgId' =
+  isolateQueue mq "tryDelPeekMsg" $
+    tryPeekMsg_ mq >>= \case
+      msg_@(Just msg)
+        | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq True >> tryPeekMsg_ mq)
+        | otherwise -> pure (Nothing, msg_)
+      _ -> pure (Nothing, Nothing)

-- 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
+deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Bool -> Int64 -> ExceptT ErrorType IO Int
+deleteExpiredMsgs mq logState old = isolateQueue mq "deleteExpiredMsgs" $ loop 0
  where
    loop dc =
-      tryPeekMsg_ q mq >>= \case
+      tryPeekMsg_ mq >>= \case
        Just Message {msgTs}
          | systemSeconds msgTs < old ->
-              tryDeleteMsg_ q mq False >> loop (dc + 1)
+              tryDeleteMsg_ mq logState >> loop (dc + 1)
        _ -> pure dc
@@ -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, notifiers} q@QueueRec {recipientId = rId, senderId = sId, notifier} = atomically $ do
+  ifM hasId (pure $ Left DUPLICATE_) $ do
+    TM.insertM rId (newTVar q) queues
+    TM.insert sId rId senders
+    forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
+    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
@@ -6,7 +6,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}

 module Simplex.Messaging.Server.StoreLog
@@ -24,33 +23,36 @@ module Simplex.Messaging.Server.StoreLog
    logDeleteQueue,
    logDeleteNotifier,
    logUpdateQueueTime,
+    readWriteQueueStore,
    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 qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
-import qualified Data.Map.Strict as M
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.ByteString.Base64.URL as B64
 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.Server.QueueStore.STM
+import Simplex.Messaging.Util (bshow, ifM, unlessM, whenM)
 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
@@ -157,13 +159,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,6 +188,9 @@ logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
 logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t

+readWriteQueueStore :: FilePath -> QueueStore -> IO (StoreLog 'WriteMode)
+readWriteQueueStore = readWriteStoreLog readQueues writeQueues
+
 readWriteStoreLog :: (FilePath -> s -> IO ()) -> (StoreLog 'WriteMode -> s -> IO ()) -> FilePath -> s -> IO (StoreLog 'WriteMode)
 readWriteStoreLog readStore writeStore f st =
  ifM
@@ -223,11 +226,31 @@ readWriteStoreLog readStore writeStore f st =
      renameFile tempBackup timedBackup
      logInfo $ "original state preserved as " <> T.pack timedBackup

-writeQueueStore :: STMQueueStore s => StoreLog 'WriteMode -> s -> IO ()
-writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M.assocs
+writeQueues :: StoreLog 'WriteMode -> QueueStore -> IO ()
+writeQueues s st = readTVarIO (queues st) >>= mapM_ writeQueue
  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
+    writeQueue v = readTVarIO v >>= \q -> when (active q) $ logCreateQueue s q
    active QueueRec {status} = status == QueueActive
+
+readQueues :: FilePath -> QueueStore -> IO ()
+readQueues 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 "create" (recipientId q)
+          SecureQueue qId sKey -> secureQueue st qId sKey >>= qError "secure" qId
+          AddNotifier qId ntfCreds -> addQueueNotifier st qId ntfCreds >>= qError "addNotifier" qId
+          SuspendQueue qId -> suspendQueue st qId >>= qError "suspend" qId
+          DeleteQueue qId -> deleteQueue st qId >>= qError "delete" qId
+          DeleteNotifier qId -> deleteQueueNotifier st qId >>= qError "deleteNotifier" qId
+          UpdateTime qId t -> updateQueueTime st qId t
+        printError :: String -> IO ()
+        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
+        qError :: B.ByteString -> RecipientId -> Either ErrorType a -> IO ()
+        qError op (EntityId qId) = \case
+          Left e -> B.putStrLn $ op <> " stored queue " <> B64.encode qId <> " error: " <> bshow e
+          Right _ -> pure ()
@@ -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
@@ -35,16 +35,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 (<$?>) #-}
@@ -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
@@ -3076,9 +3076,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
@@ -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
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
@@ -8,7 +7,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 {-# OPTIONS_GHC -Wno-orphans #-}

@@ -19,25 +17,19 @@ 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.Protocol (EntityId (..), Message (..), noMsgFlags)
 import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages, printMessageStats)
-import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth, readWriteQueueStore)
+import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth)
 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 SMPClient (testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
 import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile)
 import System.FilePath ((</>))
 import System.IO (IOMode (..), hClose, withFile)
@@ -52,18 +44,13 @@ msgStoreTests = do
    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 :: MsgStoreClass 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 :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO ()
 withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore

 testSMTStoreConfig :: STMStoreConfig
@@ -76,9 +63,7 @@ testJournalStoreCfg =
      pathParts = journalMsgStoreDepth,
      quota = 3,
      maxMsgCount = 4,
-      maxStateLines = 2,
-      stateTailSize = 256,
-      idleInterval = 21600
+      maxStateLines = 2
    }

 mkMessage :: MonadIO m => ByteString -> m Message
@@ -97,121 +82,98 @@ 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 :: MsgStoreClass s => s -> IO ()
 testGetQueue ms = do
  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
+  rId <- EntityId <$> atomically (C.randomBytes 24 g)
  runRight_ $ do
-    q <- ExceptT $ addQueue ms qr
-    let write s = writeMsg ms rId q True =<< mkMessage s
+    q <- getMsgQueue ms rId
+    let write s = writeMsg ms 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
+    Msg "message 1" <- tryPeekMsg q
+    Msg "message 1" <- tryPeekMsg q
+    Nothing <- tryDelMsg q mId2
+    Msg "message 1" <- tryDelMsg q mId1
+    Nothing <- tryDelMsg q mId1
+    Msg "message 2" <- tryPeekMsg q
+    Nothing <- tryDelMsg q mId1
+    (Nothing, Msg "message 2") <- tryDelPeekMsg q mId1
+    (Msg "message 2", Msg "message 3") <- tryDelPeekMsg q mId2
+    (Nothing, Msg "message 3") <- tryDelPeekMsg q mId2
+    Msg "message 3" <- tryPeekMsg q
+    (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3
+    Nothing <- tryDelMsg q mId2
+    Nothing <- tryDelMsg q mId3
+    Nothing <- tryPeekMsg q
    Just (Message {msgId = mId4}, True) <- write "message 4"
-    Msg "message 4" <- tryPeekMsg ms rId q
+    Msg "message 4" <- tryPeekMsg 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
+    (Nothing, Msg "message 4") <- tryDelPeekMsg q mId3
+    (Msg "message 4", Msg "message 5") <- tryDelPeekMsg 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
+    Msg "message 5" <- tryPeekMsg q
+    (Nothing, Msg "message 5") <- tryDelPeekMsg q mId4
+    (Msg "message 5", Msg "message 6") <- tryDelPeekMsg q mId5
+    (Msg "message 6", Msg "message 7") <- tryDelPeekMsg q mId6
+    (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg q mId7
+    (Just MessageQuota {}, Nothing) <- tryDelPeekMsg q mId8
+    (Nothing, Nothing) <- tryDelPeekMsg q mId8
+    pure ()
+  delMsgQueue ms rId

-testChangeReadJournal :: STMQueueStore s => s -> IO ()
+testChangeReadJournal :: MsgStoreClass s => s -> IO ()
 testChangeReadJournal ms = do
  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
+  rId <- EntityId <$> atomically (C.randomBytes 24 g)
  runRight_ $ do
-    q <- ExceptT $ addQueue ms qr
-    let write s = writeMsg ms rId q True =<< mkMessage s
+    q <- getMsgQueue ms rId
+    let write s = writeMsg ms q True =<< mkMessage s
    Just (Message {msgId = mId1}, True) <- write "message 1"
-    (Msg "message 1", Nothing) <- tryDelPeekMsg ms rId q mId1
+    (Msg "message 1", Nothing) <- tryDelPeekMsg q mId1
    Just (Message {msgId = mId2}, True) <- write "message 2"
-    (Msg "message 2", Nothing) <- tryDelPeekMsg ms rId q mId2
+    (Msg "message 2", Nothing) <- tryDelPeekMsg q mId2
    Just (Message {msgId = mId3}, True) <- write "message 3"
-    (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3
+    (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3
    Just (Message {msgId = mId4}, True) <- write "message 4"
-    (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q mId4
+    (Msg "message 4", Nothing) <- tryDelPeekMsg 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
+    (Msg "message 5", Nothing) <- tryDelPeekMsg q mId5
+    pure ()
+  delMsgQueue ms rId

 testExportImportStore :: JournalMsgStore -> IO ()
 testExportImportStore ms = do
  g <- C.newRandom
-  (rId1, qr1) <- testNewQueueRec g True
-  (rId2, qr2) <- testNewQueueRec g True
-  sl <- readWriteQueueStore testStoreLogFile ms
+  rId1 <- EntityId <$> atomically (C.randomBytes 24 g)
+  rId2 <- EntityId <$> atomically (C.randomBytes 24 g)
  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"
+    let write q s = writeMsg ms q True =<< mkMessage s
+    q1 <- getMsgQueue ms rId1
+    Just (Message {}, True) <- write q1 "message 1"
+    Just (Message {}, False) <- write q1 "message 2"
+    q2 <- getMsgQueue ms rId2
+    Just (Message {msgId = mId3}, True) <- write q2 "message 3"
+    Just (Message {msgId = mId4}, False) <- write q2 "message 4"
+    (Msg "message 3", Msg "message 4") <- tryDelPeekMsg q2 mId3
+    (Msg "message 4", Nothing) <- tryDelPeekMsg q2 mId4
+    Just (Message {}, True) <- write q2 "message 5"
+    Just (Message {}, False) <- write q2 "message 6"
+    Just (Message {}, False) <- write q2 "message 7"
+    Nothing <- write 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
@@ -220,7 +182,6 @@ testExportImportStore ms = do
  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
@@ -294,121 +255,24 @@ testQueueState ms = do
 testMessageState :: JournalMsgStore -> IO ()
 testMessageState ms = do
  g <- C.newRandom
-  (rId, qr) <- testNewQueueRec g True
+  rId <- EntityId <$> atomically (C.randomBytes 24 g)
  let dir = msgQueueDirectory ms rId
      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
-      write q s = writeMsg ms rId q True =<< mkMessage s
+      write q s = writeMsg ms q True =<< mkMessage s

  mId1 <- runRight $ do
-    q <- ExceptT $ addQueue ms qr
+    q <- getMsgQueue ms rId
    Just (Message {msgId = mId1}, True) <- write q "message 1"
    Just (Message {}, False) <- write q "message 2"
-    liftIO $ closeMsgQueue q
+    liftIO $ closeMsgQueue ms rId
    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
+    q <- getMsgQueue ms 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
+    (Msg "message 1", Msg "message 3") <- tryDelPeekMsg q mId1
+    (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3
+    liftIO $ closeMsgQueueHandles q
@@ -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 []
@@ -16,17 +16,32 @@ 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 Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.STM (QueueStore (..), newQueueStore)
 import Test.Hspec

+testNewQueueRec :: TVar ChaChaDRG -> Bool -> IO QueueRec
+testNewQueueRec g sndSecure = do
+  recipientId <- 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
+  pure QueueRec
+    { recipientId,
+      recipientKey,
+      rcvDhSecret = C.dh' k pk,
+      senderId,
+      senderKey = Nothing,
+      sndSecure,
+      notifier = Nothing,
+      status = QueueActive,
+      updatedAt = Nothing
+    }
+
 testNtfCreds :: TVar ChaChaDRG -> IO NtfCreds
 testNtfCreds g = do
  (notifierKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
@@ -51,7 +66,7 @@ deriving instance Eq NtfCreds
 storeLogTests :: Spec
 storeLogTests =
  forM_ [False, True] $ \sndSecure -> do
-    ((rId, qr), ntfCreds, date) <- runIO $ do
+    (qr, ntfCreds, date) <- runIO $ do
      g <- C.newRandom
      (,,) <$> testNewQueueRec g sndSecure <*> testNtfCreds g <*> getSystemDate
    testSMPStoreLog ("SMP server store log, sndSecure = " <> show sndSecure)
@@ -59,37 +74,37 @@ storeLogTests =
          { name = "create new queue",
            saved = [CreateQueue qr],
            compacted = [CreateQueue qr],
-            state = M.fromList [(rId, qr)]
+            state = M.fromList [(recipientId qr, qr)]
          },
        SLTC
          { name = "secure queue",
-            saved = [CreateQueue qr, SecureQueue rId testPublicAuthKey],
+            saved = [CreateQueue qr, SecureQueue (recipientId qr) testPublicAuthKey],
            compacted = [CreateQueue qr {senderKey = Just testPublicAuthKey}],
-            state = M.fromList [(rId, qr {senderKey = Just testPublicAuthKey})]
+            state = M.fromList [(recipientId qr, qr {senderKey = Just testPublicAuthKey})]
          },          
        SLTC
          { name = "create and delete queue",
-            saved = [CreateQueue qr, DeleteQueue rId],
+            saved = [CreateQueue qr, DeleteQueue $ recipientId qr],
            compacted = [],
            state = M.fromList []
          },
        SLTC
          { name = "create queue and add notifier",
-            saved = [CreateQueue qr, AddNotifier rId ntfCreds],
+            saved = [CreateQueue qr, AddNotifier (recipientId qr) ntfCreds],
            compacted = [CreateQueue $ qr {notifier = Just ntfCreds}],
-            state = M.fromList [(rId, qr {notifier = Just ntfCreds})]
+            state = M.fromList [(recipientId qr, qr {notifier = Just ntfCreds})]
          },
        SLTC
          { name = "delete notifier",
-            saved = [CreateQueue qr, AddNotifier rId ntfCreds, DeleteNotifier rId],
+            saved = [CreateQueue qr, AddNotifier (recipientId qr) ntfCreds, DeleteNotifier (recipientId qr)],
            compacted = [CreateQueue qr],
-            state = M.fromList [(rId, qr)]
+            state = M.fromList [(recipientId qr, qr)]
          },
        SLTC
          { name = "update time",
-            saved = [CreateQueue qr, UpdateTime rId date],
+            saved = [CreateQueue qr, UpdateTime (recipientId qr) date],
            compacted = [CreateQueue qr {updatedAt = Just date}],
-            state = M.fromList [(rId, qr {updatedAt = Just date})]
+            state = M.fromList [(recipientId qr, qr {updatedAt = Just date})]
          }          
      ]

@@ -102,11 +117,11 @@ testSMPStoreLog testSuite tests =
    replicateM_ 3 $ testReadWrite t
  where
    testReadWrite SLTC {compacted, state} = do
-      st <- newMsgStore testJournalStoreCfg
+      st <- newQueueStore
      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'))
+    storeState :: QueueStore -> IO (M.Map RecipientId QueueRec)
+    storeState st = readTVarIO (queues st) >>= mapM readTVarIO
@@ -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
@@ -43,9 +43,6 @@ import Util
 testHost :: NonEmpty TransportHost
 testHost = "localhost"

-testHost2 :: NonEmpty TransportHost
-testHost2 = "127.0.0.1"
-
 testPort :: ServiceName
 testPort = "5001"

@@ -135,8 +132,6 @@ cfgMS msType =
      controlPortUserAuth = Nothing,
      controlPortAdminAuth = Nothing,
      messageExpiration = Just defaultMessageExpiration,
-      expireMessagesOnStart = True,
-      idleQueueInterval = defaultIdleQueueInterval,
      notificationExpiration = defaultNtfExpiration,
      inactiveClientExpiration = Just defaultInactiveClientExpiration,
      logStatsInterval = Nothing,
@@ -61,7 +61,7 @@ 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
      describe "one server" $ do
@@ -316,7 +316,7 @@ 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
@@ -37,12 +37,11 @@ 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)
@@ -813,7 +812,6 @@ testRestoreExpireMessages =
    exportStoreMessages = \case
      AMSType SMSJournal -> do
        ms <- newMsgStore testJournalStoreCfg {quota = 4}
-        readWriteQueueStore testStoreLogFile ms >>= closeStoreLog
        removeFileIfExists testStoreMsgsFile
        exportMessages False ms testStoreMsgsFile False
      AMSType SMSMemory -> pure ()
@@ -972,7 +970,7 @@ testMsgExpireOnInterval =
  xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c), msType) -> 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' = (cfgMS msType) {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
@@ -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 (..))
@@ -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
Author	SHA1	Message	Date
IC Rainbow	ffae1ef285	Merge remote-tracking branch 'origin/master' into ab/tls-2	2024-10-27 16:05:24 +02:00
Evgeny Poberezkin	a2b8f29361	Merge branch 'master' into ab/tls-2	2024-08-17 23:06:27 +01:00
Evgeny Poberezkin	4abd389c2a	Merge branch 'master' into ab/tls-2	2024-07-17 13:09:43 +01:00
Evgeny Poberezkin	d39100f7ea	Merge branch 'master' into ab/tls-2	2024-07-09 22:46:52 +01:00
Evgeny Poberezkin	ca6790a0dd	Merge branch 'master' into ab/tls-2	2024-06-24 15:21:57 +01:00
Evgeny Poberezkin	e2d0d975e8	Merge branch 'master' into ab/tls-2	2024-06-24 08:32:53 +01:00
Alexander Bondarenko	3f510ccd23	roll back RCP "cleanup"	2024-06-12 15:24:44 +03:00
Alexander Bondarenko	63789d0c6e	deps: use tls-2.0	2024-06-11 22:48:06 +03:00